Merge branch 'experimental/upstream' into upstream

1501 files changed, 108349 insertions, 83764 deletions

diff --git a/CHANGES b/CHANGES
index 954231f8..a696ad71 100644
--- a/CHANGES
+++ b/CHANGES
@@ -1,167 +1,390 @@
-Changes from V8.3pl3 to V8.3pl4
+Changes from V8.4pl1 to V8.4pl2
 ===============================
 
-Bug fixes:
+Bug fixes
 
-- #2724 (using notations with binders in cases patterns was provoking an anomaly)
-- #2723 (alpha-conversion bug #2723 introduced in r12485-12486)
-- #2732 (anomaly when using the tolerance for writing "f atomic_tac"
-    as a short-hand for "f ltac:(atomic_tac)")
-- #2729 (vm_compute: function used to decompose constructors did not handle let-ins)
-- #2728 (compatibility with camlp5 6.05)
-- #2682 (Fail discard the effects of a successful command)
-- #2703 (Undetected universe inconsistency)
-- #2667 (Coq crashes when "Arguments Scope" has too many parameters)
-- Compilation of coqide under MacOS with gtk >= 2.24.11
-- Coqdoc: Fixing missing newline when using "Proof term."
+- Solved bugs :
+  #2466 #2629 #2668 #2750 #2839 #2869 #2954 #2955 #2959 #2962 #2966 #2967
+  #2969 #2970 #2975 #2976 #2977 #2978 #2981 #2983 #2995 #3000 #3004 #3008 
+- Partially fixed bugs : #2830 #2949
+- Coqtop should now react more reliably when receiving interrupt signals:
+  all the "try...with" constructs have been protected against undue
+  handling of the Sys.Break exception.
 
+Coqide
 
-Changes from V8.3pl2 to V8.3pl3
-===============================
+- The Windows-specific code handling the interrupt button of Coqide
+  had to be reworked (cf. bug #2869). Now, in Win32 this button does
+  not target a specific coqtop client, but instead sends a Ctrl-C to
+  any process sharing its console with Coqide. To avoid awkward
+  effects, it is recommended to launch Coqide via its icon, its menu,
+  or in a dedicated console window.
 
-The following (non exhaustive) list of bugs have been fixed:
+Extraction
 
-General
+- The option Extraction AccessOpaque is now set by default,
+  restoring compatibility of older versions of Coq (cf bug #2952).
 
-- #2411 (Axiom / Hypothesis / Variable allowed again during proofs)
-- #2603 (verify that all names of an inductive block aren't already used)
-- #1804 (pattern-matching compilation bug with highly nested sigma-types)
-- #2615 (anomaly in inferring pattern-matching return type)
-- #2504 (bug in computing universe of polymorphic inductive types)
-- #2407 (stack overflow in Function)
-- #2181 (unnamed but dependent fields in Classes)
-- bug with modules in virtual machine
+Changes from V8.4 to V8.4pl1
+============================
 
-Modules
+Bug fixes
 
-- #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)
+- Solved bugs :
+  #2851 #2863 #2865 #2893 #2895 #2892 #2905 #2906 #2907 #2917 #2921
+  #2930 #2941 #2878
+- Partially fixed bug : #2904
+- Various fixes concerning coq_makefile
 
-Tactics
+Optimizations
+
+- "Union by rank" optimization for universes contributed by J.H. Jourdan
+  and G. Sherrer (see union-find-and-coq-universes on gagallium blog).
+
+Libraries
 
-- #2467, #2464 (fixes for fsetdec)
-- Document the "appcontext" variant of "context" that better handles
-  partial applications.
-- #2640 (ltac anomaly in expecting a tactic and finding a definition)
+- Internal organisation of some modular libraries have slightly changed
+  due to bug #2904 (GenericMinMax, OrdersTac)
+- No more constant "int" in ZArith/Int.v to avoid name clash with OCaml
+  (cf bug #2878).
 
 Coqide
 
-- #2363 (fix the command separator for external commands)
-- #2499 (fix remove_current_view_page)
-- #2357 (allow the use of Abort)
+- Improved shutdown of coqtop processes spawned by coqide
+  (in particular added a missing close_on_exec primitive before forking).
+- On windows, launching coqide with the -debug option now produces
+  a log file in the user's temporary directory. The location of this
+  log file is displayed in the "About" message.
 
-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.4beta2 to V8.4
+==============================
+
+Vernacular commands
 
-Coqdoc
+- The "Reset" command is now supported again in files given to coqc or Load.
+- "Show Script" now indents again the displayed scripts. It can also work
+  correctly across Load'ed files if the option "Unset Atomic Load" is used.
+- "Open Scope" can now be given the delimiter (e.g. Z) instead of the full
+  scope name (e.g. Z_scope).
 
-- #2606 (bad processing of coq escaped in comments)
-- #2423 (handling of -R in coqdoc)
-- fixing garbage when using some greek letters as identifier names
+Notations
 
-Changes from V8.3pl1 to V8.3pl2
-===============================
+- Most compatibility notations of the standard library are now tagged as
+  (compat xyz), where xyz is a former Coq version, for instance "8.3".
+  These notations behave as (only parsing) notations, except that they may
+  triggers warnings (or errors) when used while Coq is not in a corresponding
+  -compat mode.
+- To activate these compatibility warnings, use "Set Verbose Compat Notations"
+  or the command-line flag -verbose-compat-notations.
+- For a strict mode without these compatibility notations, use
+  "Unset Compat Notations" or the command-line flag -no-compat-notations.
+
+Tactics
 
-Coqdoc and documentation bugs
+- An annotation "eqn:H" or "eqn:?" can be added to a "destruct"
+  or "induction" to make it generate equations in the spirit of "case_eq".
+  The former syntax "_eqn" is discontinued.
+- The name of the hypothesis introduced by tactic "remember" can be
+  set via the new syntax "remember t as x eqn:H" (wish #2489).
 
-- #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
+Libraries
+
+- Reals: changed definition of PI, no more axiom about sin(PI/2).
+- SetoidPermutation: a notion of permutation for lists modulo a setoid equality.
+- BigN: fixed the ocaml code doing the parsing/printing of big numbers.
+
+Changes from V8.4beta to V8.4beta2
+==================================
+
+Vernacular commands
+
+- Commands "Back" and "BackTo" are now handling the proof states. They may
+  perform some extra steps of backtrack to avoid states where the proof
+  state is unavailable (typically a closed proof).
+- The commands "Suspend" and "Resume" have been removed.
+- A basic Show Script has been reintroduced (no indentation).
+- New command "Set Parsing Explicit" for deactivating parsing (and printing)
+  of implicit arguments (useful for teaching).
+- New command "Grab Existential Variables" to transform the unresolved evars
+  at the end of a proof into goals.
 
 Tactics
 
-- #2493 (dependent pairs injection failing because of Type cumulativity missing)
-- Reduction "simpl" sometimes failing in presence of names redefined in modules
+- Still no general "info" tactical, but new specific tactics info_auto,
+  info_eauto, info_trivial which provides information on the proofs found
+  by auto/eauto/trivial. Display of these details could also be activated by
+  "Set Info Auto"/"Set Info Eauto"/"Set Info Trivial".
+- Details on everything tried by auto/eauto/trivial during a proof search
+  could be obtained by "debug auto", "debug eauto", "debug trivial" or by a
+  global "Set Debug Auto"/"Set Debug Eauto"/"Set Debug Trivial".
+- New command "r string" in Ltac debugger that interprets "idtac
+  string" in Ltac code as a breakpoint and jumps to its next use.
+- Tactics from the Dp plugin (simplify, ergo, yices, cvc3, z3, cvcl,
+  harvey, zenon, gwhy) have been removed, since Why2 has not been
+  maintained for the last few years. The Why3 plugin should be a suitable
+  replacement in most cases.
 
-Extraction
+Libraries
 
-- #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
-============================
+- MSetRBT: a new implementation of MSets via Red-Black trees (initial
+  contribution by Andrew Appel).
+- MSetAVL: for maximal sharing with the new MSetRBT, the argument order
+  of Node has changed (this should be transparent to regular MSets users).
 
-Type inference, notations and implicit arguments bug fixes
+Module System
 
-- #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
+- The names of modules (and module types) are now in a fully separated
+  namespace from ordinary definitions: "Definition E:=0. Module E. End E."
+  is now accepted.
 
-Ltac and tactics bug fixes
+CoqIDE
 
-- #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
+- Coqide now supports the "Restart" command, and "Undo" (with a warning).
+  Better support for "Abort".
 
-Coqdoc and documentation bugs
+Changes from V8.3 to V8.4beta
+=============================
 
-- #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)
+Logic
 
-Compilation
+- Standard eta-conversion now supported (dependent product only).
+- 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".
+- 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.
 
-- #2432 (support for compilation with camlp5 6.02.0)
-- support for compilation with ocaml >= 3.09.3 restored
+Tactics
 
-Extraction
+- New proof engine.
+- Scripts can now be structured thanks to bullets - * + and to subgoal
+  delimitation via { }. Note: for use with Proof General, a cvs version of
+  Proof General no older than mid-July 2011 is currently required.
+- Support for tactical "info" is suspended.
+- Support for command "Show Script" is suspended.
+- New tactics constr_eq, is_evar and has_evar for use in Ltac.
+- 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 incompatibilities).
+- 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 non 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).
+- In an ltac 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.
+- The behavior of "simpl" can be tuned using the "Arguments" vernacular.
+  In particular constants can be marked so that they are always/never unfolded
+  by "simpl", or unfolded only when a set of arguments evaluates to a
+  constructor. Last one can mark a constant so that it is unfolded only if the
+  simplified term does not expose a match in head position.
+
+Vernacular commands
 
-- #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.
+- 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_".
+- 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).
+- Command "Proof" accept a new modifier "using" to force generalization
+  over a given list of section variables at section ending.
+- New command "Arguments" generalizing "Implicit Arguments" and
+  "Arguments Scope" and that also allows to rename the parameters of a
+  definition and to tune the behavior of the tactic "simpl".
+
+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.
+- 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.
 
-Miscellaneous bug fixes
+Libraries
 
-- #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
+- 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 independent library for lists indexed by their length.
+  Vectors' names overwrite lists' one so you should not "Import" the library.
+  All old names changed: function names follow the ocaml ones and, for example,
+  Vcons becomes Vector.cons. You can get [..;..;..]-style 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).
 
+Internal infrastructure
+
+- 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 reflecting the whole standard library.
 
 Extraction
 
+- 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".
+- New option "Set/Unset Extraction KeepSingleton" for preventing the
+  extraction to optimize singleton container types.
+- 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).
+
+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.
+- The backtrack engine of CoqIDE has been reworked, it now uses the
+  "Backtrack" command similarly to Proof General.
+- The Coqide parsing of sentences has be reworked and now supports
+  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.
+
+Tools
+
+- 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.
+- Major changes to coq_makefile:
+  * 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
 =========================
@@ -192,7 +415,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.
@@ -202,7 +426,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
@@ -214,9 +438,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.
@@ -315,7 +539,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
@@ -333,11 +557,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
@@ -348,7 +572,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].
 
@@ -400,7 +624,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;
@@ -495,22 +719,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
@@ -528,18 +752,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.
@@ -566,46 +790,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
@@ -619,31 +843,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,
@@ -660,7 +884,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.
@@ -728,7 +952,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.
@@ -741,8 +965,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
@@ -751,31 +975,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)".
@@ -785,69 +1009,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
@@ -859,19 +1083,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.
 
@@ -886,7 +1110,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
@@ -894,7 +1118,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
@@ -906,30 +1130,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.
@@ -943,8 +1167,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.
@@ -980,8 +1204,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
@@ -1020,7 +1244,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.
@@ -1045,7 +1269,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
@@ -1070,7 +1294,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.
@@ -1087,14 +1311,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".
@@ -1105,19 +1329,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.
@@ -1138,20 +1362,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.
@@ -1192,7 +1416,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
@@ -1204,17 +1428,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
@@ -1245,7 +1469,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;
@@ -1267,7 +1491,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
@@ -1284,7 +1508,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
@@ -1304,7 +1528,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")
@@ -1352,7 +1576,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
 ========================================
@@ -1420,7 +1644,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
@@ -1432,7 +1656,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,
@@ -1487,10 +1711,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
 
@@ -1516,7 +1740,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
@@ -1531,14 +1755,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
@@ -1616,7 +1840,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)
@@ -1627,7 +1851,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.
 
@@ -1657,7 +1881,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
@@ -1696,7 +1920,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
@@ -1726,7 +1950,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
@@ -1742,7 +1966,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
 
@@ -1754,8 +1978,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
 
@@ -1764,7 +1988,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
@@ -1800,7 +2024,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
@@ -1812,14 +2036,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
@@ -1895,7 +2119,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
@@ -1981,7 +2205,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) (+)
 
@@ -2024,7 +2248,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 (*)(+)
@@ -2074,7 +2298,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 $) (*)
@@ -2130,7 +2354,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 (*)
@@ -2190,7 +2414,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
@@ -2217,7 +2441,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
@@ -2229,15 +2453,17 @@ 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)
+
+ LocalWords:  recommended
diff --git a/COMPATIBILITY b/COMPATIBILITY
index 4cc8b589..41474202 100644
--- a/COMPATIBILITY
+++ b/COMPATIBILITY
@@ -1,52 +1,51 @@
-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.
+The main known incompatibilities between 8.3 and 8.4 are consequences
+of the following changes:
+
+- The reorganization of the library of numbers:
+
+  Several definitions have new names or are defined in modules of
+  different names, but a special care has been taken to have this
+  renaming transparent for the user thanks to compatibility notations.
+
+  However some definitions have changed, what might require some
+  adaptations. The most noticeable examples are:
+  - The "?=" notation which now bind to Pos.compare rather than former
+    Pcompare (now Pos.compare_cont).
+  - Changes in names may induce different automatically generated
+    names in proof scripts (e.g. when issuing "destruct Z_le_gt_dec").
+  - Z.add has a new definition, hence, applying "simpl" on subterms of
+    its body might give different results than before.
+  - BigN.shiftl and BigN.shiftr have reversed arguments order, the
+    power function in BigN now takes two BigN.
+
+- Other changes in libraries:
+
+  - The definition of functions over "vectors" (list of fixed length)
+    have changed.
+  - TheoryList.v has been removed.
+
+- Slight changes in tactics:
+
+  - Less unfolding of fixpoints when applying destruct or inversion on
+    a fixpoint hiding an inductive type (add an extra call to simpl to
+    preserve compatibility).
+  - Less unexpected local definitions when applying "destruct"
+    (incompatibilities solvable by adapting name hypotheses).
+  - Tactic "apply" might succeed more often, e.g. by now solving
+    pattern-matching of the form ?f x y = g(x,y) (compatibility
+    ensured by using "Unset Tactic Pattern Unification"), but also
+    because it supports (full) betaiota (using "simple apply" might
+    then help).
+  - Tactic autorewrite does no longer instantiate pre-existing
+    existential variables.
+  - Tactic "info" is now available only for auto, eauto and trivial.
+
+- Miscellaneous changes:
+
+  - The command "Load" is now atomic for backtracking (use "Unset
+    Atomic Load" for compatibility).
diff --git a/COPYRIGHT b/COPYRIGHT
index 4609c167..3aa6aae9 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-2012 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..543cb3f3 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.
@@ -106,6 +106,7 @@ The following people have contributed to the development of different versions
 of the Coq Proof assistant during the indicated time:
 
   Bruno Barras (INRIA, 1995-now)
+  Pierre Boutillier (INRIA-PPS, 2010-now)
   Jacek Chrzaszcz (LRI, 1998-2003)
   Thierry Coquand (INRIA, 1985-1989)
   Pierre Corbineau (LRI, 2003-2005, Nijmegen, 2005-2008, Grenoble 1, 2008-now)
@@ -118,10 +119,12 @@ of the Coq Proof assistant during the indicated time:
   Amy Felty (INRIA, 1993)
   Jean-Christophe Filliâtre (ENS Lyon, 1994-1997, LRI, 1997-now)
   Eduardo Giménez (ENS Lyon, 1993-1996, INRIA, 1997-1998)
+  Stéphane Glondu (INRIA-PPS, 2007-now)
   Benjamin Grégoire (INRIA, 2003-now)
   Hugo Herbelin (INRIA, 1996-now)
   Gérard Huet (INRIA, 1985-1997)
-  Pierre Letouzey (LRI, 2000-2004 & PPS, 2005-now)
+  Pierre Letouzey (LRI, 2000-2004, PPS, 2005-2008, INRIA-PPS, 2009-now)
+  Patrick Loiseleur (Paris Sud, 1997-1999)
   Evgeny Makarov (INRIA, 2007)
   Pascal Manoury (INRIA, 1993)
   Micaela Mayero (INRIA, 1997-2002)
@@ -132,9 +135,11 @@ of the Coq Proof assistant during the indicated time:
   Julien Narboux (INRIA, 2005-2006, Strasbourg, 2007-now)
   Jean-Marc Notin (CNRS, 2006-now)
   Catherine Parent-Vigouroux (ENS Lyon, 1992-1995)
-  Patrick Loiseleur (Paris Sud, 1997-1999)
   Christine Paulin-Mohring (INRIA, 1985-1989, ENS Lyon, 1989-1997, 
                             LRI, 1997-now)
+  Pierre-Marie Pédrot (INRIA-PPS, 2011-now)
+  Matthias Puech (INRIA-Bologna, 2008-now)
+  Yann Régis-Gianas (INRIA-PPS, 2009-now)
   Clément Renard (INRIA, 2001-2004)
   Claudio Sacerdoti Coen (INRIA, 2004-2005)
   Amokrane Saïbi (INRIA, 1993-1998)
@@ -142,6 +147,7 @@ of the Coq Proof assistant during the indicated time:
   Élie Soubiran (INRIA, 2007-now)
   Matthieu Sozeau (INRIA, 2005-now)
   Arnaud Spiwack (INRIA, 2006-now)
+  Enrico Tassi (INRIA, 2011-now)
   Benjamin Werner (INRIA, 1989-1994)
 
 ***************************************************************************
diff --git a/INSTALL b/INSTALL
index b1cc3af1..15f1b90a 100644
--- a/INSTALL
+++ b/INSTALL
@@ -1,5 +1,5 @@
 
-            INSTALLATION PROCEDURES FOR THE COQ V8.3 SYSTEM
+            INSTALLATION PROCEDURES FOR THE COQ V8.4 SYSTEM
             -----------------------------------------------
 
 
@@ -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.4 yourself, you need:
 
-     - Objective Caml version 3.10.2 or later
+     - Objective Caml version 3.11.2 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.11.2 (or later)
    installed on your computer and that "ocamlmktop" and "ocamlc" (or
    its native code version "ocamlc.opt") lie in a directory which is present
    in your $PATH environment variable. 
@@ -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>
@@ -149,10 +155,6 @@ INSTALLATION PROCEDURE IN DETAILS (NORMAL USERS).
         Use the ocamlc.opt compiler instead of ocamlc (and ocamlopt.opt 
         compiler instead of ocamlopt). Makes compilation faster (recommended).
 
--nowarnings
-	Disable the Objective Caml compiler warnings. This option has no
-	effect on the result of the compilation.
-
 -browser <command>
 	Use <command> to open an URL in a browser. %s must appear in <command>,
 	and will be replaced by the URL.
@@ -201,7 +203,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 +318,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 +331,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
deleted file mode 100644
index 43390616..00000000
--- a/INSTALL.macosx
+++ /dev/null
@@ -1,30 +0,0 @@
-INSTALLATION PROCEDURE FOR THE PRECOMPILED VERSION OF COQ SYSTEM UNDER MACOS X
-------------------------------------------------------------------------------
-
-Here comes an bundle version of CoqIdE that you can save anywhere you want on
-your disk.
-
-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.)
-
-An other limitation is that Sortcut aren't MacOS like ! (The question is again
-how to make "" throw CaML.)
-
-Notice that "Compile" and "File"/"Export to" menu items should work (modulo
-(pdf)latex finding).
-
-if you want to use coqide from your terminal add
- 
-alias coqide /YOUR_INSTALL_DIRECTORY/CoqIdEv8.3.app/Contents/MacOS/startcoqide 
-
-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.
diff --git a/Makefile b/Makefile
index 97afdfd6..bb5ec3bc 100644
--- a/Makefile
+++ b/Makefile
@@ -6,69 +6,46 @@
 #         #       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
+###########################################################################
+
+# NB: due to limitations in Win32, please refrain using 'export' too much
+# to communicate between make sub-calls (in Win32, 8kb max per env variable,
+# 32kb total)
 
 # !! Before using FIND_VCS_CLAUSE, please read how you should in the !!
 # !! FIND_VCS_CLAUSE section of dev/doc/build-system.dev.txt         !!
-export FIND_VCS_CLAUSE:='(' \
+FIND_VCS_CLAUSE:='(' \
   -name '{arch}' -o \
   -name '.svn' -o \
   -name '_darcs' -o \
@@ -78,41 +55,60 @@ 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
+
+YACCFILES:=$(call find, '*.mly')
+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')
 
-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) \
+## Files that will be generated
+
+GENML4FILES:= $(ML4FILES:.ml4=.ml)
+GENMLFILES:=$(LEXFILES:.mll=.ml) $(YACCFILES:.mly=.ml) \
   scripts/tolink.ml kernel/copcodes.ml
-export GENMLIFILES:=$(YACCFILES:.mly=.mli)
+GENMLIFILES:=$(YACCFILES:.mly=.mli)
+GENPLUGINSMOD:=$(filter plugins/%,$(MLLIBFILES:%.mllib=%_mod.ml))
 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 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 MLEXTRAFILES := $(GENMLFILES) $(GENML4FILES) $(GENPLUGINSMOD)
+export MLSTATICFILES := $(call diff, $(EXISTINGML), $(MLEXTRAFILES))
+export MLIFILES := $(sort $(GENMLIFILES) $(EXISTINGMLI))
 
 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 +120,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 +166,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,9 +183,9 @@ 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
@@ -232,22 +194,24 @@ docclean:
 	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
@@ -259,21 +223,25 @@ cleanconfig:
 	rm -f config/Makefile config/coq_config.ml dev/ocamldebug-v7 ide/undo.mli
 
 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 +256,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/" \
@@ -309,3 +277,14 @@ ifdef COQ_CONFIGURED
 else
 	@echo "Please run ./configure first" >&2; exit 1
 endif
+
+# Useful to check that the exported variables are within the win32 limits
+
+printenv:
+	@env
+	@echo
+	@echo -n "Maxsize (win32 limit is 8k) : "
+	@env | wc -L
+	@echo -n "Total (win32 limit is 32k) : "
+	@env | wc -m
+
diff --git a/Makefile.build b/Makefile.build
index 717fcf20..8d3045cc 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,81 @@
 #         #       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.
+
+MLFILES:=$(MLSTATICFILES) $(MLEXTRAFILES)
+
+ALLDEPS:=$(addsuffix .d, \
+  $(ML4FILES) $(MLFILES) $(MLIFILES) $(CFILES) $(MLLIBFILES) $(VFILES))
+
+.SECONDARY: $(ALLDEPS) $(GENFILES) $(ML4FILES:.ml4=.ml)
+
+# 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)
@@ -66,25 +88,36 @@ MLINCLUDES=$(LOCALINCLUDES) -I $(MYCAMLP4LIB)
 OCAMLC += $(CAMLFLAGS)
 OCAMLOPT += $(CAMLFLAGS)
 
-BYTEFLAGS=$(MLINCLUDES) $(CAMLDEBUG) $(USERFLAGS)
-OPTFLAGS=$(MLINCLUDES) $(CAMLDEBUGOPT) $(CAMLTIMEPROF) $(USERFLAGS)
+BAREBYTEFLAGS=$(CAMLDEBUG) $(USERFLAGS)
+BAREOPTFLAGS=$(CAMLDEBUGOPT) $(CAMLTIMEPROF) $(USERFLAGS)
+BYTEFLAGS=$(MLINCLUDES) $(BAREBYTEFLAGS)
+OPTFLAGS=$(MLINCLUDES) $(BAREOPTFLAGS)
 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=`LC_ALL=C 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 +158,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 
 ###########################################################################
@@ -133,30 +173,39 @@ CINCLUDES= -I $(CAMLHLIB)
 
 # libcoqrun.a, dllcoqrun.so
 
+# NB: We used to do a ranlib after ocamlmklib, but it seems that
+# ocamlmklib is already doing it
+
 $(LIBCOQRUN): kernel/byterun/coq_jumptbl.h $(BYTERUN) 
 	cd $(dir $(LIBCOQRUN)) && \
 	$(OCAMLMKLIB) -oc $(COQRUN) $(foreach u,$(BYTERUN),$(notdir $(u)))
-	$(RANLIB) $(LIBCOQRUN)
 
 #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}
+## In Win32, cygwin provides an emulation of ln -s, but this emulation
+## won't work outside of cygwin shell (i.e. typically in a Sys.command).
+## So we just forget about it, and do a simple copy.
+
+ifeq ($(ARCH),win32)
+LN:=cp -f
+else
+LN:=ln -sf
+endif
+
+.PHONY: coqbinaries coq coqlib coqlight states
+
+coqbinaries:: ${COQBINARIES} ${CSDPCERT} ${FAKEIDE}
 
 coq: coqlib tools coqbinaries
 
@@ -166,17 +215,17 @@ 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 $(BAREOPTFLAGS) -o $@
 	$(STRIP) $@
 
-$(COQTOPBYTE): $(COQMKTOP) $(LINKCMO) $(LIBCOQRUN)
+$(COQTOPBYTE): $(BESTCOQMKTOP) $(LINKCMO) $(LIBCOQRUN)
 	$(SHOW)'COQMKTOP -o $@'	
-	$(HIDE)$(COQMKTOP) -boot -top $(BYTEFLAGS) -o $@
+	$(HIDE)$(BESTCOQMKTOP) -boot -top $(BAREBYTEFLAGS) -o $@
 
 $(COQTOPEXE): $(ORDER_ONLY_SEP) $(BESTCOQTOP)
-	cd bin; ln -sf coqtop.$(BEST)$(EXE) coqtop$(EXE)
+	cd bin && $(LN) coqtop.$(BEST)$(EXE) coqtop$(EXE)
 
 LOCALCHKLIBS:=$(addprefix -I , $(CHKSRCDIRS) )
 CHKLIBS:=$(LOCALCHKLIBS) -I $(MYCAMLP4LIB)
@@ -185,52 +234,49 @@ 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)
+	cd bin && $(LN) coqchk.$(BEST)$(EXE) coqchk$(EXE)
 
 # coqmktop 
 
 $(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)
-	cd bin; ln -sf coqmktop.$(BEST)$(EXE) coqmktop$(EXE)
+	cd bin && $(LN) coqmktop.$(BEST)$(EXE) coqmktop$(EXE)
 
 scripts/tolink.ml: Makefile.build Makefile.common
 	$(SHOW)"ECHO... >" $@
 	$(HIDE)echo "let copts = \"-cclib -lcoqrun\"" > $@
 	$(HIDE)echo "let core_libs = \""$(LINKCMO)"\"" >> $@
 	$(HIDE)echo "let core_objs = \""$(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)
-	cd bin; ln -sf coqc.$(BEST)$(EXE) coqc$(EXE)
+$(COQC): $(ORDER_ONLY_SEP) $(BESTCOQC) 
+	cd bin && $(LN) coqc.$(BEST)$(EXE) coqc$(EXE)
 
 # target for libraries
 
@@ -256,21 +302,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 +319,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 +327,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) -o $@ unix.cmxa threads.cmxa \
+		lablgtk.cmxa $(IDEOPTFLAGS) 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)'OCAMLC -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 $<
+	cd bin && $(LN) coqide.$(HASCOQIDE)$(EXE) coqide$(EXE)
 
 # 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"`
-	cd $(FULLBINDIR); ln -sf coqide.byte$(EXE) coqide$(EXE)
+	  $(foreach lib,$(IDECMA:.cma=_MLLIB_DEPENDENCIES),$(addsuffix .cmi,$($(lib))))
+	cd $(FULLBINDIR) && $(LN) 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"`
-	cd $(FULLBINDIR); ln -sf coqide.opt$(EXE) coqide$(EXE)
+	  $(foreach lib,$(IDECMA:.cma=_MLLIB_DEPENDENCIES),$(addsuffix .cmi,$($(lib))))
+	cd $(FULLBINDIR) && $(LN) 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 +404,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 +424,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 +449,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,13 +462,15 @@ noreal: logic arith bool zarith qarith lists sets fsets relations \
 # 3) plugins
 ###########################################################################
 
+.PHONY: plugins omega micromega ring setoid_ring nsatz xml extraction
+.PHONY: field fourier funind cc subtac rtauto pluginsopt
+
 plugins: $(PLUGINSVO)
 omega: $(OMEGAVO) $(OMEGACMA) $(ROMEGAVO) $(ROMEGACMA)
 micromega: $(MICROMEGAVO) $(MICROMEGACMA) $(CSDPCERT)
 ring: $(RINGVO) $(RINGCMA)
 setoid_ring: $(NEWRINGVO) $(NEWRINGCMA)
 nsatz: $(NSATZVO) $(NSATZCMA)
-dp: $(DPCMA)
 xml: $(XMLVO) $(XMLCMA)
 extraction: $(EXTRACTIONCMA)
 field: $(FIELDVO) $(FIELDCMA)
@@ -425,6 +480,8 @@ cc: $(CCVO) $(CCCMA)
 subtac: $(SUBTACCMA)
 rtauto: $(RTAUTOVO) $(RTAUTOCMA)
 
+pluginsopt: $(PLUGINSOPT)
+
 ###########################################################################
 # rules to make theories, plugins and states
 ###########################################################################
@@ -436,97 +493,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 +584,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 +593,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
 
@@ -564,12 +613,12 @@ install-binaries:: install-$(BEST)  install-tools
 install-byte::
 	$(MKDIR) $(FULLBINDIR)
 	$(INSTALLBIN) $(COQMKTOP) $(COQC) $(COQTOPBYTE) $(CHICKEN) $(FULLBINDIR)
-	cd $(FULLBINDIR); ln -sf coqtop.byte$(EXE) coqtop$(EXE); ln -sf coqchk.byte$(EXE) coqchk$(EXE)
+	cd $(FULLBINDIR); $(LN) coqtop.byte$(EXE) coqtop$(EXE); $(LN) coqchk.byte$(EXE) coqchk$(EXE)
 
 install-opt::
 	$(MKDIR) $(FULLBINDIR)
 	$(INSTALLBIN) $(COQMKTOP) $(COQC) $(COQTOPBYTE) $(COQTOPOPT) $(CHICKEN) $(CHICKENOPT) $(FULLBINDIR)
-	cd $(FULLBINDIR); ln -sf coqtop.opt$(EXE) coqtop$(EXE); ln -sf coqchk.opt$(EXE) coqchk$(EXE)
+	cd $(FULLBINDIR); $(LN) coqtop.opt$(EXE) coqtop$(EXE); $(LN) coqchk.opt$(EXE) coqchk$(EXE)
 
 install-tools::
 	$(MKDIR) $(FULLBINDIR)
@@ -579,33 +628,46 @@ 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)
+	$(INSTALLSH) $(FULLCOQLIB) $(LIBFILES) $(PLUGINS)
 	$(MKDIR) $(FULLCOQLIB)/states
 	$(INSTALLLIB) states/*.coq $(FULLCOQLIB)/states
 	$(MKDIR) $(FULLCOQLIB)/user-contrib
+ifneq ($(COQRUNBYTEFLAGS),"-custom")
 	$(INSTALLLIB) $(DLLCOQRUN) $(FULLCOQLIB)
+endif
 	$(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)
+	$(INSTALLSH)  $(FULLCOQLIB) $(CONFIG:.cmo=.cmx) $(CONFIG:.cmo=.o) $(LINKCMO:.cma=.cmxa) $(LINKCMO:.cma=.a) $(PLUGINSOPT)
 endif
 # csdpcert is not meant to be directly called by the user; we install
 # it with libraries
 	-$(MKDIR) $(FULLCOQLIB)/plugins/micromega
 	$(INSTALLBIN) $(CSDPCERT) $(FULLCOQLIB)/plugins/micromega
+	rm -f $(FULLCOQLIB)/revision
 	-$(INSTALLLIB) revision $(FULLCOQLIB)
 
 install-library-light:
 	$(MKDIR) $(FULLCOQLIB)
-	$(INSTALLSH) $(FULLCOQLIB) $(LIBFILESLIGHT) $(INITPLUGINS) $(INITPLUGINSOPT)
+	$(INSTALLSH) $(FULLCOQLIB) $(LIBFILESLIGHT) $(INITPLUGINS)
 	$(MKDIR) $(FULLCOQLIB)/states
 	$(INSTALLLIB) states/*.coq $(FULLCOQLIB)/states
+	rm -f $(FULLCOQLIB)/revision
 	-$(INSTALLLIB) revision $(FULLCOQLIB)
+ifeq ($(BEST),opt)
+	$(INSTALLSH)  $(FULLCOQLIB) $(INITPLUGINSOPT)
+endif
 
 install-coq-info: install-coq-manpages install-emacs install-latex
 
@@ -629,12 +691,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
+
+$(OCAMLDOCDIR)/coq.tex:: $(DOCMLIS:.mli=.cmi)
+	$(OCAMLDOC) -latex -rectypes -I $(MYCAMLP4LIB) $(MLINCLUDES)\
+	$(DOCMLIS) -t "Coq mlis documentation" \
+	-intro $(OCAMLDOCDIR)/docintro -o $@
 
-source-doc:
-	if !(test -d $(SOURCEDOCDIR)); then mkdir $(SOURCEDOCDIR); fi
-	$(OCAMLDOC) -html -rectypes $(LOCALINCLUDES) -d $(SOURCEDOCDIR) $(MLFILES)
+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 +739,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 +747,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 +831,52 @@ 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)
+
+define diff
+ $(strip $(foreach f, $(1), $(if $(filter $(f),$(2)),,$f)))
+endef
+
+MLWITHOUTMLI := $(call diff, $(MLFILES), $(MLIFILES:.mli=.ml))
+
+$(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 +903,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 +932,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
+
+OCAMLDEP_NG = $(COQDEPBOOT) -mldep $(OCAMLDEP)
 
-%.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)
+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)$(OCAMLC) -ccopt "-MM -MQ $@ -MQ $(<:.c=.o) -isystem $(CAMLHLIB)" $< $(TOTARGET)
 
 ###########################################################################
 # this sets up developper supporting stuff
@@ -900,28 +988,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..444a7ee5 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,34 @@ 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)
 
+CORESRCDIRS:=\
+  config 	lib		kernel		kernel/byterun	library \
+  proofs 	tactics 	pretyping	interp		toplevel \
+  parsing
+
+PLUGINS:=\
+  omega		romega 		micromega 	quote		ring \
+  setoid_ring 	xml 		extraction 	fourier \
+  cc 		funind 		firstorder 	field 		subtac \
+  rtauto 	nsatz           syntax          decl_mode
+
 SRCDIRS:=\
-  config 	tools 		tools/coqdoc 	scripts		lib \
-  kernel	kernel/byterun	library 	proofs 		tactics \
-  pretyping	interp		toplevel 	parsing 	ide/utils \
-  ide		\
-  $(addprefix plugins/, \
-    omega	romega 		micromega 	quote		ring	dp \
-    setoid_ring xml 		extraction 	fourier \
-    cc 		funind 		firstorder 	field 		subtac \
-    rtauto 	nsatz           syntax)
+  $(CORESRCDIRS)  \
+  tools 	tools/coqdoc 	scripts		ide/utils	ide \
+  $(addprefix plugins/, $(PLUGINS))
 
 # Order is relevent here because kernel and checker contain files
 # with the same name
@@ -101,8 +119,8 @@ HEVEA:=hevea
 HEVEAOPTS:=-fix -exec xxdate.exe
 HEVEALIB:=/usr/local/lib/hevea:/usr/lib/hevea
 HTMLSTYLE:=simple
-export TEXINPUTS:=$(COQSRC)/doc:$(HEVEALIB):
-COQTEXOPTS:=-n 72 -image "$(COQSRC)/$(COQTOPEXE) -boot" -sl -small
+export TEXINPUTS:=$(HEVEALIB):
+COQTEXOPTS:=-boot -n 72 -sl -small
 
 DOCCOMMON:=doc/common/version.tex doc/common/title.tex doc/common/macros.tex 
 
@@ -112,14 +130,15 @@ REFMANCOQTEXFILES:=$(addprefix doc/refman/, \
   RefMan-cic.v.tex RefMan-lib.v.tex \
   RefMan-tacex.v.tex RefMan-syn.v.tex \
   RefMan-oth.v.tex RefMan-ltac.v.tex \
-  RefMan-decl.v.tex \
+  RefMan-decl.v.tex RefMan-sch.v.tex \
+  RefMan-pro.v.tex \
   Cases.v.tex Coercion.v.tex Extraction.v.tex \
   Program.v.tex Omega.v.tex Micromega.v.tex Polynom.v.tex Nsatz.v.tex \
   Setoid.v.tex Helm.tex Classes.v.tex )
 
 REFMANTEXFILES:=$(addprefix doc/refman/, \
   headers.sty Reference-Manual.tex \
-  RefMan-pre.tex RefMan-int.tex RefMan-pro.tex RefMan-com.tex \
+  RefMan-pre.tex RefMan-int.tex RefMan-com.tex \
   RefMan-uti.tex RefMan-ide.tex RefMan-add.tex RefMan-modr.tex ) \
   $(REFMANCOQTEXFILES) \
 
@@ -139,10 +158,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 +173,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
@@ -165,7 +182,6 @@ QUOTECMA:=plugins/quote/quote_plugin.cma
 RINGCMA:=plugins/ring/ring_plugin.cma
 NEWRINGCMA:=plugins/setoid_ring/newring_plugin.cma
 NSATZCMA:=plugins/nsatz/nsatz_plugin.cma
-DPCMA:=plugins/dp/dp_plugin.cma
 FIELDCMA:=plugins/field/field_plugin.cma
 XMLCMA:=plugins/xml/xml_plugin.cma
 FOURIERCMA:=plugins/fourier/fourier_plugin.cma
@@ -182,16 +198,17 @@ 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) \
-        $(QUOTECMA) $(RINGCMA) $(NEWRINGCMA) $(DPCMA) $(FIELDCMA) \
+PLUGINSCMA:=$(OMEGACMA) $(ROMEGACMA) $(MICROMEGACMA) $(DECLMODECMA) \
+        $(QUOTECMA) $(RINGCMA) $(NEWRINGCMA) $(FIELDCMA) \
         $(FOURIERCMA) $(EXTRACTIONCMA) $(XMLCMA) \
         $(CCCMA)  $(FOCMA) $(SUBTACCMA) $(RTAUTOCMA) \
         $(FUNINDCMA) $(NSATZCMA) $(NATSYNTAXCMA) $(OTHERSYNTAXCMA)
 
 ifneq ($(HASNATDYNLINK),false)
  STATICPLUGINS:=
- INITPLUGINS:=$(EXTRACTIONCMA) $(FOCMA) $(CCCMA) $(DPCMA) \
+ INITPLUGINS:=$(EXTRACTIONCMA) $(FOCMA) $(CCCMA) \
 	$(XMLCMA) $(FUNINDCMA) $(SUBTACCMA) $(NATSYNTAXCMA)
  INITPLUGINSOPT:=$(INITPLUGINS:.cma=.cmxs)
  PLUGINS:=$(PLUGINSCMA)
@@ -204,24 +221,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 +243,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 +279,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 +299,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)
 
@@ -328,7 +319,6 @@ NEWRINGVO:=$(call cat_vo_itarget, plugins/setoid_ring)
 NSATZVO:=$(call cat_vo_itarget, plugins/nsatz)
 FOURIERVO:=$(call cat_vo_itarget, plugins/fourier)
 FUNINDVO:=$(call cat_vo_itarget, plugins/funind)
-DPVO:=$(call cat_vo_itarget, plugins/dp)
 RTAUTOVO:=$(call cat_vo_itarget, plugins/rtauto)
 EXTRACTIONVO:=$(call cat_vo_itarget, plugins/extraction)
 XMLVO:=
@@ -336,11 +326,12 @@ CCVO:=
 
 PLUGINSVO:= $(OMEGAVO) $(ROMEGAVO) $(MICROMEGAVO) $(RINGVO) $(FIELDVO) \
 	    $(XMLVO) $(FOURIERVO) $(CCVO) $(FUNINDVO) \
-	    $(RTAUTOVO) $(NEWRINGVO) $(DPVO) $(QUOTEVO) \
+	    $(RTAUTOVO) $(NEWRINGVO) $(QUOTEVO) \
             $(NSATZVO) $(EXTRACTIONVO)
 
 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 +342,6 @@ ALLMODS:=$(call vo_to_mod,$(ALLVO))
 LIBFILES:=$(THEORIESVO) $(PLUGINSVO)
 LIBFILESLIGHT:=$(THEORIESLIGHTVO)
 
-
 ###########################################################################
 # Miscellaneous
 ###########################################################################
@@ -361,58 +351,20 @@ MANPAGES:=man/coq-tex.1 man/coqdep.1 man/gallina.1 \
 	man/coqwc.1 man/coqdoc.1 man/coqide.1 \
 	man/coq_makefile.1 man/coqmktop.1 man/coqchk.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..31a0675c 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 refman-html-dir
 
-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 \
@@ -47,10 +53,10 @@ rectutorial: doc/RecTutorial/RecTutorial.html \
 
 ifdef QUICK
 %.v.tex: %.tex
-	(cd `dirname $<`; $(COQSRC)/$(COQTEX) $(COQTEXOPTS) `basename $<`)
+	$(COQTEX) $(COQTEXOPTS) $<
 else
 %.v.tex: %.tex $(COQTEX) $(COQTOPEXE) $(PLUGINSVO) $(THEORIESVO)
-	(cd `dirname $<`; $(COQSRC)/$(COQTEX) $(COQTEXOPTS) `basename $<`)
+	$(COQTEX) $(COQTEXOPTS) $<
 endif
 
 %.ps: %.dvi
@@ -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,8 +123,13 @@ 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): refman-html-dir
+
+refman-html-dir: 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
@@ -133,6 +144,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
 ######################################################################
 
@@ -185,16 +204,16 @@ doc/faq/html/index.html: doc/faq/FAQ.v.html
 ifdef QUICK
 doc/stdlib/html/genindex.html:
 else
-doc/stdlib/html/genindex.html: | $(COQDOC) $(THEORIESVO) $(PLUGINSVO)
+doc/stdlib/html/genindex.html: | $(COQDOC) $(THEORIESVO)
 endif
 	- 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)
+	  -R theories Coq $(THEORIESVO:.vo=.v)
 	mv doc/stdlib/html/index.html doc/stdlib/html/genindex.html
 
 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/make-library-index doc/stdlib/index-list.html doc/stdlib/hidden-files
 
 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 > $@
@@ -221,6 +240,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.tmp -e 's///g' $@ && rm $@.tmp
+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.tmp -e 's///g' $@ && rm $@.tmp
+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 +289,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 +321,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..9bf63c43 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.
@@ -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@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://coq.inria.fr/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/_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..4fca642e 100755
--- a/build
+++ b/build
@@ -5,17 +5,21 @@ 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
 }
 
-ocb() { $OCAMLBUILD $FLAGS $*; }
+# NB: we exec ocamlbuild and run ocb last for a correct exit code
+
+ocb() { exec $OCAMLBUILD $FLAGS $*; }
 
 rule() {
   check_config
   case $1 in
-    clean)  ocb -clean && rm -rf bin/* && rm -f $MYCFG;;
+    clean)  rm -rf bin/* $MYCFG && ocb -clean;;
     all)    ocb coq.otarget;;
     win32)  ocb coq-win32.otarget;;
     *)      ocb $1;;
diff --git a/checker/check.ml b/checker/check.ml
index 40119a7e..fb0dc12a 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-2012     *)
 (*   \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 (md:library_disk) = System.marshal_in f ch in
+      let digest = System.marshal_in f ch in
+      let table = (System.marshal_in f ch : Safe_typing.LightenLibrary.table) in
       close_in ch;
       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..6f4d96cf 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-2012     *)
 (*   \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..01912e41 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-2012     *)
 (*   \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 c8cb58ae..e5e20b1a 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-2012     *)
 (*   \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)*)
-  | Compat.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 ()
@@ -377,7 +371,8 @@ let run () =
     compile_files ();
     flush_all()
   with e ->
-    (Pp.ppnl(explain_exn e);
+    (flush_all();
+    Pp.ppnl(explain_exn e);
     flush_all();
     exit 1)
 
diff --git a/checker/closure.ml b/checker/closure.ml
index da25b3b3..34f0b396 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-2012     *)
 (*   \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..428197fa 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-2012     *)
 (*   \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..2d3b38c7 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-2012     *)
 (*   \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..691c9466 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-2012     *)
 (*   \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..0e489fbf 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-2012     *)
 (*   \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..d0040e3d 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-2012     *)
 (*   \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..dc3ed452 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
@@ -53,17 +53,14 @@ let path_of_mexpr = function
   | SEBident mp -> mp
   | _ -> raise Not_path
 
-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 is_modular = function
+  | SFBmodule _ | SFBmodtype _ -> true
+  | SFBconst _ | SFBmind _ -> false
 
-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 rec list_split_assoc ((k,m) as km) rev_before = function
+  | [] -> raise Not_found
+  | (k',b)::after when k=k' && is_modular b = m -> rev_before,b,after
+  | h::tail -> list_split_assoc km (h::rev_before) tail
 
 let check_definition_sub env cb1 cb2 =
   let check_type env t1 t2 =
@@ -117,54 +114,61 @@ 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
   with Not_found ->
     failwith ("Unknown module type: "^string_of_mp mp)
 
+let lookup_module mp env =
+  try Environ.lookup_module mp env
+  with Not_found ->
+    failwith ("Unknown module: "^string_of_mp mp)
+
 let rec check_with env mtb with_decl mp=
   match with_decl with
-    | With_definition_body _ ->
-	check_with_aux_def env mtb with_decl mp;
+    | With_definition_body (idl,c) ->
+	check_with_def env mtb (idl,c) mp;
 	mtb
-    | With_module_body _ ->
-	check_with_aux_mod env mtb with_decl mp;
+    | With_module_body (idl,mp1) ->
+	check_with_mod env mtb (idl,mp1) mp;
 	mtb
 
-and check_with_aux_def env mtb with_decl mp =
+and check_with_def env mtb (idl,c) mp =
   let sig_b = match mtb with
     | SEBstruct(sig_b) ->
 	sig_b
     | _ -> error_signature_expected mtb
   in
-  let id,idl = match with_decl with
-    | With_definition_body (id::idl,_) | With_module_body (id::idl,_) ->
-                                           id,idl
-    | With_definition_body ([],_) | With_module_body ([],_) -> assert false
+  let id,idl = match idl with
+    | [] -> assert false
+    | id::idl -> id,idl
   in
   let l = label_of_id id in
     try
-      let rev_before,spec,after = list_split_assoc l [] sig_b in
+      let rev_before,spec,after = list_split_assoc (l,(idl<>[])) [] sig_b in
       let before = List.rev rev_before in
       let env' = Modops.add_signature mp before empty_delta_resolver env in
-	match with_decl with
-          | With_definition_body ([],_) -> assert false
-	  | With_definition_body ([id],c) ->
+      if idl = [] then
 	      let cb = match spec with
 		  SFBconst cb -> cb
 		| _ -> error_not_a_constant l
 	      in
               check_definition_sub env' c cb
-	  | With_definition_body (_::_,_) ->
+      else
 	      let old = match spec with
 		  SFBmodule msb -> msb
 		| _ -> error_not_a_module l
@@ -172,49 +176,36 @@ and check_with_aux_def env mtb with_decl mp =
 		begin
 		  match old.mod_expr with
                     | None ->
-			let new_with_decl = match with_decl with
-			    With_definition_body (_,c) ->
-                              With_definition_body (idl,c)
-			  | With_module_body (_,c) ->
-                              With_module_body (idl,c) in
-			  check_with_aux_def env' old.mod_type new_with_decl (MPdot(mp,l))
+		        check_with_def env' old.mod_type (idl,c) (MPdot(mp,l))
                     | Some msb ->
 			error_a_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
 
-and check_with_aux_mod env mtb with_decl mp =
+and check_with_mod env mtb (idl,mp1) mp =
   let sig_b =
     match mtb with
     | SEBstruct(sig_b) ->
 	sig_b
     | _ -> error_signature_expected mtb in
-  let id,idl = match with_decl with
-    | With_definition_body (id::idl,_) | With_module_body (id::idl,_) ->
-        id,idl
-    | With_definition_body ([],_) | With_module_body ([],_) -> assert false
+  let id,idl = match idl with
+    | [] -> assert false
+    | id::idl -> id,idl
   in
   let l = label_of_id id in
     try
-      let rev_before,spec,after = list_split_assoc l [] sig_b in
+      let rev_before,spec,after = list_split_assoc (l,false) [] sig_b in
       let before = List.rev rev_before in
-      let rec mp_rec = function
-	| [] -> mp
-	| i::r -> MPdot(mp_rec r,label_of_id i)
-      in
       let env' = Modops.add_signature mp before empty_delta_resolver env in
-	match with_decl with
-          | With_module_body ([],_) -> assert false
-	  | With_module_body ([id], mp1) ->
+      if idl = [] then
 	      let _ = match spec with
 		  SFBmodule msb -> msb
 		| _ -> error_not_a_module l
 	      in
-	      let (_:module_body) = (lookup_module mp1 env) in ()
-        | With_module_body (_::_,mp) ->
+	      let (_:module_body) = (Environ.lookup_module mp1 env) in ()
+      else
 	    let old = match spec with
 		SFBmodule msb -> msb
 	      | _ -> error_not_a_module l
@@ -222,17 +213,11 @@ and check_with_aux_mod env mtb with_decl mp =
 	      begin
 		match old.mod_expr with
                     None ->
-                      let new_with_decl = match with_decl with
-			  With_definition_body (_,c) ->
-			    With_definition_body (idl,c)
-			| With_module_body (_,c) ->
-                            With_module_body (idl,c) in
-		 	check_with_aux_mod env'
-			  old.mod_type new_with_decl (MPdot(mp,l))
+		      check_with_mod env'
+			  old.mod_type (idl,mp1) (MPdot(mp,l))
                   | Some msb ->
                       error_a_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
@@ -259,14 +244,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..a88afd7b 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-2012     *)
 (*   \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..90d607ba 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-2012     *)
 (*   \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..ecbcb75d 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-2012     *)
 (*   \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..de7a41d4 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-2012     *)
 (*   \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..2f6e5c3b 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-2012     *)
 (*   \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..70bc428b 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-2012     *)
 (*   \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..00afd165 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-2012     *)
 (*   \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..6953df7d 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-2012     *)
 (*   \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
@@ -30,15 +28,18 @@ type namedobject =
   | Constant of constant_body
   | IndType of inductive * mutual_inductive_body
   | IndConstr of constructor * mutual_inductive_body
+
+type namedmodule =
   | Module of module_body
   | Modtype of module_type_body
 
 (* adds above information about one mutual inductive: all types and
    constructors *)
 
-let add_nameobjects_of_mib ln mib map =
-  let add_nameobjects_of_one j oib map =
-    let ip = (ln,j) in
+let add_mib_nameobjects mp l mib map =
+  let ind = make_mind mp empty_dirpath l in
+  let add_mip_nameobjects j oib map =
+    let ip = (ind,j) in
     let map =
       array_fold_right_i
       (fun i id map ->
@@ -48,22 +49,32 @@ let add_nameobjects_of_mib ln mib map =
     in
       Labmap.add (label_of_id oib.mind_typename) (IndType (ip, mib)) map
   in
-    array_fold_right_i add_nameobjects_of_one mib.mind_packets map
+    array_fold_right_i add_mip_nameobjects mib.mind_packets map
+
+
+(* creates (namedobject/namedmodule) map for the whole signature *)
 
+type labmap = { objs : namedobject Labmap.t; mods : namedmodule Labmap.t }
 
-(* creates namedobject map for the whole signature *)
+let empty_labmap = { objs = Labmap.empty; mods = Labmap.empty }
 
-let make_label_map mp list =
+let get_obj mp map l =
+  try Labmap.find l map.objs
+  with Not_found -> error_no_such_label_sub l mp
+
+let get_mod mp map l =
+  try Labmap.find l map.mods
+  with Not_found -> error_no_such_label_sub l mp
+
+let make_labmap mp list =
   let add_one (l,e) map =
-   let add_map obj = Labmap.add l obj map in
    match e with
-    | SFBconst cb -> add_map (Constant cb)
-    | SFBmind mib ->
-       add_nameobjects_of_mib (make_mind mp empty_dirpath l) mib map
-    | SFBmodule mb -> add_map (Module mb)
-    | SFBmodtype mtb -> add_map (Modtype mtb)
+    | SFBconst cb -> { map with objs = Labmap.add l (Constant cb) map.objs }
+    | SFBmind mib -> { map with objs = add_mib_nameobjects mp l mib map.objs }
+    | SFBmodule mb -> { map with mods = Labmap.add l (Module mb) map.mods }
+    | SFBmodtype mtb -> { map with mods = Labmap.add l (Modtype mtb) map.mods }
   in
-    List.fold_right add_one list Labmap.empty
+  List.fold_right add_one list empty_labmap
 
 
 let check_conv_error error f env a1 a2 =
@@ -239,22 +250,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 +280,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,42 +291,37 @@ 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
-   | _ -> error ()
 
 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;
  
 
 and check_signatures env mp1 sig1 sig2 subst1 subst2 = 
-  let map1 = make_label_map mp1 sig1 in
+  let map1 = make_labmap mp1 sig1 in
   let check_one_body  (l,spec2) =
-    let info1 =
-      try
-	Labmap.find l map1
-      with
-	  Not_found -> error_no_such_label_sub l mp1
-    in
       match spec2 with
 	| SFBconst cb2 ->
-	    check_constant  env mp1 l info1 cb2 spec2 subst1 subst2
+	    check_constant  env mp1 l (get_obj mp1 map1 l)
+	      cb2 spec2 subst1 subst2
 	| SFBmind mib2 ->
-	    check_inductive env mp1 l info1 mib2 spec2 subst1 subst2
+	    check_inductive env mp1 l (get_obj mp1 map1 l)
+	      mib2 spec2 subst1 subst2
 	| SFBmodule msb2 ->
 	    begin
-	      match info1 with
+	      match get_mod mp1 map1 l with
 		| Module msb -> check_modules env msb msb2 
 		    subst1 subst2
 		| _ -> error_not_match l spec2
 	    end
 	| SFBmodtype mtb2 ->
 	    let mtb1 =
-	      match info1 with
+	      match get_mod mp1 map1 l with
 		| Modtype mtb -> mtb
 		| _ -> error_not_match l spec2
 	    in
@@ -363,11 +376,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..121e3754 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-2012     *)
 (*   \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..4a3f47a3 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-2012     *)
 (*   \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..bcfc31c6 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-2012     *)
 (*   \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..c57b1556 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-2012     *)
 (*   \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..0daedec9 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-2012     *)
 (*   \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..fc16c9ed 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-2012     *)
 (*   \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..620b4fb0 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-2012     *)
 (*   \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
deleted file mode 100644
index 8864f52d..00000000
--- a/config/Makefile.template
+++ /dev/null
@@ -1,153 +0,0 @@
-##################################
-#
-#  Configuration file for Coq
-# 
-##################################
-
-#############################################################################
-#
-#  This file is generated by the script "configure"
-#
-#  DO NOT EDIT IT !! DO NOT EDIT IT !! DO NOT EDIT IT !! DO NOT EDIT IT !! 
-#
-#  If something is wrong below, then rerun the script "configure"
-#  with the good options (see the file INSTALL).
-#
-#############################################################################
-
-#Variable used to detect whether ./configure has run successfully.
-COQ_CONFIGURED=yes
-
-# Local use (no installation)
-LOCAL=LOCALINSTALLATION
-
-# Bytecode link flags for VM ("-custom" or "-dllib -lcoqrun")
-COQRUNBYTEFLAGS=XCOQRUNBYTEFLAGS
-COQTOOLSBYTEFLAGS=XCOQTOOLSBYTEFLAGS
-BUILDLDPATH=
-
-# Paths for true installation
-# BINDIR=path where coqtop, coqc, coqmktop, coq-tex, coqdep, gallina and
-#        do_Makefile will reside
-# LIBDIR=path where the Coq library will reside
-# MANDIR=path where to install manual pages
-# EMACSDIR=path where to put Coq's Emacs mode (coq.el)
-BINDIR="BINDIRDIRECTORY"
-COQLIBINSTALL="COQLIBDIRECTORY"
-MANDIR="MANDIRDIRECTORY"
-DOCDIR="DOCDIRDIRECTORY"
-EMACSLIB="EMACSLIBDIRECTORY"
-EMACS=EMACSCOMMAND
-
-# Path to Coq distribution
-COQSRC=COQSRCDIRECTORY
-VERSION=COQVERSION
-
-# Directory containing Camlp4 binaries. Can be empty if camlp4 is in the PATH
-CAMLP4BIN="CAMLP4BINDIRECTORY"
-
-# Ocaml version number
-CAMLVERSION=CAMLTAG
-
-# Ocaml libraries
-CAMLLIB="CAMLLIBDIRECTORY"
-
-# Ocaml .h directory
-CAMLHLIB="CAMLLIBDIRECTORY"
-
-# Camlp4 library directory (avoid CAMLP4LIB used on Windows)
-CAMLP4O=CAMLP4TOOL
-CAMLP4COMPAT=CAMLP4COMPATFLAGS
-MYCAMLP4LIB="CAMLP4LIBDIRECTORY"
-
-# LablGTK
-COQIDEINCLUDES=LABLGTKINCLUDES
-
-# Objective-Caml compile command 
-OCAML="OCAMLEXEC"
-OCAMLC="BYTECAMLC"
-OCAMLMKLIB="OCAMLMKLIBEXEC"
-OCAMLOPT="NATIVECAMLC"
-OCAMLDEP="OCAMLDEPEXEC"
-OCAMLDOC="OCAMLDOCEXEC"
-OCAMLLEX="OCAMLLEXEXEC"
-OCAMLYACC="OCAMLYACCEXEC"
-
-# Caml link command and Caml make top command
-CAMLLINK="BYTECAMLC"
-CAMLOPTLINK="NATIVECAMLC"
-CAMLMKTOP="CAMLMKTOPEXEC"
-
-# Caml flags
-CAMLFLAGS=-rectypes CAMLANNOTATEFLAG
-
-# Compilation debug flags
-CAMLDEBUG=COQDEBUGFLAG
-CAMLDEBUGOPT=COQDEBUGFLAGOPT
-
-# User compilation flag
-USERFLAGS=
-
-# Flags for GCC
-CFLAGS=CCOMPILEFLAGS
-
-# Compilation profile flag
-CAMLTIMEPROF=COQPROFILEFLAG
-
-# The best compiler: native (=opt) or bytecode (=byte) if no native compiler
-BEST=BESTCOMPILER
-
-# Your architecture
-# Can be obtain by UNIX command arch
-ARCH=ARCHITECTURE
-HASNATDYNLINK=HASNATIVEDYNLINK
-
-# Your C compiler and co
-CC="CCEXEC"
-AR="AREXEC"
-RANLIB="RANLIBEXEC"
-
-# Supplementary libs for some systems, currently:
-#  . Sun Solaris: -cclib -lunix -cclib -lnsl -cclib -lsocket
-#  . others     : -cclib -lunix
-#  . windows	: -cclib -lunix
-
-OSDEPLIBS=OSDEPENDENTLIBS
-
-# executable files extension, currently:
-#  Unix systems:
-#  Win32 systems : .exe
-EXE=EXECUTEEXTENSION
-DLLEXT=DLLEXTENSION
-
-# the command MKDIR (try to replace it with mkdirhier if you have problems)
-MKDIR=mkdir -p
-
-# where to put the coqdoc.sty style file
-COQDOCDIR="COQDOCDIRECTORY"
-
-# command to update TeX' kpathsea database
-#MKTEXLSR=MKTEXLSRCOMMAND
-
-#the command STRIP 
-# Unix systems and profiling: true
-# Unix systems and no profiling: strip
-# Win32 systems: true (actually strip is bogus)
-STRIP=STRIPCOMMAND
-
-# CoqIde (no/byte/opt)
-HASCOQIDE=COQIDEOPT
-
-# 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
-
-# make or sed are bogus and believe lines not terminating by a return
-# are inexistent
diff --git a/config/coq_config.mli b/config/coq_config.mli
index 6845df7d..2f8ea5a4 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-2012     *)
 (*   \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 16b2a82a..f7bdf154 100755
--- a/configure
+++ b/configure
@@ -6,10 +6,10 @@
 # 
 ##################################
 
-VERSION=8.3pl4
-VOMAGIC=08300
-STATEMAGIC=58300
-DATE=`LANG=C date +"%B %Y"`
+VERSION=8.4pl2
+VOMAGIC=08400
+STATEMAGIC=58400
+DATE=`LC_ALL=C LANG=C date +"%B %Y"`
 
 # Create the bin/ directory if non-existent
 test -d bin || mkdir bin
@@ -35,31 +35,36 @@ usage () {
     printf "\tSet installation directory to <dir>\n"
     echo "-local"
     printf "\tSet installation directory to the current source tree\n"
-    echo "-coqrunbyteflags"
+    echo "-coqrunbyteflags <flags>"
     printf "\tSet link flags for VM-dependent bytecode (coqtop)\n"
-    echo "-coqtoolsbyteflags"
+    echo "-coqtoolsbyteflags <flags>"
     printf "\tSet link flags for VM-independant bytecode (coqdep, coqdoc, ...)\n"
     echo "-custom"
     printf "\tGenerate all bytecode executables with -custom (not recommended)\n"
-    echo "-src"
+    echo "-src <dir>"
     printf "\tSpecifies the source directory\n"
-    echo "-bindir"
-    echo "-libdir"
-    echo "-mandir"
-    echo "-docdir"
-    printf "\tSpecifies where to install bin/lib/man/doc files resp.\n"
-    echo "-emacslib"
-    echo "-emacs"
+    echo "-bindir <dir>"
+    echo "-libdir <dir>"
+    echo "-configdir <dir>"
+    echo "-datadir <dir>"
+    echo "-mandir <dir>"
+    echo "-docdir <dir>"
+    printf "\tSpecifies where to install bin/lib/config/data/man/doc files resp.\n"
+    echo "-emacslib <dir>"
     printf "\tSpecifies where emacs files are to be installed\n"
-    echo "-coqdocdir"
+    echo "-coqdocdir <dir>"
     printf "\tSpecifies where Coqdoc style files are to be installed\n"
-    echo "-camldir"
+    echo "-camldir <dir>"
     printf "\tSpecifies the path to the OCaml library\n"
-    echo "-lablgtkdir"
+    echo "-lablgtkdir <dir>"
     printf "\tSpecifies the path to the Lablgtk library\n"
-    echo "-camlp5dir"
+    echo "-usecamlp5"
+    printf "\tSpecifies to use camlp5 instead of camlp4\n"
+    echo "-usecamlp4"
+    printf "\tSpecifies to use camlp4 instead of camlp5\n"
+    echo "-camlp5dir <dir>"
     printf "\tSpecifies where to look for the Camlp5 library and tells to use it\n"
-    echo "-arch"
+    echo "-arch <arch>"
     printf "\tSpecifies the architecture\n"
     echo "-opt"
     printf "\tSpecifies whether or not to use OCaml *.opt optimized compilers\n"
@@ -67,16 +72,14 @@ 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)"
     printf "\tSpecifies whether or not to compile the documentation\n"
     echo "-with-geoproof (yes|no)"
     printf "\tSpecifies whether or not to use Geoproof binding\n"
-    echo "-with-cc <file>"
-    echo "-with-ar <file>"
-    echo "-with-ranlib <file>"
-    printf "\tTells configure where to find gcc/ar/ranlib executables\n"
     echo "-byte-only"
     printf "\tCompiles only bytecode version of Coq\n"
     echo "-debug"
@@ -85,6 +88,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"
 }
 
 
@@ -109,10 +114,6 @@ best_compiler=opt
 cflags="-fno-defer-pop -Wall -Wno-unused"
 natdynlink=yes
 
-gcc_exec=gcc
-ar_exec=ar
-ranlib_exec=ranlib
-
 local=false
 coqrunbyteflags_spec=no
 coqtoolsbyteflags_spec=no
@@ -121,6 +122,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 +133,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 +141,7 @@ with_doc=all
 with_doc_spec=no
 force_caml_version=no
 force_caml_version_spec=no
+usecamlp5=yes
 
 COQSRC=`pwd`
 
@@ -157,8 +162,7 @@ while : ; do
     -coqtoolsbyteflags|--coqtoolsbyteflags) coqtoolsbyteflags_spec=yes
                                             coqtoolsbyteflags="$2"
                                             shift;;
-    -custom|--custom) custom_spec=yes
-                      shift;;
+    -custom|--custom) custom_spec=yes;;
     -src|--src) src_spec=yes
                 COQSRC="$2"
 	        shift;;
@@ -168,6 +172,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;;
@@ -179,6 +189,7 @@ while : ; do
 			  shift;;
     -emacs |--emacs) emacs_spec=yes
 		     emacs="$2"
+                     printf "Warning: obsolete -emacs option\n"
 		     shift;;
     -coqdocdir|--coqdocdir) coqdocdir_spec=yes
 	              coqdocdir="$2"
@@ -189,7 +200,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 +225,8 @@ while : ; do
 			  *) COQIDE=no
 		      esac
 		      shift;;
+    -nomacintegration) nomacintegration_spec=yes
+		      shift;;
     -browser|--browser) browser_spec=yes
 		      BROWSER=$2
 		      shift;;
@@ -227,18 +245,8 @@ while : ; do
 	      no) with_geoproof=false;;
 	  esac
 	  shift;;
-    -with-cc|-with-gcc|--with-cc|--with-gcc) 
-	  gcc_spec=yes
-	  gcc_exec=$2
-	  shift;;
-    -with-ar|--with-ar) 
-	  ar_spec=yes
-	  ar_exec=$2
-	  shift;;
-    -with-ranlib|--with-ranlib) 
-	  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;;
@@ -263,28 +271,31 @@ case $DATEPGM in
     "") echo "I can't find the program \"date\" in your path."
         echo "Please give me the current date"
 	read COMPILEDATE;;
-    *)  COMPILEDATE=`date +"%h %d %Y %H:%M:%S"`;;
+    *)  COMPILEDATE=`LC_ALL=C LANG=C date +"%b %d %Y %H:%M:%S"`;;
 esac
 
 # Architecture
 
 case $arch_spec in
     no) 
-    # First we test if we are running a Cygwin system
+    # First we test if we are running a Cygwin or Mingw/Msys system
     if [ `uname -s | cut -c -6` = "CYGWIN" ] ; then
 	ARCH="win32"
+	CYGWIN=yes
+    elif [ `uname -s | cut -c -7` = "MINGW32" ]; then
+	ARCH="win32"
     else
 	# If not, we determine the architecture
-	if test -x /bin/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 +330,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 +339,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
@@ -356,7 +369,8 @@ fi
 
 if [ "$browser_spec" = "no" ]; then
     case $ARCH in
-        win32) BROWSER='C:\PROGRA~1\INTERN~1\IEXPLORE %s' ;;
+        win32) BROWSER='start %s' ;;
+	Darwin) BROWSER='open %s' ;;
         *) BROWSER='firefox -remote "OpenURL(%s,new-tab)" || firefox %s &' ;;
     esac
 fi
@@ -404,24 +418,38 @@ if test ! -f "$CAMLC" ; then
     exit 1
 fi
 
-# Under Windows, OCaml only understands Windows filenames (C:\...)
-case $ARCH in
-    win32) CAMLBIN=`cygpath -m ${CAMLBIN}`;;
+# Under Windows, we need to convert from cygwin/mingw paths (/c/Program Files/Ocaml)
+# to more windows-looking paths (c:/Program Files/Ocaml). Note that / are kept
+
+mk_win_path () {
+    case $ARCH,$CYGWIN in
+	win32,yes) cygpath -m "$1" ;;
+	win32*) "$ocamlexec" "tools/mingwpath.ml" "$1" ;;
+	*) echo "$1" ;;
+    esac
+}
+
+case $ARCH,$src_spec in
+    win32,yes) echo "Error: the -src option is currently not supported on Windows"
+	       exit 1;;
+    win32) CAMLBIN=`mk_win_path "$CAMLBIN"`;;
 esac
 
-CAMLVERSION=`"$bytecamlc" -version`
+# Beware of the final \r in Win32
+CAMLVERSION=`"$CAMLC" -version | tr -d "\r"`
+CAMLLIB=`"$CAMLC" -where | tr -d "\r"`
 
 case $CAMLVERSION in
-    1.*|2.*|3.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*|3.10*|3.11.[01])
 	echo "Your version of Objective-Caml is $CAMLVERSION."
 	if [ "$force_caml_version" = "yes" ]; then
 	    echo "*Warning* You are compiling Coq with an outdated version of Objective-Caml."
 	else
-	    echo "          You need Objective-Caml 3.10.2 or later."
+	    echo "          You need Objective-Caml 3.11.2 or later."
 	    echo "          Configuration script failed!"
 	    exit 1
 	fi;;
-    ?*)
+    3.11.2|3.12*|4.*)
 	CAMLP4COMPAT="-loc loc" 
 	echo "You have Objective-Caml $CAMLVERSION. Good!";;
     *)
@@ -435,16 +463,9 @@ CAMLTAG=OCAML`echo $CAMLVERSION | sed -e "s/\([1-9]\)\.\([0-9]*\).*/\1\2/g"`
 
 # For coqmktop & bytecode compiler
 
-case $ARCH in
-    win32) # Awfull trick to get around a ^M problem at the end of CAMLLIB
-      CAMLLIB=`"$CAMLC" -where | sed -e 's/^\(.*\)$/\1/'` ;;
-    *)
-      CAMLLIB=`"$CAMLC" -where`
-esac
-
 if [ "$coq_debug_flag" = "-g" ]; then
     case $CAMLTAG in
-        OCAML31*)
+        OCAML31*|OCAML4*)
             # Compilation debug flag
             coq_debug_flag_opt="-g"
             ;;
@@ -452,13 +473,13 @@ if [ "$coq_debug_flag" = "-g" ]; then
 fi
 
 # Native dynlink
-if [ "$natdynlink" = "yes" -a -f `"$CAMLC" -where`/dynlink.cmxa ]; then
+if [ "$natdynlink" = "yes" -a -f "$CAMLLIB"/dynlink.cmxa ]; then
     HASNATDYNLINK=true
 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 +504,86 @@ 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}
+
+case $usecamlp5 in
+  yes)
     CAMLP4=camlp5
-    CAMLP4LIB=$camlp5dir
-    if [ ! -f $camlp5dir/camlp5.cma ]; then
-	echo "Cannot find camlp5 libraries in $camlp5dir (camlp5.cma not found)."
-	echo "Configuration script failed!"
-	exit 1
+    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 "No Camlp5 installation found. Looking for Camlp4 instead..."
+	usecamlp5=no
     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
-            ;;
+esac
+
+# If we're (still...) going to use Camlp5, let's check its version
+
+case $usecamlp5 in
+  yes)
+    camlp4oexec=`echo "$camlp4oexec" | tr 4 5`
+    case `"$camlp4oexec" -v 2>&1` in
+	*"version 4.0"*|*5.00*)
+	    echo "Camlp5 version < 5.01 not supported."
+	    echo "Configuration script failed!"
+	    exit 1;;
     esac
-fi
+esac
 
-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
+# We might now try to use Camlp4, either by explicit choice or
+# by lack of proper Camlp5 installation
 
+case $usecamlp5 in
+  no)
+    CAMLP4=camlp4
+    CAMLP4MOD=camlp4lib
+    CAMLP4LIB=+camlp4
+    FULLCAMLP4LIB=${CAMLLIB}/camlp4
 
-case $CAMLP4LIB in
-    +*) FULLCAMLP4LIB=$CAMLLIB/`echo $CAMLP4LIB | cut -b 2-`;;
-    *)  FULLCAMLP4LIB=$CAMLP4LIB;;
-esac
+    if [ ! -f "${FULLCAMLP4LIB}/${CAMLP4MOD}.cma" ]; then
+	echo "No Camlp4 installation found."
+	echo "Configuration script failed!"
+	exit 1
+    fi
 
-# 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
+esac
 
 # do we have a native compiler: test of ocamlopt and its version
 
 if [ "$best_compiler" = "opt" ] ; then
   if test -e "$nativecamlc" || test -e "`which $nativecamlc`"; then
       CAMLOPTVERSION=`"$nativecamlc" -v | sed -n -e 's|.*version* *\(.*\)$|\1|p' `
-      if [ "`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
@@ -561,23 +593,22 @@ fi
 
 # OS dependent libraries
 
+OSDEPLIBS="-cclib -lunix"
 case $ARCH in
   sun4*) OS=`uname -r`
 	case $OS in
 	   5*) OS="Sun Solaris $OS"
-	       OSDEPLIBS="-cclib -lunix -cclib -lnsl -cclib -lsocket";;
+	       OSDEPLIBS="$OSDEPLIBS -cclib -lnsl -cclib -lsocket";;
 	   *) OS="Sun OS $OS"
-	      OSDEPLIBS="-cclib -lunix"
         esac;;
-  alpha) OSDEPLIBS="-cclib -lunix";;
-  win32) OS="Win32" 
-	 OSDEPLIBS="-cclib -lunix"
-	 cflags="-mno-cygwin $cflags";;
-  *) OSDEPLIBS="-cclib -lunix"
 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 
@@ -591,15 +622,31 @@ if [ "$coqide_spec" = "yes" -a "$COQIDE" = "no" ]; then
     echo "CoqIde disabled as requested."
 else
     case $lablgtkdir_spec in
-	no) 
-	    if [ -f "${CAMLLIB}/lablgtk2/glib.mli" ]; then
+	no)
+            if lablgtkdirtmp=$(ocamlfind query lablgtk2 2> /dev/null); then
+                if [ -f "$lablgtkdirtmp/glib.cmi" -a -f "$lablgtkdirtmp/glib.mli" ]; then
+                    lablgtkdirfoundmsg="LabelGtk2 found by ocamlfind"
+                    lablgtkdir=$lablgtkdirtmp
+                    LABLGTKLIB=$lablgtkdir # Pour le message utilisateur
+                else
+	            echo "Headers missings in Lablgtk2 found by ocamlfind (glib.cmi/glib.mli not found)."
+                fi
+            fi
+            if [ "$lablgtkdir" = "" -a -f "${CAMLLIB}/lablgtk2/glib.mli" -a -f "${CAMLLIB}/glib.mli" ]; then
+	        lablgtkdirfoundmsg="LablGtk2 found in ocaml lib directory"
 		lablgtkdir=${CAMLLIB}/lablgtk2
-	    elif [ -f "${CAMLLIB}/site-lib/lablgtk2/glib.mli" ]; then
-		lablgtkdir=${CAMLLIB}/site-lib/lablgtk2
+                LABLGTKLIB=+lablgtk2 # Pour le message utilisateur
 	    fi;;
 	yes)
-	    if [ ! -f "$lablgtkdir/glib.mli" ]; then
-		echo "Incorrect LablGtk2 library (glib.mli not found)."
+	    if [ ! -d "$lablgtkdir" ]; then
+                echo "$lablgtkdir is not a valid directory."
+		echo "Configuration script failed!"
+		exit 1
+	    elif [ -f "$lablgtkdir/glib.cmi" -a -f "$lablgtkdir/glib.mli" ]; then
+                lablgtkdirfoundmsg="LablGtk2 directory found"
+                LABLGTKLIB=$lablgtkdir # Pour le message utilisateur
+            else
+		echo "Headers missing in LablGtk2 library (glib.cmi/glib.mli not found)."
 		echo "Configuration script failed!"
 		exit 1
 	    fi;;
@@ -608,40 +655,50 @@ else
 	echo "LablGtk2 not found: CoqIde will not be available."
 	COQIDE=no
     elif [ -z "`grep -w convert_with_fallback "$lablgtkdir/glib.mli"`" ]; then
-	echo "LablGtk2 found but too old: CoqIde will not be available."
+	echo "$lablgtkdirfoundmsg but too old: CoqIde will not be available."
 	COQIDE=no;
     elif [ "$coqide_spec" = "yes" -a "$COQIDE" = "byte" ]; then 
-	echo "LablGtk2 found, bytecode CoqIde will be used as requested."
+	echo "$lablgtkdirfoundmsg, bytecode CoqIde will be used as requested."
 	COQIDE=byte
     elif [ ! -f "${CAMLLIB}/threads/threads.cmxa" ]; then 
-	echo "LablGtk2 found, no native threads: bytecode CoqIde will be available."
+	echo "$lablgtkdirfoundmsg, no native threads: bytecode CoqIde will be available."
 	COQIDE=byte
-    else 
-	echo "LablGtk2 found, native threads: native CoqIde will be available."
+    else
+        echo "$lablgtkdirfoundmsg, native threads: native CoqIde will be available."
 	COQIDE=opt
+        if [ "$nomacintegration_spec" = "no" ] && lablgtkosxdir=$(ocamlfind query lablgtkosx 2> /dev/null);
+        then
+            IDEARCHFLAGS=lablgtkosx.cmxa
+	    IDEARCHDEF=QUARTZ
+	elif [ "$ARCH" = "win32" ];
+        then
+	    IDEARCHFLAGS=
+	    IDEARCHFILE=ide/ide_win32_stubs.o
+	    IDEARCHDEF=WIN32
+	fi
     fi
 fi
 
 case $COQIDE in
     byte|opt)
-        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
-        esac;;
-    no) LABLGTKINCLUDES="";;
+        LABLGTKINCLUDES="-I $LABLGTKLIB";;
+    no)
+        LABLGTKINCLUDES="";;
 esac
 
+[ x$lablgtkosxdir = x ] || LABLGTKINCLUDES="$LABLGTKINCLUDES -I $lablgtkosxdir"
+
 # strip command
 
 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
@@ -649,13 +706,6 @@ case $ARCH in
     fi
 esac
 
-# mktexlsr
-#MKTEXLSR=`which mktexlsr`
-#case $MKTEXLSR in
-#    "") MKTEXLSR=true;;
-#esac
-
-# "
 ### Test if documentation can be compiled (latex, hevea)
 
 if test "$with_doc" = "all" 
@@ -673,30 +723,37 @@ fi
 ###########################################
 # bindir, libdir, mandir, docdir, etc.
 
-case $src_spec in
-  no) COQTOP=${COQSRC}
-esac
-
 # OCaml only understand Windows filenames (C:\...)
 case $ARCH in
-    win32) COQTOP=`cygpath -m ${COQTOP}`
+    win32) COQSRC=`mk_win_path "$COQSRC"`
+	   CAMLBIN=`mk_win_path "$CAMLBIN"`
+	   CAMLP4BIN=`mk_win_path "$CAMLP4BIN"`
 esac
 
-case $ARCH in
+case $src_spec in
+  no) COQTOP=${COQSRC}
+esac
+
+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}share"
+	 mandir_def="${W32PREF}man"
+	 docdir_def="${W32PREF}doc"
+	 emacslib_def="${W32PREF}emacs"
+	 coqdocdir_def="${W32PREF}latex";;
   *)
 	 bindir_def=/usr/local/bin
 	 libdir_def=/usr/local/lib/coq
-	 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;;
+	 coqdocdir_def=/usr/local/share/texmf/tex/latex/misc;;
 esac
 
 emacs_def=emacs
@@ -705,7 +762,7 @@ case $bindir_spec/$prefix_spec/$local in
     yes/*/*) BINDIR=$bindir ;;
     */yes/*) BINDIR=$prefix/bin ;;
     */*/true) BINDIR=$COQTOP/bin ;;
-    *) printf "Where should I install the Coq binaries [$bindir_def]? "
+    *)  printf "Where should I install the Coq binaries [%s]? " "$bindir_def"
         read BINDIR
 	case $BINDIR in
 	    "") BINDIR=$bindir_def;;
@@ -716,24 +773,56 @@ esac
 case $libdir_spec/$prefix_spec/$local in
     yes/*/*) LIBDIR=$libdir;;
     */yes/*)
+        libdir_spec=yes
         case $ARCH in
           win32) LIBDIR=$prefix ;;
           *)  LIBDIR=$prefix/lib/coq ;;
         esac ;;
     */*/true) LIBDIR=$COQTOP ;;
-    *)  printf "Where should I install the Coq library [$libdir_def]? "
+    *)  printf "Where should I install the Coq library [%s]? " "$libdir_def"
         read LIBDIR
+        libdir_spec=yes
 	case $LIBDIR in
 	    "") LIBDIR=$libdir_def;;
 	    *) true;;
 	esac;;
 esac
 
+case $configdir_spec/$prefix_spec/$local in
+    yes/*/*) CONFIGDIR=$configdir;;
+    */yes/*) configdir_spec=yes
+	case $ARCH in
+	    win32) CONFIGDIR=$prefix/config;;
+            *) CONFIGDIR=$prefix/etc/xdg/coq;;
+	esac;;
+    */*/true) CONFIGDIR=$COQTOP/ide
+    configdir_spec=yes;;
+    *)  printf "Where should I install the Coqide configuration files [%s]? " "$configdir_def"
+        read CONFIGDIR
+	case $CONFIGDIR in
+	    "") CONFIGDIR=$configdir_def;;
+	    *) configdir_spec=yes;;
+	esac;;
+esac
+
+case $datadir_spec/$prefix_spec/$local in
+    yes/*/*) DATADIR=$datadir;;
+    */yes/*) DATADIR=$prefix/share/coq;;
+    */*/true) DATADIR=$COQTOP/ide
+        datadir_spec=yes;;
+    *)  printf "Where should I install the Coqide data files [%s]? " "$datadir_def"
+        read DATADIR
+	case $DATADIR in
+	    "") DATADIR=$datadir_def;;
+	    *) datadir_spec=yes;;
+	esac;;
+esac
+
 case $mandir_spec/$prefix_spec/$local in
     yes/*/*) MANDIR=$mandir;;
-    */yes/*) MANDIR=$prefix/man ;;
+    */yes/*) MANDIR=$prefix/share/man ;;
     */*/true) MANDIR=$COQTOP/man ;;
-    *)  printf "Where should I install the Coq man pages [$mandir_def]? "
+    *)  printf "Where should I install the Coq man pages [%s]? "  "$mandir_def"
         read MANDIR
 	case $MANDIR in
 	    "") MANDIR=$mandir_def;;
@@ -742,13 +831,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;;
-    *)  printf "Where should I install the Coq documentation [$docdir_def]? "
+    yes/*/*) DOCDIR=$docdir;;
+    */yes/*) DOCDIR=$prefix/share/doc/coq;;
+    */*/true) DOCDIR=$COQTOP/doc;;
+    *)  printf "Where should I install the Coq documentation [%s]? " "$docdir_def"
         read DOCDIR
 	case $DOCDIR in
-	    "") DOCDIR=$docdir_def; HTMLREFMANDIR=$DOCDIR/html/refman;;
+	    "") DOCDIR=$docdir_def;;
 	    *) true;;
 	esac;;
 esac
@@ -761,7 +850,7 @@ case $emacslib_spec/$prefix_spec/$local in
           *)  EMACSLIB=$prefix/share/emacs/site-lisp ;;
         esac ;;
     */*/true) EMACSLIB=$COQTOP/tools/emacs ;;
-    *) printf "Where should I install the Coq Emacs mode [$emacslib_def]? "
+    *)  printf "Where should I install the Coq Emacs mode [%s]? " "$emacslib_def"
         read EMACSLIB
 	case $EMACSLIB in
 	    "") EMACSLIB=$emacslib_def;;
@@ -777,7 +866,7 @@ case $coqdocdir_spec/$prefix_spec/$local in
           *)  COQDOCDIR=$prefix/share/emacs/site-lisp ;;
         esac ;;
     */*/true) COQDOCDIR=$COQTOP/tools/coqdoc ;;
-    *) printf "Where should I install Coqdoc TeX/LaTeX files [$coqdocdir_def]? "
+    *)  printf "Where should I install Coqdoc TeX/LaTeX files [%s]? " "$coqdocdir_def"
         read COQDOCDIR
 	case $COQDOCDIR in
 	    "") COQDOCDIR=$coqdocdir_def;;
@@ -787,7 +876,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
 
@@ -807,14 +896,14 @@ case $coqtoolsbyteflags_spec/$custom_spec/$CUSTOM_OS in
 esac
 
 # case $emacs_spec in
-#     no) printf "Which Emacs command should I use to compile coq.el [$emacs_def]? "
+#     no) printf "Which Emacs command should I use to compile coq.el [%s]? " "$emacs_def"
 #         read EMACS
 	
 # 	case $EMACS in
-# 	    "") EMACS=$emacs_def;;
+# 	    "") EMACS="$emacs_def";;
 # 	    *) true;;
 # 	esac;;
-#     yes) EMACS=$emacs;;
+#     yes) EMACS="$emacs";;
 # esac
 
 
@@ -841,6 +930,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 +946,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"
@@ -904,49 +998,63 @@ config_template="$COQSRC/config/Makefile.template"
 ### After this line, be careful when using variables,
 ### since some of them (e.g. $COQSRC) will be escaped
 
-
-# An escaped version of a variable
-escape_var () {
-"$ocamlexec" 2>&1 1>/dev/null <<EOF
-  prerr_endline(String.escaped(Sys.getenv"$VAR"));;
-EOF
+escape_string () {
+    "$ocamlexec" "tools/escape_string.ml" "$1"
 }
 
 # Escaped version of browser command
-export BROWSER
-BROWSER=`VAR=BROWSER escape_var`
+BROWSER=`escape_string "$BROWSER"`
+
+# Under Windows, we now escape the backslashes that will ends in
+# ocaml strings (coq_config.ml) or in Makefile variables.
 
-# damned backslashes under M$Windows
 case $ARCH in
     win32)
-	COQTOP=`echo $COQTOP |sed -e 's|\\\|\\\\\\\|g'`
-	BINDIR=`echo $BINDIR |sed -e 's|\\\|\\\\\\\|g'`
-	COQSRC=`cygpath -m $COQSRC |sed -e 's|\\\|\\\\\\\|g'`
-	LIBDIR=`echo $LIBDIR |sed -e 's|\\\|\\\\\\\|g'`
-	CAMLBIN=`echo $CAMLBIN |sed -e 's|\\\|\\\\\\\|g'`
-	CAMLLIB=`echo $CAMLLIB |sed -e 's|\\\|\\\\\\\|g'`
-	MANDIR=`echo $MANDIR |sed -e 's|\\\|\\\\\\\|g'`
-	DOCDIR=`echo $DOCDIR |sed -e 's|\\\|\\\\\\\|g'`
-	EMACSLIB=`echo $EMACSLIB |sed -e 's|\\\|\\\\\\\|g'`
-	COQDOCDIR=`echo $COQDOCDIR |sed -e 's|\\\|\\\\\\\|g'`
-	CAMLP4BIN=`echo $CAMLP4BIN |sed -e 's|\\\|\\\\\\\|g'`
-	CAMLP4LIB=`echo $CAMLP4LIB |sed -e 's|\\\|\\\\\\\|g'`
-	LABLGTKINCLUDES=`echo $LABLGTKINCLUDES |sed -e 's|\\\|\\\\\\\|g'`
-	COQRUNBYTEFLAGS=`echo $COQRUNBYTEFLAGS |sed -e 's|\\\|\\\\\\\|g'`
-	COQTOOLSBYTEFLAGS=`echo $COQTOOLSBYTEFLAGS |sed -e 's|\\\|\\\\\\\|g'`
-	BUILDLDPATH=`echo $BUILDLDPATH |sed -e 's|\\\|\\\\\\\|g'`
-	ocamlexec=`echo $ocamlexec |sed -e 's|\\\|\\\\\\\|g'`
-	bytecamlc=`echo $bytecamlc |sed -e 's|\\\|\\\\\\\|g'`
-	nativecamlc=`echo $nativecamlc |sed -e 's|\\\|\\\\\\\|g'`
-	ocamlmklibexec=`echo $ocamlmklibexec |sed -e 's|\\\|\\\\\\\|g'`
-	ocamldepexec=`echo $ocamldepexec |sed -e 's|\\\|\\\\\\\|g'`
-	ocamldocexec=`echo $ocamldocexec |sed -e 's|\\\|\\\\\\\|g'`
-	ocamllexexec=`echo $ocamllexexec |sed -e 's|\\\|\\\\\\\|g'`
-	ocamlyaccexec=`echo $ocamlyaccexec |sed -e 's|\\\|\\\\\\\|g'`
-	camlp4oexec=`echo $camlp4oexec |sed -e 's|\\\|\\\\\\\|g'`
+	COQTOP=`escape_string "$COQTOP"`
+	BINDIR=`escape_string "$BINDIR"`
+	COQSRC=`escape_string "$COQSRC"`
+	LIBDIR=`escape_string "$LIBDIR"`
+	CONFIGDIR=`escape_string "$CONFIGDIR"`
+	DATADIR=`escape_string "$DATADIR"`
+	CAMLBIN=`escape_string "$CAMLBIN"`
+	CAMLLIB=`escape_string "$CAMLLIB"`
+	MANDIR=`escape_string "$MANDIR"`
+	DOCDIR=`escape_string "$DOCDIR"`
+	EMACSLIB=`escape_string "$EMACSLIB"`
+	COQDOCDIR=`escape_string "$COQDOCDIR"`
+	CAMLP4BIN=`escape_string "$CAMLP4BIN"`
+	CAMLP4LIB=`escape_string "$CAMLP4LIB"`
+	LABLGTKINCLUDES=`escape_string "$LABLGTKINCLUDES"`
+	COQRUNBYTEFLAGS=`escape_string "$COQRUNBYTEFLAGS"`
+	COQTOOLSBYTEFLAGS=`escape_string "$COQTOOLSBYTEFLAGS"`
+	BUILDLDPATH=`escape_string "$BUILDLDPATH"`
+	ocamlexec=`escape_string "$ocamlexec"`
+	bytecamlc=`escape_string "$bytecamlc"`
+	nativecamlc=`escape_string "$nativecamlc"`
+	ocamlmklibexec=`escape_string "$ocamlmklibexec"`
+	ocamldepexec=`escape_string "$ocamldepexec"`
+	ocamldocexec=`escape_string "$ocamldocexec"`
+	ocamllexexec=`escape_string "$ocamllexexec"`
+	ocamlyaccexec=`escape_string "$ocamlyaccexec"`
+	camlp4oexec=`escape_string "$camlp4oexec"`
     ;;
 esac
 
+case $libdir_spec in
+    yes) LIBDIR_OPTION="Some \"$LIBDIR\"";;
+    *) LIBDIR_OPTION="None";;
+esac
+
+case $configdir_spec in
+    yes) CONFIGDIR_OPTION="Some \"$CONFIGDIR\"";;
+    *) CONFIGDIR_OPTION="None";;
+esac
+
+case $datadir_spec in
+    yes) DATADIR_OPTION="Some \"$DATADIR\"";;
+    *) DATADIR_OPTION="None";;
+esac
+
 #####################################################
 # Building the $COQTOP/config/coq_config.ml file
 #####################################################
@@ -957,8 +1065,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 +1089,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 +1105,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
 
@@ -1022,57 +1133,143 @@ chmod a-w "$mlconfig_file"
 ###############################################
 
 rm -f "$config_file"
-
-sed -e "s|LOCALINSTALLATION|$local|" \
-    -e "s|XCOQRUNBYTEFLAGS|$COQRUNBYTEFLAGS|" \
-    -e "s|XCOQTOOLSBYTEFLAGS|$COQTOOLSBYTEFLAGS|" \
-    -e "s|COQSRCDIRECTORY|$COQSRC|" \
-    -e "s|COQVERSION|$VERSION|" \
-    -e "s|BINDIRDIRECTORY|$BINDIR|" \
-    -e "s|COQLIBDIRECTORY|$LIBDIR|" \
-    -e "s|BUILDLDPATH=|$BUILDLDPATH|" \
-    -e "s|MANDIRDIRECTORY|$MANDIR|" \
-    -e "s|DOCDIRDIRECTORY|$DOCDIR|" \
-    -e "s|EMACSLIBDIRECTORY|$EMACSLIB|" \
-    -e "s|EMACSCOMMAND|$EMACS|" \
-    -e "s|COQDOCDIRECTORY|$COQDOCDIR|" \
-    -e "s|MKTEXLSRCOMMAND|$MKTEXLSR|" \
-    -e "s|ARCHITECTURE|$ARCH|" \
-    -e "s|OSDEPENDENTLIBS|$OSDEPLIBS|" \
-    -e "s|OSDEPENDENTP4OPTFLAGS|$OSDEPP4OPTFLAGS|" \
-    -e "s|CAMLLIBDIRECTORY|$CAMLLIB|" \
-    -e "s|CAMLTAG|$CAMLTAG|" \
-    -e "s|CAMLP4BINDIRECTORY|$CAMLP4BIN|" \
-    -e "s|CAMLP4LIBDIRECTORY|$CAMLP4LIB|" \
-    -e "s|CAMLP4TOOL|$camlp4oexec|" \
-    -e "s|CAMLP4COMPATFLAGS|$CAMLP4COMPAT|" \
-    -e "s|LABLGTKINCLUDES|$LABLGTKINCLUDES|" \
-    -e "s|COQDEBUGFLAGOPT|$coq_debug_flag_opt|" \
-    -e "s|COQDEBUGFLAG|$coq_debug_flag|" \
-    -e "s|COQPROFILEFLAG|$coq_profile_flag|" \
-    -e "s|CAMLANNOTATEFLAG|$coq_annotate_flag|" \
-    -e "s|CCOMPILEFLAGS|$cflags|" \
-    -e "s|BESTCOMPILER|$best_compiler|" \
-    -e "s|DLLEXTENSION|$DLLEXT|" \
-    -e "s|EXECUTEEXTENSION|$EXE|" \
-    -e "s|BYTECAMLC|$bytecamlc|" \
-    -e "s|OCAMLMKLIBEXEC|$ocamlmklibexec|" \
-    -e "s|NATIVECAMLC|$nativecamlc|" \
-    -e "s|OCAMLEXEC|$ocamlexec|" \
-    -e "s|OCAMLDEPEXEC|$ocamldepexec|" \
-    -e "s|OCAMLDOCEXEC|$ocamldocexec|" \
-    -e "s|OCAMLLEXEXEC|$ocamllexexec|" \
-    -e "s|OCAMLYACCEXEC|$ocamlyaccexec|" \
-    -e "s|CAMLMKTOPEXEC|$ocamlmktopexec|" \
-    -e "s|CCEXEC|$gcc_exec|" \
-    -e "s|AREXEC|$ar_exec|" \
-    -e "s|RANLIBEXEC|$ranlib_exec|" \
-    -e "s|STRIPCOMMAND|$STRIPCOMMAND|" \
-    -e "s|COQIDEOPT|$COQIDE|" \
-    -e "s|CHECKEDOUTSOURCETREE|$checkedout|" \
-    -e "s|WITHDOCOPT|$with_doc|" \
-    -e "s|HASNATIVEDYNLINK|$NATDYNLINKFLAG|" \
-      "$config_template" > "$config_file"
+cat << END_OF_MAKEFILE > $config_file
+###### config/Makefile : Configuration file for Coq ##############
+#                                                                #
+# This file is generated by the script "configure"               #
+# DO NOT EDIT IT !! DO NOT EDIT IT !! DO NOT EDIT IT !!          #
+# If something is wrong below, then rerun the script "configure" #
+# with the good options (see the file INSTALL).                  #
+#                                                                #
+##################################################################
+
+#Variable used to detect whether ./configure has run successfully.
+COQ_CONFIGURED=yes
+
+# Local use (no installation)
+LOCAL=$local
+
+# Bytecode link flags for VM ("-custom" or "-dllib -lcoqrun")
+COQRUNBYTEFLAGS=$COQRUNBYTEFLAGS
+COQTOOLSBYTEFLAGS=$COQTOOLSBYTEFLAGS
+$BUILDLDPATH
+
+# Paths for true installation
+# BINDIR=path where coqtop, coqc, coqmktop, coq-tex, coqdep, gallina and
+#        do_Makefile will reside
+# LIBDIR=path where the Coq library will reside
+# MANDIR=path where to install manual pages
+# EMACSDIR=path where to put Coq's Emacs mode (coq.el)
+BINDIR="$BINDIR"
+COQLIBINSTALL="$LIBDIR"
+CONFIGDIR="$CONFIGDIR"
+DATADIR="$DATADIR"
+MANDIR="$MANDIR"
+DOCDIR="$DOCDIR"
+EMACSLIB="$EMACSLIB"
+EMACS=$EMACS
+
+# Path to Coq distribution
+COQSRC="$COQSRC"
+VERSION=$VERSION
+
+# Ocaml version number
+CAMLVERSION=$CAMLTAG
+
+# Ocaml libraries
+CAMLLIB="$CAMLLIB"
+
+# Ocaml .h directory
+CAMLHLIB="$CAMLLIB"
+
+# Camlp4 : flavor, binaries, libraries ...
+# NB : CAMLP4BIN can be empty if camlp4 is in the PATH
+# NB : avoid using CAMLP4LIB (conflict under Windows)
+CAMLP4BIN="$CAMLP4BIN"
+CAMLP4=$CAMLP4
+CAMLP4O=$camlp4oexec
+CAMLP4COMPAT=$CAMLP4COMPAT
+MYCAMLP4LIB="$CAMLP4LIB"
+
+# LablGTK
+COQIDEINCLUDES=$LABLGTKINCLUDES
+
+# Objective-Caml compile command
+OCAML="$ocamlexec"
+OCAMLC="$bytecamlc"
+OCAMLMKLIB="$ocamlmklibexec"
+OCAMLOPT="$nativecamlc"
+OCAMLDEP="$ocamldepexec"
+OCAMLDOC="$ocamldocexec"
+OCAMLLEX="$ocamllexexec"
+OCAMLYACC="$ocamlyaccexec"
+
+# Caml link command and Caml make top command
+CAMLLINK="$bytecamlc"
+CAMLOPTLINK="$nativecamlc"
+CAMLMKTOP="$ocamlmktopexec"
+
+# Caml flags
+CAMLFLAGS=-rectypes $coq_annotate_flag
+
+# Compilation debug flags
+CAMLDEBUG=$coq_debug_flag
+CAMLDEBUGOPT=$coq_debug_flag_opt
+
+# User compilation flag
+USERFLAGS=
+
+# Flags for GCC
+CFLAGS=$cflags
+
+# Compilation profile flag
+CAMLTIMEPROF=$coq_profile_flag
+
+# The best compiler: native (=opt) or bytecode (=byte) if no native compiler
+BEST=$best_compiler
+
+# Your architecture
+# Can be obtain by UNIX command arch
+ARCH=$ARCH
+HASNATDYNLINK=$NATDYNLINKFLAG
+
+# Supplementary libs for some systems, currently:
+#  . Sun Solaris: -cclib -lunix -cclib -lnsl -cclib -lsocket
+#  . others     : -cclib -lunix
+OSDEPLIBS=$OSDEPLIBS
+
+# executable files extension, currently:
+#  Unix systems:
+#  Win32 systems : .exe
+EXE=$EXE
+DLLEXT=$DLLEXT
+
+# the command MKDIR (try to replace it with mkdirhier if you have problems)
+MKDIR=mkdir -p
+
+# where to put the coqdoc.sty style file
+COQDOCDIR="$COQDOCDIR"
+
+#the command STRIP
+# Unix systems and profiling: true
+# Unix systems and no profiling: strip
+STRIP=$STRIPCOMMAND
+
+# CoqIde (no/byte/opt)
+HASCOQIDE=$COQIDE
+IDEOPTFLAGS=$IDEARCHFLAGS
+IDEOPTDEPS=$IDEARCHFILE
+IDEOPTINT=$IDEARCHDEF
+
+# Defining REVISION
+CHECKEDOUT=$checkedout
+
+# Option to control compilation and installation of the documentation
+WITHDOC=$with_doc
+
+# make or sed are bogus and believe lines not terminating by a return
+# are inexistent
+END_OF_MAKEFILE
 
 chmod a-w "$config_file"
 
@@ -1085,4 +1282,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 15089 2012-03-26 16:41:59Z 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..9a788b7b 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
@@ -126,7 +123,6 @@ open Decl_mode
 open Auto
 open Autorewrite
 open Contradiction
-open Dhyp
 open Eauto
 open Elim
 open Equality
@@ -172,7 +168,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 +186,27 @@ 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);;
 
+(* Set usual printing since the global env is available from the tracer *)
+let _ = Constrextern.in_debugger := false
+let _ = Constrextern.set_extern_reference
+  (fun loc _ r -> Libnames.Qualid (loc,Nametab.shortest_qualid_of_global Idset.empty r));;
+
 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..f54df8a8 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-2012     *)
 (*   \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/header b/dev/header
index d90be792..e5184df3 100644
--- a/dev/header
+++ b/dev/header
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/dev/include b/dev/include
index 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/macosify_accel.sh b/dev/macosify_accel.sh
new file mode 100755
index 00000000..23c557f0
--- /dev/null
+++ b/dev/macosify_accel.sh
@@ -0,0 +1,3 @@
+#!/usr/bin/sed -f
+s/^;\{0,1\} *\(.*\)<Control>\(.*\)$/\1<Primary>\2/
+s/^;\{0,1\} *\(.*\)<Alt>\(.*\)$/\1<Control>\2/
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..40a5a822 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
@@ -104,17 +105,22 @@ Notation
 Dumpglob
 Reserve
 Impargs
-Constrextern
 Syntax_def
 Implicit_quantifiers
 Smartlocate
 Constrintern
-Proof_trees
+Modintern
+Constrextern
 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..c55c4377 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-2012     *)
 (*   \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,13 +56,13 @@ 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)
 
-let ppbigint n = pp (Bigint.pr_bigint n);;
+let ppbigint n = pp (str (Bigint.to_string n));;
 
 let prset pr l = str "[" ++ hov 0 (prlist_with_sep spc pr l) ++ str "]"
 let ppintset l = pp (prset int (Intset.elements l))
@@ -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 *)
@@ -451,7 +459,7 @@ let encode_path loc prefix mpdir suffix id =
   Qualid (loc, make_qualid
     (make_dirpath (List.rev (id_of_string prefix::dir@suffix))) id)
 
-let raw_string_of_ref loc = function
+let raw_string_of_ref loc _ = function
   | ConstRef cst ->
       let (mp,dir,id) = repr_con cst in
       encode_path loc "CST" (Some (mp,dir)) [] (id_of_label id)
@@ -467,7 +475,7 @@ let raw_string_of_ref loc = function
   | VarRef id ->
       encode_path loc "SECVAR" None [] id
 
-let short_string_of_ref loc = function
+let short_string_of_ref loc _ = function
   | VarRef id -> Ident (loc,id)
   | ConstRef cst -> Ident (loc,id_of_label (pi3 (repr_con cst)))
   | IndRef (kn,0) -> Ident (loc,id_of_label (pi3 (repr_mind kn)))
@@ -479,5 +487,9 @@ let short_string_of_ref loc = function
         [id_of_label (pi3 (repr_mind kn));id_of_string ("_"^string_of_int i)]
         (id_of_string ("_"^string_of_int j))
 
-let _ = Constrextern.set_debug_global_reference_printer
+(* Anticipate that printers can be used from ocamldebug and that 
+   pretty-printer should not make calls to the global env since ocamldebug
+   runs in a different process and does not have the proper env at hand *)
+let _ = Constrextern.in_debugger := true
+let _ = Constrextern.set_extern_reference
   (if !rawdebug then raw_string_of_ref else short_string_of_ref)
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/styles/html/coqremote/footer.html b/doc/common/styles/html/coqremote/footer.html
index 2b4e0de0..ff38ba8a 100644
--- a/doc/common/styles/html/coqremote/footer.html
+++ b/doc/common/styles/html/coqremote/footer.html
@@ -1,43 +1,34 @@
-<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 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
index 025e1d3a..891fb328 100644
--- a/doc/common/styles/html/coqremote/header.html
+++ b/doc/common/styles/html/coqremote/header.html
@@ -2,7 +2,7 @@
 <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"/>
+<meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1">
 <title>Standard Library | The Coq Proof Assistant</title>
 
 <link rel="shortcut icon" href="favicon.ico" type="image/x-icon" />
@@ -20,30 +20,26 @@
 <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">
+  <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/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/hidden-files b/doc/stdlib/hidden-files
new file mode 100644
index 00000000..e69de29b
--- /dev/null
+++ b/doc/stdlib/hidden-files
diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template
index 541fa1b9..833b5c4c 100644
--- a/doc/stdlib/index-list.html.template
+++ b/doc/stdlib/index-list.html.template
@@ -56,6 +56,7 @@ through the <tt>Require Import</tt> command.</p>
     theories/Logic/Epsilon.v
     theories/Logic/IndefiniteDescription.v
     theories/Logic/FunctionalExtensionality.v
+    theories/Logic/ExtensionalityFacts.v
   </dd>
     
   <dt> <b>Structures</b>:
@@ -109,7 +110,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 +118,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 +169,22 @@ 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/ZOdiv_def.v
+    theories/ZArith/ZOdiv.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 +209,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 +219,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 +230,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 +259,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 +275,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 +293,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 +305,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 +323,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 +373,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 +388,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>
@@ -371,12 +400,22 @@ through the <tt>Require Import</tt> command.</p>
     theories/Lists/List.v
     theories/Lists/ListSet.v
     theories/Lists/SetoidList.v
+    theories/Lists/SetoidPermutation.v
     theories/Lists/Streams.v
     theories/Lists/StreamMemo.v
-    theories/Lists/TheoryList.v
     theories/Lists/ListTactics.v
   </dd>
 
+  <dt> <b>Vectors</b>:
+    Dependent datastructures storing their length
+  </dt>
+  <dd>
+    theories/Vectors/Fin.v
+    theories/Vectors/VectorDef.v
+    theories/Vectors/VectorSpec.v
+    (theories/Vectors/Vector.v)
+  </dd>
+
   <dt> <b>Sorting</b>:
     Axiomatizations of sorts
   </dt>
@@ -417,7 +456,9 @@ through the <tt>Require Import</tt> command.</p>
     theories/MSets/MSetEqProperties.v
     theories/MSets/MSetWeakList.v
     theories/MSets/MSetList.v
+    theories/MSets/MSetGenTree.v
     theories/MSets/MSetAVL.v
+    theories/MSets/MSetRBT.v
     theories/MSets/MSetPositive.v
     theories/MSets/MSetToFiniteSet.v
     (theories/MSets/MSets.v)
@@ -483,7 +524,10 @@ through the <tt>Require Import</tt> command.</p>
     theories/Reals/Rsigma.v
     theories/Reals/R_sqr.v
     theories/Reals/Rtrigo_fun.v
+    theories/Reals/Rtrigo1.v
     theories/Reals/Rtrigo.v
+    theories/Reals/Ratan.v
+    theories/Reals/Machin.v
     theories/Reals/SplitAbsolu.v
     theories/Reals/SplitRmult.v
     theories/Reals/Alembert.v
@@ -504,6 +548,8 @@ through the <tt>Require Import</tt> command.</p>
     theories/Reals/Ranalysis2.v
     theories/Reals/Ranalysis3.v
     theories/Reals/Ranalysis4.v
+    theories/Reals/Ranalysis5.v
+    theories/Reals/Ranalysis_reg.v
     theories/Reals/Rcomplete.v
     theories/Reals/RiemannInt.v
     theories/Reals/RiemannInt_SF.v
@@ -539,4 +585,11 @@ through the <tt>Require Import</tt> command.</p>
     theories/Program/Combinators.v
   </dd>
 
+  <dt> <b>Unicode</b>:
+    Unicode-based notations
+  </dt>
+  <dd>
+    theories/Unicode/Utf8_core.v
+    theories/Unicode/Utf8.v
+  </dd>
 </dl>
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..1a70567f 100755
--- a/doc/stdlib/make-library-index
+++ b/doc/stdlib/make-library-index
@@ -3,37 +3,55 @@
 # Instantiate links to library files in index template
 
 FILE=$1
+HIDDEN=$2
 
 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 Vectors Sorting Wellfounded MSets FSets Reals Program Numbers Numbers/Natural/Abstract Numbers/Natural/Peano Numbers/Natural/Binary Numbers/Natural/BigN Numbers/Natural/SpecViaZ Numbers/Integer/Abstract Numbers/Integer/NatPairs Numbers/Integer/Binary Numbers/Integer/SpecViaZ Numbers/Integer/BigZ Numbers/NatInt Numbers/Cyclic/Abstract Numbers/Cyclic/Int31 Numbers/Cyclic/ZModulo Numbers/Cyclic/DoubleCyclic Numbers/Rational/BigQ Numbers/Rational/SpecViaQ Strings"
+LIBDIRS=`find theories/* -type d | sed -e "s:^theories/::"`
 
 for k in $LIBDIRS; do
     i=theories/$k
     echo $i
     
     d=`basename $i`
-    if [ "$d" != "Num" -a "$d" != "CVS" ]; then
+    if [ "$d" != "CVS" ]; then
+      ls $i | grep -q \.v'$'
+      if [ $? = 0 ]; then
 	for j in $i/*.v; do
 	    b=`basename $j .v`
 	    rm -f tmp2
 	    grep -q theories/$k/$b.v tmp
 	    a=$?
+	    grep -q theories/$k/$b.v $HIDDEN
+	    h=$?
 	    if [ $a = 0 ]; then
-		p=`echo $k | sed 's:/:.:g'`
-		sed -e "s:theories/$k/$b.v:<a href=\"Coq.$p.$b.html\">$b</a>:g" tmp > tmp2
-		mv -f tmp2 tmp
+	        if [ $h = 0 ]; then
+                    echo Error: $FILE and $HIDDEN both mention theories/$k/$b.v; exit 1
+                else
+		    p=`echo $k | sed 's:/:.:g'`
+		    sed -e "s:theories/$k/$b.v:<a href=\"Coq.$p.$b.html\">$b</a>:g" tmp > tmp2
+		    mv -f tmp2 tmp
+                fi
 	    else
-		echo Warning: theories/$k/$b.v is missing in the template file
-	    fi
+	        if [ $h = 0 ]; then
+		    echo Error: theories/$k/$b.v is missing in the template file
+                    exit 1
+                else
+                    echo Error: none of $FILE and $HIDDEN mention theories/$k/$b.v
+                    exit 1
+	        fi
+
+            fi
 	done
+      fi
     fi
     rm -f tmp2
     sed -e "s/#$d#//" tmp > tmp2
     mv -f tmp2 tmp
 done
 a=`grep theories tmp`
-if [ $? = 0 ]; then echo Warning: extra files:; echo $a; fi
+if [ $? = 0 ]; then echo Error: extra files:; echo $a; exit 1; fi
 mv tmp $FILE
 echo Done
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..470bd5b4 100644
--- a/ide/command_windows.ml
+++ b/ide/command_windows.ml
@@ -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-2012     *)
 (*   \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
 		 ~position:`CENTER
 		 ~title:"CoqIde queries" ~show:false ()
   in *)
+  let views = ref [] in
   let frame = GBin.frame ~label:"Command Pane" ~shadow_type:`IN () in
   let _ = frame#misc#hide () in
   let _ = GtkData.AccelGroup.create () in
@@ -51,12 +50,17 @@ class command_window () =
       ()
   in
 
+  let remove_cb () =
+    let index = notebook#current_page in
+    let () = notebook#remove_page index in
+    views := Minilib.list_filter_i (fun i x -> i <> index) !views
+  in
   let _ =
     toolbar#insert_button
       ~tooltip:"Delete Page"
       ~text:"Delete Page"
       ~icon:(Ideutils.stock_to_widget `DELETE)
-      ~callback:(fun () -> notebook#remove_page notebook#current_page)
+      ~callback:remove_cb
       ()
   in
 object(self)
@@ -65,25 +69,21 @@ object(self)
 
   val new_page_menu = new_page_menu
   val notebook = notebook
+
   method frame = frame
   method new_command ?command ?term () =
-    let appendp x = ignore (notebook#append_page x) in
     let frame = GBin.frame
 		  ~shadow_type:`ETCHED_OUT
-		  ~packing:appendp
 		  ()
     in
+    let _ = notebook#append_page frame#coerce in
     notebook#goto_page (notebook#page_num frame#coerce);
     let vbox = GPack.vbox ~homogeneous:false ~packing:frame#add () in
     let hbox = GPack.hbox ~homogeneous:false ~packing:vbox#pack () in
-    let combo = GEdit.combo ~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 +97,10 @@ 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
+    let () = views := !views @ [result] in
+    result#misc#modify_font !current.Preferences.text_font;
+    let clr = Tags.color_of_string !current.Preferences.background_color in
+    result#misc#modify_base [`NORMAL, `COLOR clr];
     result#misc#set_can_focus true; (* false causes problems for selection *)
     result#set_editable false;
     let callback () =
@@ -106,11 +110,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
@@ -136,15 +143,16 @@ object(self)
     ignore (combo#entry#connect#activate ~callback);
     self#frame#misc#show ()
 
+  method refresh_font () =
+    let iter view = view#misc#modify_font !current.Preferences.text_font in
+    List.iter iter !views
+
+  method refresh_color () =
+    let clr = Tags.color_of_string !current.Preferences.background_color in
+    let iter view = view#misc#modify_base [`NORMAL, `COLOR clr] in
+    List.iter iter !views
+
   initializer
-    ignore (new_page_menu#connect#clicked 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..30e953be 100644
--- a/ide/command_windows.mli
+++ b/ide/command_windows.mli
@@ -1,22 +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-2012     *)
 (*   \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
+    method refresh_font : unit -> unit
+    method refresh_color : unit -> unit
   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..4d91a11a 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-2012     *)
 (*   \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 1a5b9def..07f0ece8 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: coq.ml 15025 2012-03-09 14:27:07Z glondu $ *)
-
-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,279 @@ 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 =
-  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 (Compat.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
-}
+      (Filename.basename Sys.executable_name)
+      Coq_config.best
 
-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;
-}
 
-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;
+(** * 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 fatal_error_popup msg =
+  let popup = GWindow.message_dialog ~buttons:GWindow.Buttons.ok
+    ~message_type:`ERROR ~message:msg ()
+  in ignore (popup#run ()); exit 1
+
+let final_info_popup small msg =
+  if small then
+    let popup = GWindow.message_dialog ~buttons:GWindow.Buttons.ok
+      ~message_type:`INFO ~message:msg ()
+    in
+    let _ = popup#run () in
+    exit 0
+  else
+    let popup = GWindow.dialog () in
+    let button = GButton.button ~label:"ok" ~packing:popup#action_area#add ()
+    in
+    let scroll = GBin.scrolled_window ~hpolicy:`NEVER ~vpolicy:`AUTOMATIC
+      ~packing:popup#vbox#add ~height:500 ()
+    in
+    let _ = GMisc.label ~text:msg ~packing:scroll#add_with_viewport () in
+    let _ = popup#connect#destroy ~callback:(fun _ -> exit 0) in
+    let _ = button#connect#clicked ~callback:(fun _ -> exit 0) in
+    let _ = popup#run () in
+    exit 0
+
+let connection_error cmd lines exn =
+  fatal_error_popup
+    ("Connection with coqtop failed!\n"^
+     "Command was: "^cmd^"\n"^
+     "Answer was: "^(String.concat "\n  " lines)^"\n"^
+     "Exception was: "^Printexc.to_string exn)
+
+let display_coqtop_answer cmd lines =
+  final_info_popup (List.length lines < 30)
+    ("Coqtop exited\n"^
+     "Command was: "^cmd^"\n"^
+     "Answer was: "^(String.concat "\n  " lines))
+
+let check_remaining_opt arg =
+  if arg <> "" && arg.[0] = '-' then fatal_error_popup ("Illegal option: "^arg)
+
+let rec filter_coq_opts args =
+  let argstr = String.concat " " (List.map Filename.quote args) in
+  let cmd = Filename.quote (coqtop_path ()) ^" -nois -filteropts " ^ argstr in
+  let cmd = requote cmd in
+  let filtered_args = ref [] in
+  let errlines = ref [] in
+  try
+    let oc,ic,ec = Unix.open_process_full cmd (Unix.environment ()) in
+    filtered_args := read_all_lines oc;
+    errlines := read_all_lines ec;
+    match Unix.close_process_full (oc,ic,ec) with
+      | Unix.WEXITED 0 ->
+	List.iter check_remaining_opt !filtered_args; !filtered_args
+      | Unix.WEXITED 127 -> asks_for_coqtop args
+      | _ -> display_coqtop_answer cmd (!filtered_args @ !errlines)
+  with Sys_error _ -> asks_for_coqtop args
+    | e -> connection_error cmd (!filtered_args @ !errlines) e
+
+and asks_for_coqtop args =
+  let pb_mes = GWindow.message_dialog
+    ~message:"Failed to load coqtop. Reset the preference to default ?"
+    ~message_type:`QUESTION ~buttons:GWindow.Buttons.yes_no () in
+  match pb_mes#run () with
+    | `YES ->
+      let () = !Preferences.current.Preferences.cmd_coqtop  <- None in
+      let () = custom_coqtop := None in
+      let () = pb_mes#destroy () in
+      filter_coq_opts args
+    | `DELETE_EVENT | `NO ->
+      let () = pb_mes#destroy () in
+      let cmd_sel = GWindow.file_selection
+	~title:"Coqtop to execute (edit your preference then)"
+	~filename:(coqtop_path ()) ~urgency_hint:true () in
+      match cmd_sel#run () with
+	| `OK ->
+	  let () = custom_coqtop := (Some cmd_sel#filename) in
+	  let () = cmd_sel#destroy () in
+	  filter_coq_opts args
+	| `CANCEL | `DELETE_EVENT | `HELP -> exit 0
+
+exception WrongExitStatus of string
+
+let print_status = function
+  | Unix.WEXITED n -> "WEXITED "^string_of_int n
+  | Unix.WSIGNALED n -> "WSIGNALED "^string_of_int n
+  | Unix.WSTOPPED n -> "WSTOPPED "^string_of_int n
+
+let check_connection args =
+  let lines = ref [] in
+  let argstr = String.concat " " (List.map Filename.quote args) in
+  let cmd = Filename.quote (coqtop_path ()) ^ " -batch " ^ argstr in
+  let cmd = requote cmd in
+  try
+    let ic = Unix.open_process_in cmd in
+    lines := read_all_lines ic;
+    match Unix.close_process_in ic with
+    | Unix.WEXITED 0 -> () (* coqtop seems ok *)
+    | st -> raise (WrongExitStatus (print_status st))
+  with e -> connection_error cmd !lines e
+
+(** * 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 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
-  | Compat.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
-      | Compat.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 "*";
+(** * Count of all active coqtops *)
+
+let toplvl_ctr = ref 0
+
+let toplvl_ctr_mtx = Mutex.create ()
+
+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.
+
+    NB: it's important to close coqide's descriptors (ide2top_w and top2ide_r)
+    in coqtop. We do this indirectly via [Unix.set_close_on_exec].
+    This way, coqide has the only remaining copies of these descriptors,
+    and closing them later will have visible effects in coqtop. Cf man 7 pipe :
+
+    - If  all file descriptors referring to the write end of a pipe have been
+      closed, then an attempt to read(2) from the pipe will see end-of-file
+      (read(2) will return 0).
+    - If all file descriptors referring to the read end of a pipe have been
+      closed, then a write(2) will cause a SIGPIPE signal to be generated for
+      the calling process. If the calling process is ignoring this signal,
+      then write(2) fails with the error EPIPE.
+
+    Symmetrically, coqtop's descriptors (ide2top_r and top2ide_w) should be
+    closed in coqide.
+*)
+
+let open_process_pid prog args =
+  let (ide2top_r,ide2top_w) = Unix.pipe () in
+  let (top2ide_r,top2ide_w) = Unix.pipe () in
+  Unix.set_close_on_exec ide2top_w;
+  Unix.set_close_on_exec top2ide_r;
+  let pid = Unix.create_process prog args ide2top_r top2ide_w Unix.stderr in
+  assert (pid <> 0);
+  Unix.close ide2top_r;
+  Unix.close top2ide_w;
+  let oc = Unix.out_channel_of_descr ide2top_w in
+  let ic = Unix.in_channel_of_descr top2ide_r in
+  set_binary_mode_out oc true;
+  set_binary_mode_in ic true;
+  (pid,ic,oc)
+
+let spawn_coqtop sup_args =
+  Mutex.lock toplvl_ctr_mtx;
   try
-    vernac_com Vernacentries.interp last;
-    Lib.add_frozen_state()
+    let prog = coqtop_path () in
+    let args = Array.of_list (prog :: "-ideslave" :: sup_args) in
+    let (pid,ic,oc) = open_process_pid prog args in
+    incr toplvl_ctr;
+    Mutex.unlock toplvl_ctr_mtx;
+    { pid = pid; cin = oc; cout = ic ; sup_args = sup_args }
   with e ->
-    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 c : '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..f25268ef 100644
--- a/ide/coq.mli
+++ b/ide/coq.mli
@@ -1,84 +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-2012     *)
 (*   \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
-}
+(** * Launch a test coqtop processes, ask for a correct coqtop if it fails.
+    @return the list of arguments that coqtop did not understand
+    (the files probably ..). This command may terminate coqide in
+    case of trouble.  *)
+val filter_coq_opts : string list -> string list
 
-val printing_state : printing_state
+(** Launch a coqtop with the user args in order to be sure that it works,
+    checking in particular that initial.coq is found. This command
+    may terminate coqide in case of trouble *)
+val check_connection : string list -> unit
 
-type reset_info
+(** * The structure describing a coqtop sub-process *)
 
-val reset_initial : unit -> unit
+type coqtop
 
-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
+(** * Count of all active coqtops *)
 
-val push_phrase : ('a * reset_info) Stack.t -> reset_info -> 'a -> unit
+val coqtop_zombies : unit -> int
 
-val rewind : reset_info list -> ('a * reset_info) Stack.t -> unit
+(** * Starting / signaling / ending a real coqtop sub-process *)
 
-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
+val spawn_coqtop : string list -> coqtop
+val respawn_coqtop : coqtop -> coqtop
+val kill_coqtop : coqtop -> unit
+val break_coqtop : coqtop -> unit
 
-(* type hyp = (identifier * constr option * constr) * string *)
+(** In win32, we'll use a different kill function than Unix.kill *)
 
-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
+val killer : (int -> unit) ref
+val interrupter : (int -> unit) ref
 
-val get_current_goals : unit -> goal list
+(** * Calls to Coqtop, cf [Ide_intf] for more details *)
 
-val get_current_pm_goal : unit -> goal
+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 print_no_goal : unit -> string
+(** A specialized version of [raw_interp] dedicated to
+    set/unset options. *)
 
-val process_exn : exn -> string*(Util.loc option)
+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 hyp_menu : hyp -> (string * string) list
-val concl_menu : concl -> (string * string) list
-
-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..26dbcb12 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-2012     *)
 (*   \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";
@@ -125,7 +127,6 @@ let commands = [
      "Show Script";
      "Show Tree";*)
      "Structure";
-     (* "Suspend"; *)
      "Syntactic Definition";
      "Syntax";];
   [
diff --git a/ide/coq_lex.mll b/ide/coq_lex.mll
index 02e21166..8a4aa91c 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id$ *)
-
 {
   open Lexing
 
@@ -21,60 +19,56 @@
 
   (* 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" ; "Restart";
+	"End" ; "Section"; "Chapter"; "Transparent"; "Opaque"; "Comments" ]
+    in
+    let one_word_declarations =
+      [ (* Definitions *)
+	"Definition" ; "Let" ; "Example" ; "SubClass" ;
+        "Fixpoint" ; "CoFixpoint" ; "Scheme" ; "Function" ;
+        (* Assumptions *)
+	"Hypothesis" ; "Variable" ; "Axiom" ; "Parameter" ; "Conjecture" ;
+	"Hypotheses" ; "Variables" ; "Axioms" ; "Parameters";
+        (* Inductive *)
+        "Inductive" ; "CoInductive" ; "Record" ; "Structure" ;
+        (* Other *)
+	"Ltac" ; "Instance"; "Include"; "Context"; "Class" ;
+	 "Arguments" ]
+    in
+    let proof_declarations =
       [ "Theorem" ; "Lemma" ; " Fact" ; "Remark" ; "Corollary" ;
-        "Proposition" ; "Property" ];
-    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,41 +76,38 @@ 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+)?
+let locality = (space+ "Local")?
 
 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"
+  ("Uns" | "S")" et" (space+ ident)*
+| (("Open" | "Close") locality | "Bind" | " Delimit" )
+    space+ "Scope"
+| (("Reserved" space+)? "Notation" | "Infix") locality space+
 | "Next" space+ "Obligation"
 | "Solve" space+ "Obligations"
 | "Require" space+ ("Import"|"Export")?
-| "Infix" space+ locality
-| "Notation" space+ locality
-| "Hint" space+ locality ident
+| "Hint" locality space+ ident
 | "Reset" (space+ "Initial")?
 | "Tactic" space+ "Notation"
-| "Implicit" space+ "Arguments"
-| "Implicit" space+ ("Type"|"Types")
+| "Implicit" space+ "Type" "s"?
 | "Combined" space+ "Scheme"
 | "Extraction" space+ (("Language" space+ ("Ocaml"|"Haskell"|"Scheme"|"Toplevel"))|
     ("Library"|"Inline"|"NoInline"|"Blacklist"))
 | "Recursive" space+ "Extraction" (space+ "Library")?
 | ("Print"|"Reset") space+ "Extraction" space+ ("Inline"|"Blacklist")
 | "Extract" space+ (("Inlined" space+) "Constant"| "Inductive")
+| "Typeclasses" space+ ("eauto" | "Transparent" | "Opaque")
+| ("Generalizable" space+) ("All" | "No")? "Variable" "s"?
 
 (* At least still missing: "Inline" + decl, variants of "Identity
   Coercion", variants of Print, Add, ... *)
@@ -130,65 +121,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..9da99551 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.
@@ -23,16 +23,6 @@ binding "text" {
 class "GtkTextView" binding "text"
 
 
-style "views" {
-base[NORMAL] = "CornSilk"
-# bg_pixmap[NORMAL] = "background.jpg"
-}
-class "GtkTextView" style "views"
-
-widget "*.*.*.*.*.ScriptWindow" style "views"
-widget "*.*.*.*.GoalWindow" style "views"
-widget "*.*.*.*.MessageWindow" style "views"
-
 gtk-font-name = "Sans 12"
 
 style "location" {
diff --git a/ide/coqide.ml b/ide/coqide.ml
index 0c99b8a2..94be8318 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: coqide.ml 15023 2012-03-08 22:35:31Z pboutill $ *)
-
 open Preferences
-open Vernacexpr
-open Coq
 open Gtk_parsing
 open Ideutils
 
@@ -19,11 +15,18 @@ 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
   val input_view : Undo.undoable_view
   val last_array : string array
@@ -32,22 +35,17 @@ 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
   val mutable stats : Unix.stats option
-  val mutable detached_views : GWindow.window list
   method without_auto_complete : 'a 'b. ('a -> 'b) -> 'a -> 'b
   method set_auto_complete : bool -> unit
 
-  method kill_detached_views : unit -> unit
-  method add_detached_view : GWindow.window -> unit
-  method remove_detached_view : GWindow.window -> unit
-
   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 +59,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 raw_coq_query : string -> unit
   method show_goals : unit
   method show_goals_full : unit
   method undo_last_step : unit
@@ -102,72 +94,74 @@ 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 =
+  (* To close the detached views of this script, we call manually
+     [destroy] on it, triggering some callbacks in [detach_view].
+     In a more modern lablgtk, rather use the page-removed signal ? *)
+  s.script#destroy ();
+  Coq.kill_coqtop !(s.toplvl)
+
+let build_session s =
+  let session_paned = GPack.paned `VERTICAL () in
+  let eval_paned = GPack.paned `HORIZONTAL ~border_width:5
+    ~packing:(session_paned#pack1 ~shrink:false ~resize:true) () in
+  let script_frame = GBin.frame ~shadow_type:`IN
+    ~packing:eval_paned#add1 () in
+  let script_scroll = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC
+    ~packing:script_frame#add () in
+  let state_paned = GPack.paned `VERTICAL
+    ~packing:eval_paned#add2 () in
+  let proof_frame = GBin.frame ~shadow_type:`IN
+    ~packing:state_paned#add1 () in
+  let proof_scroll = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC
+    ~packing:proof_frame#add () in
+  let message_frame = GBin.frame ~shadow_type:`IN
+    ~packing:state_paned#add2 () in
+  let message_scroll = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC
+    ~packing:message_frame#add () in
+  let session_tab = GPack.hbox ~homogeneous:false () in
+  let img = GMisc.image ~icon_size:`SMALL_TOOLBAR
+    ~packing:session_tab#pack () in
   let _ =
-    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 +172,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 +186,83 @@ 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;
+  (* We ignore the Ctrl-C, this is required for the Stop button to work,
+     since we will actually send Ctrl-C to all processes sharing
+     our console (including us) *)
   Sys.set_signal Sys.sigint Sys.Signal_ignore
 
+
+(** * Locks *)
+
 (* Locking machinery for Coq kernel *)
 let coq_computing = Mutex.create ()
 
 (* To prevent Coq from interrupting during undoing...*)
 let coq_may_stop = Mutex.create ()
 
+(* To prevent a force_reset_initial during a force_reset_initial *)
+let resetting = Mutex.create ()
+
+exception RestartCoqtop
+exception Unsuccessful
+
+let force_reset_initial () =
+  prerr_endline "Reset Initial";
+  session_notebook#current_term.analyzed_view#force_reset_initial
+
 let break () =
-  prerr_endline "User break received:";
-  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 (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 :=
-		  Some (w,offset,(find_word_end (input_buffer#get_iter
-						   (`OFFSET offset)))#offset,false);
-		complete input_buffer w offset
+	      last_completion := None;
+	      None
 	    | Some (ss,start,stop) as result ->
-		last_completion := Some (w,offset,ss#offset,true);
-		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,136 @@ 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.
+    Invariant: either this slice ends the buffer, or it ends with ".".
+    May raise [Coq_lex.Unterminated] when the zone ends with
+    an unterminated sentence. *)
+
 let split_slice_lax (buffer:GText.buffer) from upto =
   remove_tags buffer from upto;
-  buffer#remove_tag ~start:from ~stop:upto Tags.Script.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
-
-let tag_on_insert =
-  let skip_last = ref (ref true) in (* ref to the mutable flag created on last call *)
-  fun buffer ->
-    try 
-      let insert = buffer#get_iter_at_mark `INSERT in
-      let start = grab_safe_sentence_start insert
-                    (buffer#get_iter_at_mark (`NAME "start_of_input")) in 
-      let stop = grab_sentence_end_from insert in
-      let skip_curr = ref true in (* shall the callback be skipped ? by default yes*)
-      (!skip_last) := true; (* skip the previously created callback *)
-      skip_last := skip_curr;
-      try split_slice_lax buffer start stop
-      with Not_found ->
-        skip_curr := false;
-        ignore (Glib.Timeout.add ~ms:1500
-                  ~callback:(fun () -> if not !skip_curr then (
-                    try split_slice_lax buffer start buffer#end_iter with _ -> ()); false))
-    with Not_found ->
-      let err_pos = buffer#get_iter_at_mark (`NAME "start_of_input") in
-      buffer#apply_tag Tags.Script.error ~start:err_pos ~stop:err_pos#forward_char
+(** Searching forward and backward a position fulfilling some condition *)
+
+let rec forward_search cond (iter:GText.iter) =
+  if iter#is_end || cond iter then iter
+  else forward_search cond iter#forward_char
+
+let rec backward_search cond (iter:GText.iter) =
+  if iter#is_start || cond iter then iter
+  else backward_search cond iter#backward_char
+
+let is_sentence_end s = s#has_tag Tags.Script.sentence
+let is_char s c = s#char = Char.code c
+
+(** Search backward the first character of a sentence, starting at [iter]
+    and going at most up to [soi] (meant to be the end of the locked zone).
+    Raise [StartError] when no proper sentence start has been found.
+    A character following a ending "." is considered as a sentence start
+    only if this character is a blank. In particular, when a final "."
+    at the end of the locked zone isn't followed by a blank, then this
+    non-blank character will be signaled as erroneous in [tag_on_insert] below.
+*)
+
+exception StartError
+
+let grab_sentence_start (iter:GText.iter) soi =
+  let cond iter =
+    if iter#compare soi < 0 then raise StartError;
+    let prev = iter#backward_char in
+    is_sentence_end prev &&
+      (not (is_char prev '.') ||
+       List.exists (is_char iter) [' ';'\n';'\r';'\t'])
+  in
+  backward_search cond iter
+
+(** Search forward the first character immediately after a sentence end *)
+
+let rec grab_sentence_stop (start:GText.iter) =
+  (forward_search is_sentence_end start)#forward_char
+
+(** Search forward the first character immediately after a "." sentence end
+    (and not just a "{" or "}" or comment end *)
+
+let rec grab_ending_dot (start:GText.iter) =
+  let is_ending_dot s = is_sentence_end s && s#char = Char.code '.' in
+  (forward_search is_ending_dot start)#forward_char
+
+(** Retag a zone that has been edited *)
+
+let tag_on_insert buffer =
+  (* the start of the non-locked zone *)
+  let soi = buffer#get_iter_at_mark (`NAME "start_of_input") in
+  (* the inserted zone is between [prev_insert] and [insert] *)
+  let insert = buffer#get_iter_at_mark `INSERT in
+  let prev = buffer#get_iter_at_mark (`NAME "prev_insert") in
+  (* [prev] is normally always before [insert] even when deleting.
+     Let's check this nonetheless *)
+  let prev, insert =
+    if insert#compare prev < 0 then insert, prev else prev, insert
+  in
+  try
+    let start = grab_sentence_start prev soi in
+    (** The status of "{" "}" as sentence delimiters is too fragile.
+	We retag up to the next "." instead. *)
+    let stop = grab_ending_dot insert in
+    try split_slice_lax buffer start stop
+    with Coq_lex.Unterminated ->
+      (* This shouldn't happen frequently. Either:
+         - we are at eof, with indeed an unfinished sentence.
+         - we have just inserted an opening of comment or string.
+         - the inserted text ends with a "." that interacts with the "."
+         found by [grab_ending_dot] to form a non-ending "..".
+         In any case, we retag up to eof, since this isn't that costly. *)
+      if not stop#is_end then
+        try split_slice_lax buffer start buffer#end_iter
+        with Coq_lex.Unterminated -> ()
+  with StartError ->
+    buffer#apply_tag Tags.Script.error ~start:soi ~stop:soi#forward_char
 
 let force_retag buffer =
-  try split_slice_lax buffer buffer#start_iter buffer#end_iter with _ -> ()
+  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 +559,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 +569,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 +583,14 @@ 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,27 +600,13 @@ 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
-  method add_detached_view (w:GWindow.window) =
-    detached_views <- w::detached_views
-  method remove_detached_view (w:GWindow.window) =
-    detached_views <- List.filter (fun e -> w#misc#get_oid<>e#misc#get_oid) detached_views
-
-  method kill_detached_views () =
-    List.iter (fun w -> w#destroy ()) detached_views;
-    detached_views <- []
+    self#set_auto_complete false;
+    let y = f x in
+    self#set_auto_complete old;
+    y
 
   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 +615,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 +661,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 +671,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 +704,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 +735,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,466 +751,431 @@ 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
+
+  (* This method is intended to perform stateless commands *)
+  method raw_coq_query phrase =
+    let () = prerr_endline "raw_coq_query starting now" in
+    let display_error s =
+      if not (Glib.Utf8.validate s) then
+        flash_info "This error is so nasty that I can't even display it."
+      else begin
+        self#insert_message s;
+        message_view#misc#draw None
+      end
+    in
+    try
+      match Coq.interp !mycoqtop ~raw:true ~verbose:false phrase with
+      | Interface.Fail (_, err) -> sync display_error err
+      | Interface.Good msg -> sync self#insert_message msg
+    with
+    | End_of_file -> raise RestartCoqtop
+    | e -> sync display_error (Printexc.to_string e)
 
   method find_phrase_starting_at (start:GText.iter) =
     try
-      let start = grab_safe_sentence_start start self#get_start_of_input in
-      let stop = grab_sentence_end_from start in
-      if stop#backward_char#has_tag Tags.Script.lax_end then
-        Some (start,stop)
-      else
-        None
-    with Not_found -> None
+      let start = grab_sentence_start start self#get_start_of_input in
+      let stop = grab_sentence_stop start in
+      (* Is this phrase non-empty and complete ? *)
+      if stop#compare start > 0 && is_sentence_end stop#backward_char
+      then Some (start,stop)
+      else None
+    with StartError -> None
 
   method complete_at_offset (offset:int) =
     prerr_endline ("Completion at offset : " ^ string_of_int offset);
     let it () = input_buffer#get_iter (`OFFSET offset) in
     let iit = it () in
     let start = find_word_start iit in
-      if ends_word iit then
-        let w = input_buffer#get_text
-                  ~start
-                  ~stop:iit
-                  ()
-        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 process_next_phrase verbosely =
+    try self#process_one_phrase !mycoqtop verbosely true true
+    with Unsuccessful -> ()
 
-  method insert_this_phrase_on_success
-        show_output show_msg localize coqphrase insertphrase =
-    let mark_processed reset_info is_complete =
+  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);
+      tag_on_insert input_buffer;
+      let start = self#get_start_of_input in
+      input_buffer#move_mark ~where:stop (`NAME "start_of_input");
+      input_buffer#apply_tag (safety_tag safe) ~start ~stop;
+      if (self#get_insert#compare) stop <= 0 then
+        input_buffer#place_cursor ~where:stop;
+      let ide_payload = { start = `MARK (input_buffer#create_mark start);
+                          stop = `MARK (input_buffer#create_mark stop); } in
+      Stack.push ide_payload cmd_stack;
+      self#show_goals;
+       (*Auto insert save on success...
+	 try (match Coq.get_current_goals () with
+	 | [] ->
+	 (match self#send_to_coq "Save.\n" true true true with
+	 | Some ast ->
+	 begin
+	 let stop = self#get_start_of_input in
+	 if stop#starts_line then
+	 input_buffer#insert ~iter:stop "Save.\n"
+	 else input_buffer#insert ~iter:stop "\nSave.\n";
+	 let start = self#get_start_of_input in
+	 input_buffer#move_mark ~where:stop (`NAME"start_of_input");
+	 input_buffer#apply_tag_by_name "processed" ~start ~stop;
+	 if (self#get_insert#compare) stop <= 0 then
+	 input_buffer#place_cursor stop;
+	 let start_of_phrase_mark =
+	 `MARK (input_buffer#create_mark start) in
+	 let end_of_phrase_mark =
+	 `MARK (input_buffer#create_mark stop) in
+	 push_phrase
+	 reset_info start_of_phrase_mark end_of_phrase_mark ast
+	 end
+	 | None -> ())
+	 | _ -> ())
+	 with _ -> ()*) in
+    match self#send_to_coq !mycoqtop false coqphrase show_output show_msg localize with
+      | Some safe -> sync mark_processed safe; true
+      | None ->
+        sync
+          (fun _ -> self#insert_message ("Unsuccessfully tried: "^coqphrase))
+          ();
+        false
 
   method process_until_iter_or_error stop =
     let stop' = `OFFSET stop#offset in
     let start = self#get_start_of_input#copy in
     let start' = `OFFSET start#offset in
+    sync (fun _ ->
+      input_buffer#apply_tag Tags.Script.to_process ~start ~stop;
+      input_view#set_editable false) ();
+    push_info "Coq is computing";
+    let get_current () =
+      if !current.stop_before then
+        match self#find_phrase_starting_at self#get_start_of_input with
+          | None -> self#get_start_of_input
+          | Some (_, stop2) -> stop2
+      else begin
+        self#get_start_of_input
+      end
+    in
+    let unlock () =
       sync (fun _ ->
-              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 +1186,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 +1221,197 @@ 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^".") (p^".")) 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 let _ =
-                  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 in
-		     true else false
-          | 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
-      | l -> false
-
+    begin
+      match  state with
+        | l ->
+          if GdkEvent.Key.keyval k = GdkKeysyms._Tab then begin
+            prerr_endline "active_kp_handler for Tab";
+            self#indent_current_line;
+            true
+          end else false
+    end
 
-  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 where = self#get_insert in
+                input_buffer#move_mark (`NAME "prev_insert") ~where;
+                let start = self#get_start_of_input in
+                let stop = input_buffer#end_iter in
+                input_buffer#remove_tag Tags.Script.error ~start ~stop)
+    );
+    ignore (input_buffer#connect#end_user_action
               ~callback:(fun () ->
-                           last_modification_time <- Unix.time ();
-                           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 ();
+                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 +1428,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 +1438,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 +1451,93 @@ 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;
+  (* setting fonts *)
+  script#misc#modify_font !current.text_font;
+  proof#misc#modify_font !current.text_font;
+  message#misc#modify_font !current.text_font;
+  (* setting colors *)
+  script#misc#modify_base [`NORMAL, `NAME !current.background_color];
+  proof#misc#modify_base [`NORMAL, `NAME !current.background_color];
+  message#misc#modify_base [`NORMAL, `NAME !current.background_color];
+
+  { tab_label=basename;
+    filename=begin match file with None -> "" |Some f -> f end;
+    script=script;
+    proof_view=proof;
+    message_view=message;
+    analyzed_view=legacy_av;
+    encoding="";
+    toplvl=ct;
+    command=command
+  }
 
 (* XXX - to be used later
-let load_session session filename encs =
-  session.encoding <- List.find (IdeIO.load filename session.script#buffer) encs;
-  session.tab_label#set_text (Glib.Convert.filename_to_utf8 (Filename.basename filename));
-  session.filename <- filename;
-  session.script#buffer#set_modified false
+   let 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 +1546,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 +1644,143 @@ 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 logfile = ref None
 
 let main files =
-  (* Statup preferences *)
-  load_pref ();
 
   (* Main window *)
   let w = GWindow.window
@@ -1729,1626 +1789,1167 @@ 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 _ =
+    let session = create_session None in
+    let index = session_notebook#append_term session in
+    session_notebook#goto_page index
+  in
+  let load_f _ =
+    match select_file_for_open ~title:"Load file" () with
+      | None -> ()
+      | Some f -> do_load f
+  in
+  let save_f _ =
+    let current = session_notebook#current_term in
+    try
+      (match current.analyzed_view#filename with
+        | None ->
+          begin match select_file_for_save ~title:"Save file" ()
+            with
+              | None -> ()
+              | Some f ->
+                if current.analyzed_view#save_as f then begin
+                  current.tab_label#set_text (Filename.basename f);
+                  flash_info ("File " ^ f ^ " saved")
+                end
+                else warning ("Save Failed (check if " ^ f ^ " is writable)")
+          end
+        | Some f ->
+          if current.analyzed_view#save f then
+            flash_info ("File " ^ f ^ " saved")
+          else warning  ("Save Failed (check if " ^ f ^ " is writable)")
 
-    (* 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))
+    (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 ~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
+
+  let reset_auto_save_timer () =
+    disconnect_auto_save_timer ();
+    if !current.auto_save then
+      auto_save_timer := Some
+	(GMain.Timeout.add ~ms:!current.auto_save_delay
+	   ~callback:
+	   (fun () ->
+	     do_if_not_computing "autosave" (sync auto_save_f) session_notebook#pages;
+	     true))
+  in reset_auto_save_timer (); (* to enable statup preferences timer *)
+(* end Preferences *)
+
+  let do_or_activate f () =
+    do_if_not_computing "do_or_activate"
+      (fun current ->
+        let av = current.analyzed_view in
+        ignore (f av);
+        pop_info ();
+        let msg = match Coq.status !(current.toplvl) with
+        | Interface.Fail (l, str) ->
+          "Oops, problem while fetching coq status."
+        | Interface.Good status ->
+          let path = match status.Interface.status_path with
+          | [] | _ :: [] -> "" (* Drop the topmost level, usually "Top" *)
+          | _ :: l -> " in " ^ String.concat "." l
+          in
+          let name = match status.Interface.status_proofname with
+          | None -> ""
+          | Some n -> ", proving " ^ n
+          in
+          "Ready" ^ path ^ name
+        in
+        push_info msg
+      )
+      [session_notebook#current_term]
+  in
+  let do_if_active f _ =
+    do_if_not_computing "do_if_active"
+      (fun sess -> ignore (f sess.analyzed_view))
+      [session_notebook#current_term] in
+  let match_callback _ =
+    let w = get_current_word () in
+    let cur_ct = !(session_notebook#current_term.toplvl) in
+    try
+      match Coq.mkcases cur_ct w with
+        | Interface.Fail _ -> raise Not_found
+        | Interface.Good cases ->
+          let print_branch c l =
+	    Format.fprintf c " | @[<hov 1>%a@]=> _@\n"
+	      (print_list (fun c s -> Format.fprintf c "%s@ " s)) l
+          in
+          let b = Buffer.create 1024 in
+          let fmt = Format.formatter_of_buffer b in
+          Format.fprintf fmt "@[match var with@\n%aend@]@."
+            (print_list print_branch) cases;
+          let s = Buffer.contents b in
+          prerr_endline s;
+          let {script = view } = session_notebook#current_term in
+          ignore (view#buffer#delete_selection ());
+          let m = view#buffer#create_mark
+            (view#buffer#get_iter `INSERT)
+          in
+          if view#buffer#insert_interactive s then
+            let i = view#buffer#get_iter (`MARK m) in
+            let _ = i#nocopy#forward_chars 9 in
+            view#buffer#place_cursor ~where:i;
+            view#buffer#move_mark ~where:(i#backward_chars 3)
+              `SEL_BOUND
+    with Not_found -> flash_info "Not an inductive type"
+  in
+(* External command callback *)
+  let compile_f _ =
+    let v = session_notebook#current_term in
+    let av = v.analyzed_view in
+    save_f ();
+    match av#filename with
+      | None ->
+	flash_info "Active buffer has no name"
+      | Some f ->
+	let cmd = !current.cmd_coqc ^ " -I "
+	  ^ (Filename.quote (Filename.dirname f))
+	  ^ " " ^ (Filename.quote f) in
+	let s,res = run_command av#insert_message cmd in
+	if s = Unix.WEXITED 0 then
+	  flash_info (f ^ " successfully compiled")
+	else begin
+	  flash_info (f ^ " failed to compile");
+	  av#process_until_end_or_error;
+	  av#insert_message "Compilation output:\n";
+	  av#insert_message res
+	end
+  in
+  let make_f _ =
+    let v = session_notebook#current_term in
+    let av = v.analyzed_view in
+    match av#filename with
+      | None ->
+	flash_info "Cannot make: this buffer has no name"
+      | Some f ->
+	let cmd = local_cd f ^ !current.cmd_make in
+
+	(*
+	  save_f ();
+	*)
+	av#insert_message "Command output:\n";
+	let s,res = run_command av#insert_message cmd in
+	last_make := res;
+	last_make_index := 0;
+	flash_info (!current.cmd_make ^ if s = Unix.WEXITED 0 then " succeeded" else " failed")
+  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 edit_actions = GAction.action_group ~name:"Edit" () in
+  let view_actions = GAction.action_group ~name:"View" () in
+  let export_actions = GAction.action_group ~name:"Export" () in
+  let navigation_actions = GAction.action_group ~name:"Navigation" () in
+  let tactics_actions = GAction.action_group ~name:"Tactics" () in
+  let templates_actions = GAction.action_group ~name:"Templates" () in
+  let queries_actions = GAction.action_group ~name:"Queries" () in
+  let compile_actions = GAction.action_group ~name:"Compile" () in
+  let windows_actions = GAction.action_group ~name:"Windows" () in
+  let help_actions = GAction.action_group ~name:"Help" () in
+  let add_gen_actions menu_name act_grp l =
+    let no_under = Minilib.string_map (fun x -> if x = '_' then '-' else x) in
+    let add_simple_template menu_name act_grp text =
+      let text' =
+	let l = String.length text - 1 in
+	if String.get text l = '.'
+	then text ^"\n"
+	else text ^" "
       in
-      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
+      GAction.add_action (menu_name^" "^(no_under text)) ~label:text
+	~callback:(fun _ -> let {script = view } = session_notebook#current_term in
+			    ignore (view#buffer#insert_interactive text')) act_grp
+    in
+    List.iter (function
+      | [] -> ()
+      | [s] -> add_simple_template menu_name act_grp s
+      | s::_ as ll -> let label = "_@..." in label.[1] <- s.[0];
+		      GAction.add_action (menu_name^" "^(String.make 1 s.[0])) ~label act_grp;
+		      List.iter (add_simple_template menu_name act_grp) ll
+    ) l
+  in
+  let tactic_shortcut s sc = GAction.add_action s ~label:("_"^s)
+    ~accel:(!current.modifier_for_tactics^sc)
+    ~callback:(do_if_active (fun a -> a#insert_command
+			       ("progress "^s^".") (s^"."))) in
+  let query_callback command _ =
+    let word = get_current_word () in
+    if not (word = "") then
+      let term = session_notebook#current_term in
+      let query = command ^ " " ^ word ^ "." in
+      term.message_view#buffer#set_text "";
+      term.analyzed_view#raw_coq_query query
+  in
+  let query_shortcut s accel =
+    GAction.add_action s ~label:("_"^s) ?accel ~callback:(query_callback s)
+  in
+  let add_complex_template (name, label, text, offset, len, key) =
+    (* Templates/Lemma *)
+    let callback _ =
+      let {script = view } = session_notebook#current_term in
+      if view#buffer#insert_interactive text then begin
+	let iter = view#buffer#get_iter_at_mark `INSERT in
+	ignore (iter#nocopy#backward_chars offset);
+	view#buffer#move_mark `INSERT ~where:iter;
+	ignore (iter#nocopy#backward_chars len);
+	view#buffer#move_mark `SEL_BOUND ~where:iter;
+      end in
+      match key with
+	|Some ac -> GAction.add_action name ~label ~callback ~accel:(!current.modifier_for_templates^ac)
+	|None -> GAction.add_action name ~label ~callback ?accel:None
+  in
+  let detach_view _ =
+    (* Open a separate window containing the current buffer *)
+    let trm = session_notebook#current_term in
+    let w = GWindow.window ~show:true
+      ~width:(!current.window_width*2/3)
+      ~height:(!current.window_height*2/3)
+      ~position:`CENTER
+      ~title:(if trm.filename = "" then "*scratch*" else trm.filename)
+      ()
+    in
+    let sb = GBin.scrolled_window ~packing:w#add ()
+    in
+    let nv = GText.view ~buffer:trm.script#buffer ~packing:sb#add ()
+    in
+    nv#misc#modify_font !current.text_font;
+    (* If the buffer in the main window is closed, destroy this detached view *)
+    ignore (trm.script#connect#destroy ~callback:w#destroy)
+  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 ()) ~accel:"<Ctrl>comma" ~stock:`PREFERENCES;
+      (* GAction.add_action "Save preferences" ~label:"_Save preferences" ~callback:(fun _ -> save_pref ()); *) ];
+    GAction.add_actions view_actions [
+      GAction.add_action "View" ~label:"_View";
+      GAction.add_action "Previous tab" ~label:"_Previous tab" ~accel:("<ALT>Left") ~stock:`GO_BACK
+        ~callback:(fun _ -> session_notebook#previous_page ());
+      GAction.add_action "Next tab" ~label:"_Next tab" ~accel:("<ALT>Right") ~stock:`GO_FORWARD
+        ~callback:(fun _ -> session_notebook#next_page ());
+      GAction.add_toggle_action "Show Toolbar" ~label:"Show _Toolbar"
+        ~active:(!current.show_toolbar) ~callback:
+        (fun _ -> !current.show_toolbar <- not !current.show_toolbar;
+           !refresh_toolbar_hook ());
+      GAction.add_toggle_action "Show Query Pane" ~label:"Show _Query Pane"
+        ~callback:(fun _ -> let ccw = session_notebook#current_term.command in
+                     if ccw#frame#misc#visible
+                     then ccw#frame#misc#hide ()
+                     else ccw#frame#misc#show ())
+        ~accel:"Escape";
+    ];
+    List.iter
+      (fun (opts,name,label,key,dflt) ->
+         GAction.add_toggle_action name ~active:dflt ~label
+           ~accel:(!current.modifier_for_display^key)
+          ~callback:(fun v -> do_or_activate (fun a ->
+            let () = setopts !(session_notebook#current_term.toplvl) opts v#get_active in
+            a#show_goals) ()) view_actions)
+      print_items;
+    GAction.add_actions navigation_actions [
+      GAction.add_action "Navigation" ~label:"_Navigation";
+      GAction.add_action "Forward" ~label:"_Forward" ~stock:`GO_DOWN
+	~callback:(fun _ -> do_or_activate (fun a -> a#process_next_phrase true) ())
+	~tooltip:"Forward one command" ~accel:(!current.modifier_for_navigation^"Down");
+      GAction.add_action "Backward" ~label:"_Backward" ~stock:`GO_UP
+	~callback:(fun _ -> do_or_activate (fun a -> a#undo_last_step) ())
+	~tooltip:"Backward one command" ~accel:(!current.modifier_for_navigation^"Up");
+      GAction.add_action "Go to" ~label:"_Go to" ~stock:`JUMP_TO
+	~callback:(fun _ -> do_or_activate (fun a -> a#go_to_insert) ())
+	~tooltip:"Go to cursor" ~accel:(!current.modifier_for_navigation^"Right");
+      GAction.add_action "Start" ~label:"_Start" ~stock:`GOTO_TOP
+	~callback:(fun _ -> force_reset_initial ())
+	~tooltip:"Restart coq" ~accel:(!current.modifier_for_navigation^"Home");
+      GAction.add_action "End" ~label:"_End" ~stock:`GOTO_BOTTOM
+	~callback:(fun _ -> do_or_activate (fun a -> a#process_until_end_or_error) ())
+	~tooltip:"Go to end" ~accel:(!current.modifier_for_navigation^"End");
+      GAction.add_action "Interrupt" ~label:"_Interrupt" ~stock:`STOP
+	~callback:(fun _ -> break ()) ~tooltip:"Interrupt computations"
+	~accel:(!current.modifier_for_navigation^"Break");
+      GAction.add_action "Hide" ~label:"_Hide" ~stock:`MISSING_IMAGE
+	~callback:(fun _ -> let sess = session_notebook#current_term in
+		     toggle_proof_visibility sess.script#buffer
+		       sess.analyzed_view#get_insert) ~tooltip:"Hide proof"
+	~accel:(!current.modifier_for_navigation^"h");
+      GAction.add_action "Previous" ~label:"_Previous" ~stock:`GO_BACK
+	~callback:(fun _ -> do_or_activate (fun a -> a#go_to_prev_occ_of_cur_word) ())
+	~tooltip:"Previous occurence" ~accel:(!current.modifier_for_navigation^"less");
+      GAction.add_action "Next" ~label:"_Next" ~stock:`GO_FORWARD
+	~callback:(fun _ -> do_or_activate (fun a -> a#go_to_next_occ_of_cur_word) ())
+	~tooltip:"Next occurence" ~accel:(!current.modifier_for_navigation^"greater");
+    ];
+    GAction.add_actions tactics_actions [
+      GAction.add_action "Try Tactics" ~label:"_Try Tactics";
+      GAction.add_action "Wizard" ~tooltip:"Proof Wizard" ~label:"<Proof Wizard>"
+	~stock:`DIALOG_INFO ~callback:(do_if_active (fun a -> a#tactic_wizard
+						       !current.automatic_tactics))
+	~accel:(!current.modifier_for_tactics^"dollar");
+      tactic_shortcut "auto" "a";
+      tactic_shortcut "auto with *" "asterisk";
+      tactic_shortcut "eauto" "e";
+      tactic_shortcut "eauto with *" "ampersand";
+      tactic_shortcut "intuition" "i";
+      tactic_shortcut "omega" "o";
+      tactic_shortcut "simpl" "s";
+      tactic_shortcut "tauto" "p";
+      tactic_shortcut "trivial" "v";
+    ];
+    add_gen_actions "Tactic" tactics_actions Coq_commands.tactics;
+    GAction.add_actions templates_actions [
+      GAction.add_action "Templates" ~label:"Te_mplates";
+      add_complex_template
+	("Lemma", "_Lemma __", "Lemma new_lemma : .\nIdeproof.\n\nSave.\n",
+	 19, 9, Some "L");
+      add_complex_template
+	("Theorem", "_Theorem __", "Theorem new_theorem : .\nIdeproof.\n\nSave.\n",
+	 19, 11, Some "T");
+      add_complex_template
+	("Definition", "_Definition __", "Definition ident := .\n",
+	 6, 5, Some "D");
+      add_complex_template
+	("Inductive", "_Inductive __", "Inductive ident : :=\n  | : .\n",
+	 14, 5, Some "I");
+      add_complex_template
+	("Fixpoint", "_Fixpoint __", "Fixpoint ident (_ : _) {struct _} : _ :=\n.\n",
+	 29, 5, Some "F");
+      add_complex_template ("Scheme", "_Scheme __",
+			    "Scheme new_scheme := Induction for _ Sort _\
+\nwith _ := Induction for _ Sort _.\n",61,10, Some "S");
+      GAction.add_action "match" ~label:"match ..." ~callback:match_callback
+	~accel:(!current.modifier_for_templates^"C");
+    ];
+    add_gen_actions "Template" templates_actions Coq_commands.commands;
+    GAction.add_actions queries_actions [
+      GAction.add_action "Queries" ~label:"_Queries";
+      query_shortcut "SearchAbout" (Some "F2");
+      query_shortcut "Check" (Some "F3");
+      query_shortcut "Print" (Some "F4");
+      query_shortcut "About" (Some "F5");
+      query_shortcut "Locate" None;
+      query_shortcut "Whelp Locate" None;
+    ];
+    GAction.add_actions compile_actions [
+      GAction.add_action "Compile" ~label:"_Compile";
+      GAction.add_action "Compile buffer" ~label:"_Compile buffer" ~callback:compile_f;
+      GAction.add_action "Make" ~label:"_Make" ~callback:make_f ~accel:"F6";
+      GAction.add_action "Next error" ~label:"_Next error" ~callback:next_error
+	~accel:"F7";
+      GAction.add_action "Make makefile" ~label:"Make makefile" ~callback:coq_makefile_f;
+    ];
+    GAction.add_actions windows_actions [
+      GAction.add_action "Windows" ~label:"_Windows";
+      GAction.add_action "Detach View" ~label:"Detach _View" ~callback:detach_view
+    ];
+    GAction.add_actions help_actions [
+      GAction.add_action "Help" ~label:"_Help";
+      GAction.add_action "Browse Coq Manual" ~label:"Browse Coq _Manual"
+	~callback:(fun _ ->
+		     let av = session_notebook#current_term.analyzed_view in
+		       browse av#insert_message (doc_url ()));
+      GAction.add_action "Browse Coq Library" ~label:"Browse Coq _Library"
+	~callback:(fun _ ->
+		     let av = session_notebook#current_term.analyzed_view in
+		       browse av#insert_message !current.library_url);
+      GAction.add_action "Help for keyword" ~label:"Help for _keyword"
+	~callback:(fun _ -> let av = session_notebook#current_term.analyzed_view in
+		     av#help_for_keyword ()) ~stock:`HELP;
+      GAction.add_action "About Coq" ~label:"_About" ~stock:`ABOUT;
+    ];
+    Coqide_ui.init ();
+    Coqide_ui.ui_m#insert_action_group file_actions 0;
+    Coqide_ui.ui_m#insert_action_group export_actions 0;
+    Coqide_ui.ui_m#insert_action_group edit_actions 0;
+    Coqide_ui.ui_m#insert_action_group view_actions 0;
+    Coqide_ui.ui_m#insert_action_group navigation_actions 0;
+    Coqide_ui.ui_m#insert_action_group tactics_actions 0;
+    Coqide_ui.ui_m#insert_action_group templates_actions 0;
+    Coqide_ui.ui_m#insert_action_group queries_actions 0;
+    Coqide_ui.ui_m#insert_action_group compile_actions 0;
+    Coqide_ui.ui_m#insert_action_group windows_actions 0;
+    Coqide_ui.ui_m#insert_action_group help_actions 0;
+    w#add_accel_group Coqide_ui.ui_m#get_accel_group ;
+    GtkMain.Rc.parse_string "gtk-can-change-accels = 1";
+    if Coq_config.gtk_platform <> `QUARTZ
+    then vbox#pack (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar");
+    let tbar = GtkButton.Toolbar.cast ((Coqide_ui.ui_m#get_widget "/CoqIde ToolBar")#as_widget)
+    in let () = GtkButton.Toolbar.set ~orientation:`HORIZONTAL ~style:`ICONS
+	~tooltips:true tbar in
+    let toolbar = new GObj.widget tbar in
+    vbox#pack toolbar;
+
+    ignore (w#event#connect#delete ~callback:(fun _ -> quit_f (); true));
+
+  (* The vertical Separator between Scripts and Goals *)
+  vbox#pack ~expand:true session_notebook#coerce;
+  update_notebook_pos ();
+  let nb = session_notebook in
+  let lower_hbox = GPack.hbox ~homogeneous:false ~packing:vbox#pack () in
+  lower_hbox#pack ~expand:true status#coerce;
+  let search_lbl = GMisc.label ~text:"Search:"
+    ~show:false
+    ~packing:(lower_hbox#pack ~expand:false) ()
+  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";
+
+  (* Initializing hooks *)
+
+  refresh_toolbar_hook :=
+    (fun () -> if !current.show_toolbar then toolbar#misc#show () else toolbar#misc#hide ());
+  refresh_font_hook :=
+    (fun () ->
+      let fd = !current.text_font in
+      let iter_page p =
+        p.script#misc#modify_font fd;
+        p.proof_view#misc#modify_font fd;
+        p.message_view#misc#modify_font fd;
+        p.command#refresh_font ()
       in
-	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
+      List.iter iter_page session_notebook#pages;
+    );
+  refresh_background_color_hook :=
+    (fun () ->
+      let clr = Tags.color_of_string !current.background_color in
+      let iter_page p =
+        p.script#misc#modify_base [`NORMAL, `COLOR clr];
+        p.proof_view#misc#modify_base [`NORMAL, `COLOR clr];
+        p.message_view#misc#modify_base [`NORMAL, `COLOR clr];
+        p.command#refresh_color ()
       in
-	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"
-	in
-	  ignore (save_m#connect#activate save_f);
+      List.iter iter_page session_notebook#pages;
+    );
+  resize_window_hook := (fun () ->
+    w#resize
+      ~width:!current.window_width
+      ~height:!current.window_height);
+  refresh_tabs_hook := update_notebook_pos;
+
+  let about_full_string =
+    "\nCoq is developed by the Coq Development Team\
+     \n(INRIA - CNRS - LIX - LRI - PPS)\
+     \nWeb site: " ^ Coq_config.wwwcoq ^
+    "\nFeature wish or bug report: http://coq.inria.fr/bugs/\
+     \n\
+     \nCredits for CoqIDE, the Integrated Development Environment for Coq:\
+     \n\
+     \nMain author  : Benjamin Monate\
+     \nContributors : Jean-Christophe Filliâtre\
+     \n               Pierre Letouzey, Claude Marché\
+     \n               Bruno Barras, Pierre Corbineau\
+     \n               Julien Narboux, Hugo Herbelin, ... \
+     \n\
+     \nVersion information\
+     \n-------------------\
+     \n"
+  in
+  let display_log_file (b:GText.buffer) =
+    if !debug then
+      let file = match !logfile with None -> "stderr" | Some f -> f in
+      b#insert ("Debug mode is on, log file is "^file)
+  in
+  let initial_about (b:GText.buffer) =
+    let initial_string =
+      "Welcome to CoqIDE, an Integrated Development Environment for Coq\n"
+    in
+    let coq_version = Coq.short_version () in
+    display_log_file b;
+    if Glib.Utf8.validate ("You are running " ^ coq_version) then
+      b#insert ~iter:b#start_iter ("You are running " ^ coq_version);
+    if Glib.Utf8.validate initial_string then
+      b#insert ~iter:b#start_iter initial_string;
+    (try
+       let image = Filename.concat (List.find
+	 (fun x -> Sys.file_exists (Filename.concat x "coq.png"))
+	 Minilib.xdg_data_dirs) "coq.png" in
+       let startup_image = GdkPixbuf.from_file image in
+       b#insert ~iter:b#start_iter "\n\n";
+       b#insert_pixbuf ~iter:b#start_iter ~pixbuf:startup_image;
+       b#insert ~iter:b#start_iter "\n\n\t\t   "
+     with _ -> ())
+  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 *)
-			  ~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)
-			  ()
-			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: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 ()
-
-;;
+  let about (b:GText.buffer) =
+    (try
+       let image = Filename.concat (List.find
+	 (fun x -> Sys.file_exists (Filename.concat x "coq.png"))
+	 Minilib.xdg_data_dirs) "coq.png" in
+       let startup_image = GdkPixbuf.from_file image in
+       b#insert ~iter:b#start_iter "\n\n";
+       b#insert_pixbuf ~iter:b#start_iter ~pixbuf:startup_image;
+       b#insert ~iter:b#start_iter "\n\n\t\t   "
+     with _ -> ());
+    if Glib.Utf8.validate about_full_string
+    then b#insert about_full_string;
+    let coq_version = Coq.version () in
+    if Glib.Utf8.validate coq_version
+    then b#insert coq_version;
+    display_log_file b;
+  in
+  (* Remove default pango menu for textviews *)
+  w#show ();
+  ignore ((help_actions#get_action "About Coq")#connect#activate
+	    ~callback:(fun _ -> let prf_v = session_notebook#current_term.proof_view in
+                                 prf_v#buffer#set_text ""; about prf_v#buffer));
+  (*
+
+  *)
+(* Begin Color configuration *)
+
+  Tags.set_processing_color (Tags.color_of_string !current.processing_color);
+  Tags.set_processed_color (Tags.color_of_string !current.processed_color);
+
+(* End of color configuration *)
+  ignore(nb#connect#switch_page
+	   ~callback:
+	   (fun i ->
+	     prerr_endline ("switch_page: starts " ^ string_of_int i);
+	     List.iter (function f -> f i) !to_do_on_page_switch;
+	     prerr_endline "switch_page: success")
+  );
+  if List.length files >=1 then
+    begin
+      List.iter (fun f ->
+	if Sys.file_exists f then do_load f else
+          let f = if Filename.check_suffix f ".v" then f else f^".v" in
+	  load_file (fun s -> print_endline s; exit 1) f)
+        files;
+      session_notebook#goto_page 0;
+    end
+  else
+    begin
+      let session = create_session None in
+      let index = session_notebook#append_term session in
+      session_notebook#goto_page index;
+    end;
+  initial_about session_notebook#current_term.proof_view#buffer;
+  !refresh_toolbar_hook ();
+  session_notebook#current_term.script#misc#grab_focus ();;
 
 (* 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 read_coqide_args argv =
+  let rec filter_coqtop coqtop project_files out = function
+    | "-coqtop" :: prog :: args ->
+      if coqtop = None then filter_coqtop (Some prog) project_files out args
+      else
+       (output_string stderr "Error: multiple -coqtop options"; exit 1)
+    | "-f" :: file :: args ->
+	filter_coqtop coqtop
+	  ((Minilib.canonical_path_name (Filename.dirname file),
+	    Project_file.read_project_file file) :: project_files) out args
+    | "-f" :: [] -> output_string stderr "Error: missing project file name"; exit 1
+    | "-coqtop" :: [] -> output_string stderr "Error: missing argument after -coqtop"; exit 1
+    | "-debug"::args -> Ideutils.debug := true;
+      filter_coqtop coqtop project_files ("-debug"::out) args
+    | arg::args -> filter_coqtop coqtop project_files (arg::out) args
+    | [] -> (coqtop,List.rev project_files,List.rev out)
+  in
+  let coqtop,project_files,argv = filter_coqtop None [] [] argv in
+    Ideutils.custom_coqtop := coqtop;
+    custom_project_files := project_files;
+  argv
diff --git a/ide/coqide.mli b/ide/coqide.mli
index ea995c71..44de77f7 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-2012     *)
 (*   \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
+(** In debug mode under win32, messages are written to a log file *)
+val logfile : string option ref
+
+(** Filter the argv from coqide specific options, and set
+    Minilib.coqtop_path accordingly *)
+val read_coqide_args : 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..aaede465
--- /dev/null
+++ b/ide/coqide_main.ml4
@@ -0,0 +1,135 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+let _ = Coqide.ignore_break ()
+let _ = GtkMain.Main.init ()
+
+(* We handle Gtk warning messages ourselves :
+   - on win32, we don't want them to end on a non-existing console
+   - we display critical messages via pop-ups *)
+
+let catch_gtk_messages () =
+  let all_levels =
+    [`FLAG_RECURSION;`FLAG_FATAL;`ERROR;`CRITICAL;`WARNING;
+     `MESSAGE;`INFO;`DEBUG]
+  in
+  let handler ~level msg =
+    let header = "Coqide internal error: " in
+    let level_is tag = (level land Glib.Message.log_level tag) <> 0 in
+    if level_is `ERROR then
+      let () = GToolbox.message_box ~title:"Error" (header ^ msg) in
+      Coqide.crash_save 1
+    else if level_is `CRITICAL then
+      GToolbox.message_box ~title:"Error" (header ^ msg)
+    else if level_is `DEBUG || Sys.os_type = "Win32" then
+      Ideutils.prerr_endline msg (* no-op unless in debug mode *)
+    else
+      Printf.eprintf "%s\n" msg
+  in
+  let catch domain =
+    ignore (Glib.Message.set_log_handler ~domain ~levels:all_levels handler)
+  in
+  List.iter catch ["GLib";"Gtk";"Gdk";"Pango"]
+
+let () = catch_gtk_messages ()
+
+(* We anticipate a bit the argument parsing and look for -debug *)
+
+let early_set_debug () =
+  Ideutils.debug := List.mem "-debug" (Array.to_list Sys.argv)
+
+(* 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, in debug mode we duplicate stdout/stderr in a log file. *)
+
+let log_stdout_stderr () =
+  let (name,chan) = Filename.open_temp_file "coqide_" ".log" in
+  Coqide.logfile := Some name;
+  let out_descr = Unix.descr_of_out_channel chan in
+  Unix.set_close_on_exec out_descr;
+  Unix.dup2 out_descr Unix.stdout;
+  Unix.dup2 out_descr Unix.stderr
+
+(* We also provide specific kill and interrupt functions. *)
+
+IFDEF WIN32 THEN
+external win32_kill : int -> unit = "win32_kill"
+external win32_interrupt_all : unit -> unit = "win32_interrupt_all"
+external win32_hide_console : unit -> unit = "win32_hide_console"
+
+let () =
+  set_win32_path ();
+  Coq.killer := win32_kill;
+  Coq.interrupter := (fun pid -> win32_interrupt_all ());
+  early_set_debug ();
+  if !Ideutils.debug then
+    log_stdout_stderr ()
+  else
+    win32_hide_console ()
+END
+
+IFDEF QUARTZ THEN
+  let osx = GosxApplication.osxapplication ()
+
+  let _ =
+    osx#connect#ns_application_open_file ~callback:(fun x -> Coqide.do_load x; true) in
+  let _ =
+    osx#connect#ns_application_block_termination ~callback:Coqide.forbid_quit_to_save in
+  ()
+END
+
+let () =
+  (try
+     let gtkrcdir = List.find
+       (fun x -> Sys.file_exists (Filename.concat x "coqide-gtk2rc"))
+       Minilib.xdg_config_dirs in
+     GtkMain.Rc.add_default_file (Filename.concat gtkrcdir "coqide-gtk2rc");
+   with Not_found -> ());
+  (* Statup preferences *)
+  begin
+    try Preferences.load_pref ()
+    with e ->
+      Ideutils.flash_info ("Could not load preferences ("^Printexc.to_string e^").");
+  end;
+(*    GtkData.AccelGroup.set_default_mod_mask
+      (Some [`CONTROL;`SHIFT;`MOD1;`MOD3;`MOD4]);*)
+  let argl = Array.to_list Sys.argv in
+  let argl = Coqide.read_coqide_args argl in
+  let files = Coq.filter_coq_opts (List.tl argl) in
+  let args = List.filter (fun x -> not (List.mem x files)) (List.tl argl) in
+  Coq.check_connection args;
+  Coqide.sup_args := args;
+  Coqide.main files;
+    if !Coq_config.with_geoproof then ignore (Thread.create Coqide.check_for_geoproof_input ())
+
+IFDEF QUARTZ THEN
+  let () =
+    GtkosxApplication.Application.set_menu_bar osx#as_osxapplication (GtkMenu.MenuShell.cast (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar")#as_widget) in
+  let () =
+    GtkosxApplication.Application.insert_app_menu_item osx#as_osxapplication (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar/Edit/Prefs")#as_widget 1 in
+  let () =
+    GtkosxApplication.Application.set_help_menu osx#as_osxapplication (Some (GtkMenu.MenuItem.cast (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar/Help")#as_widget)) in
+  osx#ready ()
+END
+
+    while true do
+      try
+	GtkThread.main ()
+      with
+	| Sys.Break -> Ideutils.prerr_endline "Interrupted."
+	| e ->
+	    Minilib.safe_prerr_endline
+	      ("CoqIde unexpected error:" ^ (Printexc.to_string e));
+	    Coqide.crash_save 127
+    done
diff --git a/ide/coqide_ui.ml b/ide/coqide_ui.ml
new file mode 100644
index 00000000..eaf1e934
--- /dev/null
+++ b/ide/coqide_ui.ml
@@ -0,0 +1,155 @@
+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 name='View' action='View'>
+    <menuitem action='Previous tab' />
+    <menuitem action='Next tab' />
+    <separator/>
+    <menuitem action='Show Toolbar' />
+    <menuitem action='Show Query Pane' />
+    <separator/>
+    <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='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='Compile'>
+    <menuitem action='Compile buffer' />
+    <menuitem action='Make' />
+    <menuitem action='Next error' />
+    <menuitem action='Make makefile' />
+  </menu>
+  <menu action='Windows'>
+    <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..47096e6f 100644
--- a/ide/gtk_parsing.ml
+++ b/ide/gtk_parsing.ml
@@ -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-2012     *)
 (*   \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_win32_stubs.c b/ide/ide_win32_stubs.c
new file mode 100644
index 00000000..c170b1a9
--- /dev/null
+++ b/ide/ide_win32_stubs.c
@@ -0,0 +1,51 @@
+#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) */
+
+/* For simplicity, we signal all processes sharing a console with coqide.
+   This shouldn't be an issue since currently at most one coqtop is busy
+   at a given time. Earlier, we tried to be more precise via
+   FreeConsole and AttachConsole before generating the Ctrl-C, but
+   that wasn't working so well (see #2869).
+   This code rely now on the fact that coqide is a console app,
+   and that coqide itself ignores Ctrl-C.
+*/
+
+CAMLprim value win32_interrupt_all(value unit) {
+  CAMLparam1(unit);
+  GenerateConsoleCtrlEvent(CTRL_C_EVENT,0);
+  CAMLreturn(Val_unit);
+}
+
+/* Get rid of the nasty console window (only if we created it) */
+
+CAMLprim value win32_hide_console (value unit) {
+  CAMLparam1(unit);
+  DWORD pid;
+  HWND hw = GetConsoleWindow();
+  if (hw != NULL) {
+    GetWindowThreadProcessId(hw, &pid);
+    if (pid == GetCurrentProcessId())
+      ShowWindow(hw, SW_HIDE);
+  }
+  CAMLreturn(Val_unit);
+}
diff --git a/ide/ideproof.ml b/ide/ideproof.ml
new file mode 100644
index 00000000..697e7f4f
--- /dev/null
+++ b/ide/ideproof.ml
@@ -0,0 +1,147 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+
+(* 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
+        "______________________________________(%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 = Tags.Proof.goal :: 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;
+	proof#buffer#insert "\n"
+      in
+      (* Insert remaining goals (no hypotheses) *)
+      let fold_goal i _ { Interface.goal_ccl = g } =
+        proof#buffer#insert (goal_str i goals_cnt);
+        proof#buffer#insert (g ^ "\n")
+      in
+      let () = Minilib.list_fold_left_i fold_goal 2 () rem_goals in
+
+      ignore(proof#buffer#place_cursor
+               ~where:(proof#buffer#end_iter#backward_to_tag_toggle
+			 (Some Tags.Proof.goal)));
+      ignore(proof#scroll_to_mark ~use_align:true ~yalign:0.95 `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 rec flatten = function
+| [] -> []
+| (lg, rg) :: l ->
+  let inner = flatten l in
+  List.rev_append lg inner @ rg
+
+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 = bg } ->
+    let bg = flatten (List.rev bg) in
+    let evars = match evars with None -> [] | Some evs -> evs in
+    begin match (bg, evars) with
+    | [], [] ->
+      view#buffer#insert "No more subgoals."
+    | [], _ :: _ ->
+      (* A proof has been finished, but not concluded *)
+      view#buffer#insert "No more subgoals but non-instantiated existential variables:\n\n";
+      let iter evar =
+        let msg = Printf.sprintf "%s\n" evar.Interface.evar_info in
+        view#buffer#insert msg
+      in
+      List.iter iter evars
+    | _, _ ->
+      (* 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
+    end
+  | Some { Interface.fg_goals = fg } ->
+    mode view fg hints
diff --git a/ide/ideutils.ml b/ide/ideutils.ml
index a6be77f2..164c837a 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-2012     *)
 (*   \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
 
@@ -75,51 +63,51 @@ let print_id id =
 let do_convert s =
   Utf8_convert.f
     (if Glib.Utf8.validate s then begin
-       prerr_endline "Input is UTF-8";s
-     end else
-       let from_loc () =
-	 let _,char_set = Glib.Convert.get_charset () in
-	 flash_info
-	   ("Converting from locale ("^char_set^")");
-	 Glib.Convert.convert_with_fallback ~to_codeset:"UTF-8" ~from_codeset:char_set s
-       in
-       let from_manual () =
-	 flash_info
-	   ("Converting from "^ !current.encoding_manual);
-	 Glib.Convert.convert s ~to_codeset:"UTF-8" ~from_codeset:!current.encoding_manual
-       in
-       if !current.encoding_use_utf8 || !current.encoding_use_locale then begin
-	 try
-	   from_loc ()
-	 with _ -> from_manual ()
-       end else begin
-	 try
-	   from_manual ()
-	 with _ -> from_loc ()
-       end)
+      prerr_endline "Input is UTF-8";s
+    end else
+	let from_loc () =
+	  let _,char_set = Glib.Convert.get_charset () in
+	  flash_info
+	    ("Converting from locale ("^char_set^")");
+	  Glib.Convert.convert_with_fallback ~to_codeset:"UTF-8" ~from_codeset:char_set s
+	in
+	let from_manual enc =
+	  flash_info
+	    ("Converting from "^ enc);
+	  Glib.Convert.convert s ~to_codeset:"UTF-8" ~from_codeset:enc
+	in
+	match !current.encoding with
+	  |Preferences.Eutf8 | Preferences.Elocale -> from_loc ()
+	  |Emanual enc ->
+	    try
+	      from_manual enc
+	    with _ -> from_loc ())
 
 let 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.*)";;
 
 
 let try_export file_name s =
   try let s =
-    try if !current.encoding_use_utf8 then begin
-      (prerr_endline "UTF-8 is enforced" ;s)
-    end else if !current.encoding_use_locale then begin
-      let is_unicode,char_set = Glib.Convert.get_charset () in
-      if is_unicode then
-	(prerr_endline "Locale is UTF-8" ;s)
-      else
-	(prerr_endline ("Locale is "^char_set);
-	 Glib.Convert.convert_with_fallback ~from_codeset:"UTF-8" ~to_codeset:char_set s)
-    end else
-      (prerr_endline ("Manual charset is "^ !current.encoding_manual);
-       Glib.Convert.convert_with_fallback ~from_codeset:"UTF-8" ~to_codeset:!current.encoding_manual s)
+    try match !current.encoding with
+      |Eutf8 -> begin
+	(prerr_endline "UTF-8 is enforced" ;s)
+      end
+      |Elocale -> begin
+	let is_unicode,char_set = Glib.Convert.get_charset () in
+	if is_unicode then
+	  (prerr_endline "Locale is UTF-8" ;s)
+	else
+	  (prerr_endline ("Locale is "^char_set);
+	   Glib.Convert.convert_with_fallback ~from_codeset:"UTF-8" ~to_codeset:char_set s)
+      end
+      |Emanual enc ->
+	(prerr_endline ("Manual charset is "^ enc);
+       Glib.Convert.convert_with_fallback ~from_codeset:"UTF-8" ~to_codeset:enc s)
     with e -> (prerr_endline ("Error ("^(Printexc.to_string e)^") in transcoding: falling back to UTF-8") ;s)
   in
   let oc = open_out file_name in
@@ -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
@@ -284,14 +252,40 @@ let stock_to_widget ?(size=`DIALOG) s =
   in img#set_stock s;
   img#coerce
 
+let custom_coqtop = ref None
+
+let coqtop_path () =
+  let file = match !custom_coqtop with
+    | Some s -> s
+    | None ->
+      match !current.cmd_coqtop with
+	| Some s -> s
+	| None ->
+	  let prog = String.copy Sys.executable_name in
+	  try
+	    let pos = String.length prog - 6 in
+	    let i = Str.search_backward (Str.regexp_string "coqide") prog pos in
+	    String.blit "coqtop" 0 prog i 6;
+	    prog
+	  with Not_found -> "coqtop"
+  in file
+
 let rec print_list print fmt = function
   | [] -> ()
   | [x] -> print fmt x
   | x :: r -> print fmt x; print_list print fmt r
 
+(* In win32, when a command-line is to be executed via cmd.exe
+   (i.e. Sys.command, Unix.open_process, ...), it cannot contain several
+   quoted "..." zones otherwise some quotes are lost. Solution: we re-quote
+   everything. Reference: http://ss64.com/nt/cmd.html *)
+
+let requote cmd = if Sys.os_type = "Win32" then "\""^cmd^"\"" else cmd
+
 (* TODO: allow to report output as soon as it comes (user-fiendlier
    for long commands like make...) *)
 let run_command f c =
+  let c = requote c in
   let result = Buffer.create 127 in
   let cin,cout,cerr = Unix.open_process_full c (Unix.environment ()) in
   let buff = String.make 127 ' ' in
@@ -310,86 +304,54 @@ 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 s = Sys.command com in
+  let com = Minilib.subst_command_placeholder !current.cmd_browse url in
+  let _ = Unix.open_process_out com in ()
+(* This beautiful message will wait for twt ...
   if s = 127 then
     f ("Could not execute\n\""^com^
        "\"\ncheck your preferences for setting a valid browser command\n")
-
+*)
 let 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..ff79d689 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-2012     *)
 (*   \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 :
@@ -58,6 +52,12 @@ val print_list : (formatter -> 'a -> unit) -> formatter -> 'a list -> unit
 
 val run_command : (string -> unit) -> string -> Unix.process_status*string
 
+val custom_coqtop : string option ref
+(* @return command to call coqtop
+   - custom_coqtop if set
+   - from the prefs is set
+   - try to infer it else *)
+val coqtop_path : unit -> string
 
 
 val status : GMisc.statusbar
@@ -69,14 +69,14 @@ 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
 *)
 val absolute_filename : string -> string
+
+(* In win32, when a command-line is to be executed via cmd.exe
+   (i.e. Sys.command, Unix.open_process, ...), it cannot contain several
+   quoted "..." zones otherwise some quotes are lost. Solution: we re-quote
+   everything. Reference: http://ss64.com/nt/cmd.html *)
+
+val requote : string -> string
diff --git a/ide/mac_default_accel_map b/ide/mac_default_accel_map
new file mode 100644
index 00000000..636447e3
--- /dev/null
+++ b/ide/mac_default_accel_map
@@ -0,0 +1,376 @@
+; coqide GtkAccelMap rc-file         -*- scheme -*-
+; this file is an automated accelerator map dump
+;
+; (gtk_accel_path "<Actions>/Templates/Template Read Module" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic pattern" "")
+(gtk_accel_path "<Actions>/Templates/Definition" "<Shift><Primary>d")
+; (gtk_accel_path "<Actions>/Templates/Template Program Lemma" "")
+(gtk_accel_path "<Actions>/Templates/Lemma" "<Shift><Primary>l")
+; (gtk_accel_path "<Actions>/Templates/Template Fact" "")
+(gtk_accel_path "<Actions>/Tactics/auto" "<Primary><Control>a")
+; (gtk_accel_path "<Actions>/Tactics/Tactic fold" "")
+; (gtk_accel_path "<Actions>/Help/About Coq" "")
+; (gtk_accel_path "<Actions>/Templates/Template Add Ring A Aplus Amult Aone Azero Ainv Aeq T [ c1 ... cn ]. " "")
+; (gtk_accel_path "<Actions>/Templates/Template Hypothesis" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic repeat" "")
+; (gtk_accel_path "<Actions>/Templates/Template Unset Extraction Optimize" "")
+; (gtk_accel_path "<Actions>/Templates/Template Add Printing Constructor" "")
+; (gtk_accel_path "<Actions>/Windows/Detach View" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic inversion" "")
+; (gtk_accel_path "<Actions>/Templates/Template Write State" "")
+; (gtk_accel_path "<Actions>/Export/Export to" "")
+(gtk_accel_path "<Actions>/Tactics/auto with *" "<Primary><Control>asterisk")
+; (gtk_accel_path "<Actions>/Tactics/Tactic inversion--clear" "")
+; (gtk_accel_path "<Actions>/Templates/Template Implicit Arguments" "")
+(gtk_accel_path "<Actions>/Edit/Find backwards" "<Primary>b")
+; (gtk_accel_path "<Actions>/Edit/Copy" "<Primary>c")
+; (gtk_accel_path "<Actions>/Tactics/Tactic inversion -- using" "")
+(gtk_accel_path "<Actions>/View/Previous tab" "<Control>Left")
+; (gtk_accel_path "<Actions>/Tactics/Tactic change -- in" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic jp" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic red" "")
+; (gtk_accel_path "<Actions>/Templates/Template Coercion" "")
+; (gtk_accel_path "<Actions>/Templates/Template CoFixpoint" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic intros until" "")
+; (gtk_accel_path "<Actions>/Templates/Template Derive Dependent Inversion" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic eapply" "")
+; (gtk_accel_path "<Actions>/View/View" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic change" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic firstorder using" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic decompose sum" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic cut" "")
+; (gtk_accel_path "<Actions>/Templates/Template Remove Printing Let" "")
+; (gtk_accel_path "<Actions>/Templates/Template Structure" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic compute in" "")
+; (gtk_accel_path "<Actions>/Queries/Locate" "")
+; (gtk_accel_path "<Actions>/Templates/Template Save." "")
+; (gtk_accel_path "<Actions>/Templates/Template Canonical Structure" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic compare" "")
+; (gtk_accel_path "<Actions>/Templates/Template Next Obligation" "")
+(gtk_accel_path "<Actions>/View/Display notations" "<Shift><Control>n")
+; (gtk_accel_path "<Actions>/Tactics/Tactic fail" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic left" "")
+(gtk_accel_path "<Actions>/Edit/Undo" "<Primary>u")
+(gtk_accel_path "<Actions>/Tactics/eauto with *" "<Primary><Control>ampersand")
+; (gtk_accel_path "<Actions>/Templates/Template Infix" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic functional induction" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic clear" "")
+; (gtk_accel_path "<Actions>/Templates/Template End Silent." "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic intros" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic constructor -- with" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic destruct" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic intro after" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic abstract" "")
+; (gtk_accel_path "<Actions>/Queries/About" "F5")
+; (gtk_accel_path "<Actions>/Templates/Template CoInductive" "")
+; (gtk_accel_path "<Actions>/Templates/Template Unset Hyps--limit" "")
+; (gtk_accel_path "<Actions>/Export/Ps" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic elim" "")
+; (gtk_accel_path "<Actions>/Templates/Template Transparent" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic assert (--:--)" "")
+; (gtk_accel_path "<Actions>/Templates/Template Add Rec LoadPath" "")
+; (gtk_accel_path "<Actions>/Templates/Template Extract Constant" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic compute" "")
+; (gtk_accel_path "<Actions>/Compile/Next error" "F7")
+; (gtk_accel_path "<Actions>/Templates/Template Add ML Path" "")
+; (gtk_accel_path "<Actions>/Templates/Template Test Printing Wildcard" "")
+; (gtk_accel_path "<Actions>/Templates/Template Set Implicit Arguments" "")
+; (gtk_accel_path "<Actions>/Templates/Template Test Printing Let" "")
+; (gtk_accel_path "<Actions>/Windows/Windows" "")
+; (gtk_accel_path "<Actions>/Templates/Template Defined." "")
+(gtk_accel_path "<Actions>/Templates/match" "<Shift><Primary>c")
+; (gtk_accel_path "<Actions>/Tactics/Tactic set (--:=--)" "")
+; (gtk_accel_path "<Actions>/Templates/Template Test Printing If" "")
+; (gtk_accel_path "<Actions>/Compile/Make" "F6")
+; (gtk_accel_path "<Actions>/Templates/Template Module Type" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic apply -- with" "")
+; (gtk_accel_path "<Actions>/File/Save as" "")
+; (gtk_accel_path "<Actions>/Templates/Template Remove Printing Constructor" "")
+; (gtk_accel_path "<Actions>/Templates/Template Set Hyps--limit" "")
+; (gtk_accel_path "<Actions>/Templates/Template Global Variable" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic trivial" "")
+; (gtk_accel_path "<Actions>/Templates/Template Add Setoid" "")
+; (gtk_accel_path "<Actions>/Templates/Template Proof." "")
+; (gtk_accel_path "<Actions>/Templates/Template Load Verbose" "")
+; (gtk_accel_path "<Actions>/Compile/Compile buffer" "")
+; (gtk_accel_path "<Actions>/Queries/Print" "F4")
+; (gtk_accel_path "<Actions>/Templates/Template Obligations Tactic" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic cbv" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic first" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic case" "")
+; (gtk_accel_path "<Actions>/Templates/Template Hint Constructors" "")
+; (gtk_accel_path "<Actions>/Templates/Template Add Abstract Ring A Aplus Amult Aone Azero Ainv Aeq T." "")
+; (gtk_accel_path "<Actions>/Templates/Template Coercion Local" "")
+; (gtk_accel_path "<Actions>/View/Show Query Pane" "Escape")
+; (gtk_accel_path "<Actions>/Templates/Template Add Relation" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic inversion--clear -- in" "")
+; (gtk_accel_path "<Actions>/Templates/Template Definition" "")
+; (gtk_accel_path "<Actions>/Templates/Template Add Rec ML Path" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic apply" "")
+; (gtk_accel_path "<Actions>/Export/Latex" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic inversion -- using -- in" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic generalize" "")
+; (gtk_accel_path "<Actions>/Templates/Template Reset Extraction Inline" "")
+(gtk_accel_path "<Actions>/Navigation/Hide" "<Primary><Control>h")
+; (gtk_accel_path "<Actions>/File/Close buffer" "<Primary>w")
+; (gtk_accel_path "<Actions>/Tactics/Tactic induction" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic eauto with" "")
+(gtk_accel_path "<Actions>/View/Display raw matching expressions" "<Shift><Control>m")
+(gtk_accel_path "<Actions>/Navigation/Backward" "<Primary><Control>Up")
+; (gtk_accel_path "<Actions>/Tactics/Tactic u" "")
+; (gtk_accel_path "<Actions>/Templates/Templates" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic p" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic lapply" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic t" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic s" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic r" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic case -- with" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic eexact" "")
+; (gtk_accel_path "<Actions>/Queries/Check" "F3")
+; (gtk_accel_path "<Actions>/Tactics/Tactic omega" "")
+; (gtk_accel_path "<Actions>/File/New" "<Primary>n")
+; (gtk_accel_path "<Actions>/Tactics/Tactic l" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic intro" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic j" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic i" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic e" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic g" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic f" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic d" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic c" "")
+(gtk_accel_path "<Actions>/File/Rehighlight" "<Primary>l")
+; (gtk_accel_path "<Actions>/Tactics/Tactic simple inversion" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic a" "")
+; (gtk_accel_path "<Actions>/Templates/Template Mutual Inductive" "")
+; (gtk_accel_path "<Actions>/Templates/Template Extraction NoInline" "")
+(gtk_accel_path "<Actions>/Templates/Theorem" "<Shift><Primary>t")
+; (gtk_accel_path "<Actions>/Templates/Template Derive Dependent Inversion--clear" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic unfold" "")
+; (gtk_accel_path "<Actions>/Tactics/Try Tactics" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic red in" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic rewrite <- -- in" "")
+; (gtk_accel_path "<Actions>/Templates/Template Hint Extern" "")
+; (gtk_accel_path "<Actions>/Templates/Template Unfocus" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic dependent inversion--clear" "")
+; (gtk_accel_path "<Actions>/Help/Browse Coq Library" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic lazy" "")
+; (gtk_accel_path "<Actions>/Templates/Template Scheme" "")
+(gtk_accel_path "<Actions>/Tactics/tauto" "<Primary><Control>p")
+; (gtk_accel_path "<Actions>/Tactics/Tactic cutrewrite" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic contradiction" "")
+; (gtk_accel_path "<Actions>/Templates/Template Set Printing Wildcard" "")
+; (gtk_accel_path "<Actions>/Templates/Template Add LoadPath" "")
+(gtk_accel_path "<Actions>/Navigation/Previous" "<Primary><Control>less")
+; (gtk_accel_path "<Actions>/Templates/Template Require" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic simpl" "")
+; (gtk_accel_path "<Actions>/Templates/Template Require Import" "")
+; (gtk_accel_path "<Actions>/Templates/Template Add Abstract Semi Ring A Aplus Amult Aone Azero Aeq T." "")
+(gtk_accel_path "<Actions>/Navigation/Forward" "<Primary><Control>Down")
+; (gtk_accel_path "<Actions>/Tactics/Tactic rename -- into" "")
+; (gtk_accel_path "<Actions>/Compile/Compile" "")
+; (gtk_accel_path "<Actions>/File/Save all" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic fix" "")
+; (gtk_accel_path "<Actions>/Templates/Template Parameter" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic assert" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic do" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic ring" "")
+; (gtk_accel_path "<Actions>/Export/Pdf" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic quote" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic symmetry in" "")
+; (gtk_accel_path "<Actions>/Help/Help" "")
+(gtk_accel_path "<Actions>/Templates/Inductive" "<Shift><Primary>i")
+; (gtk_accel_path "<Actions>/Edit/Clear Undo Stack" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic intro -- after" "")
+; (gtk_accel_path "<Actions>/Templates/Template Syntax" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic idtac" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic fold -- in" "")
+; (gtk_accel_path "<Actions>/Templates/Template Program Definition" "")
+(gtk_accel_path "<Actions>/Tactics/Wizard" "<Primary><Control>dollar")
+; (gtk_accel_path "<Actions>/Templates/Template Hint Resolve" "")
+; (gtk_accel_path "<Actions>/Templates/Template Set Extraction Optimize" "")
+; (gtk_accel_path "<Actions>/File/Revert all buffers" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic subst" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic autorewrite" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic pose" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic simplify--eq" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic clearbody" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic eauto" "")
+; (gtk_accel_path "<Actions>/Templates/Template Grammar" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic exact" "")
+; (gtk_accel_path "<Actions>/Templates/Template Unset Implicit Arguments" "")
+; (gtk_accel_path "<Actions>/Templates/Template Extract Inductive" "")
+(gtk_accel_path "<Actions>/View/Display implicit arguments" "<Shift><Control>i")
+; (gtk_accel_path "<Actions>/Tactics/Tactic symmetry" "")
+; (gtk_accel_path "<Actions>/Templates/Template Add Printing Let" "")
+; (gtk_accel_path "<Actions>/Help/Help for keyword" "<Primary>h")
+; (gtk_accel_path "<Actions>/File/Save" "<Primary>s")
+; (gtk_accel_path "<Actions>/Compile/Make makefile" "")
+; (gtk_accel_path "<Actions>/Templates/Template Remove LoadPath" "")
+(gtk_accel_path "<Actions>/Navigation/Interrupt" "<Primary><Control>Break")
+(gtk_accel_path "<Actions>/Navigation/End" "<Primary><Control>End")
+; (gtk_accel_path "<Actions>/Templates/Template Add Morphism" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic field" "")
+; (gtk_accel_path "<Actions>/Templates/Template Axiom" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic solve" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic casetype" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic cbv in" "")
+; (gtk_accel_path "<Actions>/Templates/Template Load" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic fourier" "")
+; (gtk_accel_path "<Actions>/Templates/Template Goal" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic exists" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic decompose record" "")
+(gtk_accel_path "<Actions>/Navigation/Go to" "<Primary><Control>Right")
+; (gtk_accel_path "<Actions>/Templates/Template Remark" "")
+; (gtk_accel_path "<Actions>/Templates/Template Set Undo" "")
+; (gtk_accel_path "<Actions>/Templates/Template Inductive" "")
+(gtk_accel_path "<Actions>/Edit/Preferences" "<Primary>VoidSymbol")
+; (gtk_accel_path "<Actions>/Export/Html" "")
+; (gtk_accel_path "<Actions>/Templates/Template Extraction Inline" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic absurd" "")
+(gtk_accel_path "<Actions>/Tactics/intuition" "<Primary><Control>i")
+; (gtk_accel_path "<Actions>/Tactics/Tactic simple induction" "")
+; (gtk_accel_path "<Actions>/Queries/Queries" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic rewrite -- in" "")
+; (gtk_accel_path "<Actions>/Templates/Template Hint Rewrite" "")
+; (gtk_accel_path "<Actions>/Templates/Template Add Semi Ring A Aplus Amult Aone Azero Aeq T [ c1 ... cn ]." "")
+; (gtk_accel_path "<Actions>/Navigation/Navigation" "")
+; (gtk_accel_path "<Actions>/Help/Browse Coq Manual" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic transitivity" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic auto" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic dependent inversion -- with" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic assumption" "")
+; (gtk_accel_path "<Actions>/Templates/Template Notation" "")
+; (gtk_accel_path "<Actions>/Edit/Cut" "<Primary>x")
+; (gtk_accel_path "<Actions>/Templates/Template Theorem" "")
+; (gtk_accel_path "<Actions>/Templates/Template Unset Printing Wildcard" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic constructor" "")
+; (gtk_accel_path "<Actions>/Templates/Template Identity Coercion" "")
+; (gtk_accel_path "<Actions>/Queries/Whelp Locate" "")
+(gtk_accel_path "<Actions>/View/Display all low-level contents" "<Shift><Control>l")
+; (gtk_accel_path "<Actions>/Tactics/Tactic right" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic elim -- with" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic cofix" "")
+; (gtk_accel_path "<Actions>/Templates/Template Restore State" "")
+; (gtk_accel_path "<Actions>/Templates/Template Lemma" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic refine" "")
+; (gtk_accel_path "<Actions>/Templates/Template Section" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic assert (--:=--)" "")
+; (gtk_accel_path "<Actions>/Edit/Find in buffer" "<Primary>f")
+; (gtk_accel_path "<Actions>/Tactics/Tactic progress" "")
+; (gtk_accel_path "<Actions>/Templates/Template Add Printing If" "")
+; (gtk_accel_path "<Actions>/Templates/Template Chapter" "")
+(gtk_accel_path "<Actions>/File/Print..." "<Primary>p")
+; (gtk_accel_path "<Actions>/Templates/Template Record" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic info" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic firstorder with" "")
+; (gtk_accel_path "<Actions>/Templates/Template Hint Unfold" "")
+; (gtk_accel_path "<Actions>/Templates/Template Set Silent." "")
+; (gtk_accel_path "<Actions>/Templates/Template Program Theorem" "")
+; (gtk_accel_path "<Actions>/Templates/Template Declare ML Module" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic lazy in" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic unfold -- in" "")
+; (gtk_accel_path "<Actions>/Edit/Paste" "<Primary>v")
+; (gtk_accel_path "<Actions>/Templates/Template Remove Printing If" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic intuition" "")
+; (gtk_accel_path "<Actions>/Queries/SearchAbout" "F2")
+; (gtk_accel_path "<Actions>/Tactics/Tactic dependent rewrite ->" "")
+; (gtk_accel_path "<Actions>/Templates/Template Module" "")
+; (gtk_accel_path "<Actions>/Templates/Template Unset Extraction AutoInline" "")
+(gtk_accel_path "<Actions>/Templates/Scheme" "<Shift><Primary>s")
+; (gtk_accel_path "<Actions>/Templates/Template V" "")
+; (gtk_accel_path "<Actions>/Templates/Template Variable" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic decide equality" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic instantiate (--:=--)" "")
+; (gtk_accel_path "<Actions>/Templates/Template Syntactic Definition" "")
+; (gtk_accel_path "<Actions>/Templates/Template Set Extraction AutoInline" "")
+; (gtk_accel_path "<Actions>/Templates/Template Unset Undo" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic dependent inversion" "")
+; (gtk_accel_path "<Actions>/Templates/Template Add Field" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic setoid--rewrite" "")
+; (gtk_accel_path "<Actions>/Templates/Template Require Export" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic rewrite <-" "")
+(gtk_accel_path "<Actions>/Tactics/omega" "<Primary><Control>o")
+; (gtk_accel_path "<Actions>/Tactics/Tactic split" "")
+; (gtk_accel_path "<Actions>/File/Quit" "<Primary>q")
+(gtk_accel_path "<Actions>/View/Display existential variable instances" "<Shift><Control>e")
+(gtk_accel_path "<Actions>/Navigation/Start" "<Primary><Control>Home")
+; (gtk_accel_path "<Actions>/Tactics/Tactic dependent rewrite <-" "")
+; (gtk_accel_path "<Actions>/Templates/Template U" "")
+; (gtk_accel_path "<Actions>/Templates/Template Variables" "")
+; (gtk_accel_path "<Actions>/Templates/Template S" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic move -- after" "")
+; (gtk_accel_path "<Actions>/Templates/Template Unset Silent." "")
+; (gtk_accel_path "<Actions>/Templates/Template Local" "")
+; (gtk_accel_path "<Actions>/Templates/Template T" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic reflexivity" "")
+; (gtk_accel_path "<Actions>/Templates/Template R" "")
+; (gtk_accel_path "<Actions>/Templates/Template Time" "")
+; (gtk_accel_path "<Actions>/Templates/Template P" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic decompose" "")
+; (gtk_accel_path "<Actions>/Templates/Template N" "")
+; (gtk_accel_path "<Actions>/Templates/Template Eval" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic congruence" "")
+; (gtk_accel_path "<Actions>/Templates/Template O" "")
+; (gtk_accel_path "<Actions>/Templates/Template E" "")
+; (gtk_accel_path "<Actions>/Templates/Template I" "")
+; (gtk_accel_path "<Actions>/Templates/Template H" "")
+; (gtk_accel_path "<Actions>/Templates/Template Extraction Language" "")
+; (gtk_accel_path "<Actions>/Templates/Template M" "")
+; (gtk_accel_path "<Actions>/Templates/Template Derive Inversion" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic double induction" "")
+; (gtk_accel_path "<Actions>/Templates/Template L" "")
+; (gtk_accel_path "<Actions>/Templates/Template Derive Inversion--clear" "")
+(gtk_accel_path "<Actions>/View/Display universe levels" "<Shift><Control>u")
+; (gtk_accel_path "<Actions>/Templates/Template G" "")
+; (gtk_accel_path "<Actions>/Templates/Template F" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic dependent inversion--clear -- with" "")
+; (gtk_accel_path "<Actions>/Templates/Template D" "")
+; (gtk_accel_path "<Actions>/Edit/Edit" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic firstorder" "")
+; (gtk_accel_path "<Actions>/Templates/Template C" "")
+(gtk_accel_path "<Actions>/Tactics/simpl" "<Primary><Control>s")
+; (gtk_accel_path "<Actions>/Tactics/Tactic replace -- with" "")
+; (gtk_accel_path "<Actions>/Templates/Template A" "")
+; (gtk_accel_path "<Actions>/Templates/Template Remove Printing Record" "")
+; (gtk_accel_path "<Actions>/Templates/Template Qed." "")
+; (gtk_accel_path "<Actions>/Templates/Template Program Fixpoint" "")
+(gtk_accel_path "<Actions>/View/Display coercions" "<Shift><Control>c")
+; (gtk_accel_path "<Actions>/Tactics/Tactic hnf" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic injection" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic rewrite" "")
+; (gtk_accel_path "<Actions>/Templates/Template Opaque" "")
+; (gtk_accel_path "<Actions>/Templates/Template Focus" "")
+; (gtk_accel_path "<Actions>/Templates/Template Ltac" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic simple destruct" "")
+(gtk_accel_path "<Actions>/View/Display all basic low-level contents" "<Shift><Control>a")
+; (gtk_accel_path "<Actions>/Tactics/Tactic jp <n>" "")
+; (gtk_accel_path "<Actions>/Templates/Template Test Printing Synth" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic set" "")
+; (gtk_accel_path "<Actions>/Edit/External editor" "")
+; (gtk_accel_path "<Actions>/View/Show Toolbar" "")
+(gtk_accel_path "<Actions>/Edit/Complete Word" "<Primary>slash")
+; (gtk_accel_path "<Actions>/Tactics/Tactic try" "")
+(gtk_accel_path "<Actions>/Templates/Fixpoint" "<Shift><Primary>f")
+; (gtk_accel_path "<Actions>/Tactics/Tactic discriminate" "")
+(gtk_accel_path "<Actions>/Navigation/Next" "<Primary><Control>greater")
+; (gtk_accel_path "<Actions>/Tactics/Tactic elimtype" "")
+; (gtk_accel_path "<Actions>/Templates/Template End" "")
+; (gtk_accel_path "<Actions>/Templates/Template Fixpoint" "")
+(gtk_accel_path "<Actions>/View/Next tab" "<Control>Right")
+; (gtk_accel_path "<Actions>/File/File" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic setoid--replace" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic generalize dependent" "")
+(gtk_accel_path "<Actions>/Tactics/trivial" "<Primary><Control>v")
+; (gtk_accel_path "<Actions>/Tactics/Tactic fix -- with" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic pose --:=--)" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic auto with" "")
+; (gtk_accel_path "<Actions>/Templates/Template Add Printing Record" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic inversion -- in" "")
+(gtk_accel_path "<Actions>/Tactics/eauto" "<Primary><Control>e")
+; (gtk_accel_path "<Actions>/File/Open" "<Primary>o")
+; (gtk_accel_path "<Actions>/Tactics/Tactic elim -- using" "")
+; (gtk_accel_path "<Actions>/Templates/Template Hint" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic tauto" "")
+; (gtk_accel_path "<Actions>/Export/Dvi" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic simpl -- in" "")
+; (gtk_accel_path "<Actions>/Templates/Template Hint Immediate" "")
diff --git a/ide/minilib.ml b/ide/minilib.ml
new file mode 100644
index 00000000..74a42b23
--- /dev/null
+++ b/ide/minilib.ml
@@ -0,0 +1,186 @@
+(***********************************************************************)
+(*  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
+
+(* Split the content of a variable such as $PATH in a list of directories.
+   The separators are either ":" in unix or ";" in win32 *)
+
+let path_to_list = Str.split (Str.regexp "[:;]")
+
+(* On win32, the home directory is probably not in $HOME, but in
+   some other environment variable *)
+
+let home =
+  try Sys.getenv "HOME" with Not_found ->
+    try (Sys.getenv "HOMEDRIVE")^(Sys.getenv "HOMEPATH") with Not_found ->
+      try Sys.getenv "USERPROFILE" with Not_found -> Filename.current_dir_name
+
+let opt2list = function None -> [] | Some x -> [x]
+
+let (/) = Filename.concat
+
+let coqify d = d / "coq"
+
+let xdg_config_home =
+  coqify (try Sys.getenv "XDG_CONFIG_HOME" with Not_found -> home / ".config")
+
+let relative_base =
+  Filename.dirname (Filename.dirname Sys.executable_name)
+
+let xdg_config_dirs =
+  let sys_dirs =
+    try List.map coqify (path_to_list (Sys.getenv "XDG_CONFIG_DIRS"))
+    with
+      | Not_found when Sys.os_type = "Win32" -> [relative_base / "config"]
+      | Not_found -> ["/etc/xdg/coq"]
+  in
+  xdg_config_home :: sys_dirs @ opt2list Coq_config.configdir
+
+let xdg_data_home =
+  coqify
+    (try Sys.getenv "XDG_DATA_HOME" with Not_found -> home / ".local" / "share")
+
+let xdg_data_dirs =
+  let sys_dirs =
+    try List.map coqify (path_to_list (Sys.getenv "XDG_DATA_DIRS"))
+    with
+      | Not_found when Sys.os_type = "Win32" -> [relative_base / "share"]
+      | Not_found -> ["/usr/local/share/coq";"/usr/share/coq"]
+  in
+  xdg_data_home :: sys_dirs @ opt2list Coq_config.datadir
+
+let coqtop_path = ref ""
+
+(* 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..2fb5023f 100644
--- a/ide/preferences.ml
+++ b/ide/preferences.ml
@@ -1,56 +1,88 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $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 Minilib.xdg_config_home "coqide.keys"
+
+let get_config_file name =
+  let find_config dir = Sys.file_exists (Filename.concat dir name) in
+  let config_dir = List.find find_config Minilib.xdg_config_dirs in
+  Filename.concat config_dir name
+
+(* Small hack to handle v8.3 to v8.4 change in configuration file *)
+let loaded_pref_file =
+  try get_config_file "coqiderc"
+  with Not_found -> Filename.concat Minilib.home ".coqiderc"
 
-let accel_file = Filename.concat System.home ".coqide.keys"
+let loaded_accel_file =
+  try get_config_file "coqide.keys"
+  with Not_found -> Filename.concat Minilib.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>"
+    | `HYPER -> "<Hyper>"
+    | `META -> "<Meta>"
+    | `RELEASE -> ""
+    | `SUPER -> "<Super>"
+    |  `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 inputenc = Elocale | Eutf8 | Emanual of string
+
+let string_of_inputenc = function
+  |Elocale -> "LOCALE"
+  |Eutf8 -> "UTF-8"
+  |Emanual s -> s
+
+let inputenc_of_string s =
+      (if s = "UTF-8" then Eutf8
+       else if s = "LOCALE" then Elocale
+       else Emanual s)
+
+
+(** Hooks *)
+
+let refresh_font_hook = ref (fun () -> ())
+let refresh_background_color_hook = ref (fun () -> ())
+let refresh_toolbar_hook = ref (fun () -> ())
+let auto_complete_hook = ref (fun x -> ())
+let contextual_menus_on_goal_hook = ref (fun x -> ())
+let resize_window_hook = ref (fun () -> ())
+let refresh_tabs_hook = ref (fun () -> ())
 
 type pref =
     {
+      mutable cmd_coqtop : string option;
       mutable cmd_coqc : string;
       mutable cmd_make : string;
       mutable cmd_coqmakefile : string;
@@ -63,18 +95,19 @@ type pref =
       mutable auto_save_delay : int;
       mutable auto_save_name : string * string;
 
-      mutable encoding_use_locale : bool;
-      mutable encoding_use_utf8 : bool;
-      mutable encoding_manual : string;
+      mutable read_project : project_behavior;
+      mutable project_file_name : string;
+
+      mutable encoding : inputenc;
 
       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;
@@ -95,15 +128,20 @@ type pref =
 *)
       mutable auto_complete : bool;
       mutable stop_before : bool;
-      mutable lax_syntax : bool;
       mutable vertical_tabs : bool;
       mutable opposite_tabs : bool;
+
+      mutable background_color : string;
+      mutable processing_color : string;
+      mutable processed_color : string;
+
 }
 
 let use_default_doc_url = "(automatic)"
 
 let (current:pref ref) =
   ref {
+    cmd_coqtop = None;
     cmd_coqc = "coqc";
     cmd_make = "make";
     cmd_coqmakefile = "coq_makefile -o makefile *.v";
@@ -117,25 +155,28 @@ let (current:pref ref) =
     auto_save_delay = 10000;
     auto_save_name = "#","#";
 
-    encoding_use_locale = true;
-    encoding_use_utf8 = false;
-    encoding_manual = "ISO_8859-1";
+    read_project = Ignore_args;
+    project_file_name = "_CoqProject";
+
+    encoding = if Sys.os_type = "Win32" then Eutf8 else Elocale;
 
     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;
@@ -151,30 +192,25 @@ let (current:pref ref) =
 *)
     auto_complete = false;
     stop_before = true;
-    lax_syntax = true;
     vertical_tabs = false;
     opposite_tabs = false;
-  }
-
-
-let change_font = ref (fun f -> ())
 
-let show_toolbar = ref (fun x -> ())
+    background_color = "cornsilk";
+    processed_color = "light green";
+    processing_color = "light blue";
 
-let auto_complete = ref (fun x -> ())
-
-let contextual_menus_on_goal = ref (fun x -> ())
-
-let resize_window = ref (fun () -> ())
+  }
 
 let save_pref () =
-  (try GtkData.AccelMap.save accel_file
-  with _ -> ());
+  if not (Sys.file_exists Minilib.xdg_config_home)
+  then Unix.mkdir Minilib.xdg_config_home 0o700;
+  let () = try GtkData.AccelMap.save accel_file with _ -> () in
   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_coqtop" (match p.cmd_coqtop with | None -> [] | Some v-> [v]) ++
     add "cmd_coqc" [p.cmd_coqc] ++
     add "cmd_make" [p.cmd_make] ++
     add "cmd_coqmakefile" [p.cmd_coqmakefile] ++
@@ -186,22 +222,18 @@ 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 "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 "project_options" [string_of_project_behavior p.read_project] ++
+    add "project_file_name" [p.project_file_name] ++
+
+    add "encoding" [string_of_inputenc p.encoding] ++
 
     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] ++
 
@@ -218,19 +250,20 @@ let save_pref () =
     add "query_window_width" [string_of_int p.query_window_width] ++
     add "auto_complete" [string_of_bool p.auto_complete] ++
     add "stop_before" [string_of_bool p.stop_before] ++
-    add "lax_syntax" [string_of_bool p.lax_syntax] ++
     add "vertical_tabs" [string_of_bool p.vertical_tabs] ++
     add "opposite_tabs" [string_of_bool p.opposite_tabs] ++
+    add "background_color" [p.background_color] ++
+    add "processing_color" [p.processing_color] ++
+    add "processed_color" [p.processed_color] ++
     Config_lexer.print_file pref_file
-  with _ -> prerr_endline "Could not save preferences."
 
 let load_pref () =
-  (try GtkData.AccelMap.load accel_file with _ -> ());
+  let () = try GtkData.AccelMap.load loaded_accel_file with _ -> () in
   let p = !current in
-  try
-    let m = Config_lexer.load_file pref_file in
+
+    let m = Config_lexer.load_file loaded_pref_file in
     let np = { p with cmd_coqc = p.cmd_coqc } in
-    let set k f = try let v = 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
@@ -238,6 +271,8 @@ let load_pref () =
     let set_command_with_pair_compat k f =
       set k (function [v1;v2] -> f (v1^"%s"^v2) | [v] -> f v | _ -> raise Exit)
     in
+    let set_option k f = set k (fun v -> f (match v with |[] -> None |h::_ ->  Some h)) in
+    set_option "cmd_coqtop" (fun v -> np.cmd_coqtop <- v);
     set_hd "cmd_coqc" (fun v -> np.cmd_coqc <- v);
     set_hd "cmd_make" (fun v -> np.cmd_make <- v);
     set_hd "cmd_coqmakefile" (fun v -> np.cmd_coqmakefile <- v);
@@ -248,22 +283,23 @@ let load_pref () =
     set_bool "auto_save" (fun v -> np.auto_save <- v);
     set_int "auto_save_delay" (fun v -> np.auto_save_delay <- v);
     set_pair "auto_save_name" (fun v1 v2 -> np.auto_save_name <- (v1,v2));
-    set_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 "encoding" (fun v -> np.encoding <- (inputenc_of_string v));
+    set_hd "project_options"
+      (fun v -> np.read_project <- (project_behavior_of_string v));
+    set_hd "project_file_name" (fun v -> np.project_file_name <- v);
     set "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 +310,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);
@@ -286,26 +322,21 @@ let load_pref () =
     set_int "query_window_height" (fun v -> np.query_window_height <- v);
     set_bool "auto_complete" (fun v -> np.auto_complete <- v);
     set_bool "stop_before" (fun v -> np.stop_before <- v);
-    set_bool "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;
+    set_hd "background_color" (fun v -> np.background_color <- v);
+    set_hd "processing_color" (fun v -> np.processing_color <- v);
+    set_hd "processed_color" (fun v -> np.processed_color <- v);
+    current := np
 (*
     Format.printf "in load_pref: current.text_font = %s@." (Pango.Font.to_string !current.text_font);
 *)
-  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_coqtop =
+    string
+      ~f:(fun s -> !current.cmd_coqtop <- if s = "AUTO" then None else Some s)
+      "       coqtop" (match !current.cmd_coqtop with |None -> "AUTO" | Some x -> x) in
   let cmd_coqc =
     string
       ~f:(fun s -> !current.cmd_coqc <- s)
@@ -332,7 +363,7 @@ let configure ?(apply=(fun () -> ())) () =
     let w = GMisc.font_selection () in
     w#set_preview_text
       "Goal (∃n : nat, n ≤ 0)∧(∀x,y,z, x∈y⋃z↔x∈y∨x∈z).";
-    box#pack w#coerce;
+    box#pack ~expand:true w#coerce;
     ignore (w#misc#connect#realize
 	      ~callback:(fun () -> w#set_font_name
 			   (Pango.Font.to_string !current.text_font)));
@@ -345,9 +376,67 @@ let configure ?(apply=(fun () -> ())) () =
 (*
 	 Format.printf "in config_font: current.text_font = %s@." (Pango.Font.to_string !current.text_font);
 *)
-	 !change_font !current.text_font)
+	 !refresh_font_hook ())
       true
   in
+
+  let config_color =
+    let box = GPack.vbox () in
+    let table = GPack.table
+      ~row_spacings:5
+      ~col_spacings:5
+      ~border_width:2
+      ~packing:(box#pack ~expand:true) ()
+    in
+    let background_label = GMisc.label
+      ~text:"Background color"
+      ~packing:(table#attach ~expand:`X ~left:0 ~top:0) ()
+    in
+    let processed_label = GMisc.label
+      ~text:"Background color of processed text"
+      ~packing:(table#attach ~expand:`X ~left:0 ~top:1) ()
+    in
+    let processing_label = GMisc.label
+      ~text:"Background color of text being processed"
+      ~packing:(table#attach ~expand:`X ~left:0 ~top:2) ()
+    in
+    let () = background_label#set_xalign 0. in
+    let () = processed_label#set_xalign 0. in
+    let () = processing_label#set_xalign 0. in
+    let background_button = GButton.color_button
+      ~color:(Tags.color_of_string (!current.background_color))
+      ~packing:(table#attach ~left:1 ~top:0) ()
+    in
+    let processed_button = GButton.color_button
+      ~color:(Tags.get_processed_color ())
+      ~packing:(table#attach ~left:1 ~top:1) ()
+    in
+    let processing_button = GButton.color_button
+      ~color:(Tags.get_processing_color ())
+      ~packing:(table#attach ~left:1 ~top:2) ()
+    in
+    let reset_button = GButton.button
+      ~label:"Reset"
+      ~packing:box#pack ()
+    in
+    let reset_cb () =
+      background_button#set_color (Tags.color_of_string "cornsilk");
+      processing_button#set_color (Tags.color_of_string "light blue");
+      processed_button#set_color (Tags.color_of_string "light green");
+    in
+    let _ = reset_button#connect#clicked ~callback:reset_cb in
+    let label = "Color configuration" in
+    let callback () =
+      !current.background_color <- Tags.string_of_color background_button#color;
+      !current.processing_color <- Tags.string_of_color processing_button#color;
+      !current.processed_color <- Tags.string_of_color processed_button#color;
+      !refresh_background_color_hook ();
+      Tags.set_processing_color processing_button#color;
+      Tags.set_processed_color processed_button#color
+    in
+    custom ~label box callback true
+  in
+
 (*
   let show_toolbar =
     bool
@@ -376,7 +465,7 @@ let configure ?(apply=(fun () -> ())) () =
     bool
       ~f:(fun s ->
 	    !current.auto_complete <- s;
-	    !auto_complete s)
+	    !auto_complete_hook s)
       "Auto Complete" !current.auto_complete
   in
 
@@ -423,85 +512,85 @@ let configure ?(apply=(fun () -> ())) () =
       "Stop interpreting before the current point" !current.stop_before
   in
 
-  let lax_syntax =
-    bool
-      ~f:(fun s -> !current.lax_syntax <- s)
-      "Relax read-only constraint at end of command" !current.lax_syntax
-  in
-
   let vertical_tabs =
     bool
-      ~f:(fun s -> !current.vertical_tabs <- s)
+      ~f:(fun s -> !current.vertical_tabs <- s; !refresh_tabs_hook ())
       "Vertical tabs" !current.vertical_tabs
   in
 
   let opposite_tabs =
     bool
-      ~f:(fun s -> !current.opposite_tabs <- s)
+      ~f:(fun s -> !current.opposite_tabs <- s; !refresh_tabs_hook ())
       "Tabs on opposite side" !current.opposite_tabs
   in
 
   let encodings =
     combo
       "File charset encoding "
-      ~f:(fun s ->
-	    match s with
-	    | "UTF-8" ->
-		!current.encoding_use_utf8 <- true;
-		!current.encoding_use_locale <- false
-	    | "LOCALE" ->
-		!current.encoding_use_utf8 <- false;
-		!current.encoding_use_locale <- true
-	    | _ ->
-		!current.encoding_use_utf8 <- false;
-		!current.encoding_use_locale <- false;
-		!current.encoding_manual <- s;
-	 )
+      ~f:(fun s -> !current.encoding <- (inputenc_of_string s))
       ~new_allowed: true
-      ["UTF-8";"LOCALE";!current.encoding_manual]
-      (if !current.encoding_use_utf8 then "UTF-8"
-       else if !current.encoding_use_locale then "LOCALE" else !current.encoding_manual)
+      ("UTF-8"::"LOCALE":: match !current.encoding with
+	|Emanual s -> [s]
+	|_ -> []
+      )
+      (string_of_inputenc !current.encoding)
+  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 +609,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 +622,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 +635,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
@@ -567,43 +659,46 @@ let configure ?(apply=(fun () -> ())) () =
     bool
       ~f:(fun s ->
 	    !current.contextual_menus_on_goal <- s;
-	    !contextual_menus_on_goal s)
+	    !contextual_menus_on_goal_hook s)
       "Contextual menus on goal" !current.contextual_menus_on_goal
   in
 
-  let misc = [contextual_menus_on_goal;auto_complete;stop_before;lax_syntax;
+  let misc = [contextual_menus_on_goal;auto_complete;stop_before;
               vertical_tabs;opposite_tabs] in
 
 (* 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("Colors", Some `SELECT_COLOR, [config_color]);
+     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",
-	     [cmd_coqc;cmd_make;cmd_coqmakefile; cmd_coqdoc; cmd_print;
-	      cmd_editor;
-	      cmd_browse;doc_url;library_url]);
-     Section("Tactics Wizard",
+     Section("Externals", None,
+	     [cmd_coqtop;cmd_coqc;cmd_make;cmd_coqmakefile; cmd_coqdoc;
+	      cmd_print;cmd_editor;cmd_browse;doc_url;library_url]);
+     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
 (*
   Format.printf "before edit: current.text_font = %s@." (Pango.Font.to_string !current.text_font);
 *)
-  let x = edit ~apply ~width:500 "Customizations" cmds in
+  let x = edit ~apply "Customizations" cmds in
 (*
   Format.printf "after edit: current.text_font = %s@." (Pango.Font.to_string !current.text_font);
 *)
diff --git a/ide/preferences.mli b/ide/preferences.mli
index 472ae30f..382aa091 100644
--- a/ide/preferences.mli
+++ b/ide/preferences.mli
@@ -1,15 +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-2012     *)
 (*   \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 inputenc = Elocale | Eutf8 | Emanual of string
 
 type pref =
     {
+      mutable cmd_coqtop : string option;
       mutable cmd_coqc : string;
       mutable cmd_make : string;
       mutable cmd_coqmakefile : string;
@@ -22,18 +24,19 @@ type pref =
       mutable auto_save_delay : int;
       mutable auto_save_name : string * string;
 
-      mutable encoding_use_locale : bool;
-      mutable encoding_use_utf8 : bool;
-      mutable encoding_manual : string;
+      mutable read_project : project_behavior;
+      mutable project_file_name : string;
+
+      mutable encoding : inputenc;
 
       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;
@@ -54,9 +57,12 @@ type pref =
 *)
       mutable auto_complete : bool;
       mutable stop_before : bool;
-      mutable lax_syntax : bool;
       mutable vertical_tabs : bool;
       mutable opposite_tabs : bool;
+
+      mutable background_color : string;
+      mutable processing_color : string;
+      mutable processed_color : string;
     }
 
 val save_pref : unit -> unit
@@ -66,9 +72,11 @@ val current : pref ref
 
 val configure : ?apply:(unit -> unit) -> unit -> unit
 
-val change_font : ( Pango.font_description -> unit) ref
-val show_toolbar : (bool -> unit) ref
-val auto_complete : (bool -> unit) ref
-val resize_window : (unit -> unit) ref
+(* Hooks *)
+val refresh_font_hook : (unit -> unit) ref
+val refresh_background_color_hook : (unit -> unit) ref
+val refresh_toolbar_hook : (unit -> unit) ref
+val resize_window_hook : (unit -> unit) ref
+val refresh_tabs_hook : (unit -> unit) ref
 
 val use_default_doc_url : string
diff --git a/ide/project_file.ml4 b/ide/project_file.ml4
new file mode 100644
index 00000000..aa1189ce
--- /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..7b67944b 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-2012     *)
 (*   \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
@@ -15,6 +13,9 @@ let make_tag (tt:GText.tag_table) ~name prop =
   tt#add new_tag#as_tag;
   new_tag
 
+let processed_color = ref "light green"
+let processing_color = ref "light blue"
+
 module Script =
 struct
   let table = GText.tag_table ()
@@ -25,19 +26,19 @@ struct
   let comment = make_tag table ~name:"comment" [`FOREGROUND "brown"]
   let reserved = make_tag table ~name:"reserved" [`FOREGROUND "dark red"]
   let error = make_tag table ~name:"error" [`UNDERLINE `DOUBLE ; `FOREGROUND "red"]
-  let to_process = make_tag table ~name:"to_process" [`BACKGROUND "light blue" ;`EDITABLE false]
-  let processed = make_tag table ~name:"processed" [`BACKGROUND "light green" ;`EDITABLE false]
+  let to_process = make_tag table ~name:"to_process" [`BACKGROUND !processing_color ;`EDITABLE false]
+  let processed = make_tag table ~name:"processed" [`BACKGROUND !processed_color;`EDITABLE false]
   let unjustified = make_tag table ~name:"unjustified" [`UNDERLINE `SINGLE; `FOREGROUND "red"; `BACKGROUND "gold";`EDITABLE false]
   let found = make_tag table ~name:"found" [`BACKGROUND "blue"; `FOREGROUND "white"]
   let hidden = make_tag table ~name:"hidden" [`INVISIBLE true; `EDITABLE false]
   let folded = make_tag table ~name:"locked" [`EDITABLE false; `BACKGROUND "light grey"]
   let paren = make_tag table ~name:"paren" [`BACKGROUND "purple"]
-  let lax_end = make_tag table ~name:"sentence_end" []
+  let sentence = make_tag table ~name:"sentence" []
 end
 module Proof =
 struct
   let table = GText.tag_table ()
-  let highlight = make_tag table ~name:"highlight" [`BACKGROUND "light green"]
+  let highlight = make_tag table ~name:"highlight" [`BACKGROUND !processed_color]
   let hypothesis = make_tag table ~name:"hypothesis" []
   let goal = make_tag table ~name:"goal" []
 end
@@ -47,3 +48,27 @@ struct
   let error = make_tag table ~name:"error" [`FOREGROUND "red"]
 end
 
+let string_of_color clr =
+  let r = Gdk.Color.red clr in
+  let g = Gdk.Color.green clr in
+  let b = Gdk.Color.blue clr in
+  Printf.sprintf "#%04X%04X%04X" r g b
+
+let color_of_string s =
+  let colormap = Gdk.Color.get_system_colormap () in
+  Gdk.Color.alloc ~colormap (`NAME s)
+
+let get_processed_color () = color_of_string !processed_color
+
+let set_processed_color clr =
+  let s = string_of_color clr in
+  processed_color := s;
+  Script.processed#set_property (`BACKGROUND s);
+  Proof.highlight#set_property (`BACKGROUND s)
+
+let get_processing_color () = color_of_string !processing_color
+
+let set_processing_color clr =
+  let s = string_of_color clr in
+  processing_color := s;
+  Script.to_process#set_property (`BACKGROUND s)
diff --git a/ide/tags.mli b/ide/tags.mli
new file mode 100644
index 00000000..36f18a2f
--- /dev/null
+++ b/ide/tags.mli
@@ -0,0 +1,50 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+module Script :
+sig
+  val table : GText.tag_table
+  val kwd : GText.tag
+  val qed : GText.tag
+  val decl : GText.tag
+  val proof_decl : GText.tag
+  val comment : GText.tag
+  val reserved : GText.tag
+  val error : GText.tag
+  val to_process : GText.tag
+  val processed : GText.tag
+  val unjustified : GText.tag
+  val found : GText.tag
+  val hidden : GText.tag
+  val folded : GText.tag
+  val paren : GText.tag
+  val sentence : GText.tag
+end
+
+module Proof :
+sig
+  val table : GText.tag_table
+  val highlight : GText.tag
+  val hypothesis : GText.tag
+  val goal : GText.tag
+end
+
+module Message :
+sig
+  val table : GText.tag_table
+  val error : GText.tag
+end
+
+val string_of_color : Gdk.color -> string
+val color_of_string : string -> Gdk.color
+
+val get_processed_color : unit -> Gdk.color
+val set_processed_color : Gdk.color -> unit
+
+val get_processing_color : unit -> Gdk.color
+val set_processing_color : Gdk.color -> unit
diff --git a/ide/typed_notebook.ml b/ide/typed_notebook.ml
index 3dd2279f..60c89eb1 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-2012     *)
 (*   \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..0951ab5e 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-2012     *)
 (*   \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..95168b17 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-2012     *)
 (*   \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..4b471395 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-2012     *)
 (*   \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..df76ee5e 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-2012     *)
 (*   \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..f27f96a6 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-2012     *)
 (*   \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..4606ef29 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 =
@@ -60,9 +60,9 @@ let html = Configwin_ihm.html
 
 let edit
     ?(apply=(fun () -> ()))
-    title ?(width=400) ?(height=400)
+    title ?width ?height
     conf_struct_list =
-  Configwin_ihm.edit ~with_apply: true ~apply title ~width ~height conf_struct_list
+  Configwin_ihm.edit ~with_apply: true ~apply title ?width ?height conf_struct_list
 
 let get = Configwin_ihm.edit ~with_apply: false ~apply: (fun () -> ())
 
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..7dbd0452 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#pack ~expand:true) ~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 page_label = GMisc.label ~text: label () in
-  let _ = notebook#append_page
-      ~tab_label: page_label#coerce
-      main_box#coerce
+
+  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
 
-  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.*)
+  (* 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
+
+    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
-  in
-  let f_apply () =
-    List.iter (fun param_box -> param_box#apply) list_param_box  ;
+  let f_apply () = param_box#apply
   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,62 +1130,49 @@ 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 =
+    title ?width ?height
+    conf_struct =
   let dialog = GWindow.dialog
     ~position:`CENTER
     ~modal: true ~title: title
-    ~height ~width
+    ?height ?width
     ()
   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/ide/utils/okey.ml b/ide/utils/okey.ml
index 57939266..905c3485 100644
--- a/ide/utils/okey.ml
+++ b/ide/utils/okey.ml
@@ -47,6 +47,10 @@ let int_of_modifier = function
   | `BUTTON3 -> 1024
   | `BUTTON4 -> 2048
   | `BUTTON5 -> 4096
+  | `HYPER -> 1 lsl 22
+  | `META -> 1 lsl 20
+  | `RELEASE -> 1 lsl 30
+  | `SUPER -> 1 lsl 21
 
 let print_modifier l =
   List.iter
@@ -65,7 +69,11 @@ let print_modifier l =
 	  | `BUTTON2 -> "B2"
 	  | `BUTTON3 -> "B3"
 	  | `BUTTON4 -> "B4"
-	  | `BUTTON5 -> "B5")
+	  | `BUTTON5 -> "B5"
+          | `HYPER -> "HYPER"                                                                                                     
+          | `META -> "META"                                                                                                       
+          | `RELEASE -> ""                                                                                                        
+          | `SUPER -> "SUPER")
 	    m)^" ")
     )
     l;
diff --git a/interp/constrextern.ml b/interp/constrextern.ml
index dc339622..ee529fe0 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-2012     *)
 (*   \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
@@ -96,17 +137,22 @@ let insert_pat_alias loc p = function
 let extern_evar loc n l =
   if !print_evar_arguments then CEvar (loc,n,l) else CEvar (loc,n,None)
 
-let debug_global_reference_printer =
-  ref (fun _ -> failwith "Cannot print a global reference")
+(** We allow customization of the global_reference printer.
+    For instance, in the debugger the tables of global references
+    may be inaccurate *)
+
+let default_extern_reference loc vars r =
+  Qualid (loc,shortest_qualid_of_global vars r)
+
+let my_extern_reference = ref default_extern_reference
+
+let set_extern_reference f = my_extern_reference := f
+let get_extern_reference () = !my_extern_reference
 
-let set_debug_global_reference_printer f =
-  debug_global_reference_printer := f
+let extern_reference loc vars l = !my_extern_reference loc vars l
+
+let in_debugger = ref false
 
-let extern_reference loc vars r =
-  try Qualid (loc,shortest_qualid_of_global vars r)
-  with Not_found ->
-    (* happens in debugger *)
-    !debug_global_reference_printer loc r
 
 (************************************************************************)
 (* Equality up to location (useful for translator v8) *)
@@ -117,6 +163,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 ->
@@ -158,7 +206,8 @@ let rec check_same_type ty1 ty2 =
   | CLetIn(_,(_,na1),a1,b1), CLetIn(_,(_,na2),a2,b2) when na1=na2 ->
       check_same_type a1 a2;
       check_same_type b1 b2
-  | CAppExpl(_,r1,al1), CAppExpl(_,r2,al2) when r1=r2 ->
+  | CAppExpl(_,(proj1,r1),al1), CAppExpl(_,(proj2,r2),al2) when proj1=proj2 ->
+      check_same_ref r1 r2;
       List.iter2 check_same_type al1 al2
   | CApp(_,(_,e1),al1), CApp(_,(_,e2),al2) ->
       check_same_type e1 e2;
@@ -202,75 +251,8 @@ and check_same_fix_binder bl1 bl2 =
           check_same_binder ([na1],default_binder_kind,def1) ([na2],default_binder_kind,def2)
       | _ -> failwith "not same 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
+let is_same_type c d =
+  try let () = check_same_type c d in true
   with Failure _ | Invalid_argument _ -> false
 
 (**********************************************************************)
@@ -279,7 +261,7 @@ let same_rawconstr c d =
 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 []
@@ -315,17 +297,17 @@ let make_notation_gen loc ntn mknot mkprim destprim l =
   if has_curly_brackets ntn
   then expand_curly_brackets loc mknot ntn l
   else match ntn,List.map destprim l with
-    (* Special case to avoid writing "- 3" for e.g. (Zopp 3) *)
+    (* Special case to avoid writing "- 3" for e.g. (Z.opp 3) *)
     | "- _", [Some (Numeral p)] when Bigint.is_strictly_pos p ->
         mknot (loc,ntn,([mknot (loc,"( _ )",l)]))
     | _ ->
 	match decompose_notation_key ntn, l with
 	| [Terminal "-"; Terminal x], [] ->
 	    (try mkprim (loc, Numeral (Bigint.neg (Bigint.of_string x)))
-	     with _ -> mknot (loc,ntn,[]))
+	     with e when Errors.noncritical e -> mknot (loc,ntn,[]))
 	| [Terminal x], [] ->
 	    (try mkprim (loc, Numeral (Bigint.of_string x))
-	     with _ -> mknot (loc,ntn,[]))
+	     with e when Errors.noncritical e -> mknot (loc,ntn,[]))
 	| _ ->
 	    mknot (loc,ntn,l)
 
@@ -347,7 +329,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 +352,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 !in_debugger || !Flags.raw_print then raise Exit;
 	  let projs = Recordops.lookup_projections (fst cstrsp) in
 	  let rec ip projs args acc =
 	    match projs with
@@ -395,11 +377,12 @@ and extern_symbol_pattern (tmp_scope,scopes as allscopes) vars t = function
   | (keyrule,pat,n as _rule)::rules ->
     try
       match t,n with
-      | PatCstr (loc,(ind,_),l,na), n when n = Some 0 or n = None or 
-	 n = Some(fst(Global.lookup_inductive ind)).Declarations.mind_nparams ->
+      | PatCstr (loc,(ind,_),l,na), n when (n = Some 0 or n = None or
+	 n = Some(fst(Global.lookup_inductive ind)).Declarations.mind_nparams)
+          && (match keyrule with SynDefRule _ -> true | _ -> false) ->
         (* Abbreviation for the constructor name only *)
 	(match keyrule with
-        | NotationRule (sc,ntn) -> raise No_match
+        | NotationRule _ -> assert false
         | SynDefRule kn ->
 	    let qid = Qualid (loc, shortest_qualid_of_syndef vars kn) in
 	    let l = List.map (extern_cases_pattern_in_scope allscopes vars) l in
@@ -464,12 +447,16 @@ 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 *)
 let explicitize loc inctx impl (cf,f) args =
+  let impl = if !Constrintern.parsing_explicit then [] else impl in
   let n = List.length args in
   let rec exprec q = function
     | a::args, imp::impl when is_status_implicit imp ->
@@ -477,8 +464,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
@@ -504,7 +492,9 @@ let explicitize loc inctx impl (cf,f) args =
 	if args = [] then f else CApp (loc, (None, f), args)
 
 let extern_global loc impl f =
-  if impl <> [] & List.for_all is_status_implicit impl then
+  if not !Constrintern.parsing_explicit &&
+     impl <> [] && List.for_all is_status_implicit impl
+  then
     CAppExpl (loc, (None, f), [])
   else
     CRef f
@@ -513,7 +503,7 @@ let extern_app loc inctx impl (cf,f) args =
   if args = [] (* maybe caused by a hidden coercion *) then
     extern_global loc impl f
   else
-  if
+  if not !Constrintern.parsing_explicit &&
     ((!Flags.raw_print or
       (!print_implicits & not !print_implicits_explicit_args)) &
      List.exists is_status_implicit impl)
@@ -532,7 +522,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 +541,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 +559,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 +571,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 +589,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 +657,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
+      let (idl,c) = factorize_prod scopes (add_vname vars na) na bk t c in
       CProdN (loc,[(dummy_loc,na)::idl,Default bk,t],c)
 
-  | 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
+      let (idl,c) = factorize_lambda inctx scopes (add_vname vars na) na bk t c in
       CLambdaN (loc,[(dummy_loc,na)::idl,Default bk,t],c)
 
-  | 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 +733,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,46 +744,39 @@ 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)
 
 and sub_extern inctx (_,scopes) = extern inctx (None,scopes)
 
-and factorize_prod scopes vars aty c =
-  try
-    if !Flags.raw_print or !print_no_symbol then raise No_match;
-    ([],extern_symbol scopes vars c (uninterp_notations c))
-  with No_match -> match c with
-  | RProd (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
-           ((loc,Name id)::nal,c)
-  | c -> ([],extern_typ scopes vars c)
-
-and factorize_lambda inctx scopes vars aty c =
-  try
-    if !Flags.raw_print or !print_no_symbol then raise No_match;
-    ([],extern_symbol scopes vars c (uninterp_notations c))
-  with No_match -> match c with
-  | RLambda (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) =
-	     factorize_lambda inctx scopes (add_vname vars na) aty c in
-           ((loc,na)::nal,c)
-  | c -> ([],sub_extern inctx scopes vars c)
+and factorize_prod scopes vars na bk aty c =
+  let c = extern_typ scopes vars c in
+  match na, c with
+  | Name id, CProdN (loc,[nal,Default bk',ty],c)
+      when bk = bk' && is_same_type aty ty
+      & not (occur_var_constr_expr id ty) (* avoid na in ty escapes scope *) ->
+      nal,c
+  | _ ->
+      [],c
+
+and factorize_lambda inctx scopes vars na bk aty c =
+  let c = sub_extern inctx scopes vars c in
+  match c with
+  | CLambdaN (loc,[nal,Default bk',ty],c)
+      when bk = bk' && is_same_type aty ty
+      & not (occur_name na ty) (* avoid na in ty escapes scope *) ->
+      nal,c
+  | _ ->
+      [],c
 
 and extern_local_binder scopes vars = function
     [] -> ([],[],[])
@@ -806,7 +790,7 @@ and extern_local_binder scopes vars = function
       let ty = extern_typ scopes vars (anonymize_if_reserved na ty) in
       (match extern_local_binder scopes (name_fold Idset.add na vars) l with
           (assums,ids,LocalRawAssum(nal,k,ty')::l)
-            when same ty ty' &
+            when is_same_type ty ty' &
               match na with Name id -> not (occur_var_constr_expr id ty')
                 | _ -> true ->
               (na::assums,na::ids,
@@ -822,33 +806,42 @@ and extern_eqn inctx scopes vars (loc,ids,pl,c) =
 and extern_symbol (tmp_scope,scopes as allscopes) vars t = function
   | [] -> raise No_match
   | (keyrule,pat,n as _rule)::rules ->
-      let loc = 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 e when Errors.noncritical e -> [] in
+	          let impls =
+		    let impls =
+		      select_impargs_size
+		        (List.length args) (implicits_of_global ref) in
+		    try list_skipn n impls
+                    with e when Errors.noncritical e -> [] in
+                  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 +881,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
 
 (******************************************************************)
@@ -905,104 +898,94 @@ let extern_rawtype vars c =
 
 let loc = dummy_loc (* for constr and pattern, locations are lost *)
 
-let extern_constr_gen at_top scopt 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
+let extern_constr_gen goal_concl_style scopt env t =
+  (* "goal_concl_style" means do alpha-conversion using the "goal" convention *)
+  (* i.e.: avoid using the names of goal/section/rel variables and the short *)
+  (* names of global definitions of current module when computing names for *)
+  (* bound variables. *)
+  (* Not "goal_concl_style" means do alpha-conversion avoiding only *)
+  (* those goal/section/rel variables that occurs in the subterm under *)
+  (* consideration; see namegen.ml for further details *)
+  let avoid = if goal_concl_style then ids_of_context env else [] in
+  let rel_env_names = names_of_rel_context env in
+  let r = Detyping.detype goal_concl_style avoid rel_env_names t in
   let vars = vars_of_env env in
   extern false (scopt,[]) vars r
 
-let extern_constr_in_scope at_top scope env t =
-  extern_constr_gen at_top (Some scope) env t
+let extern_constr_in_scope goal_concl_style scope env t =
+  extern_constr_gen goal_concl_style (Some scope) env t
 
-let extern_constr at_top env t =
-  extern_constr_gen at_top None env t
+let extern_constr goal_concl_style env t =
+  extern_constr_gen goal_concl_style None 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
+let extern_type goal_concl_style env t =
+  let avoid = if goal_concl_style then ids_of_context env else [] in
+  let rel_env_names = names_of_rel_context env in
+  let r = Detyping.detype goal_concl_style avoid rel_env_names t in
+  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..55fababd 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-2012     *)
 (*   \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
+val is_same_type : constr_expr -> constr_expr -> bool
 
-(* 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,29 @@ val print_universes : bool ref
 val print_no_symbol : bool ref
 val print_projections : bool ref
 
-(* Debug printing options *)
-val set_debug_global_reference_printer :
-  (loc -> global_reference -> reference) -> unit
+(** Customization of the global_reference printer *)
+val set_extern_reference :
+  (loc -> Idset.t -> global_reference -> reference) -> unit
+val get_extern_reference :
+  unit -> (loc -> Idset.t -> global_reference -> reference)
+
+val in_debugger : bool ref
 
-(* 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 96393659..e806686a 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: constrintern.ml 15072 2012-03-20 17:36:33Z 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,9 @@ let error_inductive_parameter_not_implicit loc =
 (* Pre-computing the implicit arguments and arguments scopes needed   *)
 (* for interpretation *)
 
-let empty_internalization_env = []
+let parsing_explicit = ref false
+
+let empty_internalization_env = Idmap.empty
 
 let compute_explicitable_implicit imps = function
   | Inductive params ->
@@ -175,7 +176,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 +186,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 +236,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            *)
 
@@ -250,8 +259,9 @@ let pr_scope_stack = function
 
 let error_inconsistent_scope loc id scopes1 scopes2 =
   user_err_loc (loc,"set_var_scope",
-    pr_id id ++ str " is used both in " ++
-    pr_scope_stack scopes1 ++ strbrk " and in " ++ pr_scope_stack scopes2)
+    pr_id id ++ str " is here used in " ++
+    pr_scope_stack scopes2 ++ strbrk " while it was elsewhere used in " ++
+    pr_scope_stack scopes1)
 
 let error_expect_constr_notation_type loc id =
   user_err_loc (loc,"",
@@ -262,20 +272,20 @@ 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 &
-      (* scopes have no effect on the interpretation of identifiers, hence
-         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
-	error_inconsistent_scope loc id
-	  (make_current_scope (Option.get !idscopes))
-	  (make_current_scope (scopt,scopes))
-    else
-      idscopes := Some (scopt,scopes);
+    if istermvar then
+      (* scopes have no effect on the interpretation of identifiers *)
+      if !idscopes = None then
+        idscopes := Some (env.tmp_scope,env.scopes)
+      else
+        if make_current_scope (Option.get !idscopes)
+          <> make_current_scope (env.tmp_scope,env.scopes)
+        then
+	  error_inconsistent_scope loc id
+	    (make_current_scope (Option.get !idscopes))
+	    (make_current_scope (env.tmp_scope,env.scopes));
     match typ with
     | NtnInternTypeBinder ->
 	if istermvar then error_expect_binder_notation_type loc id
@@ -289,24 +299,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 +344,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,47 +405,48 @@ 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) ->
       (match bk with
       | Default k ->
-          let (loc,na) = List.hd nal in
-	  (* TODO: fail if several names with different implicit types *)
-	  let ty = locate_if_isevar loc na (intern_type env ty) in
+	  let ty = intern_type env ty in
+          let impls = impls_type_list ty in
 	    List.fold_left
-	     (fun (env,bl) na ->
-	       (push_name_env lvar env na,(snd na,k,None,ty)::bl))
+	     (fun (env,bl) (loc,na as locna) ->
+	       (push_name_env lvar impls env locna,
+                (na,k,None,locate_if_isevar loc na ty)::bl))
 	      (env,bl) nal
       | Generalized (b,b',t) ->
 	  let env, b = intern_generalized_binder ~global_level intern_type lvar env bl (List.hd nal) b b' t ty in
 	    env, b @ bl)
   | 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'
 
@@ -420,19 +455,20 @@ let iterate_binder intern lvar (env,bl) = function
       let intern_type env = intern (set_type_scope env) in
       (match bk with
       | Default k ->
-          let (loc,na) = List.hd nal in
-	  (* TODO: fail if several names with different implicit types *)
 	  let ty = intern_type env ty in
-	  let ty = locate_if_isevar loc na ty in
+          let impls = impls_type_list ty in
 	  List.fold_left
-	    (fun (env,bl) na -> (push_name_env lvar env na,(snd na,k,None,ty)::bl))
+	    (fun (env,bl) (loc,na as locna) ->
+              (push_name_env lvar impls env locna,
+               (na,k,None,locate_if_isevar loc na ty)::bl))
 	    (env,bl) nal
       | Generalized (b,b',t) ->
 	  let env, b = intern_generalized_binder intern_type lvar env bl (List.hd nal) b b' t ty in
 	    env, b @ bl)
   | LocalRawDef((loc,na as locna),def) ->
-      (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 +486,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 +501,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 +515,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 +529,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 +553,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 +570,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 +588,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 +606,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 +641,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 +649,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, []
-      with _ ->
+	GRef (loc, ref), impls, scopes, []
+      with e when Errors.noncritical e ->
 	(* [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 +689,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,40 +697,42 @@ 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
 	let r,args2 = intern_non_secvar_qualid loc qid intern env lvar args in
 	find_appl_head_data r, args2
-      with e ->
+      with e when Errors.noncritical 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 scopes =
   if n=0 then [] else match scopes with
@@ -767,8 +808,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 *)
 
@@ -792,7 +833,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
@@ -800,7 +841,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))
@@ -845,7 +887,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
@@ -863,7 +905,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)
 
@@ -882,9 +924,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
@@ -892,12 +934,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))
 
@@ -916,7 +958,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 =
@@ -927,15 +969,15 @@ let sort_fields mode loc l completer =
 		    | [] -> anomaly "Number of projections mismatch"
 		    | (_, regular)::tm ->
 		       let boolean = not regular in
-		       if ConstRef name = global_reference_of_reference refer
-		       then
+                       (match global_reference_of_reference refer with
+                       | ConstRef name' when eq_constant name name' ->
 			 if boolean && mode then
 			   user_err_loc (loc, "", str"No local fields allowed in a record construction.")
 			 else build_patt b tm (i + 1) (i, snd acc) (* we found it *)
-		       else
+                       | _ ->
 			  build_patt b tm (if boolean&&mode then i else i + 1)
 			    (if boolean && mode then acc
-			     else fst acc, (i, ConstRef name) :: snd acc))
+			     else fst acc, (i, ConstRef name) :: snd acc)))
 	      | None :: b-> (* we don't want anonymous fields *)
 		 if mode then
 		   user_err_loc (loc, "", str "This record contains anonymous fields.")
@@ -956,6 +998,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
 		   | [] ->
@@ -963,7 +1009,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 eq_gr glob_refer a
 		       then (i,List.rev_append acc l)
 		       else add_patt b ((i,a)::acc)
 	         in
@@ -986,12 +1032,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 =
@@ -999,41 +1045,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
@@ -1046,7 +1093,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);
@@ -1065,7 +1112,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
@@ -1073,15 +1120,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 =
@@ -1125,13 +1172,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
@@ -1140,30 +1187,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,
@@ -1177,21 +1228,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) ->
@@ -1201,8 +1257,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)))
@@ -1212,16 +1269,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" *)
@@ -1230,18 +1288,18 @@ 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
             | x -> (intern env f,[],[],[]), args in
 	let args =
-	  intern_impargs c env impargs args_scopes (merge_impargs l args) in
+          intern_impargs c env impargs args_scopes (merge_impargs l args) in
 	check_projection isproj (List.length args) c;
 	(match c with
           (* Now compact "(f args') args" *)
-	  | 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
@@ -1259,48 +1317,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)
 
@@ -1308,52 +1358,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;
@@ -1361,46 +1411,59 @@ 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 not (List.mem_assoc id (snd lvar)) ->
+          loc,Name id
+      | GRef (loc, VarRef id), None -> loc,Name id
       | _, None -> dummy_loc,Anonymous
       | _, Some (loc,na) -> loc,na in
     (tm',(snd na,typ)), na::ids
 
   and iterate_prod 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
-	  RProd (join_loc loc1 loc2, na, bk, ty, body)
-    | [] -> intern_type env body
+    let default env bk = function
+    | (loc1,na)::nal' as nal ->
+	if nal' <> [] then check_capture loc1 ty na;
+        let ty = intern_type env ty in
+        let impls = impls_type_list ty in
+	let env = List.fold_left (push_name_env lvar impls) env nal in
+        List.fold_right (fun (loc,na) c ->
+          GProd (join_loc loc loc2, na, bk, locate_if_isevar loc na ty, c))
+          nal (intern_type env body)
+    | [] -> assert false
     in
       match bk with
 	| Default b -> default env b nal
 	| Generalized (b,b',t) ->
 	    let env, ibind = intern_generalized_binder intern_type lvar env [] (List.hd nal) b b' t ty in
 	    let body = intern_type env body in
-	      it_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)
-      | [] -> intern env body
+    let default env bk = function
+    | (loc1,na)::nal' as nal ->
+        if nal' <> [] then check_capture loc1 ty na;
+        let ty = intern_type env ty in
+        let impls = impls_type_list ty in
+	let env = List.fold_left (push_name_env lvar impls) env nal in
+        List.fold_right (fun (loc,na) c ->
+          GLambda (join_loc loc loc2, na, bk, locate_if_isevar loc na ty, c))
+          nal (intern env body)
+    | [] -> assert false
     in match bk with
       | Default b -> default env b nal
       | Generalized (b, b', t) ->
 	  let env, ibind = intern_generalized_binder intern_type lvar env [] (List.hd nal) b b' t ty in
 	  let body = intern env body in
-	    it_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
     let eargs, rargs = extract_explicit_arg l args in
+    if !parsing_explicit then
+      if eargs <> [] then
+        error "Arguments given by name or position not supported in explicit mode."
+      else
+        intern_args env subscopes rargs
+    else
     let rec aux n impl subscopes eargs rargs =
       let (enva,subscopes') = apply_scope_env env subscopes in
       match (impl,rargs) with
@@ -1416,7 +1479,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') ->
@@ -1424,7 +1487,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"."));
 	  []
@@ -1448,7 +1511,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 =
@@ -1457,32 +1520,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
@@ -1490,10 +1555,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 =
@@ -1501,19 +1566,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
 
@@ -1521,7 +1586,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
@@ -1529,43 +1594,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
@@ -1577,12 +1643,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
@@ -1593,11 +1659,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) =
@@ -1605,7 +1672,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 =
@@ -1617,20 +1684,20 @@ let interp_rawcontext_gen understand_type understand_judgment env bl =
 		(push_rel d env, d::params, succ n, impls)
 	  | Some b ->
 	      let c = understand_judgment env b in
-	      let d = (na, Some c.uj_val, c.uj_type) in
+	      let d = (na, Some c.uj_val, Termops.refresh_universes c.uj_type) in
 		(push_rel d env, d::params, succ n, impls))
       (env,[],1,[]) (List.rev bl)
   in (env, par), impls
 
-let interp_context_gen understand_type understand_judgment ?(global_level=false) 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..7a4bba10 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-2012     *)
 (*   \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,60 @@ 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 options *)
+val parsing_explicit : bool ref
+
+(** Globalization leak for Grammar *)
 val for_grammar : ('a -> 'b) -> 'a -> 'b
diff --git a/interp/coqlib.ml b/interp/coqlib.ml
index c5850abf..d9649976 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-2012     *)
 (*   \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..3dd82c28 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-2012     *)
 (*   \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..b0a49c17 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-2012     *)
 (*   \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..e4712cf1 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-2012     *)
 (*   \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..a9adbe83 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-2012     *)
 (*   \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
 
@@ -65,23 +63,10 @@ type 'a with_ebindings = 'a * open_constr bindings
 
 type 'a generic_argument = argument_type * Obj.t
 
-let dyntab = ref ([] : string list)
-
 type rlevel
 type glevel
 type tlevel
 
-type ('a,'b) abstract_argument_type = argument_type
-
-let create_arg s =
-  if List.mem s !dyntab then
-    anomaly ("Genarg.create: already declared generic argument " ^ s);
-  dyntab := s :: !dyntab;
-  let t = ExtraArgType s in
-  (t,t,t)
-
-let exists_argtype s = List.mem s !dyntab
-
 type intro_pattern_expr =
   | IntroOrAndPattern of or_and_intro_pattern_expr
   | IntroWildcard
@@ -261,3 +246,32 @@ let unquote x = x
 type an_arg_of_this_type = Obj.t
 
 let in_generic t x = (t, Obj.repr x)
+
+let dyntab = ref ([] : (string * glevel generic_argument option) list)
+
+type ('a,'b) abstract_argument_type = argument_type
+
+let create_arg v s =
+  if List.mem_assoc s !dyntab then
+    anomaly ("Genarg.create: already declared generic argument " ^ s);
+  let t = ExtraArgType s in
+  dyntab := (s,Option.map (in_gen t) v) :: !dyntab;
+  (t,t,t)
+
+let exists_argtype s = List.mem_assoc s !dyntab
+
+let default_empty_argtype_value s = List.assoc s !dyntab
+
+let default_empty_value t =
+  let rec aux = function
+  | List0ArgType _ -> Some (in_gen t [])
+  | OptArgType _ -> Some (in_gen t None)
+  | PairArgType(t1,t2) ->
+      (match aux t1, aux t2 with
+      | Some (_,v1), Some (_,v2) -> Some (in_gen t (v1,v2))
+      | _ -> None)
+  | ExtraArgType s -> default_empty_argtype_value s
+  | _ -> None in
+  match aux t with
+  | Some v -> Some (out_gen t v)
+  | None -> None
diff --git a/interp/genarg.mli b/interp/genarg.mli
index 54b415d1..302aa950 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-2012     *)
 (*   \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,9 +254,10 @@ 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 ->
+val create_arg : 'rawa option ->
+    string ->
       ('a,tlevel) abstract_argument_type
       * ('globa,glevel) abstract_argument_type
       * ('rawa,rlevel) abstract_argument_type
@@ -265,7 +265,7 @@ val create_arg : string ->
 val exists_argtype : string -> bool
 
 type argument_type =
-  (* Basic types *)
+  (** Basic types *)
   | BoolArgType
   | IntArgType
   | IntOrVarArgType
@@ -275,7 +275,7 @@ type argument_type =
   | IdentArgType of bool
   | VarArgType
   | RefArgType
-  (* Specific types *)
+  (** Specific types *)
   | SortArgType
   | ConstrArgType
   | ConstrMayEvalArgType
@@ -299,8 +299,7 @@ val in_gen :
 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]
 
@@ -313,3 +312,5 @@ type an_arg_of_this_type
 
 val in_generic :
   argument_type -> an_arg_of_this_type -> 'co generic_argument
+
+val default_empty_value : ('a,rlevel) abstract_argument_type -> 'a option
diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml
index 88ed0873..2c000258 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-2012     *)
 (*   \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))
 
@@ -90,8 +88,8 @@ let is_freevar ids env x =
     if Idset.mem x ids then false
     else
       try ignore(Environ.lookup_named x env) ; false
-      with _ -> not (is_global x)
-  with _ -> true
+      with e when Errors.noncritical e -> not (is_global x)
+  with e when Errors.noncritical e -> true
 
 (* Auxiliary functions for the inference of implicitly quantified variables. *)
 
@@ -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..5a13bfd1 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-2012     *)
 (*   \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..071fe7f8 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-2012     *)
 (*   \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..69f05ed1 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-2012     *)
 (*   \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 4b67f8bd..03fa23a3 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: notation.ml 14882 2012-01-05 23:44:40Z 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*)
@@ -55,6 +53,9 @@ let notation_level_map = ref Gmap.empty
 (* Scopes table: scope_name -> symbol_interpretation *)
 let scope_map = ref Gmap.empty
 
+(* Delimiter table : delimiter -> scope_name *)
+let delimiters_map = ref Gmap.empty
+
 let empty_scope = {
   notations = Gmap.empty;
   delimiters = None
@@ -73,15 +74,28 @@ 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 error_unknown_scope sc = error ("Scope "^sc^" is not declared.")
+
 let find_scope scope =
   try Gmap.find scope !scope_map
-  with Not_found -> error ("Scope "^scope^" is not declared.")
+  with Not_found -> error_unknown_scope scope
 
 let check_scope sc = let _ = find_scope sc in ()
 
+(* [sc] might be here a [scope_name] or a [delimiter]
+   (now allowed after Open Scope) *)
+
+let normalize_scope sc =
+  try let _ = Gmap.find sc !scope_map in sc
+  with Not_found ->
+    try
+      let sc = Gmap.find sc !delimiters_map in
+      let _ = Gmap.find sc !scope_map in sc
+    with Not_found -> error_unknown_scope sc
+
 (**********************************************************************)
 (* The global stack of scopes                                         *)
 
@@ -101,10 +115,13 @@ let scope_is_open sc = scope_is_open_in_scopes sc (!scope_stack)
 
 (* Exportation of scopes *)
 let open_scope i (_,(local,op,sc)) =
-  if i=1 then begin
-  (match sc with Scope sc -> check_scope sc | _ -> ());
-  scope_stack := if op then sc :: !scope_stack else list_except sc !scope_stack
-  end
+  if i=1 then
+    let sc = match sc with
+      | Scope sc -> Scope (normalize_scope sc)
+      | _ -> sc
+    in
+    scope_stack :=
+      if op then sc :: !scope_stack else list_except sc !scope_stack
 
 let cache_scope o =
   open_scope 1 o
@@ -119,7 +136,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;
@@ -144,8 +161,6 @@ let make_current_scopes (tmp_scope,scopes) =
 (**********************************************************************)
 (* Delimiters *)
 
-let delimiters_map = ref Gmap.empty
-
 let declare_delimiters scope key =
   let sc = find_scope scope in
   let newsc = { sc with delimiters = Some key } in
@@ -153,15 +168,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 +193,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 +204,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 +231,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 +256,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 +364,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
@@ -367,14 +378,14 @@ let interp_prim_token_gen g loc p local_scopes =
   with Not_found ->
     user_err_loc (loc,"interp_prim_token",
     (match p with
-      | Numeral n -> str "No interpretation for numeral " ++ pr_bigint n
+      | Numeral n -> str "No interpretation for numeral " ++ str (to_string n)
       | String s -> str "No interpretation for string " ++ qs s) ++ str ".")
 
 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 +394,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 +410,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 +422,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 +454,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 +463,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 +503,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 +554,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 +625,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 +640,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 +667,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 +714,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 +727,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 +763,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 +774,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 *)
@@ -797,3 +834,8 @@ let _ =
     { freeze_function = freeze;
       unfreeze_function = unfreeze;
       init_function = init }
+
+let with_notation_protection f x =
+  let fs = freeze () in
+  try let a = f x in unfreeze fs; a
+  with reraise -> unfreeze fs; raise reraise
diff --git a/interp/notation.mli b/interp/notation.mli
index 33ffe7b4..2ecfbda7 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-2012     *)
 (*   \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,21 @@ 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 *)
+
+val with_notation_protection : ('a -> 'b) -> 'a -> 'b
diff --git a/interp/ppextend.ml b/interp/ppextend.ml
index 71029f3f..45aab2c1 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-2012     *)
 (*   \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..cae644ab 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-2012     *)
 (*   \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..935a7269 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-2012     *)
 (*   \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..b57894b9 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-2012     *)
 (*   \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..2976f078 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-2012     *)
 (*   \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..de34f5ba 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-2012     *)
 (*   \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..8dfeba07 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-2012     *)
 (*   \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
@@ -20,7 +18,9 @@ open Nametab
 
 (* Syntactic definitions. *)
 
-let syntax_table = ref (KNmap.empty : interpretation KNmap.t)
+type version = Flags.compat_version option
+
+let syntax_table = ref (KNmap.empty : (interpretation*version) KNmap.t)
 
 let _ = Summary.declare_summary
 	  "SYNTAXCONSTANT"
@@ -28,14 +28,14 @@ let _ = Summary.declare_summary
 	    Summary.unfreeze_function = (fun ft -> syntax_table := ft);
 	    Summary.init_function = (fun () -> syntax_table := KNmap.empty) }
 
-let add_syntax_constant kn c =
-  syntax_table := KNmap.add kn c !syntax_table
+let add_syntax_constant kn c onlyparse =
+  syntax_table := KNmap.add kn (c,onlyparse) !syntax_table
 
-let load_syntax_constant i ((sp,kn),(local,pat,onlyparse)) =
+let load_syntax_constant i ((sp,kn),(_,pat,onlyparse)) =
   if Nametab.exists_cci sp then
     errorlabstrm "cache_syntax_constant"
       (pr_id (basename sp) ++ str " already exists");
-  add_syntax_constant kn pat;
+  add_syntax_constant kn pat onlyparse;
   Nametab.push_syndef (Nametab.Until i) sp kn
 
 let is_alias_of_already_visible_name sp = function
@@ -48,7 +48,7 @@ let is_alias_of_already_visible_name sp = function
 let open_syntax_constant i ((sp,kn),(_,pat,onlyparse)) =
   if not (is_alias_of_already_visible_name sp pat) then begin
     Nametab.push_syndef (Nametab.Exactly i) sp kn;
-    if not onlyparse then
+    if onlyparse = None then
       (* Redeclare it to be used as (short) name in case an other (distfix)
 	 notation was declared inbetween *)
       Notation.declare_uninterpretation (Notation.SynDefRule kn) pat
@@ -64,7 +64,8 @@ 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 * Flags.compat_version option -> obj =
   declare_object {(default_object "SYNTAXCONSTANT") with
     cache_function = cache_syntax_constant;
     load_function = load_syntax_constant;
@@ -82,5 +83,50 @@ let out_pat (ids,ac) = (List.map (fun (id,(sc,typ)) -> (id,sc)) ids,ac)
 let declare_syntactic_definition local id onlyparse pat =
   let _ = add_leaf id (in_syntax_constant (local,in_pat pat,onlyparse)) in ()
 
+let pr_global r = pr_global_env Idset.empty r
+let pr_syndef kn = pr_qualid (shortest_qualid_of_syndef Idset.empty kn)
+
+let allow_compat_notations = ref true
+let verbose_compat_notations = ref false
+
+let is_verbose_compat () =
+  !verbose_compat_notations || not !allow_compat_notations
+
+let verbose_compat kn def = function
+  | Some v when is_verbose_compat () && Flags.version_strictly_greater v ->
+    let act =
+      if !verbose_compat_notations then msg_warning else errorlabstrm ""
+    in
+    let pp_def = match def with
+      | [], ARef r -> str " is " ++ pr_global_env Idset.empty r
+      | _ -> str " is a compatibility notation"
+    in
+    let since = str (" since Coq > " ^ Flags.pr_version v ^ ".") in
+    act (pr_syndef kn ++ pp_def ++ since)
+  | _ -> ()
+
 let search_syntactic_definition kn =
-  out_pat (KNmap.find kn !syntax_table)
+  let pat,v = KNmap.find kn !syntax_table in
+  let def = out_pat pat in
+  verbose_compat kn def v;
+  def
+
+open Goptions
+
+let set_verbose_compat_notations =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "verbose compatibility notations";
+      optkey   = ["Verbose";"Compat";"Notations"];
+      optread  = (fun () -> !verbose_compat_notations);
+      optwrite = ((:=) verbose_compat_notations) }
+
+let set_compat_notations =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "accept compatibility notations";
+      optkey   = ["Compat"; "Notations"];
+      optread  = (fun () -> !allow_compat_notations);
+      optwrite = ((:=) allow_compat_notations) }
diff --git a/interp/syntax_def.mli b/interp/syntax_def.mli
index a3f846bb..036fe30a 100644
--- a/interp/syntax_def.mli
+++ b/interp/syntax_def.mli
@@ -1,27 +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-2012     *)
 (*   \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
 
-val declare_syntactic_definition : bool -> identifier -> bool ->
-  syndef_interpretation -> unit
+val declare_syntactic_definition : bool -> identifier ->
+  Flags.compat_version option -> syndef_interpretation -> unit
 
 val search_syntactic_definition : kernel_name -> syndef_interpretation
+
+(** Options concerning verbose display of compatibility notations
+    or their deactivation *)
+
+val set_verbose_compat_notations : bool -> unit
+val set_compat_notations : bool -> unit
diff --git a/interp/topconstr.ml b/interp/topconstr.ml
index bcd07aea..b02a67ea 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: topconstr.ml 15072 2012-03-20 17:36:33Z 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 x 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
@@ -573,8 +564,11 @@ let match_opt f sigma t1 t2 = match (t1,t2) with
   | _ -> raise No_match
 
 let match_names metas (alp,sigma) na1 na2 = match (na1,na2) with
-  | (Name id1,Name id2) when List.mem id2 (fst metas) ->
-      alp, bind_env alp sigma id2 (RVar (dummy_loc,id1))
+  | (_,Name id2) when List.mem id2 (fst metas) ->
+      let rhs = match na1 with
+      | Name id1 -> GVar (dummy_loc,id1)
+      | Anonymous -> GHole (dummy_loc,Evd.InternalHole) in
+      alp, bind_env alp sigma id2 rhs
   | (Name id1,Name id2) -> (id1,id2)::alp,sigma
   | (Anonymous,Anonymous) -> alp,sigma
   | _ -> raise No_match
@@ -588,20 +582,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 +623,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 +846,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 +880,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
@@ -935,11 +957,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
@@ -956,10 +978,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
@@ -987,7 +1005,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)
@@ -1034,7 +1052,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) ->
@@ -1143,9 +1161,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
 	| [] ->
@@ -1192,7 +1210,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... *)
@@ -1239,14 +1257,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 abfbd9a1..c4c775b5 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: topconstr.mli 15072 2012-03-20 17:36:33Z 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..c0119aa2 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-2012     *)
+(*   \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..da34d81e 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-2012     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: cbytecodes.mli 15714 2012-08-08 18:54:37Z 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..fb749e31 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-2012     *)
+(*   \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..00f1f7fb 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-2012     *)
+(*   \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..d4f3efd5 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-2012     *)
 (*   \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..26adc226 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-2012     *)
 (*   \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..2879391b 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-2012     *)
 (*   \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..f875fabf 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-2012     *)
 (*   \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..ae717353 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-2012     *)
 (*   \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,28 @@ 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 const_hyps =
+    Sign.fold_named_context (fun (h,_,_) hyps ->
+      List.filter (fun (id,_,_) -> id <> h) hyps)
+      hyps ~init:cb.const_hyps in
   let typ = match cb.const_type with
     | NonPolymorphicType t ->
 	let typ = abstract_constant_type (expmod_constr r.d_modlist t) hyps in
@@ -129,8 +146,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, const_hyps)
diff --git a/kernel/cooking.mli b/kernel/cooking.mli
index df7e51f2..1586adae 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-2012     *)
 (*   \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
 
@@ -25,10 +23,10 @@ type recipe = {
 
 val cook_constant :
   env -> recipe ->
-    constr_substituted option * constant_type * constraints * bool * bool
-  * bool
+    constant_def * constant_type * constraints * Sign.section_context
+
 
-(*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..9c9f6a57 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-2012     *)
+(*   \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);*)
@@ -178,7 +190,9 @@ and eval_to_patch env (buff,pl,fv) =
 and val_of_constr env c =
   let (_,fun_code,_ as ccfv) =
     try compile env c
-    with e -> print_string "can not compile \n";Format.print_flush();raise e in
+    with reraise ->
+      print_string "can not compile \n";Format.print_flush();raise reraise
+  in
   eval_to_patch env (to_memory ccfv)
 
 let set_transparent_const kn =
diff --git a/kernel/csymtable.mli b/kernel/csymtable.mli
index 894a33ef..565c31ae 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-2012     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: csymtable.mli 15714 2012-08-08 18:54:37Z herbelin $ *)
+
 open Names
 open Term
 open Pre_env
diff --git a/kernel/declarations.ml b/kernel/declarations.ml
index c18e6bb0..5f677d05 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-2012     *)
 (*   \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..a298d56a 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-2012     *)
 (*   \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
@@ -185,6 +192,10 @@ type structure_field_body =
   | SFBmodule of module_body
   | SFBmodtype of module_type_body
 
+(** NB: we may encounter now (at most) twice the same label in
+    a [structure_body], once for a module ([SFBmodule] or [SFBmodtype])
+    and once for an object ([SFBconst] or [SFBmind]) *)
+
 and structure_body = (label * structure_field_body) list
 
 and struct_expr_body =
@@ -199,29 +210,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..f17918a6 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-2012     *)
 (*   \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..2460ec64 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-2012     *)
 (*   \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..39ada672 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-2012     *)
 (*   \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..7b1c1d41 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-2012     *)
 (*   \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..0bd7c515 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-2012     *)
 (*   \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..8cc3a1d0 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-2012     *)
 (*   \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..0dd2cd69 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-2012     *)
 (*   \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..4d71a81d 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-2012     *)
 (*   \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..53a1525b 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-2012     *)
 (*   \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..89ba7869 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-2012     *)
 (*   \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..9aeaf110 100644
--- a/kernel/mod_subst.ml
+++ b/kernel/mod_subst.ml
@@ -1,305 +1,252 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $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 l =
+    (string_of_kn kn ^ "=>" ^ string_of_hint hint) :: l
+  in
+  let mp_to_string mp mp' l =
+    (string_of_mp mp ^ "=>" ^ string_of_mp mp') :: l
+  in
+  let l = Deltamap.fold mp_to_string kn_to_string resolve [] in
+  String.concat ", " (List.rev l)
+
+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 e when Errors.noncritical e -> 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 e when Errors.noncritical e -> 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 ->
+    if kn1 == kn2 then None
+    else
+      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 +274,49 @@ 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 =
+  let o1 = subst_mp0 sub mp1 in
+  let o2 = if mp1 == mp2 then o1 else subst_mp0 sub mp2 in
+  match o1, o2 with
+    | None, None -> raise No_subst
+    | Some (mp',resolve), None -> User, (f mp' mp2), resolve
+    | None, Some (mp',resolve) -> Canonical, (f mp1 mp'), resolve
+    | Some (mp1',_), Some (mp2',resolve2) -> Canonical, (f mp1' mp2'), resolve2
 
-let subst_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 +326,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 +392,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 +416,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 +493,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..21b6bf93 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-2012     *)
 (*   \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..3a4c93ec 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-2012     *)
 (*   \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,17 +29,20 @@ let path_of_mexpr = function
   | MSEident mp -> mp
   | _ -> raise Not_path
 
-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 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_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 is_modular = function
+  | SFBmodule _ | SFBmodtype _ -> true
+  | SFBconst _ | SFBmind _ -> false
+
+let rec list_split_assoc ((k,m) as km) rev_before = function
+  | [] -> raise Not_found
+  | (k',b)::after when k=k' && is_modular b = m -> rev_before,b,after
+  | h::tail -> list_split_assoc km (h::rev_before) tail
 
 let discr_resolver env mtb =
      match mtb.typ_expr with
@@ -51,136 +58,130 @@ let rec rebuild_mp mp l =
 	
 let rec check_with env sign with_decl alg_sign mp equiv = 
   let sign,wd,equiv,cst= match with_decl with
-    | With_Definition (id,_) ->
-	let sign,cb,cst = check_with_aux_def env sign with_decl mp equiv in
-	  sign,With_definition_body(id,cb),equiv,cst
-    | With_Module (id,mp1) -> 
-	let sign,equiv,cst = 
-	  check_with_aux_mod env sign with_decl mp equiv in
-	  sign,With_module_body(id,mp1),equiv,cst in
+    | With_Definition (idl,c) ->
+	let sign,cb,cst = check_with_def env sign (idl,c) mp equiv in
+	sign,With_definition_body(idl,cb),equiv,cst
+    | With_Module (idl,mp1) ->
+	let sign,equiv,cst = check_with_mod env sign (idl,mp1) mp equiv in
+	sign,With_module_body(idl,mp1),equiv,cst
+  in
     if alg_sign = None then
       sign,None,equiv,cst
     else
       sign,Some (SEBwith(Option.get(alg_sign),wd)),equiv,cst
 	    
-and check_with_aux_def env sign with_decl mp equiv = 
+and check_with_def env sign (idl,c) mp equiv =
   let sig_b = match sign with 
     | SEBstruct(sig_b) -> sig_b
     | _ -> error_signature_expected sign
   in
-  let id,idl = match with_decl with
-    | With_Definition (id::idl,_) | With_Module (id::idl,_) -> id,idl
-    | With_Definition ([],_) | With_Module ([],_) -> assert false
+  let id,idl = match idl with
+    | [] -> assert false
+    | id::idl -> id,idl
   in
   let l = label_of_id id in
     try
-      let rev_before,spec,after = list_split_assoc l [] sig_b in
+      let rev_before,spec,after = list_split_assoc (l,(idl<>[])) [] sig_b in
       let before = List.rev rev_before in
       let env' = Modops.add_signature mp before equiv env in
-	match with_decl with
-          | With_Definition ([],_) -> assert false
-	  | With_Definition ([id],c) ->
+      if idl = [] then
+	      (* Toplevel definition *)
 	      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
-	  | With_Definition (_::_,c) ->
+	      (* In the spirit of subtyping.check_constant, we accept
+                 any implementations of parameters and opaques terms,
+	         as long as they have the right type *)
+	      let def,cst = match cb.const_body with
+		| Undef _ | OpaqueDef _ ->
+		    let (j,cst1) = Typeops.infer env' c in
+		    let typ = Typeops.type_of_constant_type env' cb.const_type in
+		    let cst2 = Reduction.conv_leq env' j.uj_type typ in
+		    let cst =
+		      union_constraints
+			(union_constraints cb.const_constraints cst1)
+			cst2
+		    in
+		    let def = Def (Declarations.from_val j.uj_val) in
+		    def,cst
+		| Def cs ->
+		    let cst1 = Reduction.conv env' c (Declarations.force cs) in
+		    let cst = union_constraints cb.const_constraints cst1 in
+		    let def = Def (Declarations.from_val c) in
+		    def,cst
+	      in
+	      let cb' =
+		{ cb with
+		  const_body = def;
+		  const_body_code =
+		    Cemitcodes.from_val (compile_constant_body env' def);
+		  const_constraints = cst }
+	      in
+	      SEBstruct(before@(l,SFBconst(cb'))::after),cb',cst
+      else
+	      (* Definition inside a sub-module *)
 	      let old = match spec with
-		  SFBmodule msb -> msb
+		| SFBmodule msb -> msb
 		| _ -> error_not_a_module (string_of_label l)
 	      in
 		begin
 		  match old.mod_expr with
                     | None ->
-			let new_with_decl = With_Definition (idl,c) in 
 			let sign,cb,cst = 
-			  check_with_aux_def env' old.mod_type new_with_decl 
+			  check_with_def env' old.mod_type (idl,c)
 			    (MPdot(mp,l)) old.mod_delta in
 			let new_spec = SFBmodule({old with
 						    mod_type = sign;
 						    mod_type_alg = None}) in
-			  SEBstruct(before@((l,new_spec)::after)),cb,cst
+			  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 = 
+and check_with_mod env sign (idl,mp1) mp equiv = 
   let sig_b = match sign with 
     | SEBstruct(sig_b) ->sig_b
     | _ -> error_signature_expected sign
   in
-  let id,idl = match with_decl with
-    | With_Definition (id::idl,_) | With_Module (id::idl,_) -> id,idl
-    | With_Definition ([],_) | With_Module ([],_) -> assert false
+  let id,idl = match idl with
+    | [] -> assert false
+    | id::idl -> id,idl
   in
   let l = label_of_id id in
     try
-      let rev_before,spec,after = list_split_assoc l [] sig_b in
+      let rev_before,spec,after = list_split_assoc (l,true) [] sig_b in
       let before = List.rev rev_before in
-      let rec mp_rec = function
-	| [] -> mp
-	| i::r -> MPdot(mp_rec r,label_of_id i)
-      in
       let env' = Modops.add_signature mp before equiv env in
-	match with_decl with
-          | With_Module ([],_) -> assert false
-	  | With_Module ([id], mp1) ->
+      if idl = [] then
+	      (* Toplevel module definition *)
 	      let old = match spec with
 		  SFBmodule msb -> msb
 		| _ -> error_not_a_module (string_of_label l)
 	      in
 	      let mb_mp1 = (lookup_module mp1 env) in
 	      let mtb_mp1 = 
-		module_type_of_module 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);
@@ -190,7 +191,8 @@ and check_with_aux_mod env sign with_decl mp equiv =
 	      let id_subst = map_mp (MPdot(mp,l)) (MPdot(mp,l)) new_mb.mod_delta in
 		SEBstruct(before@(l,new_spec)::subst_signature id_subst after),
 	      add_delta_resolver equiv new_mb.mod_delta,cst
-          | With_Module (idc,mp1) -> 
+      else
+	      (* Module definition of a sub-module *)
 	      let old = match spec with
 		  SFBmodule msb -> msb
 		| _ -> error_not_a_module (string_of_label l)
@@ -198,10 +200,9 @@ and check_with_aux_mod env sign with_decl mp equiv =
 	      begin
 		match old.mod_expr with
 		    None ->
-		      let new_with_decl = With_Module (idl,mp1) in
 		      let sign,equiv',cst =
-			check_with_aux_mod env'
-			  old.mod_type new_with_decl (MPdot(mp,l)) old.mod_delta in
+			check_with_mod env'
+			  old.mod_type (idl,mp1) (MPdot(mp,l)) old.mod_delta in
 		      let new_equiv = add_delta_resolver equiv equiv' in
 		      let new_spec = SFBmodule {old with 
 						  mod_type = sign;
@@ -215,14 +216,13 @@ 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 +243,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 +258,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 +268,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 rec translate_struct_include_module_entry env mp inl mse  = match mse with
+  let mp_from = mp_from_mexpr mte in
+  let sign,alg,resolve,cst = translate_struct_type_entry env inl mte in
+  let mtb = subst_modtype_and_resolver
+    {typ_mp = mp_from;
+     typ_expr = sign;
+     typ_expr_alg = None;
+     typ_constraints = cst;
+     typ_delta = resolve} mp
+  in {mtb with typ_expr_alg = alg}
+
+let rec translate_struct_include_module_entry env mp inl = function
   | MSEident mp1 ->
-      let mb = lookup_module mp1 env in 
-      let mb' = strengthen_and_subst_mb mb mp 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
@@ -397,7 +364,7 @@ let rec add_struct_expr_constraints env = function
 
   | SEBstruct (structure_body) ->
       List.fold_left
-        (fun env (l,item) -> add_struct_elem_constraints env item)
+        (fun env (_,item) -> add_struct_elem_constraints env item)
         env
         structure_body
 
@@ -442,17 +409,17 @@ let rec struct_expr_constraints cst = function
 
   | SEBstruct (structure_body) ->
       List.fold_left
-        (fun cst (l,item) -> struct_elem_constraints cst item)
+        (fun cst (_,item) -> struct_elem_constraints cst item)
         cst
         structure_body
 
   | 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 +435,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..0990e36c 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-2012     *)
 (*   \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..a81f868e 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-2012     *)
 (*   \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 of env * types * types
+  | 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..daea3258 100644
--- a/kernel/modops.mli
+++ b/kernel/modops.mli
@@ -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-2012     *)
 (*   \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
+open Term
 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 +33,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 of env * types * types
+  | 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..8c228404 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-2012     *)
 (*   \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,100 +183,104 @@ 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 =
+  if mp1 == mp2 then make_con mp1 dir l
+  else ((mp1,dir,l),(mp2,dir,l))
+let canonical_con con = snd con
+let user_con con = fst con
+let repr_con con = fst con
+
+let eq_constant (_,kn1) (_,kn2) = kn1=kn2
+
+let con_label con = label (fst con)
+let con_modpath con = modpath (fst con)
+
+let string_of_con con = string_of_kn (fst con)
+let pr_con con = str (string_of_con con)
+let debug_string_of_con con =
+  "(" ^ string_of_kn (fst con) ^ "," ^ string_of_kn (snd con) ^ ")"
+let debug_pr_con con = str (debug_string_of_con con)
+
+let con_with_label ((mp1,dp1,l1),(mp2,dp2,l2) as con) lbl =
+  if lbl = l1 && lbl = l2 then con
+  else ((mp1,dp1,lbl),(mp2,dp2,lbl))
+
+(** For the environment we distinguish constants by their user part*)
 module User_ord = struct
   type t = kernel_name*kernel_name
   let compare x y= kn_ord (fst x) (fst y)
 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))
-let make_mind_equiv mp1 mp2 dir l = ((mp1,dir,l),(mp2,dir,l))
+let make_mind mp dir l = mind_of_kn (mp,dir,l)
+let make_mind_equiv mp1 mp2 dir l =
+  if mp1 == mp2 then make_mind mp1 dir l
+  else ((mp1,dir,l),(mp2,dir,l))
 let canonical_mind mind = snd mind
 let user_mind mind = fst mind
 let repr_mind mind = fst mind
-let 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 +289,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 +332,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 +353,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 +364,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 +382,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..24b16f28 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-2012     *)
 (*   \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..f0a3292c 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-2012     *)
 (*   \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
@@ -85,7 +90,7 @@ let push_rel d env =
 
 let lookup_rel_val n env =
   try List.nth env.env_rel_val (n - 1)
-  with _ -> raise Not_found
+  with e when Errors.noncritical e -> raise Not_found
 
 let env_of_rel n env =
   { env with
diff --git a/kernel/pre_env.mli b/kernel/pre_env.mli
index 70776551..7d32b8fa 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-2012     *)
 (*   \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..6c52e151 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-2012     *)
 (*   \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..acc97380 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-2012     *)
 (*   \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..6f52edcd 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-2012     *)
 (*   \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..88bdf706 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-2012     *)
 (*   \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..ec891e13 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-2012     *)
 (*   \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
@@ -71,7 +101,8 @@ type safe_environment =
     { old : safe_environment;
       env : env;
       modinfo : module_info;
-      labset : Labset.t;
+      modlabels : Labset.t;
+      objlabels : Labset.t;
       revstruct : structure_body;
       univ : Univ.constraints;
       engagement : engagement option;
@@ -79,16 +110,29 @@ 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_modlabel l senv = Labset.mem l senv.modlabels
+let exists_objlabel l senv = Labset.mem l senv.objlabels
+
+let check_modlabel l senv =
+  if exists_modlabel l senv then error_existing_label l
+let check_objlabel l senv =
+  if exists_objlabel l senv then error_existing_label l
 
+let check_objlabels ls senv =
+  Labset.iter (fun l -> check_objlabel 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 =
@@ -100,9 +144,10 @@ let rec empty_environment =
       variant = NONE;
       resolver = empty_delta_resolver;
       resolver_of_param = empty_delta_resolver};
-    labset = Labset.empty;
+    modlabels = Labset.empty;
+    objlabels = Labset.empty;
     revstruct = [];
-    univ = Univ.Constraint.empty;
+    univ = Univ.empty_constraint;
     engagement = None;
     imports = [];
     loads = [];
@@ -111,16 +156,55 @@ 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 mlabs,olabs = match sfb with
+    | SFBmind mib ->
+      let l = labels_of_mib mib in
+      check_objlabels l senv; (Labset.empty,l)
+    | SFBconst _ ->
+      check_objlabel l senv; (Labset.empty, Labset.singleton l)
+    | SFBmodule _ | SFBmodtype _ ->
+      check_modlabel l senv; (Labset.singleton l, Labset.empty)
+  in
+  let senv = add_constraints (constraints_of_sfb sfb) senv in
+  let env' = match sfb, gn with
+    | SFBconst cb, C con -> Environ.add_constant con cb senv.env
+    | SFBmind mib, I mind -> Environ.add_mind mind mib senv.env
+    | SFBmodtype mtb, MT mp -> Environ.add_modtype mp mtb senv.env
+    | SFBmodule mb, M -> Modops.add_module mb senv.env
+    | _ -> assert false
+  in
+  { senv with
+    env = env';
+    modlabels = Labset.union mlabs senv.modlabels;
+    objlabels = Labset.union olabs senv.objlabels;
+    revstruct = field :: senv.revstruct }
+
+(* 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 +215,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 +270,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 +296,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_modlabel l senv;
  let mp = MPdot(senv.modinfo.modpath, l) in
  let modinfo = { modpath = mp;
 		 label = l;
@@ -325,9 +341,10 @@ let start_module l senv =
    mp, { old = senv;
 	 env = senv.env;
 	 modinfo = modinfo;
-	 labset = Labset.empty;
+	 modlabels = Labset.empty;
+	 objlabels = Labset.empty;
 	 revstruct = [];
-         univ = Univ.Constraint.empty;
+         univ = Univ.empty_constraint;
          engagement = None;
 	 imports = senv.imports;
 	 loads = [];
@@ -347,7 +364,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 +378,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 +394,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;
@@ -409,14 +426,15 @@ let end_module l restype senv =
     mp,resolver,{ old = oldsenv.old;
 		  env = newenv;
 		  modinfo = modinfo;
-		  labset = Labset.add l oldsenv.labset;
+		  modlabels = Labset.add l oldsenv.modlabels;
+		  objlabels = oldsenv.objlabels;
 		  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 +442,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 +455,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.")
+     | _ -> error ("You cannot Include a higher-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 *)
 
@@ -564,7 +522,8 @@ let add_module_parameter mbid mte inl senv =
 				   variant = new_variant;
 				   resolver_of_param = add_delta_resolver
 			      resolver_of_param senv.modinfo.resolver_of_param};
-		     labset = senv.labset;
+		     modlabels = senv.modlabels;
+		     objlabels = senv.objlabels;
 		     revstruct = [];
 		     univ = senv.univ;
 		     engagement = senv.engagement;
@@ -576,7 +535,7 @@ let add_module_parameter mbid mte inl senv =
 (* Interactive module types *)
 
 let start_modtype l senv =
-  check_label l senv.labset;
+  check_modlabel l senv;
  let mp = MPdot(senv.modinfo.modpath, l) in
  let modinfo = { modpath = mp;
 		 label = l;
@@ -587,9 +546,10 @@ let start_modtype l senv =
   mp, { old = senv;
 	env = senv.env;
 	modinfo = modinfo;
-	labset = Labset.empty;
+	modlabels = Labset.empty;
+	objlabels = Labset.empty;
 	revstruct = [];
-        univ = Univ.Constraint.empty;
+        univ = Univ.empty_constraint;
         engagement = None;
 	imports = senv.imports;
 	loads = [] ;
@@ -605,7 +565,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
@@ -638,9 +598,10 @@ let end_modtype l senv =
     mp, { old = oldsenv.old;
 	  env = newenv;
 	  modinfo = oldsenv.modinfo;
-	  labset = Labset.add l oldsenv.labset;
+	  modlabels = Labset.add l oldsenv.modlabels;
+	  objlabels = oldsenv.objlabels;
 	  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;
@@ -697,9 +658,10 @@ let start_library dir senv =
   mp, { old = senv;
 	env = senv.env;
 	modinfo = modinfo;
-	labset = Labset.empty;
+	modlabels = Labset.empty;
+	objlabels = Labset.empty;
 	revstruct = [];
-        univ = Univ.Constraint.empty;
+        univ = Univ.empty_constraint;
         engagement = None;
 	imports = senv.imports;
 	loads = [];
@@ -710,7 +672,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 +748,147 @@ 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 e when Errors.noncritical e ->
+              error "Error while retrieving an opaque body"
+	  in
+	  match load_proof with
+	    | Flags.Force ->
+	      let lc = Lazy.lazy_from_val (access k) in
+	      OpaqueDef (make_lazy_constr lc)
+	    | Flags.Lazy ->
+	      let lc = lazy (access k) in
+	      OpaqueDef (make_lazy_constr lc)
+	    | Flags.Dont ->
+	      Undef None
+    in
+    traverse_library decode_key lightened_library
+
+end
 
 type judgment = unsafe_judgment
 
diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli
index 33a6a775..34dc68d2 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-2012     *)
 (*   \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_objlabel : label -> safe_environment -> bool
 
 (*spiwack: safe retroknowledge functionalities *)
 
diff --git a/kernel/sign.ml b/kernel/sign.ml
index d241f677..a654bc04 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-2012     *)
 (*   \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..4325fe90 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-2012     *)
 (*   \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..c809572a 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-2012     *)
 (*   \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 *)
@@ -31,15 +32,18 @@ type namedobject =
   | Constant of constant_body
   | IndType of inductive * mutual_inductive_body
   | IndConstr of constructor * mutual_inductive_body
+
+type namedmodule =
   | Module of module_body
   | Modtype of module_type_body
 
 (* adds above information about one mutual inductive: all types and
    constructors *)
 
-let add_nameobjects_of_mib ln mib map =
-  let add_nameobjects_of_one j oib map =
-    let ip = (ln,j) in
+let add_mib_nameobjects mp l mib map =
+  let ind = make_mind mp empty_dirpath l in
+  let add_mip_nameobjects j oib map =
+    let ip = (ind,j) in
     let map =
       array_fold_right_i
       (fun i id map ->
@@ -49,43 +53,54 @@ let add_nameobjects_of_mib ln mib map =
     in
       Labmap.add (label_of_id oib.mind_typename) (IndType (ip, mib)) map
   in
-    array_fold_right_i add_nameobjects_of_one mib.mind_packets map
+  array_fold_right_i add_mip_nameobjects mib.mind_packets map
+
+
+(* creates (namedobject/namedmodule) map for the whole signature *)
+
+type labmap = { objs : namedobject Labmap.t; mods : namedmodule Labmap.t }
 
+let empty_labmap = { objs = Labmap.empty; mods = Labmap.empty }
 
-(* creates namedobject map for the whole signature *)
+let get_obj mp map l =
+  try Labmap.find l map.objs
+  with Not_found -> error_no_such_label_sub l (string_of_mp mp)
 
-let make_label_map mp list =
+let get_mod mp map l =
+  try Labmap.find l map.mods
+  with Not_found -> error_no_such_label_sub l (string_of_mp mp)
+
+let make_labmap mp list =
   let add_one (l,e) map =
-   let add_map obj = Labmap.add l obj map in
    match e with
-    | SFBconst cb -> add_map (Constant cb)
-    | SFBmind mib ->
-       add_nameobjects_of_mib (make_mind mp empty_dirpath l) mib map
-    | SFBmodule mb -> add_map (Module mb)
-    | SFBmodtype mtb -> add_map (Modtype mtb)
+    | SFBconst cb -> { map with objs = Labmap.add l (Constant cb) map.objs }
+    | SFBmind mib -> { map with objs = add_mib_nameobjects mp l mib map.objs }
+    | SFBmodule mb -> { map with mods = Labmap.add l (Module mb) map.mods }
+    | SFBmodtype mtb -> { map with mods = Labmap.add l (Modtype mtb) map.mods }
   in
-    List.fold_right add_one list Labmap.empty
+  List.fold_right add_one list empty_labmap
+
 
-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 +129,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 +175,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 +197,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,10 +215,12 @@ 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 =
 
+    let err = NotConvertibleTypeField (env, t1, t2) in
+
     (* If the type of a constant is generated, it may mention
        non-variable algebraic universes that the general conversion
        algorithm is not ready to handle. Anyway, generated types of
@@ -233,66 +257,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 err end
+        | _ ->
+	  t1,t2
       else
         (t1,t2) in
-    check_conv cst conv_leq env t1 t2
+    check_conv err 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 +300,11 @@ 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
+      let error = NotConvertibleTypeField (env, arity1, typ2) in
+       check_conv error 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,46 +312,37 @@ 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 ()
+      let error = NotConvertibleTypeField (env, ty1, ty2) in
+       check_conv error cst conv env ty1 ty2
 
 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
 
 and check_signatures cst env mp1 sig1 mp2 sig2 subst1 subst2 reso1 reso2= 
-  let map1 = make_label_map mp1 sig1 in
+  let map1 = make_labmap mp1 sig1 in
   let check_one_body cst (l,spec2) =
-    let info1 =
-      try
-	Labmap.find l map1
-      with
-	  Not_found -> error_no_such_label_sub l
-	    (string_of_mp mp1)
-    in
-      match spec2 with
+    match spec2 with
 	| SFBconst cb2 ->
-	    check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2
+	    check_constant cst env mp1 l (get_obj mp1 map1 l)
+	      cb2 spec2 subst1 subst2
 	| SFBmind mib2 ->
-	    check_inductive cst env
-	      mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2
+	    check_inductive cst env mp1 l (get_obj mp1 map1 l)
+	      mp2 mib2 spec2 subst1 subst2 reso1 reso2
 	| SFBmodule msb2 ->
-	    begin
-	      match info1 with
-		| Module msb -> check_modules cst env msb msb2 
-		    subst1 subst2
-		| _ -> error_not_match l spec2
+	    begin match get_mod mp1 map1 l with
+	      | Module msb -> check_modules cst env msb msb2 subst1 subst2
+	      | _ -> error_signature_mismatch l spec2 ModuleFieldExpected
 	    end
 	| SFBmodtype mtb2 ->
-	    let mtb1 =
-	      match info1 with
-		| Modtype mtb -> mtb
-		| _ -> error_not_match l spec2
+	    let mtb1 = match get_mod mp1 map1 l with
+	      | Modtype mtb -> mtb
+	      | _ -> error_signature_mismatch l spec2 ModuleTypeFieldExpected
 	    in
 	    let env = add_module (module_body_of_type mtb2.typ_mp mtb2)
 	      (add_module (module_body_of_type mtb1.typ_mp mtb1) env) in
@@ -368,7 +360,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 +404,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..d3a48a8a 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-2012     *)
 (*   \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..2b4547d0 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-2012     *)
 (*   \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                            *)
@@ -299,6 +264,7 @@ let destMeta c = match kind_of_term c with
   | _ -> invalid_arg "destMeta"
 
 let isMeta c = match kind_of_term c with Meta _ -> true | _ -> false
+let isMetaOf mv c = match kind_of_term c with Meta mv' -> mv = mv' | _ -> false
 
 (* Destructs a variable *)
 let destVar c = match kind_of_term c with
@@ -334,18 +300,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
 
@@ -363,9 +323,11 @@ let isCast c = match kind_of_term c with Cast _ -> true | _ -> false
 
 (* Tests if a de Bruijn index *)
 let isRel c = match kind_of_term c with Rel _ -> true | _ -> false
+let isRelN n c = match kind_of_term c with Rel n' -> n = n' | _ -> false
 
 (* 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 +349,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 +374,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 +443,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 +567,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 +584,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 +657,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 +772,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 +824,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 +868,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 +887,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 +901,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 +1152,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 +1379,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 69828715..15fcdd18 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: term.mli 15029 2012-03-13 14:47:00Z 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,13 +226,16 @@ 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 isRelN : int -> constr -> bool
 val isVar  : constr -> bool
+val isVarId : identifier -> constr -> bool
 val isInd  : constr -> bool
 val isEvar : constr -> bool
 val isMeta : constr -> bool
+val isMetaOf : metavariable -> constr -> bool
 val isEvar_or_Meta : constr -> bool
 val isSort : constr -> bool
 val isCast : constr -> bool
@@ -247,77 +256,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 +347,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,184 +375,185 @@ 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. *)
 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
@@ -538,29 +570,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
@@ -569,13 +602,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
@@ -584,27 +617,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..ee5e8fda 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-2012     *)
 (*   \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,10 @@ 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,hyps = Cooking.cook_constant env r in
+     def,typ,cst,Some hyps)
 
 (* 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..c2f046a2 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-2012     *)
 (*   \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..890f0976 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-2012     *)
 (*   \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..1967018f 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-2012     *)
 (*   \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..affd4dc4 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-2012     *)
 (*   \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..51f36d6d 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-2012     *)
 (*   \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 869a60e2..028eaeb4 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: univ.ml 15019 2012-03-02 17:27:18Z letouzey $ *)
-
-(* 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,19 @@ 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;
+      rank: int }
 
-let terminal u = {univ=u; lt=[]; le=[]}
+let terminal u = {univ=u; lt=[]; le=[]; rank=0}
 
-(* 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 +148,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 +157,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 +196,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 +225,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 +250,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).
@@ -283,17 +312,13 @@ let compare_neq strict g arcu arcv =
   in
   cmp NLE [] [] ([],[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 true g arcu arcv
 
-let is_leq g u v =
-  let arcu = repr g u
-  and arcv = repr g v in
+let is_leq g arcu arcv =
   arcu == arcv || (compare_neq false g arcu arcv = LE)
 
-let is_lt g u v = (compare g u v = LT)
+let is_lt g arcu arcv = (compare g arcu arcv = LT)
 
 (* Invariants : compare(u,v) = EQ <=> compare(v,u) = EQ
                 compare(u,v) = LT or LE => compare(v,u) = NLE
@@ -304,11 +329,12 @@ let is_lt g u v = (compare g u v = LT)
    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
 
@@ -328,12 +354,12 @@ 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
+  let g, arcu = safe_repr g u in
+  let g, arcv = safe_repr g v in
   if strict then
-    is_lt g v u
+    is_lt g arcv arcu
   else
-    compare_eq g v Set || is_leq g v u
+    arcv == snd (safe_repr g UniverseLevel.Set) || is_leq g arcv arcu
 
 (*
 let compare_greater g strict u v =
@@ -341,125 +367,152 @@ 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 = if is_lt g u v then g else setlt g u v
+let setlt_if (g,arcu) v =
+  let arcv = repr g v in
+  if is_lt g arcu arcv then g, arcu
+  else setlt g arcu arcv
 
-(* setleq : 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 = if is_leq g u v then g else setleq g u v
+let setleq_if (g,arcu) v =
+  let arcv = repr g v in
+  if is_leq g arcu arcv then g, arcu
+  else setleq g arcu arcv
 
-(* merge : 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
-    | arcu::v -> (* arcu is chosen as canonical and all others (v) are *)
-                 (* redirected to it *)
-	let redirect (g,w,w') arcv =
- 	  let g' = enter_equiv_arc arcv.univ arcu.univ g in
- 	  (g',list_unionq arcv.lt w,arcv.le@w')
-	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'''
-    | [] -> anomaly "Univ.between"
-
-(* merge_disc : universe_level -> universe_level -> unit *)
+let merge g arcu arcv =
+  (* we find the arc with the biggest rank, and we redirect all others to it *)
+  let arcu, g, v =
+    let best_ranked (max_rank, old_max_rank, best_arc, rest) arc =
+      if arc.rank >= max_rank
+      then (arc.rank, max_rank, arc, best_arc::rest)
+      else (max_rank, old_max_rank, best_arc, arc::rest)
+    in
+    match between g arcu arcv with
+      | [] -> anomaly "Univ.between"
+      | arc::rest ->
+        let (max_rank, old_max_rank, best_arc, rest) =
+          List.fold_left best_ranked (arc.rank, min_int, arc, []) rest in
+        if max_rank > old_max_rank then best_arc, g, rest
+        else begin
+          (* one redirected node also has max_rank *)
+          let arcu = {best_arc with rank = max_rank + 1} in
+          arcu, enter_arc arcu g, rest
+        end
+  in
+  let redirect (g,w,w') arcv =
+    let g' = enter_equiv_arc arcv.univ arcu.univ g in
+    (g',list_unionq arcv.lt w,arcv.le@w')
+  in
+  let (g',w,w') = List.fold_left redirect (g,[],[]) v in
+  let g_arcu = (g',arcu) in
+  let g_arcu = List.fold_left setlt_if g_arcu w in
+  let g_arcu = List.fold_left setleq_if g_arcu w' in
+  fst g_arcu
+
+(* merge_disc : 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 arc1 arc2 =
+  let arcu, arcv = if arc1.rank < arc2.rank then arc2, arc1 else arc1, arc2 in
+  let arcu, g = 
+    if arc1.rank <> arc2.rank then arcu, g
+    else
+      let arcu = {arcu with rank = succ arcu.rank} in 
+      arcu, enter_arc arcu g
+  in
   let g' = enter_equiv_arc arcv.univ arcu.univ g in
-  let g'' = 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
-  if is_leq g u v then g
-  else match compare g v u with
+  let g,arcu = safe_repr g u in
+  let g,arcv = safe_repr g v in
+  if is_leq g arcu arcv then g
+  else match compare g arcv arcu with
     | LT -> error_inconsistency Le u v
-    | LE -> merge g v u
-    | NLE -> setleq g u v
+    | LE -> merge g arcv arcu
+    | NLE -> fst (setleq g arcu arcv)
     | EQ -> anomaly "Univ.compare"
 
-(* 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 ->
-      if is_leq g v u then error_inconsistency Lt u v
-      else setlt g u v
+      if is_leq g arcv arcu then error_inconsistency Lt u v
+      else fst (setlt g arcu arcv)
 
 (* 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
@@ -467,18 +520,23 @@ module Constraint = Set.Make(
       let i = Pervasives.compare c c' in
       if i <> 0 then i
       else
-	let i' = cmp_univ_level u u' in
+	let i' = UniverseLevel.compare u u' in
 	if i' <> 0 then i'
-	else cmp_univ_level v v'
+	else UniverseLevel.compare v v'
   end)
 
 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
@@ -496,13 +554,210 @@ 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; rank=rank} ->
+      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;
+	rank = rank
+      }
+  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;
+      rank = 0
+    } 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; rank=r} ->
+        assert (u == v);
+        if filter u then
+          let lt = List.filter filter lt in
+          let le = List.filter filter le in
+          UniverseLMap.add u (Canonical {univ=u; lt=lt; le=le; rank=r}) res
+        else
+          let res = List.fold_left (fun g u -> if filter u then push g u else g) res lt in
+          let res = List.fold_left (fun g u -> if filter u then push g u else g) res le in
+          res) g UniverseLMap.empty
+    in
+    if continue then make_level accu g (i+1) else i, accu
+  in
+  let max, levels = make_level UniverseLMap.empty orig 0 in
+  (* defensively check that the result makes sense *)
+  check_sorted orig levels;
+  let types = Array.init (max+1) (fun x -> UniverseLevel.Level (mp, x)) in
+  let g = UniverseLMap.map (fun x -> Equiv types.(x)) levels in
+  let g =
+    let rec aux i g =
+      if i < max then
+        let u = types.(i) in
+        let g = UniverseLMap.add u (Canonical {
+          univ = u;
+          le = [];
+          lt = [types.(i+1)];
+	  rank = 1
+        }) g in aux (i+1) g
+      else g
+    in aux 0 g
+  in g
+
 (**********************************************************************)
 (* 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 ())
 
@@ -584,16 +839,6 @@ let univ_depends u v =
 
 (* 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 ()
@@ -615,7 +860,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 "")
@@ -625,37 +870,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
@@ -666,7 +914,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 89b20de3..22723713 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: univ.mli 15019 2012-03-02 17:27:18Z letouzey $ 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
 
@@ -82,14 +95,21 @@ val no_upper_constraints : universe -> constraints -> bool
 
 val univ_depends : universe -> universe -> 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..4168e501 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-2012     *)
 (*   \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..ebf1e8fd 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-2012     *)
 (*   \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..9185ba64 100644
--- a/lib/bigint.ml
+++ b/lib/bigint.ml
@@ -1,41 +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-2012     *)
 (*   \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*)
-
 (***************************************************)
 (* Basic operations on (unbounded) integer numbers *)
 (***************************************************)
 
-(* An integer is canonically represented as an array of k-digits blocs.
+(* An integer is canonically represented as an array of k-digits blocs,
+   i.e. in base 10^k.
 
    0 is represented by the empty array and -1 by the singleton [|-1|].
-   The first bloc is in the range ]0;10^k[ for positive numbers.
-   The first bloc is in the range ]-10^k;-1[ for negative ones.
-   All other blocs are numbers in the range [0;10^k[.
+   The first bloc is in the range ]0;base[ for positive numbers.
+   The first bloc is in the range [-base;-1[ for numbers < -1.
+   All other blocs are numbers in the range [0;base[.
 
-   Negative numbers are represented using 2's complementation. For instance,
-   with 4-digits blocs, [-9655;6789] denotes -96543211
-*)
+   Negative numbers are represented using 2's complementation :
+   one unit is "borrowed" from the top block for complementing
+   the other blocs. For instance, with 4-digits blocs,
+   [|-5;6789|] denotes -43211
+   since -5.10^4+6789=-((4.10^4)+(10000-6789)) = -43211
 
-(* The base is a power of 10 in order to facilitate the parsing and printing
+   The base is a power of 10 in order to facilitate the parsing and printing
    of numbers in digital notation.
 
    All functions, to the exception of to_string and of_string should work
    with an arbitrary base, even if not a power of 10.
 
-   In practice, we set k=4 so that no overflow in ocaml machine words
-   (i.e. the interval [-2^30;2^30-1]) occur when multiplying two
-   numbers less than (10^k)
+   In practice, we set k=4 on 32-bits machines, so that no overflow in ocaml
+   machine words (i.e. the interval [-2^30;2^30-1]) occur when multiplying two
+   numbers less than (10^k). On 64-bits machines, k=9.
 *)
 
 (* The main parameters *)
@@ -47,6 +44,7 @@ let size =
 let format_size =
   (* How to parametrize a printf format *)
   if size = 4 then Printf.sprintf "%04d"
+  else if size = 9 then Printf.sprintf "%09d"
   else fun n ->
     let rec aux j l n =
       if j=size then l else aux (j+1) (string_of_int (n mod 10) :: l) (n/10)
@@ -56,44 +54,81 @@ let format_size =
 let base =
   let rec exp10 = function 0 -> 1 | n -> 10 * exp10 (n-1) in exp10 size
 
+(******************************************************************)
+(* First, we represent all numbers by int arrays.
+   Later, we will optimize the particular case of small integers  *)
+(******************************************************************)
+
+module ArrayInt = struct
+
 (* Basic numbers *)
 let zero = [||]
 let neg_one = [|-1|]
 
-(* Sign of an integer *)
-let is_strictly_neg n = n<>[||] && n.(0) < 0
-let is_strictly_pos n = n<>[||] && n.(0) > 0
-let is_neg_or_zero n = n=[||] or n.(0) < 0
-let is_pos_or_zero n = n=[||] or n.(0) > 0
+(* An array is canonical when
+   - it is empty
+   - it is [|-1|]
+   - its first bloc is in [-base;-1[U]0;base[
+     and the other blocs are in [0;base[. *)
+
+let canonical n =
+  let ok x = (0 <= x && x < base) in
+  let rec ok_tail k = (k = 0) || (ok n.(k) && ok_tail (k-1)) in
+  let ok_init x = (-base <= x && x < base && x <> -1 && x <> 0)
+  in
+  (n = [||]) || (n = [|-1|]) ||
+    (ok_init n.(0) && ok_tail (Array.length n - 1))
+
+(* [normalize_pos] : removing initial blocks of 0 *)
 
 let normalize_pos n =
   let k = ref 0 in
   while !k < Array.length n & n.(!k) = 0 do incr k done;
   Array.sub n !k (Array.length n - !k)
 
+(* [normalize_neg] : avoid (-1) as first bloc.
+   input: an array with -1 as first bloc and other blocs in [0;base[
+   output: a canonical array *)
+
 let normalize_neg n =
   let k = ref 1 in
   while !k < Array.length n & n.(!k) = base - 1 do incr k done;
   let n' = Array.sub n !k (Array.length n - !k) in
   if Array.length n' = 0 then [|-1|] else (n'.(0) <- n'.(0) - base; n')
 
+(* [normalize] : avoid 0 and (-1) as first bloc.
+   input: an array with first bloc in [-base;base[ and others in [0;base[
+   output: a canonical array *)
+
 let rec normalize n =
-  if Array.length n = 0 then n else
-    if n.(0) = -1 then normalize_neg n else normalize_pos n
+  if Array.length n = 0 then n
+  else if n.(0) = -1 then normalize_neg n
+  else if n.(0) = 0 then normalize_pos n
+  else n
+
+(* Opposite (expects and returns canonical arrays) *)
 
 let neg m =
   if m = zero then zero else
   let n = Array.copy m in
   let i = ref (Array.length m - 1) in
   while !i > 0 & n.(!i) = 0 do decr i done;
-  if !i > 0 then begin
+  if !i = 0 then begin
+    n.(0) <- - n.(0);
+    (* n.(0) cannot be 0 since m is canonical *)
+    if n.(0) = -1 then normalize_neg n
+    else if n.(0) = base then (n.(0) <- 0; Array.append [| 1 |] n)
+    else n
+  end else begin
+    (* here n.(!i) <> 0, hence 0 < base - n.(!i) < base for n canonical *)
     n.(!i) <- base - n.(!i); decr i;
     while !i > 0 do n.(!i) <- base - 1 - n.(!i); decr i done;
+    (* since -base <= n.(0) <= base-1, hence -base <= -n.(0)-1 <= base-1 *)
     n.(0) <- - n.(0) - 1;
-    if n.(0) < -1 then (n.(0) <- n.(0) + base; Array.append [| -1 |] n) else
-    if n.(0) = - base then (n.(0) <- 0; Array.append [| -1 |] n)
-    else normalize n
-  end else (n.(0) <- - n.(0); n)
+    (* since m is canonical, m.(0)<>0 hence n.(0)<>-1,
+       and m=-1 is already handled above, so here m.(0)<>-1 hence n.(0)<>0 *)
+    n
+  end
 
 let push_carry r j =
   let j = ref j in
@@ -103,10 +138,10 @@ let push_carry r j =
   while !j > 0 & r.(!j) >= base do
     r.(!j) <- r.(!j) - base; decr j; r.(!j) <- r.(!j) + 1
   done;
+  (* here r.(0) could be in [-2*base;2*base-1] *)
   if r.(0) >= base then (r.(0) <- r.(0) - base; Array.append [| 1 |] r)
   else if r.(0) < -base then (r.(0) <- r.(0) + 2*base; Array.append [| -2 |] r)
-  else if r.(0) = -base then (r.(0) <- 0; Array.append [| -1 |] r)
-  else normalize r
+  else normalize r (* in case r.(0) is 0 or -1 *)
 
 let add_to r a j =
   if a = zero then r else begin
@@ -154,6 +189,13 @@ let rec mult m n =
   done;
   normalize r
 
+(* Comparisons *)
+
+let is_strictly_neg n = n<>[||] && n.(0) < 0
+let is_strictly_pos n = n<>[||] && n.(0) > 0
+let is_neg_or_zero n = n=[||] or n.(0) < 0
+let is_pos_or_zero n = n=[||] or n.(0) > 0
+
 let rec less_than_same_size m n i j =
   i < Array.length m &&
   (m.(i) < n.(j) or (m.(i) = n.(j) && less_than_same_size m n (i+1) (j+1)))
@@ -166,6 +208,8 @@ let less_than m n =
     is_strictly_pos n && (Array.length m < Array.length n or
     (Array.length m = Array.length n && less_than_same_size m n 0 0))
 
+(* For this equality test it is critical that n and m are canonical *)
+
 let equal m n = (m = n)
 
 let less_than_shift_pos k m n =
@@ -177,16 +221,30 @@ let rec can_divide k m d i =
   (m.(k+i) > d.(i)) or
   (m.(k+i) = d.(i) && can_divide k m d (i+1))
 
-(* computes m - d * q * base^(|m|-k) in-place on positive numbers *)
+(* For two big nums m and d and a small number q,
+   computes m - d * q * base^(|m|-|d|-k) in-place (in m).
+   Both m d and q are positive. *)
+
 let sub_mult m d q k =
   if q <> 0 then
   for i = Array.length d - 1 downto 0 do
     let v = d.(i) * q in
     m.(k+i) <- m.(k+i) - v mod base;
     if m.(k+i) < 0 then (m.(k+i) <- m.(k+i) + base; m.(k+i-1) <- m.(k+i-1) -1);
-    if v >= base then m.(k+i-1) <- m.(k+i-1) - v / base;
+    if v >= base then begin
+      m.(k+i-1) <- m.(k+i-1) - v / base;
+      let j = ref (i-1) in
+      while m.(k + !j) < 0 do (* result is positive, hence !j remains >= 0 *)
+        m.(k + !j) <- m.(k + !j) + base; decr j; m.(k + !j) <- m.(k + !j) -1
+      done
+    end
   done
 
+(** Euclid division m/d = (q,r)
+    This is the "Floor" variant, as with ocaml's /
+    (but not as ocaml's Big_int.quomod_big_int).
+    We have sign r = sign m *)
+
 let euclid m d =
   let isnegm, m =
     if is_strictly_neg m then (-1),neg m else 1,Array.copy m in
@@ -224,33 +282,21 @@ let euclid m d =
 (* Parsing/printing ordinary 10-based numbers *)
 
 let of_string s =
-  let isneg = String.length s > 1 & s.[0] = '-' in
-  let n = if isneg then 1 else 0 in
-  let d = ref n in
-  while !d < String.length s && s.[!d] = '0' do incr d done;
-  if !d = String.length s then zero else
-  let r = (String.length s - !d) mod size in
+  let len = String.length s in
+  let isneg = len > 1 & s.[0] = '-' in
+  let d = ref (if isneg then 1 else 0) in
+  while !d < len && s.[!d] = '0' do incr d done;
+  if !d = len then zero else
+  let r = (len - !d) mod size in
   let h = String.sub s (!d) r in
-  if !d = String.length s - 1 && isneg && h="1" then neg_one else
   let e = if h<>"" then 1 else 0 in
-  let l = (String.length s - !d) / size in
-  let a = Array.create (l + e + n) 0 in
-  if isneg then begin
-    a.(0) <- (-1);
-    let carry = ref 0 in
-    for i=l downto 1 do
-      let v = int_of_string (String.sub s ((i-1)*size + !d +r) size)+ !carry in
-      if v <> 0 then (a.(i+e)<- base - v; carry := 1) else carry := 0
-    done;
-    if e=1 then a.(1) <- base - !carry - int_of_string h;
-  end
-  else begin
-    if e=1 then a.(0) <- int_of_string h;
-    for i=1 to l do
-      a.(i+e-1) <- int_of_string (String.sub s ((i-1)*size + !d + r) size)
-    done
-  end;
-  a
+  let l = (len - !d) / size in
+  let a = Array.create (l + e) 0 in
+  if e=1 then a.(0) <- int_of_string h;
+  for i=1 to l do
+    a.(i+e-1) <- int_of_string (String.sub s ((i-1)*size + !d + r) size)
+  done;
+  if isneg then neg a else a
 
 let to_string_pos sgn n =
    if Array.length n = 0 then "0" else
@@ -262,25 +308,44 @@ let to_string n =
   if is_strictly_neg n then to_string_pos "-" (neg n)
   else to_string_pos "" n
 
+end
+
 (******************************************************************)
 (* Optimized operations on (unbounded) integer numbers            *)
 (* integers smaller than base are represented as machine integers *)
 (******************************************************************)
 
+open ArrayInt
+
 type bigint = Obj.t
 
+(* Since base is the largest power of 10 such that base*base <= max_int,
+   we have max_int < 100*base*base : any int can be represented
+   by at most three blocs *)
+
+let small n = (-base <= n) && (n < base)
+
+let mkarray n =
+  (* n isn't small, this case is handled separately below *)
+  let lo = n mod base
+  and hi = n / base in
+  let t = if small hi then [|hi;lo|] else [|hi/base;hi mod base;lo|]
+  in
+  for i = Array.length t -1 downto 1 do
+    if t.(i) < 0 then (t.(i) <- t.(i) + base; t.(i-1) <- t.(i-1) -1)
+  done;
+  t
+
 let ints_of_int n =
-  if n >= base then [| n / base; n mod base |]
-  else if n <= - base then [| n / base - 1; n mod base + base |]
-  else if n = 0 then [| |] else [| n |]
+  if n = 0 then [| |]
+  else if small n then [| n |]
+  else mkarray n
 
-let big_of_int n =
-  if n >= base then Obj.repr [| n / base; n mod base |]
-  else if n <= - base then Obj.repr [| n / base - 1; n mod base + base |]
-  else Obj.repr n
+let of_int n =
+  if small n then Obj.repr n else Obj.repr (mkarray n)
 
-let big_of_ints n =
-  let n = normalize n in
+let of_ints n =
+  let n = normalize n in (* TODO: using normalize here seems redundant now *)
   if n = zero then Obj.repr 0 else
   if Array.length n = 1 then Obj.repr n.(0) else
   Obj.repr n
@@ -288,63 +353,81 @@ let big_of_ints n =
 let coerce_to_int = (Obj.magic : Obj.t -> int)
 let coerce_to_ints = (Obj.magic : Obj.t -> int array)
 
-let ints_of_z n =
+let to_ints n =
   if Obj.is_int n then ints_of_int (coerce_to_int n)
   else coerce_to_ints n
 
+let int_of_ints =
+  let maxi = mkarray max_int and mini = mkarray min_int in
+  fun t ->
+    let l = Array.length t in
+    if (l > 3) || (l = 3 && (less_than maxi t || less_than t mini))
+    then failwith "Bigint.to_int: too large";
+    let sum = ref 0 in
+    let pow = ref 1 in
+    for i = l-1 downto 0 do
+      sum := !sum + t.(i) * !pow;
+      pow := !pow*base;
+    done;
+    !sum
+
+let to_int n =
+  if Obj.is_int n then coerce_to_int n
+  else int_of_ints (coerce_to_ints n)
+
 let app_pair f (m, n) =
   (f m, f n)
 
 let add m n =
   if Obj.is_int m & Obj.is_int n
-  then big_of_int (coerce_to_int m + coerce_to_int n)
-  else big_of_ints (add (ints_of_z m) (ints_of_z n))
+  then of_int (coerce_to_int m + coerce_to_int n)
+  else of_ints (add (to_ints m) (to_ints n))
 
 let sub m n =
   if Obj.is_int m & Obj.is_int n
-  then big_of_int (coerce_to_int m - coerce_to_int n)
-  else big_of_ints (sub (ints_of_z m) (ints_of_z n))
+  then of_int (coerce_to_int m - coerce_to_int n)
+  else of_ints (sub (to_ints m) (to_ints n))
 
 let mult m n =
   if Obj.is_int m & Obj.is_int n
-  then big_of_int (coerce_to_int m * coerce_to_int n)
-  else big_of_ints (mult (ints_of_z m) (ints_of_z n))
+  then of_int (coerce_to_int m * coerce_to_int n)
+  else of_ints (mult (to_ints m) (to_ints n))
 
 let euclid m n =
   if Obj.is_int m & Obj.is_int n
-  then app_pair big_of_int
+  then app_pair of_int
     (coerce_to_int m / coerce_to_int n, coerce_to_int m mod coerce_to_int n)
-  else app_pair big_of_ints (euclid (ints_of_z m) (ints_of_z n))
+  else app_pair of_ints (euclid (to_ints m) (to_ints n))
 
 let less_than m n =
   if Obj.is_int m & Obj.is_int n
   then coerce_to_int m < coerce_to_int n
-  else less_than (ints_of_z m) (ints_of_z n)
+  else less_than (to_ints m) (to_ints n)
 
 let neg n =
-  if Obj.is_int n then big_of_int (- (coerce_to_int n))
-  else big_of_ints (neg (ints_of_z n))
+  if Obj.is_int n then of_int (- (coerce_to_int n))
+  else of_ints (neg (to_ints n))
 
-let of_string m = big_of_ints (of_string m)
-let to_string m = to_string (ints_of_z m)
+let of_string m = of_ints (of_string m)
+let to_string m = to_string (to_ints m)
 
-let zero = big_of_int 0
-let one = big_of_int 1
+let zero = of_int 0
+let one = of_int 1
+let two = of_int 2
 let sub_1 n = sub n one
 let add_1 n = add n one
-let two = big_of_int 2
 let mult_2 n = add n n
 
 let div2_with_rest n =
   let (q,b) = euclid n two in
   (q, b = one)
 
-let is_strictly_neg n = is_strictly_neg (ints_of_z n)
-let is_strictly_pos n = is_strictly_pos (ints_of_z n)
-let is_neg_or_zero n = is_neg_or_zero (ints_of_z n)
-let is_pos_or_zero n = is_pos_or_zero (ints_of_z n)
+let is_strictly_neg n = is_strictly_neg (to_ints n)
+let is_strictly_pos n = is_strictly_pos (to_ints n)
+let is_neg_or_zero n = is_neg_or_zero (to_ints n)
+let is_pos_or_zero n = is_pos_or_zero (to_ints n)
 
-let pr_bigint n = str (to_string n)
+let equal m n = (m = n)
 
 (* spiwack: computes n^m *)
 (* The basic idea of the algorithm is that n^(2m) = (n^2)^m *)
@@ -354,58 +437,68 @@ let pr_bigint n = str (to_string n)
     k*n^(2m+1) = (n*k)*(n*n)^m *)
 let pow  =
   let rec pow_aux odd_rest n m = (* odd_rest is the k from above *)
-    if is_neg_or_zero m then
+    if m<=0 then
       odd_rest
     else
-      let (quo,rem) = div2_with_rest m in
+      let quo = m lsr 1 (* i.e. m/2 *)
+      and odd = (m land 1) <> 0 in
       pow_aux
-	((* [if m mod 2 = 1]*)
-         if rem then
-          mult n odd_rest
-	 else
-          odd_rest )
-	(* quo = [m/2] *)
-	(mult n n) quo
+	(if odd then mult n odd_rest else odd_rest)
+	(mult n n)
+	quo
   in
   pow_aux one
 
-(* Testing suite *)
+(** Testing suite w.r.t. OCaml's Big_int *)
+
+(*
+module B = struct
+  open Big_int
+  let zero = zero_big_int
+  let to_string = string_of_big_int
+  let of_string = big_int_of_string
+  let add = add_big_int
+  let opp = minus_big_int
+  let sub = sub_big_int
+  let mul = mult_big_int
+  let abs = abs_big_int
+  let sign = sign_big_int
+  let euclid n m =
+    let n' = abs n and m' = abs m in
+    let q',r' = quomod_big_int n' m' in
+    (if sign (mul n m) < 0 && sign q' <> 0 then opp q' else q'),
+    (if sign n < 0 then opp r' else r')
+end
 
 let check () =
-  let numbers = [
-  "1";"2";"99";"100";"101";"9999";"10000";"10001";
-  "999999";"1000000";"1000001";"99999999";"100000000";"100000001";
-  "1234";"5678";"12345678";"987654321";
-  "-1";"-2";"-99";"-100";"-101";"-9999";"-10000";"-10001";
-  "-999999";"-1000000";"-1000001";"-99999999";"-100000000";"-100000001";
-  "-1234";"-5678";"-12345678";"-987654321";"0"
-  ]
+  let roots = [ 1; 100; base; 100*base; base*base ] in
+  let rands = [ 1234; 5678; 12345678; 987654321 ] in
+  let nums = (List.flatten (List.map (fun x -> [x-1;x;x+1]) roots)) @ rands in
+  let numbers =
+    List.map string_of_int nums @
+    List.map (fun n -> string_of_int (-n)) nums
   in
-  let eucl n m =
-    let n' = abs_float n and m' = abs_float m in
-    let q' = floor (n' /. m') in let r' = n' -. m' *. q' in
-    (if n *. m < 0. & q' <> 0. then -. q' else q'),
-    (if n < 0. then -. r' else r') in
-  let round f = floor (abs_float f +. 0.5) *. (if f < 0. then -1. else 1.) in
   let i = ref 0 in
-  let compare op n n' =
+  let compare op x y n n' =
     incr i;
     let s = Printf.sprintf "%30s" (to_string n) in
-    let s' = Printf.sprintf "% 30.0f" (round n') in
-    if s <> s' then Printf.printf "%s: %s <> %s\n" op s s' in
-List.iter (fun a -> List.iter (fun b ->
-  let n = of_string a and m = of_string b in
-  let n' = float_of_string a and m' = float_of_string b in
-  let a = add n m and a' = n' +. m' in
-  let s = sub n m and s' = n' -. m' in
-  let p = mult n m and p' = n' *. m' in
-  let q,r = try euclid n m with Division_by_zero -> zero,zero
-  and q',r' = eucl n' m' in
-  compare "+" a a';
-  compare "-" s s';
-  compare "*" p p';
-  compare "/" q q';
-  compare "%" r r') numbers) numbers;
+    let s' = Printf.sprintf "%30s" (B.to_string n') in
+    if s <> s' then Printf.printf "%s%s%s: %s <> %s\n" x op y s s' in
+  let test x y =
+    let n = of_string x and m = of_string y in
+    let n' = B.of_string x and m' = B.of_string y in
+    let a = add n m and a' = B.add n' m' in
+    let s = sub n m and s' = B.sub n' m' in
+    let p = mult n m and p' = B.mul n' m' in
+    let q,r = try euclid n m with Division_by_zero -> zero,zero
+    and q',r' = try B.euclid n' m' with Division_by_zero -> B.zero, B.zero
+    in
+    compare "+" x y a a';
+    compare "-" x y s s';
+    compare "*" x y p p';
+    compare "/" x y q q';
+    compare "%" x y r r'
+  in
+  List.iter (fun a -> List.iter (test a) numbers) numbers;
   Printf.printf "%i tests done\n" !i
-
-
+*)
diff --git a/lib/bigint.mli b/lib/bigint.mli
index 9a890570..754f10d6 100644
--- a/lib/bigint.mli
+++ b/lib/bigint.mli
@@ -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-2012     *)
 (*   \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
 
 val of_string : string -> bigint
 val to_string : bigint -> string
 
+val of_int : int -> bigint
+val to_int : bigint -> int (** May raise a Failure on oversized numbers *)
+
 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
@@ -42,6 +39,4 @@ val is_pos_or_zero : bigint -> bool
 val is_neg_or_zero : bigint -> bool
 val neg : bigint -> bigint
 
-val pow : bigint -> bigint -> bigint
-
-val pr_bigint : bigint -> std_ppcmds
+val pow : bigint -> int -> 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 a0264dc7..a428ec10 100644
--- a/lib/compat.ml4
+++ b/lib/compat.ml4
@@ -1,83 +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-2012     *)
 (*   \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
-exception Exc_located = Ploc.Exc
-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
-exception Exc_located = Stdpp.Exc_located
-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
-exception Exc_located = Stdpp.Exc_located
-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
-exception Exc_located = M.Exc_located
-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..0562cc40 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-2012     *)
 (*   \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..7ce43bd5 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-2012     *)
 (*   \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..b795a4b4 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-2012     *)
 (*   \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..9173e810 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-2012     *)
 (*   \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..c672d30c 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -9,39 +9,77 @@
 (* 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 exe s = s ^ Coq_config.exec_extension
+
+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
@@ -51,19 +89,19 @@ let rec which l f =
 	else which tl f
 
 let guess_camlbin () =
-  let path = try Sys.getenv "PATH" with _ -> raise Not_found in
+  let path = Sys.getenv "PATH" in (* may raise Not_found *)
   let lpath = path_to_list path in
-    which lpath "ocamlc"
+    which lpath (exe "ocamlc")
 
 let guess_camlp4bin () =
-  let path = try Sys.getenv "PATH" with _ -> raise Not_found in
+  let path = Sys.getenv "PATH" in (* may raise Not_found *)
   let lpath = path_to_list path in
-    which lpath Coq_config.camlp4
+    which lpath (exe Coq_config.camlp4)
 
 let camlbin () =
   if !Flags.camlbin_spec then !Flags.camlbin else
     if !Flags.boot then Coq_config.camlbin else
-      try guess_camlbin () with _ -> Coq_config.camlbin
+      try guess_camlbin () with e when e <> Sys.Break -> Coq_config.camlbin
 
 let camllib () =
   if !Flags.boot
@@ -74,11 +112,13 @@ 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 e when e <> Sys.Break ->
+        let cb = camlbin () in
+	if Sys.file_exists (Filename.concat cb (exe Coq_config.camlp4)) then cb
+	else Coq_config.camlp4bin
 
 let camlp4lib () =
   if !Flags.boot
@@ -86,7 +126,7 @@ let camlp4lib () =
   else
     let camlp4bin = camlp4bin () in
     let com = (Filename.concat camlp4bin Coq_config.camlp4) ^ " -where" in
-    let _,res = System.run_command (fun x -> x) (fun _ -> ()) com in
-    Util.strip res
-
-
+    let ex,res = System.run_command (fun x -> x) (fun _ -> ()) com in
+    match ex with
+      |Unix.WEXITED 0 -> Util.strip res
+      |_ -> "/dev/null"
diff --git a/lib/envars.mli b/lib/envars.mli
index 05357b32..9ec170db 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-2012     *)
 (*   \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..6affea23
--- /dev/null
+++ b/lib/errors.ml
@@ -0,0 +1,79 @@
+(***********************************************************************)
+(*  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
+    | any -> print_gen bottom stk' any
+
+(** 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
+
+(** Critical exceptions shouldn't be catched and ignored by mistake
+    by inner functions during a [vernacinterp]. They should be handled
+    only at the very end of interp, to be displayed to the user. *)
+
+(** NB: in the 8.4 branch, for maximal compatibility, anomalies
+    are considered non-critical *)
+
+let noncritical = function
+  | Sys.Break | Out_of_memory | Stack_overflow -> false
+  | _ -> true
+
diff --git a/lib/errors.mli b/lib/errors.mli
new file mode 100644
index 00000000..ae4d0b85
--- /dev/null
+++ b/lib/errors.mli
@@ -0,0 +1,49 @@
+(***********************************************************************)
+(*  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
+
+(** Critical exceptions shouldn't be catched and ignored by mistake
+    by inner functions during a [vernacinterp]. They should be handled
+    only in [Toplevel.do_vernac] (or Ideslave), to be displayed to the user.
+    Typical example: [Sys.Break]. In the 8.4 branch, for maximal
+    compatibility, anomalies are not considered as critical...
+*)
+val noncritical : exn -> bool
diff --git a/lib/explore.ml b/lib/explore.ml
index c40362c8..1c8776a4 100644
--- a/lib/explore.ml
+++ b/lib/explore.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-2012     *)
 (*   \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
+open Pp
 
 (*s Definition of a search problem. *)
 
@@ -16,20 +14,20 @@ module type SearchProblem = sig
   type state
   val branching : state -> state list
   val success : state -> bool
-  val pp : state -> unit
+  val pp : state -> std_ppcmds
 end
 
 module Make = functor(S : SearchProblem) -> struct
 
   type position = int list
 
-  let pp_position p =
+  let msg_with_position p pp =
     let rec pp_rec = function
-      | [] -> ()
-      | [i] -> printf "%d" i
-      | i :: l -> pp_rec l; printf ".%d" i
+      | [] -> mt ()
+      | [i] -> int i
+      | i :: l -> pp_rec l ++ str "." ++ int i
     in
-    open_hbox (); pp_rec p; close_box ()
+    msg_debug (h 0 (pp_rec p) ++ pp)
 
   (*s Depth first search. *)
 
@@ -42,7 +40,7 @@ module Make = functor(S : SearchProblem) -> struct
 
   let debug_depth_first s =
     let rec explore p s =
-      pp_position p; S.pp s;
+      msg_with_position p (S.pp s);
       if S.success s then s else explore_many 1 p (S.branching s)
     and explore_many i p = function
       | [] -> raise Not_found
@@ -85,7 +83,7 @@ module Make = functor(S : SearchProblem) -> struct
 	  explore q
       | s :: l ->
 	  let ps = i::p in
-	  pp_position ps; S.pp s;
+	  msg_with_position ps (S.pp s);
 	  if S.success s then s else enqueue (succ i) p (push (ps,s) q) l
     in
     enqueue 1 [] empty [s]
diff --git a/lib/explore.mli b/lib/explore.mli
index e01f851c..7190d5e3 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-2012     *)
 (*   \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
@@ -28,11 +27,12 @@ module type SearchProblem = sig
 
   val success : state -> bool
 
-  val pp : state -> unit
+  val pp : state -> Pp.std_ppcmds
 
 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..32c68b25 100644
--- a/lib/flags.ml
+++ b/lib/flags.ml
@@ -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-2012     *)
 (*   \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
-  with e -> o := old; raise e
+  with reraise -> o := old; raise reraise
 
 let without_option o f x =
   let old = !o in o:=false;
   try let r = f x in o := old; r
-  with e -> o := old; raise e
+  with reraise -> o := old; raise reraise
 
 let boot = ref false
 
@@ -25,24 +23,34 @@ 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
-let compat_version = ref None
-let version_strictly_greater v =
-  match !compat_version with None -> true | Some v' -> v'>v
+(* Current means no particular compatibility consideration.
+   For correct comparisons, this constructor should remain the last one. *)
+
+type compat_version = V8_2 | V8_3 | Current
+let compat_version = ref Current
+let version_strictly_greater v = !compat_version > v
 let version_less_or_equal v = not (version_strictly_greater v)
 
+let pr_version = function
+  | V8_2 -> "8.2"
+  | V8_3 -> "8.3"
+  | Current -> "current"
+
 (* Translate *)
 let beautify = ref false
 let make_beautify f = beautify := f
@@ -86,12 +94,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 +122,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 +146,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..eb53f1a2 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-2012     *)
 (*   \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,20 +15,22 @@ 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
-val compat_version : compat_version option ref
+type compat_version = V8_2 | V8_3 | Current
+val compat_version : compat_version ref
 val version_strictly_greater : compat_version -> bool
 val version_less_or_equal : compat_version -> bool
+val pr_version : compat_version -> string
 
 val beautify : bool ref
 val make_beautify : bool -> unit
@@ -53,41 +53,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..08c99daf 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-2012     *)
 (*   \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..06fbd638 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-2012     *)
 (*   \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..8c61d6eb 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-2012     *)
 (*   \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..5e772088 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-2012     *)
 (*   \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..5f4738dc 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-2012     *)
 (*   \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..b4a9da2f 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-2012     *)
 (*   \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..bb2252da
--- /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-2012     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* The following module is a specialized version of [Hashtbl] that is
+   a better space saver. Actually, [Hashcons] instanciates [Hashtbl.t]
+   with [constr] used both as a key and as an image.  Thus, in each
+   cell of the internal bucketlist, there are two representations of
+   the same value. In this implementation, there is only one.
+
+   Besides, the responsibility of computing the hash function is now
+   given to the caller, which makes possible the interleaving of the
+   hash key computation and the hash-consing. *)
+
+module type Hashtype = sig
+  type t
+  val equals : t -> t -> bool
+end
+
+module type S = sig
+  type elt
+  (* [may_add_and_get key constr] uses [key] to look for [constr]
+     in the hash table [H]. If [constr] is in [H], returns the
+     specific representation that is stored in [H]. Otherwise,
+     [constr] is stored in [H] and will be used as the canonical
+     representation of this value in the future. *)
+  val may_add_and_get : int -> elt -> elt
+end
+
+module Make (E : Hashtype) =
+  struct
+
+    type elt = E.t
+
+    type bucketlist = Empty | Cons of elt * int * bucketlist
+
+    let initial_size = 19991
+    let table_data = ref (Array.make initial_size Empty)
+    let table_size = ref 0
+
+    let resize () =
+      let odata = !table_data in
+      let osize = Array.length odata in
+    let nsize = min (2 * osize + 1) Sys.max_array_length in
+    if nsize <> osize then begin
+      let ndata = Array.create nsize Empty in
+      let rec insert_bucket = function
+	| Empty -> ()
+	| Cons (key, hash, rest) ->
+          let nidx = hash mod nsize in
+          ndata.(nidx) <- Cons (key, hash, ndata.(nidx));
+          insert_bucket rest
+      in
+      for i = 0 to osize - 1 do insert_bucket odata.(i) done;
+      table_data := ndata
+    end
+
+  let add hash key =
+    let odata = !table_data in
+    let osize = Array.length odata in
+    let i = hash mod osize in
+    odata.(i) <- Cons (key, hash, odata.(i));
+    incr table_size;
+    if !table_size > osize lsl 1 then resize ()
+
+  let find_rec hash key bucket =
+    let rec aux = function
+      | Empty ->
+	add hash key; key
+      | Cons (k, h, rest) ->
+	if hash == h && E.equals key k then k else aux rest
+    in
+    aux bucket
+
+  let may_add_and_get hash key =
+    let odata = !table_data in
+    match odata.(hash mod (Array.length odata)) with
+      |	Empty -> add hash key; key
+      | Cons (k1, h1, rest1) ->
+	if hash == h1 && E.equals key k1 then k1 else
+	  match rest1 with
+            | Empty -> add hash key; key
+	    | Cons (k2, h2, rest2) ->
+              if hash == h2 && E.equals key k2 then k2 else
+		match rest2 with
+		  | Empty -> add hash key; key
+		  | Cons (k3, h3, rest3) ->
+		    if hash == h3 && E.equals key k3 then k3
+		    else find_rec hash key rest3
+
+end
+
+module Combine = struct
+    (* These are helper functions to combine the hash keys in a similar
+       way as [Hashtbl.hash] does. The constants [alpha] and [beta] must
+       be prime numbers. There were chosen empirically. Notice that the
+       problem of hashing trees is hard and there are plenty of study on
+       this topic. Therefore, there must be room for improvement here. *)
+    let alpha = 65599
+    let beta  = 7
+    let combine x y     = x * alpha + y
+    let combine3 x y z   = combine x (combine y z)
+    let combine4 x y z t = combine x (combine3 y z t)
+    let combinesmall x y = beta * x + y
+end
diff --git a/lib/hashtbl_alt.mli b/lib/hashtbl_alt.mli
new file mode 100644
index 00000000..7a1dcd57
--- /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-2012     *)
+(*   \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..4f0a65a6 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-2012     *)
 (*   \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..c2bd95ae 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-2012     *)
 (*   \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..0500becc 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-2012     *)
 (*   \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..f8aeecc5 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-2012     *)
 (*   \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..569a028f 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-2012     *)
 (*   \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
@@ -160,6 +158,17 @@ let tclose () = [< 'Ppcmd_close_tbox >]
 
 let (++) = Stream.iapp
 
+let rec eval_ppcmds l =
+  let rec aux l =
+    try
+      let a = match Stream.next l with
+      | Ppcmd_box (b,s) -> Ppcmd_box (b,eval_ppcmds s)
+      | a -> a in
+      let rest = aux l in
+      a :: rest
+    with Stream.Failure -> [] in
+  Stream.of_list (aux l)
+
 (* In new syntax only double quote char is escaped by repeating it *)
 let rec escape_string s =
   let rec escape_at s i =
@@ -270,28 +279,21 @@ let pp_dirs ft =
     try
       Stream.iter pp_dir dirstream; com_brk ft
     with
-      | e -> Format.pp_print_flush ft () ; raise e
+      | reraise -> Format.pp_print_flush ft () ; raise reraise
 
 
 (* 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)
-
-let warnstart() =
-  if not !print_emacs then mt() else str emacs_warning_start_string
+let emacs_quote_start = String.make 1 (Char.chr 254)
+let emacs_quote_end = String.make 1 (Char.chr 255)
 
-let warnend() =
-  if not !print_emacs then mt() else str emacs_warning_end_string
+let emacs_quote strm =
+  if !print_emacs then
+    [< str emacs_quote_start; hov 0 strm; str emacs_quote_end >]
+  else hov 0 strm
 
-let warnbody strm =
-  [< warnstart() ; hov 0 (str "Warning: " ++ strm) ; warnend() >]
+let warnbody strm = emacs_quote (str "Warning: " ++ strm)
 
 (* pretty printing functions WITHOUT FLUSH *)
 let pp_with ft strm =
@@ -339,3 +341,10 @@ 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
+
+(* Same specific display in emacs as warning, but without the "Warning:" *)
+let msg_debug x = msgnl (emacs_quote x)
+
+let string_of_ppcmds c =
+  msg_with Format.str_formatter c;
+  Format.flush_str_formatter ()
diff --git a/lib/pp.mli b/lib/pp.mli
index 61b544e3..7917ba15 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-2012     *)
 (*   \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,15 @@ 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 Evaluation. } *)
+
+val eval_ppcmds : std_ppcmds -> std_ppcmds
+
+(** {6 Derived commands. } *)
 
 val spc : unit -> std_ppcmds
 val cut : unit -> std_ppcmds
@@ -59,7 +59,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 +67,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 +77,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 +87,37 @@ 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
+
+(** Same specific display in emacs as warning, but without the "Warning:" **)
+val msg_debug : std_ppcmds -> unit
+
+val string_of_ppcmds : std_ppcmds -> string
diff --git a/lib/pp_control.ml b/lib/pp_control.ml
index a7ad553b..dce42e29 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-2012     *)
 (*   \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..f887e9ec 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-2012     *)
 (*   \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..39e08721 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-2012     *)
 (*   \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.)
@@ -265,7 +260,7 @@ let time_overhead_B_C () =
       let _dw = dummy_spent_alloc () in
       let _dt = get_time () in
       ()
-    with _ -> assert false
+    with e when e <> Sys.Break -> assert false
   done;
   let after = get_time () in
   let beforeloop =  get_time () in
@@ -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 =
@@ -396,7 +390,7 @@ let profile1 e f a =
       (match !stack with [] -> assert false | _::s -> stack := s);
     last_alloc := get_alloc ();
     r
-  with exn ->
+  with reraise ->
     let dw = spent_alloc () in
     let dt = get_time () - t in
     e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt;
@@ -409,7 +403,7 @@ let profile1 e f a =
     if not (p==e) then
       (match !stack with [] -> assert false | _::s -> stack := s);
     last_alloc := get_alloc ();
-    raise exn
+    raise reraise
 
 let profile2 e f a b =
   let dw = spent_alloc () in
@@ -438,7 +432,7 @@ let profile2 e f a b =
       (match !stack with [] -> assert false | _::s -> stack := s);
     last_alloc := get_alloc ();
     r
-  with exn ->
+  with reraise ->
     let dw = spent_alloc () in
     let dt = get_time () - t in
     e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt;
@@ -451,7 +445,7 @@ let profile2 e f a b =
     if not (p==e) then
       (match !stack with [] -> assert false | _::s -> stack := s);
     last_alloc := get_alloc ();
-    raise exn
+    raise reraise
 
 let profile3 e f a b c =
   let dw = spent_alloc () in
@@ -480,7 +474,7 @@ let profile3 e f a b c =
       (match !stack with [] -> assert false | _::s -> stack := s);
     last_alloc := get_alloc ();
     r
-  with exn ->
+  with reraise ->
     let dw = spent_alloc () in
     let dt = get_time () - t in
     e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt;
@@ -493,7 +487,7 @@ let profile3 e f a b c =
     if not (p==e) then
       (match !stack with [] -> assert false | _::s -> stack := s);
     last_alloc := get_alloc ();
-    raise exn
+    raise reraise
 
 let profile4 e f a b c d =
   let dw = spent_alloc () in
@@ -522,7 +516,7 @@ let profile4 e f a b c d =
       (match !stack with [] -> assert false | _::s -> stack := s);
     last_alloc := get_alloc ();
     r
-  with exn ->
+  with reraise ->
     let dw = spent_alloc () in
     let dt = get_time () - t in
     e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt;
@@ -535,7 +529,7 @@ let profile4 e f a b c d =
     if not (p==e) then
       (match !stack with [] -> assert false | _::s -> stack := s);
     last_alloc := get_alloc ();
-    raise exn
+    raise reraise
 
 let profile5 e f a b c d g =
   let dw = spent_alloc () in
@@ -564,7 +558,7 @@ let profile5 e f a b c d g =
       (match !stack with [] -> assert false | _::s -> stack := s);
     last_alloc := get_alloc ();
     r
-  with exn ->
+  with reraise ->
     let dw = spent_alloc () in
     let dt = get_time () - t in
     e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt;
@@ -577,7 +571,7 @@ let profile5 e f a b c d g =
     if not (p==e) then
       (match !stack with [] -> assert false | _::s -> stack := s);
     last_alloc := get_alloc ();
-    raise exn
+    raise reraise
 
 let profile6 e f a b c d g h =
   let dw = spent_alloc () in
@@ -606,7 +600,7 @@ let profile6 e f a b c d g h =
       (match !stack with [] -> assert false | _::s -> stack := s);
     last_alloc := get_alloc ();
     r
-  with exn ->
+  with reraise ->
     let dw = spent_alloc () in
     let dt = get_time () - t in
     e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt;
@@ -619,7 +613,7 @@ let profile6 e f a b c d g h =
     if not (p==e) then
       (match !stack with [] -> assert false | _::s -> stack := s);
     last_alloc := get_alloc ();
-    raise exn
+    raise reraise
 
 let profile7 e f a b c d g h i =
   let dw = spent_alloc () in
@@ -648,7 +642,7 @@ let profile7 e f a b c d g h i =
       (match !stack with [] -> assert false | _::s -> stack := s);
     last_alloc := get_alloc ();
     r
-  with exn ->
+  with reraise ->
     let dw = spent_alloc () in
     let dt = get_time () - t in
     e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt;
@@ -661,7 +655,7 @@ let profile7 e f a b c d g h i =
     if not (p==e) then
       (match !stack with [] -> assert false | _::s -> stack := s);
     last_alloc := get_alloc ();
-    raise exn
+    raise reraise
 
 (* Some utilities to compute the logical and physical sizes and depth
    of ML objects *)
diff --git a/lib/profile.mli b/lib/profile.mli
index 208238e7..a67622fd 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-2012     *)
 (*   \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..9ef7f313 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-2012     *)
 (*   \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..7bfac2d4 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-2012     *)
 (*   \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..28eb65c8
--- /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 Not_found -> 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..ae637708 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-2012     *)
 (*   \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
 
@@ -111,7 +140,8 @@ let exclude_search_in_dirname f = skipped_dirnames := f :: !skipped_dirnames
 
 let ok_dirname f =
   f <> "" && f.[0] <> '.' && not (List.mem f !skipped_dirnames) &&
-  try ignore (check_ident f); true with _ -> false
+  try ignore (check_ident f); true
+  with e when e <> Sys.Break -> false
 
 let all_subdirs ~unix_path:root =
   let l = ref [] in
@@ -179,6 +209,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)
 
@@ -186,17 +224,22 @@ let file_readable_p name =
   try access name [R_OK];true with Unix_error (_, _, _) -> false
 
 let open_trapping_failure name =
-  try open_out_bin name with _ -> error ("Can't open " ^ name)
+  try open_out_bin name
+  with e when e <> Sys.Break -> error ("Can't open " ^ name)
 
 let try_remove filename =
   try Sys.remove filename
-  with _ -> msgnl (str"Warning: " ++ str"Could not remove file " ++
-                   str filename ++ str" which is corrupted!" )
+  with e when e <> Sys.Break ->
+    msgnl (str"Warning: " ++ str"Could not remove file " ++
+             str filename ++ str" which is corrupted!" )
 
 let marshal_out ch v = Marshal.to_channel ch v []
-let marshal_in ch =
+let marshal_in filename ch =
   try Marshal.from_channel ch
-  with End_of_file -> error "corrupted file: reached end of file"
+  with
+    | End_of_file -> error "corrupted file: reached end of file"
+    | Failure _ (* e.g. "truncated object" *) ->
+        error (filename ^ " is corrupted, try to rebuild it.")
 
 exception Bad_magic_number of string
 
@@ -222,14 +265,14 @@ let extern_intern ?(warn=true) magic suffix =
       try
         marshal_out channel val_0;
         close_out channel
-      with e ->
-	begin try_remove filename; raise e end
+      with reraise ->
+	begin try_remove filename; raise reraise end
     with Sys_error s -> error ("System error: " ^ s)
   and intern_state paths name =
     try
       let _,filename = find_file_in_path ~warn paths (make_suffix name suffix) in
       let channel = raw_intern filename in
-      let v = marshal_in channel in
+      let v = marshal_in filename channel in
       close_in channel;
       v
     with Sys_error s ->
@@ -300,34 +343,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..d8420e7d 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-2012     *)
 (*   \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,12 +41,13 @@ 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. *)
 
 val marshal_out : out_channel -> 'a -> unit
-val marshal_in : in_channel -> 'a
+val marshal_in : string -> in_channel -> 'a
 
 exception Bad_magic_number of string
 
@@ -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..90d23bf1 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-2012     *)
 (*   \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..38ab0ffa
--- /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-2012     *)
+(*   \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..18468661
--- /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-2012     *)
+(*   \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..4f14b83a 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,27 @@ let list_map4 f l1 l2 l3 l4 =
   in
   map (l1,l2,l3,l4)
 
+let list_map_to_array f l =
+  Array.of_list (List.map f l)
+
+let rec list_smartfilter f l = match l with
+    [] -> l
+  | h::tl ->
+      let tl' = list_smartfilter f tl in
+	if f h then
+	  if tl' == tl then l
+	  else h :: tl'
+	else tl'
+	  
+let list_index_f f x =
+  let rec index_x n = function
+    | y::l -> if f x y then n else index_x (succ n) l
+    | [] -> raise Not_found
+  in
+  index_x 1
+
+let list_index0_f f x l = list_index_f f x l - 1
+
 let list_index x =
   let rec index_x n = function
     | y::l -> if x = y then n else index_x (succ n) l
@@ -584,6 +607,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 +703,20 @@ 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_filter_along f filter l =
+  snd (list_filter2 (fun b c -> f b) (filter,l))
+
+let list_filter_with filter l =
+  list_filter_along (fun x -> x) filter l
+
 let list_subset l1 l2 =
   let t2 = Hashtbl.create 151 in
   List.iter (fun x -> Hashtbl.add t2 x ()) l2;
@@ -685,15 +726,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].
@@ -707,7 +750,7 @@ let list_split_when p =
   split_when_loop []
 
 (* [list_split_by p l] splits [l] into two lists [(l1,l2)] such that elements of
-   [l1] satisfy [p] and elements of [l2] do not *)
+   [l1] satisfy [p] and elements of [l2] do not; order is preserved *)
 let list_split_by p =
   let rec split_by_loop = function
   | []   -> ([],[])
@@ -757,9 +800,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 +855,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
@@ -865,6 +909,14 @@ let rec list_cartesians_filter op init ll =
 
 let rec list_drop_last = function [] -> assert false | hd :: [] -> [] | hd :: tl -> hd :: list_drop_last tl
 
+(* Factorize lists of pairs according to the left argument *)
+let rec list_factorize_left = function
+  | (a,b)::l ->
+      let al,l' = list_split_by (fun (a',b) -> a=a') l in
+      (a,(b::List.map snd al)) :: list_factorize_left l'
+  | [] ->
+      []
+
 (* Arrays *)
 
 let array_compare item_cmp v1 v2 =
@@ -878,6 +930,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 +1056,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 +1234,21 @@ let array_rev_to_list a =
     if i >= Array.length a then res else tolist (i+1) (a.(i) :: res) in
   tolist 0 []
 
+let array_filter_along f filter v =
+  Array.of_list (list_filter_along f filter (Array.to_list v))
+
+let array_filter_with filter v =
+  Array.of_list (list_filter_with filter (Array.to_list v))
+
+(* Stream *)
+
+let stream_nth n st =
+  try List.nth (Stream.npeek (n+1) st) n
+  with Failure _ -> raise Stream.Failure
+
+let stream_njunk n st =
+  for i = 1 to n do Stream.junk st done
+
 (* Matrices *)
 
 let matrix_transpose mat =
diff --git a/lib/util.mli b/lib/util.mli
index e5b5f8c6..05d499cb 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-2012     *)
+(*   \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,11 @@ 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
+val list_filter_with : bool list -> 'a list -> 'a list
+val list_filter_along : ('a -> bool) -> 'a list -> 'b list -> 'b list
+
+(** [list_smartmap f [a1...an] = List.map f [a1...an]] but if for all i
    [ f ai == ai], then [list_smartmap f l==l] *)
 val list_smartmap : ('a -> 'a) -> 'a list -> 'a list
 val list_map_left : ('a -> 'b) -> 'a list -> 'b list
@@ -146,14 +149,24 @@ val list_map3 :
   ('a -> 'b -> 'c -> 'd) -> 'a list -> 'b list -> 'c list -> 'd list
 val list_map4 :
   ('a -> 'b -> 'c -> 'd -> 'e) -> 'a list -> 'b list -> 'c list -> 'd list -> 'e list
+val list_map_to_array : ('a -> 'b) -> 'a list -> 'b array
 val list_filter_i :
   (int -> 'a -> bool) -> 'a list -> 'a list
-(* [list_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 +179,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 +202,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
 
@@ -218,10 +242,12 @@ val list_cartesians_filter :
   ('a -> 'b -> 'b option) -> 'b -> 'a list list -> 'b list
 
 val list_union_map : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b
+val list_factorize_left : ('a * 'b) list -> ('a * 'b list) list
 
-(*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 +269,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
@@ -267,12 +295,19 @@ val array_fold_map2' :
 val array_distinct : 'a array -> bool
 val array_union_map : ('a -> 'b -> 'b) -> 'a array -> 'b -> 'b
 val array_rev_to_list : 'a array -> 'a list
+val array_filter_along : ('a -> bool) -> 'a list -> 'b array -> 'b array
+val array_filter_with : bool list -> 'a array -> 'a array
+
+(** {6 Streams. } *)
 
-(*s Matrices *)
+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 +337,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 +357,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 +375,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..5b06e720
--- /dev/null
+++ b/lib/xml_lexer.mll
@@ -0,0 +1,305 @@
+{(*
+ * 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
+        | newline | (newline break) | break
+                {
+                        Buffer.add_char tmp '\n';
+                        newline lexbuf;
+                        pcdata lexbuf
+                }
+	| pcchar+
+		{
+			Buffer.add_string tmp (lexeme lexbuf);
+			pcdata lexbuf
+		}
+	| "&#"
+		{
+			Buffer.add_string tmp (lexeme lexbuf);
+			pcdata lexbuf;
+		}
+	| '&'
+		{
+			Buffer.add_string tmp (entity lexbuf);
+			pcdata lexbuf
+		}
+	| ""
+		{ Buffer.contents tmp }
+
+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..600796f7
--- /dev/null
+++ b/lib/xml_parser.ml
@@ -0,0 +1,237 @@
+(*
+ * 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
+	| Empty
+
+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 s = tag -> List.rev !elems
+		| t -> raise (Internal_error (EndOfTagExpected tag))
+
+let rec read_xml s =
+  let node = read_node s in
+  match node with
+  | Element _ -> node
+  | PCData c ->
+    if is_blank c then read_xml s
+    else raise (Xml_lexer.Error Xml_lexer.ENodeExpected)
+
+let convert = function
+	| Xml_lexer.EUnterminatedComment -> UnterminatedComment
+	| Xml_lexer.EUnterminatedString -> UnterminatedString
+	| Xml_lexer.EIdentExpected -> IdentExpected
+	| Xml_lexer.ECloseExpected -> CloseExpected
+	| Xml_lexer.ENodeExpected -> NodeExpected
+	| Xml_lexer.EAttributeNameExpected -> AttributeNameExpected
+	| Xml_lexer.EAttributeValueExpected -> AttributeValueExpected
+	| Xml_lexer.EUnterminatedEntity -> 	UnterminatedEntity
+
+let error_of_exn stk = function
+  | NoMoreData when Stack.pop stk = Xml_lexer.Eof -> Empty
+  | NoMoreData -> NodeExpected
+  | Internal_error e -> e
+  | Xml_lexer.Error e -> convert e
+  | e -> raise e
+
+let do_parse xparser source =
+        let stk = Stack.create() in
+	try
+		Xml_lexer.init source;
+		let s = { source = source; xparser = xparser; stack = stk } in
+		let x = read_xml s in
+		if xparser.check_eof && pop s <> Xml_lexer.Eof then raise (Internal_error EOFExpected);
+		Xml_lexer.close source;
+		x
+	with e when e <> Sys.Break ->
+	  Xml_lexer.close source;
+	  raise (!xml_error (error_of_exn stk e) source)
+
+let parse p = function
+	| SChannel ch -> do_parse p (Lexing.from_channel ch)
+	| SString str -> do_parse p (Lexing.from_string str)
+	| SLexbuf lex -> do_parse p lex
+	| SFile fname ->
+		let ch = (try open_in fname with Sys_error _ -> raise (!file_not_found fname)) in
+		try
+			let x = do_parse p (Lexing.from_channel ch) in
+			close_in ch;
+			x
+		with
+			reraise ->
+				close_in ch;
+				raise reraise
+
+
+let error_msg = function
+        | UnterminatedComment -> "Unterminated comment"
+        | UnterminatedString -> "Unterminated string"
+        | UnterminatedEntity -> "Unterminated entity"
+        | IdentExpected -> "Ident expected"
+        | CloseExpected -> "Element close expected"
+        | NodeExpected -> "Xml node expected"
+        | AttributeNameExpected -> "Attribute name expected"
+        | AttributeValueExpected -> "Attribute value expected"
+        | EndOfTagExpected tag -> sprintf "End of tag expected : '%s'" tag
+        | EOFExpected -> "End of file expected"
+	| Empty -> "Empty"
+
+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..cc9bcd33
--- /dev/null
+++ b/lib/xml_parser.mli
@@ -0,0 +1,105 @@
+(*
+ * 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
+	| Empty
+
+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..bb108ddc 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-2012     *)
 (*   \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
@@ -54,6 +54,16 @@ module ContextObjectMap = Map.Make (OrderedContextObject)
 
 let modcache = ref (MPmap.empty : structure_body MPmap.t)
 
+let rec search_mod_label lab = function
+  | [] -> raise Not_found
+  | (l,SFBmodule mb) :: _ when l = lab -> mb
+  | _ :: fields -> search_mod_label lab fields
+
+let rec search_cst_label lab = function
+  | [] -> raise Not_found
+  | (l,SFBconst cb) :: _ when l = lab -> cb
+  | _ :: fields -> search_cst_label lab fields
+
 let rec lookup_module_in_impl mp =
   try Global.lookup_module mp
   with Not_found ->
@@ -64,9 +74,7 @@ let rec lookup_module_in_impl mp =
 	raise Not_found (* should have been found by [lookup_module] *)
       | MPdot (mp',lab') ->
 	let fields = memoize_fields_of_mp mp' in
-	match List.assoc lab' fields with
-	  | SFBmodule mb -> mb
-	  | _ -> assert false (* same label for a non-module ?! *)
+	search_mod_label lab' fields
 
 and memoize_fields_of_mp mp =
   try MPmap.find mp !modcache
@@ -126,9 +134,7 @@ let lookup_constant_in_impl cst fallback =
     let fields = memoize_fields_of_mp mp in
     (* A module found this way is necessarily closed, in particular
        our constant cannot be in an opened section : *)
-    match List.assoc lab fields with
-      | SFBconst cb -> cb
-      | _ -> assert false (* label not pointing to a constant ?! *)
+    search_cst_label lab fields
   with Not_found ->
     (* Either:
        - The module part of the constant isn't registered yet :
@@ -142,7 +148,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 +217,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..5d16ac72 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-2012     *)
 (*   \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..33e9a2e7 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-2012     *)
 (*   \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..3b1ca2bf 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-2012     *)
 (*   \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..88503b42 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-2012     *)
 (*   \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_objlabel (label_of_id id)
+
+let check_exists sp =
+  let id = basename sp in
+  if exists_name id then alreadydeclared (pr_id id ++ str " already exists")
+
 let cache_constant ((sp,kn),(cdt,dhyps,kind)) =
   let 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..6f69f673 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-2012     *)
 (*   \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..db7b8915 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-2012     *)
 (*   \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
@@ -927,9 +990,9 @@ let declare_include_ interp_struct me_asts =
 let protect_summaries f =
   let fs = Summary.freeze_summaries () in
   try f fs
-  with e ->
+  with reraise ->
     (* Something wrong: undo the whole process *)
-    Summary.unfreeze_summaries fs; raise e
+    Summary.unfreeze_summaries fs; raise reraise
 
 let declare_include interp_struct me_asts =
   protect_summaries
diff --git a/library/declaremods.mli b/library/declaremods.mli
index 46b7f411..c22ecf83 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-2012     *)
 (*   \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..dd8a702e 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-2012     *)
 (*   \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..d06db6e3 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-2012     *)
 (*   \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..ba0f5adc 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-2012     *)
 (*   \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..bc90220d 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-2012     *)
 (*   \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..89541462 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-2012     *)
 (*   \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_objlabel id = exists_objlabel 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..0ca89a15 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-2012     *)
 (*   \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_objlabel  : 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..cbf58540 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-2012     *)
 (*   \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,28 +225,29 @@ 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);
+		       subst_function = (fun (_,v) -> v);
 		       discharge_function = (fun (_,v) -> Some v);
 		       load_function = (fun _ (_,v) -> write v)}
     in
@@ -269,7 +265,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 +288,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 +326,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 +346,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 +360,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..70dab37b 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-2012     *)
 (*   \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..5a3160cb
--- /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-2012     *)
+(*   \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..c33ea9b1 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-2012     *)
 (*   \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
@@ -90,7 +88,7 @@ let kind_of_head env t =
   | Sort _ | Ind _ | Prod _ -> RigidHead RigidType
   | Cast (c,_,_) -> aux k l c b
   | Lambda (_,_,c) when l = [] -> assert (not b); aux (k+1) [] c b
-  | Lambda (_,_,c) -> aux (k+1) (List.tl l) (subst1 (List.hd l) c) b
+  | Lambda (_,_,c) -> aux k (List.tl l) (subst1 (List.hd l) c) b
   | LetIn _ -> assert false
   | Meta _ | Evar _ -> NotImmediatelyComputableHead
   | App (c,al) -> aux k (Array.to_list al @ l) c b
@@ -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..01ad6a18 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-2012     *)
 (*   \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 96209505..930b8f09 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: impargs.ml 15069 2012-03-20 14:06:07Z herbelin $ *)
-
 open Util
 open Names
 open Libnames
@@ -76,9 +74,9 @@ let with_implicits flags f x =
     let rslt = f x in
     implicit_args := oflags;
     rslt
-  with e -> begin
+  with reraise -> begin
     implicit_args := oflags;
-    raise e
+    raise reraise
   end
 
 let set_maximality imps b =
@@ -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
@@ -247,6 +245,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 *)
@@ -438,9 +440,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 =
@@ -457,7 +456,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
@@ -495,18 +505,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
@@ -514,6 +529,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
@@ -552,7 +568,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;
@@ -592,6 +612,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..2fcc91df 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-2012     *)
 (*   \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..44a3c973 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-2012     *)
 (*   \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,106 +572,43 @@ 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)
- *)
-let delete_gen test =
-  let (after,equal,before) = split_lib_gen test in
-  let rec chop_at_dot = function
-    | [] as l -> l
-    | (_, Leaf o)::t when object_tag o = "DOT" -> t
-    | _::t -> chop_at_dot t
-  and chop_before_dot = function
-    | [] as l -> l
-    | (_, Leaf o)::t as l when object_tag o = "DOT" -> l
-    | _::t -> chop_before_dot t
- in
-  set_lib_stk (List.rev_append (chop_at_dot after) (chop_before_dot before))
-
-let delete sp = delete_gen (fun x -> fst x = sp)
-
-let reset_name (loc,id) =
-  let (sp,_) =
-    try
-      find_entry_p (fun (sp,_) -> let (_,spi) = repr_path (fst sp) in id = spi)
-    with Not_found ->
-      user_err_loc (loc,"reset_name",pr_id id ++ str ": no such entry")
-  in
-  reset_to sp
-
-let remove_name (loc,id) =
-  let (sp,_) =
-    try
-      find_entry_p (fun (sp,_) -> let (_,spi) = repr_path (fst sp) in id = spi)
-    with Not_found ->
-      user_err_loc (loc,"remove_name",pr_id id ++ str ": no such entry")
-  in
-    delete sp
-
-let is_mod_node = function
-  | OpenedModule _ | OpenedModtype _ | OpenedSection _
-  | ClosedModule _ | ClosedModtype _ | ClosedSection _  -> true
-  | Leaf o -> let t = object_tag o in t = "MODULE" || t = "MODULE TYPE"
-	|| t = "MODULE ALIAS"
-  | _ -> false
-
-(* Reset on a module or section name in order to bypass constants with
-   the same name *)
+let first_command_label = 1
 
-let reset_mod (loc,id) =
-  let (_,before) =
-    try
-      find_split_p (fun (sp,node) ->
-                    let (_,spi) = repr_path (fst sp) in id = spi
-                    && is_mod_node node)
-    with Not_found ->
-      user_err_loc (loc,"reset_mod",pr_id id ++ str ": no such entry")
-  in
-  set_lib_stk before
-
-let mark_end_of_command, current_command_label, set_command_label =
-  let n = ref 0 in
+let mark_end_of_command, current_command_label, reset_command_label =
+  let n = ref (first_command_label-1) in
   (fun () ->
     match !lib_stk with
         (_,Leaf o)::_ when object_tag o = "DOT" -> ()
       | _ -> incr n;add_anonymous_leaf (inLabel !n)),
   (fun () -> !n),
-  (fun x -> n:=x)
+  (fun x -> n:=x;add_anonymous_leaf (inLabel x))
 
 let is_label_n n x =
   match x with
     | (sp,Leaf o) when object_tag o = "DOT" && n = outLabel o -> true
     | _ -> false
 
-(* Reset the label registered by [mark_end_of_command()] with number n. *)
-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))
-
-let rec back_stk n stk =
-  match stk with
-      (sp,Leaf o)::tail when object_tag o = "DOT" ->
-        if n=0 then sp else back_stk (n-1) tail
-    | _::tail -> back_stk n tail
-    | [] -> error "Reached begin of command history"
+(** Reset the label registered by [mark_end_of_command()] with number n,
+    which should be strictly in the past. *)
 
-let back n = reset_to (back_stk n !lib_stk)
+let reset_label n =
+  if n >= current_command_label () then
+    error "Cannot backtrack to the current label or a future one";
+  reset_to_gen (is_label_n n);
+  (* forget state numbers after n only if reset succeeded *)
+  reset_command_label n
+
+(** Search the last label registered before defining [id] *)
+
+let label_before_name (loc,id) =
+  let found = ref false in
+  let search = function
+    | (_,Leaf o) when !found && object_tag o = "DOT" -> true
+    | (sp,_) -> (if id = snd (repr_path (fst sp)) then found := true); false
+  in
+  match find_entry_p search with
+    | (_,Leaf o) -> outLabel o
+    | _ -> raise Not_found
 
 (* State and initialization. *)
 
@@ -749,29 +628,6 @@ let init () =
   path_prefix := initial_prefix;
   init_summaries()
 
-(* Initial state. *)
-
-let initial_state = ref None
-
-let declare_initial_state () =
-  let name = add_anonymous_entry (FrozenState (freeze_summaries())) in
-  initial_state := Some name
-
-let reset_initial () =
-  match !initial_state with
-    | None ->
-        error "Resetting to the initial state is possible only interactively"
-    | Some sp ->
-  	begin match split_lib sp with
-	  | (_,[_,FrozenState fs as hd],before) ->
-	      lib_stk := hd::before;
-	      recalc_path_prefix ();
-			set_command_label 0;
-	      unfreeze_summaries fs
-	  | _ -> assert false
-	end
-
-
 (* Misc *)
 
 let mp_of_global ref =
@@ -793,7 +649,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..42892bdf 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-2012     *)
 (*   \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,34 @@ 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. *)
-val mark_end_of_command : unit -> unit
-(* 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. *)
-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 +79,91 @@ 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
+
+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 *)
 
-(*s Compilation units *)
+(** {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 } *)
 
-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
+(** NB: The next commands are low-level ones, do not use them directly
+    otherwise the command history stack in [Backtrack] will be out-of-sync.
+    Also note that [reset_initial] is now [reset_label first_command_label] *)
 
-val has_top_frozen_state : unit -> Libnames.object_name option
+(** Adds a "dummy" entry in lib_stk with a unique new label number. *)
+val mark_end_of_command : unit -> unit
+
+(** Returns the current label number *)
+val current_command_label : unit -> int
+
+(** The first label number *)
+val first_command_label : int
 
-(* [back n] resets to the place corresponding to the $n$-th call of
-   [mark_end_of_command] (counting backwards) *)
-val back : int -> unit
+(** [reset_label n] resets [lib_stk] to the label n registered by
+   [mark_end_of_command()]. It forgets anything registered after
+   this label. The label should be strictly in the past. *)
+val reset_label : int -> unit
+
+(** search the label registered immediately before adding some definition *)
+val label_before_name : Names.identifier Util.located -> int
 
-(*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
 
@@ -159,17 +172,13 @@ val unfreeze : frozen -> unit
 
 val init : unit -> unit
 
-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 +198,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..3337bdce 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-2012     *)
 (*   \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..8e358519 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-2012     *)
 (*   \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..f1716af4 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-2012     *)
 (*   \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..fb38c4c3 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-2012     *)
 (*   \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..c857fc86 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-2012     *)
 (*   \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;
@@ -375,38 +368,55 @@ let explain_locate_library_error qid = function
 let try_locate_absolute_library dir =
   try
     locate_absolute_library dir
-  with e ->
+  with e when Errors.noncritical e ->
     explain_locate_library_error (qualid_of_dirpath dir) e
 
 let try_locate_qualified_library (loc,qid) =
   try
     let (_,dir,f) = locate_qualified_library (Flags.is_verbose()) qid in
     dir,f
-  with e ->
+  with e when Errors.noncritical e ->
     explain_locate_library_error qid e
 
 
 (************************************************************************)
 (* 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 f ch <> digest then failwith "File changed!";
+    let table = (System.marshal_in f ch : LightenLibrary.table) in
+    close_in ch;
+    table
+  with e when Errors.noncritical e ->
+    error
+      ("The file "^f^" is inaccessible or has changed,\n" ^
+       "cannot load some opaque constant bodies in it.\n")
 
 let intern_from_file f =
   let ch = System.with_magic_number_check raw_intern_library f in
-  let md = System.marshal_in ch in
-  let digest = System.marshal_in ch in
+  let lmd = System.marshal_in f ch in
+  let pos = pos_in ch in
+  let digest = System.marshal_in f ch in
+  let table = lazy (fetch_opaque_table (f,pos,digest)) in
+  register_library_filename lmd.md_name f;
+  let library = mk_library lmd table digest in
   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,10 +646,17 @@ 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
+  with reraise ->
+    warning ("Removed file "^f'); close_out ch; Sys.remove f'; raise reraise
 
 (************************************************************************)
 (*s Display the memory use of a library. *)
diff --git a/library/library.mli b/library/library.mli
index bc939666..75e2c3d4 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-2012     *)
 (*   \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..01a9a624 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-2012     *)
 (*   \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..c90aa7c7 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-2012     *)
 (*   \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..52e69018 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-2012     *)
 (*   \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..10c2357b 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-2012     *)
 (*   \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..0b685d83 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-2012     *)
 (*   \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..7e6535d9 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-2012     *)
 (*   \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..67d3463a 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-2012     *)
 (*   \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..7ded099a 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-2012     *)
 (*   \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/coqc.1 b/man/coqc.1
index 7113d504..1e597afd 100644
--- a/man/coqc.1
+++ b/man/coqc.1
@@ -40,6 +40,18 @@ with option
 it accepts the same options as
 .B coqtop.
 
+.TP
+.BI \-image \ bin
+use
+.I bin
+as underlying
+.B coqtop
+instead of the default one.
+
+.TP
+.BI \-verbose
+print the compiled file on the standard output.
+
 .SH SEE ALSO
 
 .BR coqtop (1),
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/man/coqtop.1 b/man/coqtop.1
index 3eab597f..fff813bb 100644
--- a/man/coqtop.1
+++ b/man/coqtop.1
@@ -135,12 +135,6 @@ set the rcfile to
 .I filename
 
 .TP
-.BI \-user \ uid
-use the rcfile of user
-.I uid
-
-
-.TP
 .B \-batch
 batch mode (exits just after arguments parsing)
 
diff --git a/myocamlbuild.ml b/myocamlbuild.ml
index 1994efac..7a214bcd 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");
+
+  if w32 then begin
+    flag ["p4mod"] (A "-DWIN32");
+    dep ["ocaml"; "link"; "ide"] ["ide/ide_win32_stubs.o"];
+  end;
 
-  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 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,69 @@ 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 *)
+(** Embed the Coq icon inside the windows version of Coqide *)
+
+  if w32 then dep ["link"; "ocaml"; "program"; "ide"] [w32ico];
+  if w32 then flag ["link"; "ocaml"; "program"; "ide"] (P w32ico);
+
+(** Ealier we tried to make Coqide a console-free win32 app,
+    but that was troublesome (unavailable stdout/stderr, issues
+    with the stop button,...). If somebody really want to try again,
+    the extra args to add are :
+      [A "-ccopt"; A "-link -Wl,-subsystem,windows"]
+    Other solution: use the mkwinapp tool. *)
 
-  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
+(** The mingw32-ocaml cross-compiler currently uses Filename.dir_sep="/".
+    Let's tweak that... *)
+
+  if w32 then begin
+    ocaml_lib "tools/win32hack";
+    List.iter (fun (_,s,_) -> tag_file (s^".native") ["use_win32hack"])
+      all_binaries
+  end;
+
+(** 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;camlp4incl;A"-o";Px fo]);
+    rule fb ~prod:fb ~deps:(depsall@depsb) ~insert:`top
+      (cmd [P coqmktop_boot;w32flag;A"-boot";A"-top";incl fb;camlp4incl;A"-o";Px fb]);
   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..214a6b98 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-2012     *)
 (*   \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,50 +100,113 @@ 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 has_extraarg =
+  List.exists (function GramNonTerminal(_,ExtraArgType _,_,_) -> true | _ -> false)
+
+let statically_known_possibly_empty s (prods,_) =
+  List.for_all (function
+    | GramNonTerminal(_,ExtraArgType s',_,_) ->
+        (* For ExtraArg we don't know (we'll have to test dynamically) *)
+        (* unless it is a recursive call *)
+        s <> s'
+    | GramNonTerminal(_,(OptArgType _|List0ArgType _),_,_) ->
+        (* Opt and List0 parses the empty string *)
+        true
+    | _ ->
+        (* This consumes a token for sure *) false)
+      prods
+
+let possibly_empty_subentries loc (prods,act) =
+  let bind_name p v e = match p with
+    | None -> e
+    | Some id ->
+        let s = Names.string_of_id id in <:expr< let $lid:s$ = $v$ in $e$ >> in
+  let rec aux = function
+    | [] -> <:expr< let loc = $default_loc$ in let _ = loc = loc in $act$ >>
+    | GramNonTerminal(_,OptArgType _,_,p) :: tl ->
+        bind_name p <:expr< None >> (aux tl)
+    | GramNonTerminal(_,List0ArgType _,_,p) :: tl ->
+        bind_name p <:expr< [] >> (aux tl)
+    | GramNonTerminal(_,(ExtraArgType _ as t),_,p) :: tl ->
+        (* We check at runtime if extraarg s parses "epsilon" *)
+        let s = match p with None -> "_" | Some id -> Names.string_of_id id in
+        <:expr< let $lid:s$ = match Genarg.default_empty_value $make_rawwit loc t$ with
+          [ None -> raise Exit
+          | Some v -> v ] in $aux tl$ >>
+    | _ -> assert false (* already filtered out *) in
+  if has_extraarg prods then
+    (* Needs a dynamic check; catch all exceptions if ever some rhs raises *)
+    (* an exception rather than returning a value; *)
+    (* declares loc because some code can refer to it; *)
+    (* ensures loc is used to avoid "unused variable" warning *)
+    (true, <:expr< try Some $aux prods$ with [ e when Errors.noncritical e -> None ] >>)
+  else
+    (* Static optimisation *)
+    (false, aux prods)
+
+let make_possibly_empty_subentries loc s cl =
+  let cl = List.filter (statically_known_possibly_empty s) cl in
+  if cl = [] then
+    <:expr< None >>
+  else
+    let rec aux = function
+    | (true, e) :: l ->
+        <:expr< match $e$ with [ Some v -> Some v | None -> $aux l$ ] >>
+    | (false, e) :: _ ->
+        <:expr< Some $e$ >>
+    | [] ->
+        <:expr< None >> in
+    aux (List.map (possibly_empty_subentries loc) cl)
 
 let make_act loc act pil =
   let rec make = function
-    | [] -> <:expr< 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$
-            (Tacinterp.interp_genarg ist gl
-               (Genarg.in_gen $make_globwit loc globtyp$ x)) >>
+	  let (sigma,a_interp) =
+	    Tacinterp.interp_genarg ist gl
+               (Genarg.in_gen $make_globwit loc globtyp$ x)
+	  in
+          (sigma , out_gen $make_wit loc globtyp$ a_interp)>>
     | Some f -> <:expr< $lid:f$>> in
   let substitute = match h with
     | None ->
@@ -149,28 +220,29 @@ 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;
+  let default_value = <:expr< $make_possibly_empty_subentries loc s cl$ >> in
+  declare_str_items loc
+   [ <:str_item<
       value ($lid:"wit_"^s$, $lid:"globwit_"^s$, $lid:"rawwit_"^s$) =
-        Genarg.create_arg $se$;
-      value $lid:s$ = Pcoq.create_generic_entry $se$ $rawwit$;
+      Genarg.create_arg $default_value$ $se$>>;
+     <:str_item<
+      value $lid:s$ = Pcoq.create_generic_entry $se$ $rawwit$ >>;
+     <:str_item< do {
       Tacinterp.add_interp_genarg $se$
         ((fun e x ->
           (Genarg.in_gen $globwit$ ($glob$ e (out_gen $rawwit$ x)))),
         (fun ist gl x ->
-          (Genarg.in_gen $wit$ ($interp$ ist gl (out_gen $globwit$ x)))),
+	  let (sigma,a_interp) = $interp$ ist gl (out_gen $globwit$ x) in
+          (sigma , Genarg.in_gen $wit$ a_interp)),
         (fun subst x ->
           (Genarg.in_gen $globwit$ ($substitute$ subst (out_gen $globwit$ x)))));
-      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 +253,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 None $se$ >>;
+     <:str_item<
+      value $lid:s$ = Pcoq.create_generic_entry $se$ $rawwit$ >>;
+    <:str_item< do {
+      Compat.maybe_uncurry (Pcoq.Gram.extend ($lid:s$ : Pcoq.Gram.entry 'a))
+	(None, [(None, None, $rules$)]);
       Pptactic.declare_extra_genarg_pprule
         ($rawwit$, $pr_rules$)
         ($globwit$, fun _ _ _ _ -> Util.anomaly "vernac argument needs not globwit printer")
-        ($wit$, fun _ _ _ _ -> Util.anomaly "vernac argument needs not wit printer");
-    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 +327,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 072b09fa..12359776 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: egrammar.ml 15072 2012-03-20 17:36:33Z 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")
@@ -116,33 +113,33 @@ let make_cases_pattern_action
   (f : loc -> cases_pattern_notation_substitution -> cases_pattern_expr) pil =
   let rec make (env,envlist,hasbinders as fullenv) = function
   | [] ->
-      Gramext.action (fun loc -> f loc (check_cases_pattern_env loc fullenv))
+      Gram.action (fun loc -> f loc (check_cases_pattern_env 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) ->
+        Gram.action (fun (v:cases_pattern_expr) ->
           make (v::env, envlist, hasbinders) tl)
     | ETReference ->
-        Gramext.action (fun (v:reference) ->
+        Gram.action (fun (v:reference) ->
 	  make (CPatAtom (dummy_loc,Some v) :: env, envlist, hasbinders) tl)
     | ETName ->
-        Gramext.action (fun (na:name located) ->
+        Gram.action (fun (na:name located) ->
 	  make (cases_pattern_expr_of_name na :: env, envlist, hasbinders) tl)
     | ETBigint ->
-        Gramext.action (fun (v:Bigint.bigint) ->
+        Gram.action (fun (v:Bigint.bigint) ->
 	  make (CPatPrim (dummy_loc,Numeral v) :: env, envlist, hasbinders) tl)
     | ETConstrList (_,_) ->
-        Gramext.action  (fun (vl:cases_pattern_expr list) ->
+        Gram.action  (fun (vl:cases_pattern_expr list) ->
 	  make (env, vl :: envlist, hasbinders) tl)
     | ETBinder _ | ETBinderList (true,_) ->
-	Gramext.action (fun (v:local_binder list) ->
+	Gram.action (fun (v:local_binder list) ->
 	  make (env, envlist, hasbinders) tl)
     | ETBinderList (false,_) ->
-	Gramext.action (fun (v:local_binder list list) ->
+	Gram.action (fun (v:local_binder list list) ->
 	  make (env, envlist, true) tl)
     | (ETPattern | ETOther _) ->
         anomaly "Unexpected entry of type cases pattern or other")
@@ -158,7 +155,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
@@ -168,17 +165,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 ->
@@ -188,7 +186,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) =
@@ -199,8 +197,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'
 
 (**********************************************************************)
@@ -210,11 +208,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 =
@@ -228,10 +226,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)
 
@@ -241,19 +239,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)               *)
@@ -264,7 +264,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)^".")
 
@@ -288,14 +288,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
@@ -361,3 +361,8 @@ let _ =
     { freeze_function = freeze;
       unfreeze_function = unfreeze;
       init_function = init }
+
+let with_grammar_rule_protection f x =
+  let fs = freeze () in
+  try let a = f x in unfreeze fs; a
+  with reraise -> unfreeze fs; raise reraise
diff --git a/parsing/egrammar.mli b/parsing/egrammar.mli
index 8554c9be..f04809ce 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-2012     *)
 (*   \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
@@ -74,3 +71,5 @@ val get_extend_vernac_grammars :
 val recover_notation_grammar :
   notation -> (precedence * tolerability list) ->
   notation_var_internalization_type list * notation_grammar
+
+val with_grammar_rule_protection : ('a -> 'b) -> 'a -> 'b
diff --git a/parsing/extend.ml b/parsing/extend.ml
index 9b85ada5..0a76829b 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-2012     *)
 (*   \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..f63123cd 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-2012     *)
 (*   \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..75f6a7de 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-2012     *)
 (*   \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
 
@@ -17,12 +15,12 @@ open Genarg
 
 let tactic_main_level = 5
 
-let (wit_tactic0,globwit_tactic0,rawwit_tactic0) = create_arg "tactic0"
-let (wit_tactic1,globwit_tactic1,rawwit_tactic1) = create_arg "tactic1"
-let (wit_tactic2,globwit_tactic2,rawwit_tactic2) = create_arg "tactic2"
-let (wit_tactic3,globwit_tactic3,rawwit_tactic3) = create_arg "tactic3"
-let (wit_tactic4,globwit_tactic4,rawwit_tactic4) = create_arg "tactic4"
-let (wit_tactic5,globwit_tactic5,rawwit_tactic5) = create_arg "tactic5"
+let (wit_tactic0,globwit_tactic0,rawwit_tactic0) = create_arg None "tactic0"
+let (wit_tactic1,globwit_tactic1,rawwit_tactic1) = create_arg None "tactic1"
+let (wit_tactic2,globwit_tactic2,rawwit_tactic2) = create_arg None "tactic2"
+let (wit_tactic3,globwit_tactic3,rawwit_tactic3) = create_arg None "tactic3"
+let (wit_tactic4,globwit_tactic4,rawwit_tactic4) = create_arg None "tactic4"
+let (wit_tactic5,globwit_tactic5,rawwit_tactic5) = create_arg None "tactic5"
 
 let wit_tactic = function
   | 0 -> wit_tactic0
diff --git a/parsing/extrawit.mli b/parsing/extrawit.mli
index 9b0aac39..8cd162c9 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-2012     *)
 (*   \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..22dc427b 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-2012     *)
 (*   \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,15 +25,20 @@ 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
   | (c,(_,Some ty)) -> CCast(join_loc (constr_loc c) (constr_loc ty), c, CastConv (DEFAULTcast, ty))
 
+let binders_of_names l =
+  List.map (fun (loc, na) ->
+    LocalRawAssum ([loc, na], Default Explicit,
+		   CHole (loc, Some (Evd.BinderType na)))) l
+
 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 +68,55 @@ 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"
+let name_colon =
+  Gram.Entry.of_parser "name_colon"
     (fun strm ->
-      match Stream.npeek 1 strm with
-	| [("IDENT",s)] ->
-            (match Stream.npeek 2 strm with
-              | [_; ("", ":")] ->
-                  Stream.junk strm; Stream.junk 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)
+      match get_tok (stream_nth 0 strm) with
+	| IDENT s ->
+            (match get_tok (stream_nth 1 strm) with
+              | KEYWORD ":" ->
+                  stream_njunk 2 strm;
+                  Name (Names.id_of_string s)
+              | _ -> err ())
+	| KEYWORD "_" ->
+          (match get_tok (stream_nth 1 strm) with
+              | KEYWORD ":" ->
+                  stream_njunk 2 strm;
+                  Anonymous
+              | _ -> err ())
+        | _ -> err ())
 
 let aliasvar = function CPatAlias (loc, _, id) -> Some (loc,Name id) | _ -> None
 
@@ -147,9 +144,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 +212,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 +224,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 +331,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"
@@ -389,8 +389,7 @@ GEXTEND Gram
           [LocalRawAssum (id::idl,Default Explicit,c)]
 	(* binders factorized with open binder *)
       | id = name; idl = LIST0 name; bl = binders ->
-          let t = CHole (loc, Some (Evd.BinderType (snd id))) in
-          LocalRawAssum (id::idl,Default Explicit,t)::bl
+          binders_of_names (id::idl) @ bl
       | id1 = name; ".."; id2 = name ->
           [LocalRawAssum ([id1;(loc,Name ldots_var);id2],
 	                  Default Explicit,CHole (loc,None))]
@@ -432,8 +431,8 @@ GEXTEND Gram
     [ [ "!" ; c = operconstr LEVEL "200" -> (loc, Anonymous), true, c
       | "{"; id = name; "}"; ":" ; expl = [ "!" -> true | -> false ] ; c = operconstr LEVEL "200" ->
 	  id, expl, c
-      | iid=ident_colon ; expl = [ "!" -> true | -> false ] ; c = operconstr LEVEL "200" ->
-	  (loc, Name iid), expl, c
+      | iid=name_colon ; expl = [ "!" -> true | -> false ] ; c = operconstr LEVEL "200" ->
+	  (loc, iid), expl, c
       | c = operconstr LEVEL "200" ->
 	  (loc, Anonymous), false, c
     ] ]
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..d082b91c 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-2012     *)
 (*   \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*)
@@ -82,25 +80,24 @@ GEXTEND Gram
 	  TacFirst l
       | IDENT "solve" ; "["; l = LIST0 tactic_expr SEP "|"; "]" ->
 	  TacSolve l
-      | IDENT "complete" ; ta = tactic_expr -> TacComplete ta
       | IDENT "idtac"; l = LIST0 message_token -> TacId l
       | IDENT "fail"; n = [ n = int_or_var -> n | -> fail_default_value ];
 	  l = LIST0 message_token -> TacFail (n,l)
       | IDENT "external"; com = STRING; req = STRING; la = LIST1 tactic_arg ->
-	  TacArg (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..6fee4e1f 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-2012     *)
 (*   \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..8a6f67c4 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-2012     *)
 (*   \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
 
@@ -27,19 +23,21 @@ let thm_token = G_vernac.thm_token
 GEXTEND Gram
   GLOBAL: command;
 
-  destruct_location :
-  [ [ IDENT "Conclusion"  -> Tacexpr.ConclLocation ()
-    | discard = [ IDENT "Discardable" -> true | -> false ]; "Hypothesis"
-	-> Tacexpr.HypLocation discard ] ]
-  ;
   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)
@@ -55,19 +53,18 @@ GEXTEND Gram
       | IDENT "Defined" -> VernacEndProof (Proved (false,None))
       |	IDENT "Defined"; id=identref ->
 	  VernacEndProof (Proved (false,Some (id,None)))
-      | IDENT "Suspend" -> VernacSuspend
-      | 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 "Unfocused" -> VernacUnfocused
+      | 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 +77,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:
@@ -123,17 +108,10 @@ GEXTEND Gram
       | IDENT "Constructors"; lc = LIST1 global -> HintsConstructors lc
       | IDENT "Extern"; n = natural; c = OPT constr_pattern ; "=>";
           tac = tactic ->
-	  HintsExtern (n,c,tac)
-      | IDENT "Destruct";
-          id = ident; ":=";
-          pri = natural;
-          dloc = destruct_location;
-          hyptyp = constr_pattern;
-          "=>"; tac = tactic ->
-            HintsDestruct(id,pri,dloc,hyptyp,tac) ] ]
+	  HintsExtern (n,c,tac) ] ]
     ;
   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..1609e541 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-2012     *)
 (*   \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
@@ -144,25 +126,23 @@ let mk_cofix_tac (loc,id,bl,ann,ty) =
 let induction_arg_of_constr (c,lbind as clbind) =
   if lbind = NoBindings then
     try ElimOnIdent (constr_loc c,snd(coerce_to_id c))
-    with _ -> ElimOnConstr clbind
+    with e when Errors.noncritical e -> ElimOnConstr clbind
   else ElimOnConstr clbind
 
 let mkTacCase with_evar = function
-  | [([ElimOnConstr cl],None,(None,None))],None ->
+  | [ElimOnConstr cl,(None,None)],None,None ->
       TacCase (with_evar,cl)
   (* Reinterpret numbers as a notation for terms *)
-  | [([(ElimOnAnonHyp n)],None,(None,None))],None ->
+  | [ElimOnAnonHyp n,(None,None)],None,None ->
       TacCase (with_evar,
-        (CPrim (dummy_loc, Numeral (Bigint.of_string (string_of_int n))),
+        (CPrim (dummy_loc, Numeral (Bigint.of_int n)),
 	 NoBindings))
   (* Reinterpret ident as notations for variables in the context *)
   (* because we don't know if they are quantified or not *)
-  | [([ElimOnIdent id],None,(None,None))],None ->
+  | [ElimOnIdent id,(None,None)],None,None ->
       TacCase (with_evar,(CRef (Ident id),NoBindings))
   | ic ->
-      if List.exists (fun (cl,a,b) ->
-           List.exists (function ElimOnAnonHyp _ -> true | _ -> false) cl)
-           (fst ic)
+      if List.exists (function (ElimOnAnonHyp _,_) -> true | _ -> false) (pi1 ic)
       then
 	error "Use of numbers as direct arguments of 'case' is not supported.";
       TacInductionDestruct (false,with_evar,ic)
@@ -183,8 +163,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 +202,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 +216,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) ] ]
   ;
@@ -303,11 +277,6 @@ GEXTEND Gram
       | "*" -> loc, IntroForthcoming true
       | "**" -> loc, IntroForthcoming false ] ]
   ;
-  intropattern_modifier:
-    [ [ IDENT "_eqn";
-        id = [ ":"; id = naming_intropattern -> id | -> loc, IntroAnonymous ]
-        -> id ] ]
-  ;
   simple_intropattern:
     [ [ pat = disjunctive_intropattern -> pat
       | pat = naming_intropattern -> pat
@@ -372,7 +341,7 @@ GEXTEND Gram
       | IDENT "lazy"; s = strategy_flag -> Lazy s
       | IDENT "compute"; delta = delta_flag -> Cbv (all_with delta)
       | IDENT "vm_compute" -> CbvVm
-      | IDENT "unfold"; ul = LIST1 unfold_occ -> Unfold ul
+      | IDENT "unfold"; ul = LIST1 unfold_occ SEP "," -> Unfold ul
       | IDENT "fold"; cl = LIST1 constr -> Fold cl
       | IDENT "pattern"; pl = LIST1 pattern_occ SEP"," -> Pattern pl
       | s = IDENT -> ExtraRedExpr s ] ]
@@ -451,7 +420,7 @@ GEXTEND Gram
   ;
   hintbases:
     [ [ "with"; "*" -> None
-      | "with"; l = LIST1 IDENT -> Some l
+      | "with"; l = LIST1 [ x = IDENT -> x] -> Some l
       | -> Some [] ] ]
   ;
   auto_using:
@@ -469,10 +438,15 @@ GEXTEND Gram
     [ [ "as"; ipat = simple_intropattern -> Some ipat
       | -> None ] ]
   ;
-  with_induction_names:
-    [ [ "as"; ipat = simple_intropattern; eq = OPT intropattern_modifier
-        -> (eq,Some ipat)
-      | -> (None,None) ] ]
+  eqn_ipat:
+    [ [ IDENT "eqn"; ":"; id = naming_intropattern -> Some id
+      | IDENT "_eqn"; ":"; id = naming_intropattern ->
+        let msg = "Obsolete syntax \"_eqn:H\" could be replaced by \"eqn:H\"" in
+        msg_warning (strbrk msg); Some id
+      | IDENT "_eqn" ->
+        let msg = "Obsolete syntax \"_eqn\" could be replaced by \"eqn:?\"" in
+        msg_warning (strbrk msg); Some (loc, IntroAnonymous)
+      | -> None ] ]
   ;
   as_name:
     [ [ "as"; id = ident -> Names.Name id | -> Names.Anonymous ] ]
@@ -501,14 +475,11 @@ GEXTEND Gram
     [ [ b = orient; p = rewriter -> let (m,c) = p in (b,m,c) ] ]
   ;
   induction_clause:
-    [ [ lc = LIST1 induction_arg; ipats = with_induction_names;
-        el = OPT eliminator -> (lc,el,ipats) ] ]
-  ;
-  one_induction_clause:
-    [ [ ic = induction_clause; cl = opt_clause -> ([ic],cl) ] ]
+    [ [ c = induction_arg; pat = as_ipat; eq = eqn_ipat -> (c,(eq,pat)) ] ]
   ;
   induction_clause_list:
-    [ [ ic = LIST1 induction_clause SEP ","; cl = opt_clause -> (ic,cl) ] ]
+    [ [ ic = LIST1 induction_clause SEP ",";
+	el = OPT eliminator; cl = opt_clause -> (ic,el,cl) ] ]
   ;
   move_location:
     [ [ IDENT "after"; id = id_or_meta -> MoveAfter id
@@ -559,15 +530,16 @@ GEXTEND Gram
 	  TacMutualCofix (false,id,List.map mk_cofix_tac fd)
 
       | IDENT "pose"; (id,b) = bindings_with_parameters ->
-	  TacLetTac (Names.Name id,b,nowhere,true)
+	  TacLetTac (Names.Name id,b,nowhere,true,None)
       | IDENT "pose"; b = constr; na = as_name ->
-	  TacLetTac (na,b,nowhere,true)
+	  TacLetTac (na,b,nowhere,true,None)
       | IDENT "set"; (id,c) = bindings_with_parameters; p = clause_dft_concl ->
-	  TacLetTac (Names.Name id,c,p,true)
+	  TacLetTac (Names.Name id,c,p,true,None)
       | IDENT "set"; c = constr; na = as_name; p = clause_dft_concl ->
-          TacLetTac (na,c,p,true)
-      | IDENT "remember"; c = constr; na = as_name; p = clause_dft_all ->
-          TacLetTac (na,c,p,false)
+          TacLetTac (na,c,p,true,None)
+      | IDENT "remember"; c = constr; na = as_name; e = eqn_ipat;
+          p = clause_dft_all ->
+          TacLetTac (na,c,p,false,e)
 
       (* Begin compatibility *)
       | IDENT "assert"; test_lpar_id_coloneq; "("; (loc,id) = identref; ":=";
@@ -602,9 +574,9 @@ GEXTEND Gram
       (* Derived basic tactics *)
       | IDENT "simple"; IDENT"induction"; h = quantified_hypothesis ->
           TacSimpleInductionDestruct (true,h)
-      | IDENT "induction"; ic = one_induction_clause ->
+      | IDENT "induction"; ic = induction_clause_list ->
 	  TacInductionDestruct (true,false,ic)
-      | IDENT "einduction"; ic = one_induction_clause ->
+      | IDENT "einduction"; ic = induction_clause_list ->
 	  TacInductionDestruct(true,true,ic)
       | IDENT "double"; IDENT "induction"; h1 = quantified_hypothesis;
 	  h2 = quantified_hypothesis -> TacDoubleInduction (h1,h2)
@@ -621,21 +593,18 @@ GEXTEND Gram
 
       (* Automation tactic *)
       | IDENT "trivial"; lems = auto_using; db = hintbases ->
-	  TacTrivial (lems,db)
+          TacTrivial (Off,lems,db)
+      | IDENT "info_trivial"; lems = auto_using; db = hintbases ->
+          TacTrivial (Info,lems,db)
+      | IDENT "debug"; IDENT "trivial"; lems = auto_using; db = hintbases ->
+          TacTrivial (Debug,lems,db)
+
       | IDENT "auto"; n = OPT int_or_var; lems = auto_using; db = hintbases ->
-	  TacAuto (n,lems,db)
-
-(* Obsolete since V8.0
-      | IDENT "autotdb"; n = OPT natural -> TacAutoTDB n
-      | IDENT "cdhyp"; id = identref -> TacDestructHyp (true,id)
-      | IDENT "dhyp";  id = identref -> TacDestructHyp (false,id)
-      | IDENT "dconcl"  -> TacDestructConcl
-      | IDENT "superauto"; l = autoargs -> TacSuperAuto l
-*)
-      | IDENT "auto"; IDENT "decomp"; p = OPT natural;
-          lems = auto_using -> TacDAuto (None,p,lems)
-      | IDENT "auto"; n = OPT int_or_var; IDENT "decomp"; p = OPT natural;
-          lems = auto_using -> TacDAuto (n,p,lems)
+          TacAuto (Off,n,lems,db)
+      | IDENT "info_auto"; n = OPT int_or_var; lems = auto_using;
+          db = hintbases -> TacAuto (Info,n,lems,db)
+      | IDENT "debug"; IDENT "auto"; n = OPT int_or_var; lems = auto_using;
+          db = hintbases -> TacAuto (Debug,n,lems,db)
 
       (* Context management *)
       | IDENT "clear"; "-"; l = LIST1 id_or_meta -> TacClear (true, l)
@@ -656,9 +625,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..301370e7 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-2012     *)
 (*   \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;
+    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,34 @@ 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 "extra"; IDENT "scopes" -> [`ExtraScopes]
+      | 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 +710,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 +731,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 +769,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 +808,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 +849,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 +869,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 +877,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 +901,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
@@ -818,9 +927,8 @@ GEXTEND Gram
       | IDENT "Restore"; IDENT "State"; s = ne_string -> VernacRestoreState s
 
 (* Resetting *)
-      | IDENT "Reset"; id = identref -> VernacResetName id
-      | IDENT "Delete"; id = identref -> VernacRemoveName id
       | IDENT "Reset"; IDENT "Initial" -> VernacResetInitial
+      | IDENT "Reset"; id = identref -> VernacResetName id
       | IDENT "Back" -> VernacBack 1
       | IDENT "Back"; n = natural -> VernacBack n
       | IDENT "BackTo"; n = natural -> VernacBackTo n
@@ -862,18 +970,13 @@ 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 | -> [] ];
 	 sc = OPT [ ":"; sc = IDENT -> sc ] ->
          VernacInfix (enforce_module_locality local,(op,modl),p,sc)
      | IDENT "Notation"; local = obsolete_locality; id = identref;
-	 idl = LIST0 ident; ":="; c = constr;
-	 b = [ "("; IDENT "only"; IDENT "parsing"; ")" -> true | -> false ] ->
+	 idl = LIST0 ident; ":="; c = constr; b = only_parsing ->
            VernacSyntacticDefinition
 	     (id,(idl,c),enforce_module_locality local,b)
      | IDENT "Notation"; local = obsolete_locality; s = ne_lstring; ":=";
@@ -901,6 +1004,13 @@ GEXTEND Gram
         to factorize with other "Print"-based vernac entries *)
   ] ]
   ;
+  only_parsing:
+    [ [ "("; IDENT "only"; IDENT "parsing"; ")" ->
+         Some Flags.Current
+      | "("; IDENT "compat"; s = STRING; ")" ->
+         Some (Coqinit.get_compat_version s)
+      | -> None ] ]
+  ;
   obsolete_locality:
     [ [ IDENT "Local" -> true | -> false ] ]
   ;
@@ -912,16 +1022,20 @@ 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 Flags.Current
+      | IDENT "compat"; s = STRING ->
+        SetOnlyParsing (Coqinit.get_compat_version s)
+      | 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 +1044,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..869674f4 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-2012     *)
 (*   \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,16 +95,17 @@ 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)
 
 let get_xml_inductive_kn al =
   inductive_of_cdata (* uriType apparent synonym of uri *)
-    (try get_xml_attr "uri" al with _ -> get_xml_attr "uriType" al)
+    (try get_xml_attr "uri" al
+     with e when Errors.noncritical e -> get_xml_attr "uriType" al)
 
 let get_xml_constant al = constant_of_cdata (get_xml_attr "uri" al)
 
@@ -138,63 +136,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 +231,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 +251,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 +276,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..caea30b2 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-2012     *)
 (*   \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..a0820f55 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-2012     *)
 (*   \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..7f11af93 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-2012     *)
 (*   \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..53c317c0 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-2012     *)
 (*   \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..5405e523 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-2012     *)
 (*   \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
@@ -46,7 +40,9 @@ let lposint = 0
 let lnegint = 35 (* must be consistent with Notation "- x" *)
 let ltop = (200,E)
 let lproj = 1
-let lsimple = (1,E)
+let ldelim = 1
+let lsimpleconstr = (8,E)
+let lsimplepatt = (1,E)
 
 let prec_less child (parent,assoc) =
   if parent < 0 && child = lprod then true
@@ -110,18 +106,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
@@ -159,7 +151,7 @@ let pr_or_var pr = function
   | ArgVar (loc,s) -> pr_lident (loc,s)
 
 let pr_prim_token = function
-  | Numeral n -> Bigint.pr_bigint n
+  | Numeral n -> str (Bigint.to_string n)
   | String s -> qs s
 
 let pr_evar pr n l =
@@ -187,6 +179,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) ->
@@ -196,7 +190,7 @@ let rec pr_patt sep inh p =
   | CPatNotation (_,s,(l,ll)) ->
       pr_notation (pr_patt mt) (fun _ _ _ -> mt()) s (l,ll,[])
   | CPatPrim (_,p) -> pr_prim_token p, latom
-  | CPatDelimiters (_,k,p) -> pr_delimiters k (pr_patt mt lsimple p), 1
+  | CPatDelimiters (_,k,p) -> pr_delimiters k (pr_patt mt lsimplepatt p), 1
   in
   let loc = cases_pattern_expr_loc p in
   pr_with_comments loc
@@ -227,25 +221,33 @@ let surround_impl k p =
   | Explicit -> str"(" ++ p ++ str")"
   | Implicit -> str"{" ++ p ++ str"}"
 
-let surround_binder k p =
-  match k with
-  | Default b -> hov 1 (surround_impl b p)
-  | Generalized (b, b', t) ->
-      hov 1 (surround_impl b' (surround_impl b p))
-
 let surround_implicit k p =
   match k with
-  | Default Explicit -> p
-  | Default Implicit -> (str"{" ++ p ++ str"}")
-  | Generalized (b, b', t) ->
-      surround_impl b' (surround_impl b p)
+  | Explicit -> p
+  | Implicit -> (str"{" ++ p ++ str"}")
 
 let pr_binder many pr (nal,k,t) =
-  match t with
-  | CHole _ -> prlist_with_sep spc pr_lname nal
-  | _ ->
-    let s = prlist_with_sep spc pr_lname nal ++ str" : " ++ pr t in
-      hov 1 (if many then surround_binder k s else surround_implicit k s)
+  match k with
+    | Generalized (b, b', t') ->
+      assert (b=Implicit);
+      begin match nal with
+	|[loc,Anonymous] ->
+	  hov 1 (str"`" ++ (surround_impl b'
+			      ((if t' then str "!" else mt ()) ++ pr t)))
+	|[loc,Name id] ->
+	  hov 1 (str "`" ++ (surround_impl b'
+			       (pr_lident (loc,id) ++ str " : " ++
+				  (if t' then str "!" else mt()) ++ pr t)))
+	|_ -> anomaly "List of generalized binders have alwais one element."
+      end
+    | Default b ->
+      match t with
+	| CHole _ ->
+	  let s = prlist_with_sep spc pr_lname nal in
+	  hov 1 (surround_implicit b s)
+	| _ ->
+	  let s = prlist_with_sep spc pr_lname nal ++ str " : " ++ pr t in
+	  hov 1 (if many then surround_impl b s else surround_implicit b s)
 
 let pr_binder_among_many pr_c = function
   | LocalRawAssum (nal,k,t) ->
@@ -315,85 +317,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
@@ -410,19 +333,27 @@ let pr_recursive_decl pr pr_dangling dangling_with_for id bl annot t c =
   pr_opt_type_spc pr t ++ str " :=" ++
   pr_sep_com (fun () -> brk(1,2)) (pr_body ltop) c
 
-let pr_fixdecl pr prd dangling_with_for ((_,id),(n,ro),bl,t,c) =
-  let annot =
-    match ro with
-	CStructRec ->
-	  if List.length bl > 1 && n <> None then
-	    spc() ++ str "{struct " ++ pr_id (snd (Option.get n)) ++ str"}"
-	  else mt()
-      | CWfRec c ->
-	  spc () ++ str "{wf " ++ pr lsimple c ++ pr_id (snd (Option.get n)) ++ str"}"
-      | CMeasureRec (m,r) ->
-	  spc () ++ str "{measure " ++ pr lsimple m ++ pr_id (snd (Option.get n)) ++
-	    (match r with None -> mt() | Some r -> str" on " ++ pr lsimple r) ++ str"}"
-  in
+let pr_guard_annot pr_aux bl (n,ro) =
+  match n with
+    | None -> mt ()
+    | Some (loc, id) ->
+      match (ro : Topconstr.recursion_order_expr) with
+	| CStructRec ->
+	  let names_of_binder = function
+	    | LocalRawAssum (nal,_,_) -> nal
+	    | LocalRawDef (_,_) -> []
+	  in let ids = List.flatten (List.map names_of_binder bl) in
+	     if List.length ids > 1 then
+	       spc() ++ str "{struct " ++ pr_id id ++ str"}"
+	     else mt()
+	| CWfRec c ->
+	  spc() ++ str "{wf " ++ pr_aux c ++ spc() ++ pr_id id ++ str"}"
+	| CMeasureRec (m,r) ->
+	  spc() ++ str "{measure " ++ pr_aux m ++ spc() ++ pr_id id++
+	    (match r with None -> mt() | Some r -> str" on " ++ pr_aux r) ++ str"}"
+
+let pr_fixdecl pr prd dangling_with_for ((_,id),ro,bl,t,c) =
+  let annot = pr_guard_annot (pr lsimpleconstr) bl ro in
     pr_recursive_decl pr prd dangling_with_for id bl annot t c
 
 let pr_cofixdecl pr prd dangling_with_for ((_,id),bl,t,c) =
@@ -436,28 +367,13 @@ 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
     | None -> mt ()) ++
   (match indnalopt with
     | None -> mt ()
-    | Some t -> spc () ++ str "in " ++ pr lsimple t)
+    | Some t -> spc () ++ str "in " ++ pr lsimpleconstr t)
 
 let pr_case_item pr (tm,asin) =
   hov 0 (pr (lcast,E) tm ++ pr_asin pr asin)
@@ -466,9 +382,7 @@ let pr_case_type pr po =
   match po with
     | None | Some (CHole _) -> mt()
     | Some p ->
-        spc() ++ hov 2 (str "return" ++ pr_sep_com spc (pr lsimple) p)
-
-let pr_return_type pr po = pr_case_type pr po
+        spc() ++ hov 2 (str "return" ++ pr_sep_com spc (pr lsimpleconstr) p)
 
 let pr_simple_return_type pr na po =
   (match na with
@@ -478,7 +392,7 @@ let pr_simple_return_type pr na po =
   pr_case_type pr po
 
 let pr_proj pr pr_app a f l =
-  hov 0 (pr lsimple a ++ cut() ++ str ".(" ++ pr_app pr f l ++ str ")")
+  hov 0 (pr (lproj,E) a ++ cut() ++ str ".(" ++ pr_app pr f l ++ str ")")
 
 let pr_appexpl pr f l =
       hov 2 (
@@ -621,9 +535,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) ->
@@ -633,47 +547,14 @@ let pr pr sep inherited a =
       pr (fun()->str"(") (max_int,L) t ++ str")", latom
   | CNotation (_,s,env) ->
       pr_notation (pr mt) (pr_binders_gen (pr mt ltop)) s env
-  | CGeneralization (_,bk,ak,c) -> pr_generalization bk ak (pr mt lsimple c), latom
+  | CGeneralization (_,bk,ak,c) -> pr_generalization bk ak (pr mt ltop c), latom
   | CPrim (_,p) -> pr_prim_token p, prec_of_prim_token p
-  | CDelimiters (_,sc,a) -> pr_delimiters sc (pr mt lsimple a), 1
-  | CDynamic _ -> str "<dynamic>", latom
+  | CDelimiters (_,sc,a) -> pr_delimiters sc (pr mt (ldelim,E) a), ldelim
   in
   let loc = constr_loc a in
   pr_with_comments loc
     (sep() ++ if prec_less prec inherited then strm else surround strm)
 
-
-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;
@@ -686,10 +567,14 @@ let modular_constr_pr = pr
 let rec fix rf x =rf (fix rf) x
 let pr = fix modular_constr_pr mt
 
+let pr_simpleconstr = function
+  | CAppExpl (_,(None,f),[]) -> str "@" ++ pr_reference f
+  | c -> pr lsimpleconstr c
+
 let default_term_pr = {
-  pr_constr_expr   = pr lsimple;
+  pr_constr_expr   = pr_simpleconstr;
   pr_lconstr_expr  = pr ltop;
-  pr_constr_pattern_expr  = pr lsimple;
+  pr_constr_pattern_expr  = pr_simpleconstr;
   pr_lconstr_pattern_expr = pr ltop
 }
 
diff --git a/parsing/ppconstr.mli b/parsing/ppconstr.mli
index d27b318a..7a24eb9f 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-2012     *)
 (*   \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
@@ -56,12 +51,16 @@ val pr_with_occurrences :
   ('a -> std_ppcmds) -> 'a with_occurrences -> std_ppcmds
 val pr_red_expr :
   ('a -> std_ppcmds) * ('a -> std_ppcmds) * ('b -> std_ppcmds) * ('c -> std_ppcmds) ->
-    ('a,'b,'c) red_expr_gen -> std_ppcmds
+  ('a,'b,'c) red_expr_gen -> std_ppcmds
 val pr_may_eval :
   ('a -> std_ppcmds) -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) ->
   ('c -> std_ppcmds) -> ('a,'b,'c) may_eval -> std_ppcmds
 
-val pr_rawsort : rawsort -> std_ppcmds
+val pr_glob_sort : glob_sort -> std_ppcmds
+val pr_guard_annot : (constr_expr -> std_ppcmds) ->
+  local_binder list ->
+  ('a * Names.identifier) option * recursion_order_expr ->
+  std_ppcmds
 
 val pr_binders : local_binder list -> std_ppcmds
 val pr_constr_pattern_expr : constr_pattern_expr -> std_ppcmds
@@ -80,22 +79,23 @@ 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]
-    for "lconstr" printers (spiwack: we might need more specification here).
+    [s] is typically {!Pp.mt} and [p] is [lsimpleconstr] for "constr" printers
+    and [ltop] for "lconstr" printers (spiwack: we might need more
+    specification here).
     We can make a new modular constr printer by overriding certain branches,
     for instance if we want to build a printer which prints "Prop" as "Omega"
     instead we can proceed as follows:
     let my_modular_constr_pr pr s p = function
-      | CSort (_,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. *)
 
 type precedence
-val lsimple : precedence
+val lsimpleconstr : precedence
 val ltop : precedence
 val modular_constr_pr :
                ((unit->std_ppcmds) -> precedence -> constr_expr -> std_ppcmds) ->
diff --git a/parsing/pptactic.ml b/parsing/pptactic.ml
index f63d6659..17ef9f85 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-2012     *)
 (*   \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
@@ -270,7 +260,14 @@ let rec pr_generic prc prlc prtac prpat x =
 
 let rec tacarg_using_rule_token pr_gen = function
   | Some s :: l, al -> str s :: tacarg_using_rule_token pr_gen (l,al)
-  | None :: l, a :: al -> pr_gen a :: tacarg_using_rule_token pr_gen (l,al)
+  | None :: l, a :: al ->
+      let print_it =
+        match genarg_tag a with
+        | OptArgType _ -> fold_opt (fun _ -> true) false a
+        | _ -> true
+      in
+      let r = tacarg_using_rule_token pr_gen (l,al) in
+      if print_it then pr_gen a :: r else r
   | [], [] -> []
   | _ -> failwith "Inconsistent arguments of extended tactic"
 
@@ -296,8 +293,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 +313,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 +321,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,15 +345,15 @@ 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_as_ipat pat = str "as " ++ pr_intro_pattern pat
+let pr_eqn_ipat pat = str "eqn:" ++ pr_intro_pattern pat
 
 let pr_with_induction_names = function
   | None, None -> mt ()
-  | eqpat, ipat ->
-      spc () ++ hov 1 (str "as" ++ pr_opt pr_intro_pattern eqpat ++
-                       pr_opt pr_intro_pattern ipat)
+  | Some eqpat, None -> spc () ++ hov 1 (pr_eqn_ipat eqpat)
+  | None, Some ipat -> spc () ++ hov 1 (pr_as_ipat ipat)
+  | Some eqpat, Some ipat ->
+    spc () ++ hov 1 (pr_as_ipat ipat ++ spc () ++ pr_eqn_ipat eqpat)
 
 let pr_as_intro_pattern ipat =
   spc () ++ hov 1 (str "as" ++ spc () ++ pr_intro_pattern ipat)
@@ -411,11 +398,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,16 +430,7 @@ 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_orient b = if b then mt () else str "<- "
 
 let pr_multi = function
   | Precisely 1 -> mt ()
@@ -512,7 +490,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,19 +526,10 @@ 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 string_of_debug = function
+  | Off -> ""
+  | Debug -> "debug "
+  | Info -> "info_"
 
 let pr_then () = str ";"
 
@@ -670,19 +639,14 @@ let rec pr_atom0 = function
   | TacAssumption -> str "assumption"
   | TacAnyConstructor (false,None) -> str "constructor"
   | TacAnyConstructor (true,None) -> str "econstructor"
-  | TacTrivial ([],Some []) -> str "trivial"
-  | TacAuto (None,[],Some []) -> str "auto"
+  | TacTrivial (d,[],Some []) -> str (string_of_debug d ^ "trivial")
+  | TacAuto (d,None,[],Some []) -> str (string_of_debug d ^ "auto")
   | TacReflexivity -> str "reflexivity"
   | TacClear (true,[]) -> str "clear"
   | t -> str "(" ++ pr_atom1 t ++ str ")"
 
   (* Main tactic printer *)
 and pr_atom1 = function
-  | TacAutoTDB _ | TacDestructHyp _ | TacDestructConcl
-  | TacSuperAuto _ | TacExtend (_,
-    ("GTauto"|"GIntuition"|"TSimplif"|
-     "LinearIntuition"),_) ->
-      errorlabstrm "Obsolete V8" (str "Tactic is not ported to V8.0")
   | TacExtend (loc,s,l) ->
       pr_with_comments loc (pr_extend 1 s l)
   | TacAlias (loc,s,l,_) ->
@@ -740,12 +704,13 @@ and pr_atom1 = function
   | TacGeneralizeDep c ->
       hov 1 (str "generalize" ++ spc () ++ str "dependent" ++
              pr_constrarg c)
-  | TacLetTac (na,c,cl,true) when cl = nowhere ->
+  | TacLetTac (na,c,cl,true,_) when cl = nowhere ->
       hov 1 (str "pose" ++ pr_pose pr_lconstr pr_constr na c)
-  | TacLetTac (na,c,cl,b) ->
+  | TacLetTac (na,c,cl,b,e) ->
       hov 1 ((if b then str "set" else str "remember") ++
              (if b then pr_pose pr_lconstr else pr_pose_as_style)
 	        pr_constr na c ++
+             pr_opt (fun p -> pr_eqn_ipat p ++ spc ()) e ++
              pr_clauses (Some b) pr_ident cl)
 (*  | TacInstantiate (n,c,ConclLocation ()) ->
       hov 1 (str "instantiate" ++ spc() ++
@@ -761,14 +726,14 @@ and pr_atom1 = function
   | TacSimpleInductionDestruct (isrec,h) ->
       hov 1 (str "simple " ++ str (if isrec then "induction" else "destruct")
              ++ pr_arg pr_quantified_hypothesis h)
-  | TacInductionDestruct (isrec,ev,(l,cl)) ->
+  | TacInductionDestruct (isrec,ev,(l,el,cl)) ->
       hov 1 (str (with_evars ev (if isrec then "induction" else "destruct")) ++
              spc () ++
-             prlist_with_sep pr_comma (fun (h,e,ids) ->
-	       prlist_with_sep spc (pr_induction_arg pr_lconstr pr_constr) h ++
-	       pr_with_induction_names ids ++
-               pr_opt pr_eliminator e) l ++
-               pr_opt_no_spc (pr_clauses None pr_ident) cl)
+             prlist_with_sep pr_comma (fun (h,ids) ->
+	       pr_induction_arg pr_lconstr pr_constr h ++
+	       pr_with_induction_names ids) l ++
+             pr_opt pr_eliminator el ++
+	     pr_opt_no_spc (pr_clauses None pr_ident) cl)
   | TacDoubleInduction (h1,h2) ->
       hov 1
         (str "double induction" ++
@@ -789,17 +754,15 @@ and pr_atom1 = function
       hov 1 (str "lapply" ++ pr_constrarg c)
 
   (* Automation tactics *)
-  | TacTrivial ([],Some []) as x -> pr_atom0 x
-  | TacTrivial (lems,db) ->
-      hov 0 (str "trivial" ++
+  | TacTrivial (_,[],Some []) as x -> pr_atom0 x
+  | TacTrivial (d,lems,db) ->
+      hov 0 (str (string_of_debug d ^ "trivial") ++
              pr_auto_using pr_constr lems ++ pr_hintbases db)
-  | TacAuto (None,[],Some []) as x -> pr_atom0 x
-  | TacAuto (n,lems,db) ->
-      hov 0 (str "auto" ++ pr_opt (pr_or_var int) n ++
+  | TacAuto (_,None,[],Some []) as x -> pr_atom0 x
+  | TacAuto (d,n,lems,db) ->
+      hov 0 (str (string_of_debug d ^ "auto") ++
+	     pr_opt (pr_or_var int) n ++
              pr_auto_using pr_constr lems ++ pr_hintbases db)
-  | TacDAuto (n,p,lems) ->
-      hov 1 (str "auto" ++ pr_opt (pr_or_var int) n ++ str "decomp" ++
-             pr_opt int p ++ pr_auto_using pr_constr lems)
 
   (* Context management *)
   | TacClear (true,[]) as t -> pr_atom0 t
@@ -835,7 +798,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) ->
@@ -850,17 +813,17 @@ and pr_atom1 = function
 
   (* Equivalence relations *)
   | TacReflexivity as x -> pr_atom0 x
-  | TacSymmetry cls -> str "symmetry " ++ pr_clauses (Some true) pr_ident cls
+  | TacSymmetry cls -> str "symmetry" ++ pr_clauses (Some true) pr_ident cls
   | TacTransitivity (Some c) -> str "transitivity" ++ pr_constrarg c
   | TacTransitivity None -> str "etransitivity"
 
   (* Equality and inversion *)
   | TacRewrite (ev,l,cl,by) ->
-      hov 1 (str (with_evars ev "rewrite") ++
+      hov 1 (str (with_evars ev "rewrite") ++ spc () ++
 	     prlist_with_sep
 	     (fun () -> str ","++spc())
 	     (fun (b,m,c) ->
-		pr_orient b ++ spc() ++ pr_multi m ++ pr_with_bindings c)
+		pr_orient b ++ pr_multi m ++ pr_with_bindings c)
 	     l
 	     ++ pr_clauses (Some true) pr_ident cl
 	     ++	(match by with Some by -> pr_by_tactic (pr_tac_level ltop) by | None -> mt()))
@@ -935,6 +898,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,14 +916,14 @@ 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 ->
       str "solve" ++ spc () ++ pr_seq_body (pr_tac ltop) tl, llet
   | TacComplete t ->
-      str "complete" ++ spc () ++ pr_tac (lcomplete,E) t, lcomplete
+      pr_tac (lcomplete,E) t, lcomplete
   | TacId l ->
       str "idtac" ++ prlist (pr_arg (pr_message_token pr_ident)) l, latom
   | TacAtom (loc,TacAlias (_,s,l,_)) ->
@@ -965,20 +932,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 +964,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 +1006,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..0f82071d 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-2012     *)
 (*   \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 3ed4d8a7..f2491293 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: ppvernac.ml 15025 2012-03-09 14:27:07Z glondu $ *)
-
 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
 
@@ -58,7 +58,11 @@ let pr_module = Libnames.pr_reference
 
 let pr_import_module = Libnames.pr_reference
 
-let sep_end () = str"."
+let sep_end = function
+  | VernacBullet _
+  | VernacSubproof None
+  | VernacEndSubproof -> str""
+  | _ -> str"."
 
 (* Warning: [pr_raw_tactic] globalises and fails if globalisation fails *)
 
@@ -85,27 +89,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 +158,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 +168,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
@@ -221,11 +207,7 @@ let pr_hints local db h pr_c pr_pat =
 	let pat = match c with None -> mt () | Some pat -> pr_pat pat in
           str "Extern" ++ spc() ++ int n ++ spc() ++ pat ++ str" =>" ++
           spc() ++ pr_raw_tactic tac
-    | HintsDestruct(name,i,loc,c,tac) ->
-        str "Destruct " ++ pr_id name ++ str" :=" ++ spc() ++
-        hov 0 (int i ++ spc() ++ pr_destruct_location loc ++ spc() ++
-               pr_c c ++ str " =>") ++ spc() ++
-        pr_raw_tactic tac in
+  in
   hov 2 (str"Hint "++pr_locality local ++ pph ++ opth)
 
 let pr_with_declaration pr_c = function
@@ -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,37 +286,12 @@ 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
 
 let pr_and_type_binders_arg bl =
   pr_binders_arg bl
 
-let names_of_binder = function
-  | LocalRawAssum (nal,_,_) -> nal
-  | LocalRawDef (_,_) -> []
-
-let pr_guard_annot bl (n,ro) =
-  match n with
-  | None -> mt ()
-  | Some (loc, id) ->
-      match (ro : Topconstr.recursion_order_expr) with
-      | CStructRec ->
-          let ids = List.flatten (List.map names_of_binder bl) in
-	  if List.length ids > 1 then
-	    spc() ++ str "{struct " ++ pr_id id ++ str"}"
-	  else mt()
-      | CWfRec c ->
-	  spc() ++ str "{wf " ++ pr_lconstr_expr c ++ spc() ++
-	  pr_id id ++ str"}"
-      | CMeasureRec (m,r) ->
-	  spc() ++ str "{measure " ++ pr_lconstr_expr m ++ spc() ++
-	  pr_id id ++ (match r with None -> mt() | Some r -> str" on " ++
-	    pr_lconstr_expr r) ++ str"}"
-
 let pr_onescheme (idop,schem) =
   match schem with
   | InductionScheme (dep,ind,s) ->
@@ -331,7 +301,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 +309,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,11 +372,12 @@ 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"
+  | SetOnlyParsing Flags.Current -> str"only parsing"
+  | SetOnlyParsing v -> str("compat \"" ^ Flags.pr_version v ^ "\"")
   | SetFormat s -> str"format " ++ pr_located qs s
 
 let pr_syntax_modifiers = function
@@ -422,27 +393,12 @@ 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
     (head ++ spc() ++ pr_lident (Option.get id) ++ spc() ++
     (match bl with [] -> mt() | _ -> pr_binders bl ++ spc()) ++
-    pr_opt (pr_guard_annot bl) guard ++
+    pr_opt (pr_guard_annot pr_lconstr_expr bl) guard ++
     str":" ++ pr_spc_lconstr c)
 
 (**************************************)
@@ -453,22 +409,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"{"  ++
@@ -480,26 +441,22 @@ let rec pr_vernac = function
   (* Proof management *)
   | VernacAbortAll -> str "Abort All"
   | VernacRestart -> str"Restart"
-  | VernacSuspend -> str"Suspend"
   | VernacUnfocus -> str"Unfocus"
+  | VernacUnfocused -> str"Unfocused"
   | VernacGoal c -> str"Goal" ++ pr_lconstrarg c
   | VernacAbort id -> str"Abort" ++ pr_opt pr_lident id
-  | VernacResume id -> str"Resume" ++ pr_opt pr_lident id
   | VernacUndo i -> if i=1 then str"Undo" else str"Undo" ++ pr_intarg i
   | VernacUndoTo i -> str"Undo" ++ spc() ++ str"To" ++ pr_intarg i
   | VernacBacktrack (i,j,k) ->
       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,13 +467,10 @@ 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"
 
   (* Resetting *)
-  | VernacRemoveName id -> str"Remove" ++ spc() ++ pr_lident id
   | VernacResetName id -> str"Reset" ++ spc() ++ pr_lident id
   | VernacResetInitial -> str"Reset Initial"
   | VernacBack i -> if i=1 then str"Back" else str"Back" ++ pr_intarg i
@@ -529,7 +483,7 @@ let rec pr_vernac = function
   (* Control *)
   | VernacList l ->
       hov 2 (str"[" ++ spc() ++
-             prlist (fun v -> pr_located pr_vernac v ++ sep_end () ++ fnl()) l
+             prlist (fun v -> pr_located pr_vernac v ++ sep_end (snd v) ++ fnl()) l
              ++ spc() ++ str"]")
   | VernacLoad (f,s) -> str"Load" ++ if f then (spc() ++ str"Verbose"
   ++ spc()) else spc()  ++ qs s
@@ -650,33 +604,31 @@ let rec pr_vernac = function
         let (_,_,_,k,_),_ = List.hd l in
 	match k with Record -> "Record" | Structure -> "Structure"
 	  | Inductive_kw -> "Inductive" | CoInductive -> "CoInductive"
-	  | Class b -> if b then "Definitional Class" else "Class" in
+	  | Class _ -> "Class" in
       hov 1 (pr_oneind key (List.hd l)) ++
       (prlist (fun ind -> fnl() ++ hov 1 (pr_oneind "with" ind)) (List.tl l))
 
 
-  | VernacFixpoint (recs,b) ->
+  | VernacFixpoint recs ->
       let pr_onerec = function
         | ((loc,id),ro,bl,type_,def),ntn ->
-            let annot = pr_guard_annot bl ro in
-            pr_id id ++ pr_binders_arg bl ++ annot ++ spc()
+            let annot = pr_guard_annot pr_lconstr_expr bl ro in
+            pr_id id ++ pr_binders_arg bl ++ annot
             ++ pr_type_option (fun c -> spc() ++ pr_lconstr_expr c) type_
-            ++ pr_opt (fun def -> str" :=" ++ brk(1,2) ++ pr_lconstr def) def ++
+            ++ 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() ++
@@ -715,38 +667,29 @@ let rec pr_vernac = function
 	spc() ++ str":" ++ spc() ++ pr_class_rawexpr c1 ++ spc() ++ str">->" ++
 	spc() ++ pr_class_rawexpr c2)
 
-
-(*   | VernacClass (id, par, ar, sup, props) -> *)
-(*       hov 1 ( *)
-(* 	str"Class" ++ spc () ++ pr_lident id ++ *)
-(* (\* 	  prlist_with_sep (spc) (pr_lident_constr (spc() ++ str ":" ++ spc())) par ++  *\) *)
-(* 	  pr_and_type_binders_arg par ++ *)
-(* 	  (match ar with Some ar -> spc () ++ str":" ++ spc() ++ pr_rawsort (snd ar) | None -> mt()) ++ *)
-(* 	  spc () ++ str":=" ++ spc () ++ *)
-(* 	  prlist_with_sep (fun () -> str";" ++ spc())  *)
-(* 	  (fun (lid,oc,c) -> pr_lident_constr ((if oc then str" :>" else str" :") ++ spc()) (lid,c)) props ) *)
-
  | VernacInstance (abst,glob, sup, (instid, bk, cl), props, pri) ->
      hov 1 (
        pr_non_locality (not glob) ++
        (if abst then str"Declare " else mt ()) ++
-       str"Instance" ++ spc () ++
-	 pr_and_type_binders_arg sup ++
-	 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)
+       str"Instance" ++ 
+       (match snd instid with Name id -> spc () ++ pr_lident (fst instid, id) ++ spc () | 
+	Anonymous -> mt ()) ++
+       pr_and_type_binders_arg sup ++
+       str":" ++ spc () ++	 
+       pr_constr_expr cl ++ spc () ++
+	 (match props with
+	  | Some p -> spc () ++ str":=" ++ spc () ++ pr_constr_expr p
+	  | None -> mt()))
 
  | VernacContext l ->
      hov 1 (
-       str"Context" ++ spc () ++ str"[" ++ spc () ++
-	 pr_and_type_binders_arg l ++ spc () ++ str "]")
+       str"Context" ++ spc () ++ pr_and_type_binders_arg l)
 
 
- | 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 +723,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 _|Compat.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,15 +773,20 @@ 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) ->
       hov 2
-        (pr_locality local ++ str"Notation " ++ pr_lident id ++
-	 prlist_with_sep spc pr_id ids ++ str" :=" ++ pr_constrarg c ++
-         pr_syntax_modifiers (if onlyparsing then [SetOnlyParsing] else []))
+        (pr_locality local ++ str"Notation " ++ pr_lident id ++ spc () ++
+	 prlist (fun x -> spc() ++ pr_id x) ids ++ str":=" ++ pr_constrarg c ++
+         pr_syntax_modifiers
+	   (match onlyparsing with None -> [] | Some v -> [SetOnlyParsing v]))
   | VernacDeclareImplicits (local,q,[]) ->
       hov 2 (pr_section_locality local ++ str"Implicit Arguments" ++ spc() ++ 
 	pr_smart_global q)
@@ -856,6 +796,33 @@ 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"
+        | `ExtraScopes -> str "extra scopes"
+        | `ClearImplicits -> str "clear implicits"
+        | `ClearScopes -> str "clear scopes")
+        mods)
   | VernacReserve bl ->
       let n = List.length (List.flatten (List.map fst bl)) in
       hov 2 (str"Implicit Type" ++
@@ -899,8 +866,8 @@ let rec pr_vernac = function
       | Some r0 ->
           hov 2 (str"Eval" ++ spc() ++
           pr_red_expr (pr_constr,pr_lconstr,pr_smart_global, pr_constr) r0 ++
-          spc() ++ str"in" ++ spc () ++ pr_constr c)
-      | None -> hov 2 (str"Check" ++ spc() ++ pr_constr c)
+          spc() ++ str"in" ++ spc () ++ pr_lconstr c)
+      | None -> hov 2 (str"Check" ++ spc() ++ pr_lconstr c)
       in
       (if io = None then mt() else int (Option.get io) ++ str ": ") ++
       pr_mayeval r c
@@ -933,7 +900,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 +934,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 "{"
+  | VernacSubproof (Some i) -> str "BeginSubproof " ++ pr_int i
+  | VernacEndSubproof -> str "}"
 
 and pr_extend s cl =
   let pr_arg a =
@@ -996,4 +976,4 @@ and pr_extend s cl =
 
 in pr_vernac
 
-let pr_vernac v = make_pr_vernac pr_constr_expr pr_lconstr_expr v ++ sep_end ()
+let pr_vernac v = make_pr_vernac pr_constr_expr pr_lconstr_expr v ++ sep_end v
diff --git a/parsing/ppvernac.mli b/parsing/ppvernac.mli
index e63cf7b0..6d381c72 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-2012     *)
 (*   \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,12 +15,10 @@ open Nametab
 open Util
 open Ppconstr
 open Pptactic
-open Rawterm
+open Glob_term
 open Pcoq
 open Libnames
 open Ppextend
 open Topconstr
 
-val sep_end : unit -> std_ppcmds
-
 val pr_vernac : vernac_expr -> std_ppcmds
diff --git a/parsing/prettyp.ml b/parsing/prettyp.ml
index ea97a198..99e10908 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-2012     *)
 (*   \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,14 @@ 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 e when Errors.noncritical e -> [])
+    ((<>) 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 +390,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 +420,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 +440,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 +486,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 +514,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 +530,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 +563,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 +605,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 +662,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."
@@ -721,15 +675,20 @@ let print_opaque_name qid =
         let (_,c,ty) = lookup_named id env in
 	print_named_decl (id,c,ty)
 
-let print_about_any k =
+let print_about_any loc k =
   match k with
   | Term ref ->
+    Dumpglob.add_glob loc ref;
       pr_infos_list
-       ([print_ref false ref; blankline] @
+       (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 ->
+    let () = match Syntax_def.search_syntactic_definition kn with
+    | [],Topconstr.ARef ref -> Dumpglob.add_glob loc ref
+    | _ -> () in
       v 0 (
       print_syntactic_def kn ++
       hov 0 (str "Expands to: " ++ pr_located_qualid k)) ++ fnl()
@@ -738,20 +697,11 @@ let print_about_any k =
 
 let print_about = function
   | Genarg.ByNotation (loc,ntn,sc) ->
-      print_about_any
+      print_about_any loc
         (Term (Notation.interp_notation_as_global_reference loc (fun _ -> true)
                ntn sc))
   | 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
+      print_about_any (loc_of_reference ref) (locate_any_name ref)
 
 (* for debug *)
 let inspect depth =
@@ -789,7 +739,7 @@ let print_coercions () =
 let index_of_class cl =
   try
     fst (class_info cl)
-  with _ ->
+  with e when Errors.noncritical e ->
     errorlabstrm "index_of_class"
       (pr_class cl ++ spc() ++ str "not a defined class.")
 
@@ -799,7 +749,7 @@ let print_path_between cls clt =
   let p =
     try
       lookup_path_between_class (i,j)
-    with _ ->
+    with e when Errors.noncritical e ->
       errorlabstrm "index_cl_of_id"
         (str"No path between " ++ pr_class cls ++ str" and " ++ pr_class clt
 	 ++ str ".")
diff --git a/parsing/prettyp.mli b/parsing/prettyp.mli
index fef66a63..84de2074 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-2012     *)
 (*   \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..29ebe4fa 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-2012     *)
 (*   \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,29 +19,36 @@ open Libnames
 open Nametab
 open Evd
 open Proof_type
-open Decl_mode
 open Refiner
 open Pfedit
 open Ppconstr
 open Constrextern
 open Tacexpr
+open Declarations
+
+open Store.Field
 
-let emacs_str s alts =
-  match !Flags.print_emacs, !Flags.print_emacs_safechar with
-    | true, true -> alts
-    | true , false -> s
-    | false,_ -> ""
+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                                                             *)
 
-  (* [at_top] means ids of env must be avoided in bound variables *)
-let pr_constr_core at_top env t =
-  pr_constr_expr (extern_constr at_top env t)
-let pr_lconstr_core at_top env t =
-  pr_lconstr_expr (extern_constr at_top env t)
+(* [goal_concl_style] means that all names of goal/section variables
+   and all names of rel variables (if any) in the given env and all short
+   names of global definitions of the current module must be avoided while
+   printing bound variables.
+   Otherwise, short names of global definitions are printed qualified
+   and only names of goal/section variables and rel names that do
+   _not_ occur in the scope of the binder to be printed are avoided. *)
+
+let pr_constr_core goal_concl_style env t =
+  pr_constr_expr (extern_constr goal_concl_style env t)
+let pr_lconstr_core goal_concl_style env t =
+  pr_lconstr_expr (extern_constr goal_concl_style env t)
 
-let pr_lconstr_env_at_top env = pr_lconstr_core true env
 let pr_lconstr_env env = pr_lconstr_core false env
 let pr_constr_env env = pr_constr_core false env
 
@@ -63,7 +67,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
@@ -71,12 +75,12 @@ let pr_lconstr_under_binders_env = pr_constr_under_binders_env_gen pr_lconstr_en
 let pr_constr_under_binders c = pr_constr_under_binders_env (Global.env()) c
 let pr_lconstr_under_binders c = pr_lconstr_under_binders_env (Global.env()) c
 
-let pr_type_core at_top env t =
-  pr_constr_expr (extern_type at_top env t)
-let pr_ltype_core at_top env t =
-  pr_lconstr_expr (extern_type at_top env t)
+let pr_type_core goal_concl_style env t =
+  pr_constr_expr (extern_type goal_concl_style env t)
+let pr_ltype_core goal_concl_style env t =
+  pr_lconstr_expr (extern_type goal_concl_style env t)
 
-let pr_ltype_env_at_top env = pr_ltype_core true env
+let pr_goal_concl_style_env env = pr_ltype_core true env
 let pr_ltype_env env = pr_ltype_core false env
 let pr_type_env env = pr_type_core false env
 
@@ -88,40 +92,97 @@ 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
 
+
+(** Term printers resilient to [Nametab] errors *)
+
+(** When the nametab isn't up-to-date, the term printers above
+    could raise [Not_found] during [Nametab.shortest_qualid_of_global].
+    In this case, we build here a fully-qualified name based upon
+    the kernel modpath and label of constants, and the idents in
+    the [mutual_inductive_body] for the inductives and constructors
+    (needs an environment for this). *)
+
+let id_of_global env = function
+  | ConstRef kn -> id_of_label (con_label kn)
+  | IndRef (kn,0) -> id_of_label (mind_label kn)
+  | IndRef (kn,i) ->
+    (Environ.lookup_mind kn env).mind_packets.(i).mind_typename
+  | ConstructRef ((kn,i),j) ->
+    (Environ.lookup_mind kn env).mind_packets.(i).mind_consnames.(j-1)
+  | VarRef v -> v
+
+let cons_dirpath id dp = make_dirpath (id :: repr_dirpath dp)
+
+let rec dirpath_of_mp = function
+  | MPfile sl -> sl
+  | MPbound uid -> make_dirpath [id_of_mbid uid]
+  | MPdot (mp,l) -> cons_dirpath (id_of_label l) (dirpath_of_mp mp)
+
+let dirpath_of_global = function
+  | ConstRef kn -> dirpath_of_mp (con_modpath kn)
+  | IndRef (kn,_) | ConstructRef ((kn,_),_) ->
+    dirpath_of_mp (mind_modpath kn)
+  | VarRef _ -> empty_dirpath
+
+let qualid_of_global env r =
+  Libnames.make_qualid (dirpath_of_global r) (id_of_global env r)
+
+let safe_gen f env c =
+  let orig_extern_ref = Constrextern.get_extern_reference () in
+  let extern_ref loc vars r =
+    try orig_extern_ref loc vars r
+    with e when Errors.noncritical e ->
+      Libnames.Qualid (loc, qualid_of_global env r)
+  in
+  Constrextern.set_extern_reference extern_ref;
+  try
+    let p = f env c in
+    Constrextern.set_extern_reference orig_extern_ref;
+    p
+  with e when Errors.noncritical e ->
+    Constrextern.set_extern_reference orig_extern_ref;
+    str "??"
+
+let safe_pr_lconstr_env = safe_gen pr_lconstr_env
+let safe_pr_constr_env = safe_gen pr_constr_env
+let safe_pr_lconstr t = safe_pr_lconstr_env (Global.env()) t
+let safe_pr_constr t = safe_pr_constr_env (Global.env()) t
+
+
 (**********************************************************************)
 (* Global references *)
 
 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 +190,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 +283,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 +292,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 +304,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 +319,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_goal_concl_style_env 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_goal_concl_style_env 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 +360,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,21 +376,69 @@ 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.gather_dependent_evars 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. *)
+(* spiwack: [pr_first] is true when the first goal must be singled out
+   and printed in its entirety. *)
+(* courtieu: in emacs mode, even less cases where the first goal is printed
+   in its entirety *)
+let default_pr_subgoals ?(pr_first=true) close_cmd sigma seeds stack goals =
+  let rec print_stack a = function
+    | [] -> Pp.int a
+    | b::l -> Pp.int a ++ str"-" ++ print_stack b l
+  in
+  let print_unfocused a l =
+    str"unfocused: " ++ print_stack a l
+  in
+  let rec pr_rec n = function
+    | [] -> (mt ())
+    | g::rest ->
+        let pc = pr_concl n sigma g in
+        let prest = pr_rec (n+1) rest in
+        (cut () ++ pc ++ prest)
+  in
+  let print_multiple_goals g l =
+    if pr_first then
+      default_pr_goal { it = g ; sigma = sigma } ++
+      pr_rec 2 l
+    else 
+      pr_rec 1 (g::l)
+  in
+  match goals,stack with
+  | [],_ ->
       begin
 	match close_cmd with
 	  Some cmd ->
@@ -348,38 +446,54 @@ let default_pr_subgoals close_cmd sigma = function
 	       str "." ++ fnl ())
 	| None ->
 	    let exl = Evarutil.non_instantiated sigma in
-	      if exl = [] then
-		(str"Proof completed." ++ fnl ())
-	      else
-		let pei = pr_evars_int 1 exl in
-		  (str "No more subgoals but non-instantiated existential " ++
-		     str "variables:" ++ fnl () ++ (hov 0 pei))
+	    if exl = [] then
+	      (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)
+	       ++ emacs_print_dependent_evars sigma seeds ++ fnl () ++
+                 str "You can use Grab Existential Variables.")
       end
-  | [g] ->
-      let pg = default_pr_goal g in
-      v 0 (str ("1 "^"subgoal") ++cut () ++ pg)
-  | g1::rest ->
-      let rec pr_rec n = function
-        | [] -> (mt ())
-        | g::rest ->
-            let pc = pr_concl n g in
-            let prest = pr_rec (n+1) rest in
-            (cut () ++ pc ++ prest)
-      in
-      let pg1 = default_pr_goal g1 in
-      let prest = pr_rec 2 rest in
-      v 0 (int(List.length rest+1) ++ str" subgoals" ++ cut ()
-	   ++ pg1 ++ prest ++ fnl ())
-
+  | [g],[] when not !Flags.print_emacs ->
+      let pg = default_pr_goal { it = g ; sigma = sigma } in
+      v 0 (
+	str "1 subgoal" ++ pr_goal_tag g ++ cut () ++ pg
+	++ emacs_print_dependent_evars sigma seeds
+      )
+  | [g],a::l when not !Flags.print_emacs ->
+      let pg = default_pr_goal { it = g ; sigma = sigma } in
+      v 0 (
+	str "1 focused subgoal (" ++ print_unfocused a l ++ str")" ++ pr_goal_tag g ++ cut () ++ pg
+	++ emacs_print_dependent_evars sigma seeds
+      )
+  | g1::rest,[] ->
+      let goals = print_multiple_goals g1 rest in
+      v 0 (
+	int(List.length rest+1) ++ str" subgoals" ++
+          str (emacs_str ", subgoal 1") ++ pr_goal_tag g1 ++ cut ()
+	++ goals ++ fnl ()
+	++ emacs_print_dependent_evars sigma seeds
+      )
+  | g1::rest,a::l ->
+      let goals = print_multiple_goals g1 rest in
+      v 0 (
+	int(List.length rest+1) ++ str" focused subgoals (" ++
+          print_unfocused a l ++ str")" ++ cut () ++
+          str (emacs_str ", subgoal 1") ++ pr_goal_tag g1 ++ cut ()
+	++ goals
+	++ 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            : ?pr_first:bool -> string option -> evar_map -> evar list -> int list -> goal list -> std_ppcmds;
+ pr_subgoal             : int -> evar_map -> goal list -> std_ppcmds;
+ pr_goal                : goal sigma -> std_ppcmds;
 }
 
 let default_printer_pr = {
@@ -392,7 +506,7 @@ let printer_pr = ref default_printer_pr
 
 let set_printer_pr = (:=) printer_pr
 
-let pr_subgoals x = !printer_pr.pr_subgoals x
+let pr_subgoals ?pr_first x = !printer_pr.pr_subgoals ?pr_first x
 let pr_subgoal  x = !printer_pr.pr_subgoal  x
 let pr_goal     x = !printer_pr.pr_goal     x
 
@@ -400,25 +514,43 @@ 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)
+  (* spiwack: it shouldn't be the job of the printer to look up stuff
+     in the [evar_map], I did stuff that way because it was more
+     straightforward, but seriously, [Proof.proof] should return
+     [evar_info]-s instead. *)
+  let p = Proof_global.give_me_the_proof () in
+  let (goals , stack , sigma ) = Proof.proof p in
+  let stack = List.map (fun (l,r) -> List.length l + List.length r) stack in
+  let seeds = Proof.V82.top_evars p in
+  begin match goals with
+  | [] -> let { Evd.it = bgoals ; sigma = bsigma } = Proof.V82.background_subgoals p in
+          begin match bgoals with
+	  | [] -> pr_subgoals None sigma seeds stack goals
+	  | _ ->
+	    (* emacs mode: xml-like flag for detecting information message *)
+	    str (emacs_str "<infomsg>") ++
+	    str"This subproof is complete, but there are still unfocused goals."
+	    ++ str (emacs_str "</infomsg>")
+	    ++ fnl () ++ fnl () ++ pr_subgoals ~pr_first:false None bsigma seeds [] bgoals
+	  end
+  | _ -> pr_subgoals None sigma seeds stack 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 +590,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,_) ->
@@ -515,7 +647,7 @@ let pr_assumptionset env s =
 	str (string_of_mp mp ^ "." ^ string_of_label lab)
     in
     let safe_pr_ltype typ =
-      try str " : " ++ pr_ltype typ with _ -> mt ()
+      try str " : " ++ pr_ltype typ with e when Errors.noncritical e -> mt ()
     in
     let (vars,axioms,opaque) =
       ContextObjectMap.fold (fun t typ r ->
@@ -570,3 +702,89 @@ let pr_instance_gmap insts =
   prlist_with_sep fnl (fun (gr, insts) ->
     prlist_with_sep fnl pr_instance (cmap_to_list insts))
     (Gmap.to_list insts)
+
+(** Inductive declarations *)
+
+open Termops
+open Reduction
+open Inductive
+open Inductiveops
+
+let print_params env params =
+  if params = [] then mt () else pr_rel_context env params ++ brk(1,2)
+
+let 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..3abe90e7 100644
--- a/parsing/printer.mli
+++ b/parsing/printer.mli
@@ -1,41 +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-2012     *)
 (*   \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
 val pr_lconstr             : constr -> std_ppcmds
 
 val pr_constr_env          : env -> constr -> std_ppcmds
 val pr_constr              : constr -> std_ppcmds
 
+(** Same, but resilient to [Nametab] errors. Prints fully-qualified
+    names when [shortest_qualid_of_global] has failed. Prints "??"
+    in case of remaining issues (such as reference not in env). *)
+
+val safe_pr_lconstr_env         : env -> constr -> std_ppcmds
+val safe_pr_lconstr             : constr -> std_ppcmds
+
+val safe_pr_constr_env          : env -> constr -> std_ppcmds
+val safe_pr_constr              : constr -> std_ppcmds
+
+
 val pr_open_constr_env     : env -> open_constr -> std_ppcmds
 val pr_open_constr         : open_constr -> std_ppcmds
 
@@ -48,7 +54,7 @@ val pr_constr_under_binders      : constr_under_binders -> std_ppcmds
 val pr_lconstr_under_binders_env : env -> constr_under_binders -> std_ppcmds
 val pr_lconstr_under_binders     : constr_under_binders -> std_ppcmds
 
-val pr_ltype_env_at_top    : env -> types -> std_ppcmds
+val pr_goal_concl_style_env : env -> types -> std_ppcmds
 val pr_ltype_env           : env -> types -> std_ppcmds
 val pr_ltype               : types -> std_ppcmds
 
@@ -58,11 +64,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 +80,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 +91,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 +104,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            : ?pr_first:bool -> string option -> evar_map -> evar list -> int list -> goal list -> std_ppcmds
+val pr_subgoal             : int -> evar_map -> goal list -> std_ppcmds
+val pr_concl               : int -> evar_map -> goal -> std_ppcmds
 
 val pr_open_subgoals       : unit -> std_ppcmds
 val pr_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            : ?pr_first:bool -> string option -> evar_map -> evar list -> int 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 +162,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..b46cf42d 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-2012     *)
 (*   \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,162 @@ 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
+(** Each time we have to print a non-globally visible structure,
+    we place its elements in a fake fresh namespace. *)
 
-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
+let mk_fake_top =
+  let r = ref 0 in
+  fun () -> incr r; id_of_string ("FAKETOP"^(string_of_int !r))
+
+let nametab_register_dir mp =
+  let id = mk_fake_top () in
+  let dir = make_dirpath [id] in
+  Nametab.push_dir (Nametab.Until 1) dir (DirModule (dir,(mp,empty_dirpath)))
 
-  let modtype = 
-    match mb.mod_type with
-    | t -> spc () ++ str": " ++ 
-	print_modtype locals t
+(** Nota: the [global_reference] we register in the nametab below
+    might differ from internal ones, since we cannot recreate here
+    the canonical part of constant and inductive names, but only
+    the user names. This works nonetheless since we search now
+    [Nametab.the_globrevtab] modulo user name. *)
+
+let nametab_register_body mp dir (l,body) =
+  let push id ref =
+    Nametab.push (Nametab.Until (1+List.length (repr_dirpath dir)))
+      (make_path dir id) ref
   in
-    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 nametab_register_module_body mp struc =
+  (* If [mp] is a globally visible module, we simply import it *)
+  try Declaremods.really_import_module mp
+  with Not_found ->
+    (* Otherwise we try to emulate an import by playing with nametab *)
+    nametab_register_dir mp;
+    List.iter (nametab_register_body mp empty_dirpath) struc
+
+let nametab_register_module_param mbid seb =
+  (* For algebraic seb, we use a Declaremods function that converts into mse *)
+  try Declaremods.process_module_seb_binding mbid seb
+  with e when Errors.noncritical e ->
+    (* Otherwise, for expanded structure, we try to play with the nametab *)
+    match seb with
+      | SEBstruct struc ->
+        let mp = MPbound mbid in
+        let dir = make_dirpath [id_of_mbid mbid] in
+        nametab_register_dir mp;
+        List.iter (nametab_register_body mp dir) struc
+      | _ -> ()
+
+let print_body is_impl env mp (l,body) =
+  let name = str (string_of_label l) in
+  hov 2 (match body with
+    | SFBmodule _ -> str "Module " ++ name
+    | SFBmodtype _ -> str "Module Type " ++ name
+    | SFBconst cb ->
+      (match cb.const_body with
+	| Def _ -> str "Definition "
+	| OpaqueDef _ when is_impl -> str "Theorem "
+	| _ -> str "Parameter ") ++ name ++
+      (match env with
+	  | None -> mt ()
+	  | Some env ->
+	    str " :" ++ spc () ++
+	    hov 0 (Printer.pr_ltype_env env
+		     (Typeops.type_of_constant_type env cb.const_type)) ++
+	    (match cb.const_body with
+	      | Def l when is_impl ->
+		spc () ++
+		hov 2 (str ":= " ++
+		       Printer.pr_lconstr_env env (Declarations.force l))
+	      | _ -> mt ()) ++
+            str ".")
+    | SFBmind mib ->
+      try
+	let env = Option.get env in
+	Printer.pr_mutual_inductive_body env (make_mind mp empty_dirpath l) mib
+      with e when Errors.noncritical e ->
+	(if mib.mind_finite then str "Inductive " else str "CoInductive")
+	++ name)
+
+let print_struct is_impl env mp struc =
+  prlist_with_sep spc (print_body is_impl env mp) struc
+
+let rec flatten_app mexpr l = match mexpr with
+  | SEBapply (mexpr, SEBident arg,_) -> flatten_app mexpr (arg::l)
+  | SEBident mp -> mp::l
+  | _ -> assert false
 
-and print_modtype locals mty =
+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
+      nametab_register_module_param mbid seb1;
+      hov 2 (str "Funsig" ++ spc () ++ str "(" ++
+	       pr_id (id_of_mbid mbid) ++ str ":" ++
+	       print_modtype env mp1 locals seb1 ++
+	       str ")" ++ spc() ++ print_modtype env' mp locals' mtb2)
+  | SEBstruct (sign) ->
+      let env' = Option.map
+	(Modops.add_signature mp sign Mod_subst.empty_delta_resolver) env in
+      nametab_register_module_body mp sign;
+      hv 2 (str "Sig" ++ spc () ++ print_struct false env' mp sign ++
+	    brk (1,-2) ++ str "End")
+  | SEBapply _ ->
+      let lapp = flatten_app mty [] in
       let fapp = List.hd lapp in
       let mapp = List.tl lapp in
-	hov 3 (str"(" ++ (print_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
+      nametab_register_module_param mbid typ;
       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
+      nametab_register_module_body mp struc;
+      hv 2 (str "Struct" ++ spc () ++ print_struct true env' mp struc ++
+	    brk (1,-2) ++ str "End")
+  | SEBapply _ ->
+      let lapp = flatten_app mexpr [] in
+      hov 3 (str"(" ++ prlist_with_sep spc (print_modpath locals) lapp ++ str")")
+  | SEBwith (_,_)-> anomaly "Not available yet"
 
 
 let rec printable_body dir =
@@ -146,13 +237,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 (fun e -> eval_ppcmds (print_modexpr env mp [] e)) mexpr
+let print_modtype' env mp mty =
+  States.with_state_protection (fun e -> eval_ppcmds (print_modtype env mp [] e)) mty
+
+let print_module' env mp with_body mb =
   let name = print_modpath [] mp in
-    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 e when Errors.noncritical e ->
+    print_module' None mp with_body me ++ fnl ()
 
 let print_modtype kn =
   let mtb = Global.lookup_modtype kn in
   let name = print_kn [] kn in
-      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 e when Errors.noncritical e ->
+	print_modtype' None kn mtb.typ_expr))
diff --git a/parsing/printmod.mli b/parsing/printmod.mli
index 77ff34f1..17ad6b25 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-2012     *)
 (*   \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..dfe7d9c0 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-2012     *)
 (*   \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..02311fe4 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-2012     *)
 (*   \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
 
@@ -289,6 +273,11 @@ let mlexpr_of_message_token = function
   | Tacexpr.MsgInt n -> <:expr< Tacexpr.MsgInt $mlexpr_of_int n$ >>
   | Tacexpr.MsgIdent id -> <:expr< Tacexpr.MsgIdent $mlexpr_of_hyp id$ >>
 
+let mlexpr_of_debug = function
+  | Tacexpr.Off -> <:expr< Tacexpr.Off >>
+  | Tacexpr.Debug -> <:expr< Tacexpr.Debug >>
+  | Tacexpr.Info -> <:expr< Tacexpr.Info >>
+
 let rec mlexpr_of_atomic_tactic = function
   (* Basic tactics *)
   | Tacexpr.TacIntroPattern pl ->
@@ -354,11 +343,13 @@ let rec mlexpr_of_atomic_tactic = function
                 (mlexpr_of_pair mlexpr_of_occ_constr mlexpr_of_name) cl$ >>
   | Tacexpr.TacGeneralizeDep c ->
       <:expr< Tacexpr.TacGeneralizeDep $mlexpr_of_constr c$ >>
-  | Tacexpr.TacLetTac (na,c,cl,b) ->
+  | Tacexpr.TacLetTac (na,c,cl,b,e) ->
       let na = mlexpr_of_name na in
       let cl = mlexpr_of_clause_pattern cl in
       <:expr< Tacexpr.TacLetTac $na$ $mlexpr_of_constr c$ $cl$
-	      $mlexpr_of_bool b$ >>
+	      $mlexpr_of_bool b$
+	      (mlexpr_of_option (mlexpr_of_located mlexpr_of_intro_pattern) e)
+      >>
 
   (* Derived basic tactics *)
   | Tacexpr.TacSimpleInductionDestruct (isrec,h) ->
@@ -366,13 +357,15 @@ let rec mlexpr_of_atomic_tactic = function
                   $mlexpr_of_quantified_hypothesis h$ >>
   | Tacexpr.TacInductionDestruct (isrec,ev,l) ->
       <:expr< Tacexpr.TacInductionDestruct $mlexpr_of_bool isrec$ $mlexpr_of_bool ev$
-	$mlexpr_of_pair (mlexpr_of_list (mlexpr_of_triple
-	  (mlexpr_of_list mlexpr_of_induction_arg)
-	  (mlexpr_of_option mlexpr_of_constr_with_binding)
-	  (mlexpr_of_pair
-	    (mlexpr_of_option (mlexpr_of_located mlexpr_of_intro_pattern))
-	    (mlexpr_of_option (mlexpr_of_located mlexpr_of_intro_pattern)))))
-	  (mlexpr_of_option mlexpr_of_clause) l$ >>
+	$mlexpr_of_triple
+	(mlexpr_of_list
+	   (mlexpr_of_pair
+	      mlexpr_of_induction_arg
+	      (mlexpr_of_pair
+		 (mlexpr_of_option (mlexpr_of_located mlexpr_of_intro_pattern))
+		 (mlexpr_of_option (mlexpr_of_located mlexpr_of_intro_pattern)))))
+	(mlexpr_of_option mlexpr_of_constr_with_binding)
+	(mlexpr_of_option mlexpr_of_clause) l$ >>
 
   (* Context management *)
   | Tacexpr.TacClear (b,l) ->
@@ -397,7 +390,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 *)
@@ -415,22 +408,18 @@ let rec mlexpr_of_atomic_tactic = function
   | Tacexpr.TacTransitivity c -> <:expr< Tacexpr.TacTransitivity $mlexpr_of_option mlexpr_of_constr c$ >>
 
   (* Automation tactics *)
-  | Tacexpr.TacAuto (n,lems,l) ->
+  | Tacexpr.TacAuto (debug,n,lems,l) ->
+      let d = mlexpr_of_debug debug in
       let n = mlexpr_of_option (mlexpr_of_or_var mlexpr_of_int) n in
       let lems = mlexpr_of_list mlexpr_of_constr lems in
       let l = mlexpr_of_option (mlexpr_of_list mlexpr_of_string) l in
-      <:expr< Tacexpr.TacAuto $n$ $lems$ $l$ >>
-  | Tacexpr.TacTrivial (lems,l) ->
+      <:expr< Tacexpr.TacAuto $d$ $n$ $lems$ $l$ >>
+  | Tacexpr.TacTrivial (debug,lems,l) ->
+      let d = mlexpr_of_debug debug in
       let l = mlexpr_of_option (mlexpr_of_list mlexpr_of_string) l in
       let lems = mlexpr_of_list mlexpr_of_constr lems in
-      <:expr< Tacexpr.TacTrivial $lems$ $l$ >>
+      <:expr< Tacexpr.TacTrivial $d$ $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 +439,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 +476,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 +486,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 +497,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 +546,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..7fe5a3c4 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-2012     *)
 (*   \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..527cc6b2 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-2012     *)
 (*   \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 2fbe3f44..77364180 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-2012     *)
 (*   \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 15043 2012-03-18 13:57:01Z 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
@@ -131,28 +119,42 @@ let make_one_printing_rule se (pt,e) =
 
 let make_printing_rule se = mlexpr_of_list (make_one_printing_rule se)
 
-let rec contains_epsilon loc = function
-  | List0ArgType _ as t ->
-      <:expr< Genarg.in_gen $make_globwit loc t$ [] >>
-  | List1ArgType t' as t ->
-      <:expr< Genarg.in_gen $make_globwit loc t$
-         [out_gen $make_globwit loc t'$ $contains_epsilon loc t'$] >>
-  | OptArgType _ as t ->
-      <:expr< Genarg.in_gen $make_globwit loc t$ None >>
-(*  | PairArgType(t1,t2) -> contains_epsilon t1 && contains_epsilon t2*)
-  | ExtraArgType("hintbases") as t ->
-      <:expr< Genarg.in_gen $make_globwit loc t$ (Some []) >> (* fragile *)
-  | _ -> raise Exit
-
-let is_atomic loc = function
-  | GramTerminal s :: l ->
-     (try
+let rec possibly_empty_subentries loc = function
+  | [] -> []
+  | (s,prodsl) :: l ->
+    let rec aux = function
+    | [] -> (false,<:expr< None >>)
+    | prods :: rest ->
+      try
         let l = List.map (function
-          GramTerminal _ -> raise Exit
-	| GramNonTerminal(_,t,_,_) -> contains_epsilon loc t) l
-        in [<:expr< ($str:s$, $mlexpr_of_list (fun x -> x) l$) >>]
-      with Exit -> [])
-  | _ -> []
+        | GramNonTerminal(_,(List0ArgType _|
+                             OptArgType _|
+                             ExtraArgType _ as t),_,_)->
+            (* This possibly parses epsilon *)
+            let rawwit = make_rawwit loc t in
+            <:expr< match Genarg.default_empty_value $rawwit$ with
+                    [ None -> failwith ""
+                    | Some v ->
+                        Tacinterp.intern_genarg Tacinterp.fully_empty_glob_sign
+                          (Genarg.in_gen $rawwit$ v) ] >>
+        | GramTerminal _ | GramNonTerminal(_,_,_,_) ->
+            (* This does not parse epsilon (this Exit is static time) *)
+             raise Exit) prods in
+        if has_extraarg prods then
+          (true,<:expr< try Some $mlexpr_of_list (fun x -> x) l$
+                        with [ Failure "" -> $snd (aux rest)$ ] >>)
+        else
+          (true, <:expr< Some $mlexpr_of_list (fun x -> x) l$ >>)
+      with Exit -> aux rest in
+    let (nonempty,v) = aux prodsl in
+    if nonempty then (s,v) :: possibly_empty_subentries loc l
+    else possibly_empty_subentries loc l
+
+let possibly_atomic loc prods =
+  let l = list_map_filter (function
+    | GramTerminal s :: l, _ -> Some (s,l)
+    | _ -> None) prods in
+  possibly_empty_subentries loc (list_factorize_left l)
 
 let declare_tactic loc s cl =
   let se = mlexpr_of_string s in
@@ -171,32 +173,37 @@ let declare_tactic loc s cl =
   in
   let hidden = if List.length cl = 1 then List.map hide_tac cl else [] in
   let atomic_tactics =
-    mlexpr_of_list (fun x -> x)
-      (List.flatten (List.map (fun (al,_) -> is_atomic loc al) cl)) in
-  <:str_item<
-    declare
-      open Pcoq;
-      open Extrawit;
-      declare $list:hidden$ end;
+    mlexpr_of_list (mlexpr_of_pair mlexpr_of_string (fun x -> x))
+      (possibly_atomic loc cl) in
+  declare_str_items loc
+   (hidden @
+    [ <:str_item< do {
       try
-        let _=Tacinterp.add_tactic $se$ (fun [ $list:make_clauses s cl$ ]) in
+        let _=Tacinterp.add_tactic $se$ $make_fun_clauses loc s cl$ in
         List.iter
-          (fun (s,l) -> Tacinterp.add_primitive_tactic s
+          (fun (s,l) -> match l with
+           [ Some l ->
+              Tacinterp.add_primitive_tactic s
               (Tacexpr.TacAtom($default_loc$,
-                 Tacexpr.TacExtend($default_loc$,$se$,l))))
+                 Tacexpr.TacExtend($default_loc$,$se$,l)))
+           | None -> () ])
           $atomic_tactics$
-      with e -> Pp.pp (Cerrors.explain_exn e);
+      with [ e when Errors.noncritical e ->
+	    Pp.msg_warning
+	      (Stream.iapp
+	        (Pp.str ("Exception in tactic extend " ^ $se$ ^": "))
+	        (Errors.print e)) ];
       Egrammar.extend_tactic_grammar $se$ $gl$;
-      List.iter Pptactic.declare_extra_tactic_pprule $pp$;
-    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 ] ]
@@ -222,5 +229,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..eaab1445 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-2012     *)
 (*   \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..1c045e62 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-2012     *)
 (*   \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..cf24aa5f
--- /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-2012     *)
+(*   \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..a1ecd2c6
--- /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-2012     *)
+(*   \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..bcdf7cff 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-2012     *)
 (*   \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,37 @@ 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 se = mlexpr_of_string s in
   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 $se$ $funcl$
+	with [ e when Errors.noncritical e ->
+	  Pp.msg_warning
+	    (Stream.iapp
+	       (Pp.str ("Exception in vernac extend " ^ $se$ ^": "))
+	       (Errors.print e)) ];
+	Egrammar.extend_vernac_command_grammar $se$ $nt$ $gl$
+      } >> ]
 
 open Pcaml
+open PcamlSig
 
 EXTEND
   GLOBAL: str_item;
@@ -72,13 +72,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..1c021eee 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-2012     *)
 (*   \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}
 
@@ -366,7 +404,8 @@ let rec canonize_name c =
 let build_subst uf subst =
   Array.map (fun i ->
 	       try term uf i
-	       with _ -> anomaly "incomplete matching") subst
+	       with e when Errors.noncritical e ->
+                 anomaly "incomplete matching") subst
 
 let rec inst_pattern subst = function
     PVar i ->
@@ -384,7 +423,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 +469,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 +480,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 +500,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 +515,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 +571,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 +730,9 @@ 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 gls = Goal.V82.new_goal_with sigma gl [id,None,typ] in
+    state.gls<- gls;
     id
 
 let complete_one_class state i=
@@ -763,14 +800,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 +825,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 +847,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 +870,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..9653da2c 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-2012     *)
 (*   \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..c5bbd105 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-2012     *)
 (*   \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..b8a8d229 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-2012     *)
 (*   \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..764e36b0 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-2012     *)
 (*   \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
@@ -38,11 +35,11 @@ let _f_equal = constant ["Init";"Logic"] "f_equal"
 
 let _eq_rect = constant ["Init";"Logic"] "eq_rect"
 
-let _refl_equal = constant ["Init";"Logic"] "refl_equal"
+let _refl_equal = constant ["Init";"Logic"] "eq_refl"
 
-let _sym_eq = constant ["Init";"Logic"] "sym_eq"
+let _sym_eq = constant ["Init";"Logic"] "eq_sym"
 
-let _trans_eq = constant ["Init";"Logic"] "trans_eq"
+let _trans_eq = constant ["Init";"Logic"] "eq_trans"
 
 let _eq = constant ["Init";"Logic"] "eq"
 
@@ -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
@@ -132,7 +129,9 @@ let non_trivial = function
 
 let patterns_of_constr env sigma nrels term=
   let f,args=
-    try destApp (whd_delta env term) with _ -> raise Not_found in
+    try destApp (whd_delta env term)
+    with e when Errors.noncritical e -> raise Not_found
+  in
 	if eq_constr f (Lazy.force _eq) && (Array.length args)=3
 	then
 	  let patt1,rels1 = pattern_of_constr env sigma args.(1)
@@ -214,9 +213,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 +259,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 +280,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 +310,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 +320,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 +331,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 +351,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 +413,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 +455,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..365c172c 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-2012     *)
 (*   \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..c9805f02 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-2012     *)
 (*   \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..69b0a0e3 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-2012     *)
 (*   \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..7637fed2 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-2012     *)
 (*   \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..bd6ed064 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-2012     *)
 (*   \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..da88d48d 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-2012     *)
 (*   \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 ()
+
+
+(* Current proof mode *)
+
+type command_mode =
+    Mode_tactic
+  | Mode_proof
+  | Mode_none
 
-let pm_in,pm_out = Dyn.create "pm_info"
+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 e when Errors.noncritical e -> Mode_none
 
-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"
+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..f23a97b4 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-2012     *)
 (*   \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..ab161b35 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-2012     *)
 (*   \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,17 +371,17 @@ 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
 	      dfs (pred n)
-      with _ ->
+      with e when Errors.noncritical e ->
 	begin
 	  enstack_subsubgoals env se stack gls;
 	  dfs n
@@ -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 ->
@@ -548,7 +519,10 @@ let decompose_eq id gls =
 
 let instr_rew _thus rew_side cut gls0 =
   let last_id =
-    try get_last (pf_env gls0) with _ -> error "No previous equality." in
+    try get_last (pf_env gls0)
+    with e when Errors.noncritical e ->
+      error "No previous equality."
+  in
   let typ,lhs,rhs = decompose_eq last_id gls0 in
   let items_tac gls =
     match cut.cut_by with
@@ -602,8 +576,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 +804,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 =
@@ -878,7 +852,7 @@ let build_per_info etype casee gls =
   let ind =
     try
       destInd hd
-    with _ ->
+    with e when Errors.noncritical e ->
       error "Case analysis must be done on an inductive object." in
   let mind,oind = Global.lookup_inductive ind in
   let nparams,index =
@@ -1316,15 +1290,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 +1369,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 +1422,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..775d2f53 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-2012     *)
 (*   \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..5699c1bf
--- /dev/null
+++ b/plugins/decl_mode/g_decl_mode.ml4
@@ -0,0 +1,409 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*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_goal_concl_style_env 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 None "proof_instr"
+let _ = Tacinterp.add_interp_genarg "proof_instr"
+  begin
+  begin fun e x -> (* declares the globalisation function *)
+    Genarg.in_gen globwit_proof_instr 
+      (Decl_interp.intern_proof_instr e (Genarg.out_gen rawwit_proof_instr x))
+  end,
+  begin fun ist gl x -> (* declares the interpretation function *)
+    Tacmach.project gl ,
+    Genarg.in_gen wit_proof_instr 
+      (interp_proof_instr ist gl (Genarg.out_gen globwit_proof_instr x))
+  end,
+  begin fun _ x -> x end (* declares the substitution function, irrelevant in our case *)
+   end
+
+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..7ba0d4ff 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-2012     *)
 (*   \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
deleted file mode 100644
index 5ddc4452..00000000
--- a/plugins/dp/Dp.v
+++ /dev/null
@@ -1,120 +0,0 @@
-(* Calls to external decision procedures *)
-
-Require Export ZArith.
-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.
-
-Lemma zenon_noteq : forall (T : Type) (t : T),
-  ((t <> t) -> False).
-Proof. tauto. Qed.
-
-Lemma zenon_and : forall P Q : Prop,
-  (P -> Q -> False) -> (P /\ Q -> False).
-Proof. tauto. Qed.
-
-Lemma zenon_or : forall P Q : Prop,
-  (P -> False) -> (Q -> False) -> (P \/ Q -> False).
-Proof. tauto. Qed.
-
-Lemma zenon_imply : forall P Q : Prop,
-  (~P -> False) -> (Q -> False) -> ((P -> Q) -> False).
-Proof. tauto. Qed.
-
-Lemma zenon_equiv : forall P Q : Prop,
-  (~P -> ~Q -> False) -> (P -> Q -> False) -> ((P <-> Q) -> False).
-Proof. tauto. Qed.
-
-Lemma zenon_notand : forall P Q : Prop,
-  (~P -> False) -> (~Q -> False) -> (~(P /\ Q) -> False).
-Proof. tauto. Qed.
-
-Lemma zenon_notor : forall P Q : Prop,
-  (~P -> ~Q -> False) -> (~(P \/ Q) -> False).
-Proof. tauto. Qed.
-
-Lemma zenon_notimply : forall P Q : Prop,
-  (P -> ~Q -> False) -> (~(P -> Q) -> False).
-Proof. tauto. Qed.
-
-Lemma zenon_notequiv : forall P Q : Prop,
-  (~P -> Q -> False) -> (P -> ~Q -> False) -> (~(P <-> Q) -> False).
-Proof. tauto. Qed.
-
-Lemma zenon_ex : forall (T : Type) (P : T -> Prop),
-  (forall z : T, ((P z) -> False)) -> ((exists x : T, (P x)) -> False).
-Proof. firstorder. Qed.
-
-Lemma zenon_all : forall (T : Type) (P : T -> Prop) (t : T),
-  ((P t) -> False) -> ((forall x : T, (P x)) -> False).
-Proof. firstorder. Qed.
-
-Lemma zenon_notex : forall (T : Type) (P : T -> Prop) (t : T),
-  (~(P t) -> False) -> (~(exists x : T, (P x)) -> False).
-Proof. firstorder. Qed.
-
-Lemma zenon_notall : forall (T : Type) (P : T -> Prop),
-  (forall z : T, (~(P z) -> False)) -> (~(forall x : T, (P x)) -> False).
-Proof. intros T P Ha Hb. apply Hb. intro. apply NNPP. exact (Ha x). Qed.
-
-Lemma zenon_equal_base : forall (T : Type) (f : T), f = f.
-Proof. auto. Qed.
-
-Lemma zenon_equal_step :
-  forall (S T : Type) (fa fb : S -> T) (a b : S),
-  (fa = fb) -> (a <> b -> False) -> ((fa a) = (fb b)).
-Proof. intros. rewrite (NNPP (a = b)). congruence. auto. Qed.
-
-Lemma zenon_pnotp : forall P Q : Prop,
-  (P = Q) -> (P -> ~Q -> False).
-Proof. intros P Q Ha. rewrite Ha. auto. Qed.
-
-Lemma zenon_notequal : forall (T : Type) (a b : T),
-  (a = b) -> (a <> b -> False).
-Proof. auto. Qed.
-
-Ltac zenon_intro id :=
-  intro id || let nid := fresh in (intro nid; clear nid)
-.
-
-Definition zenon_and_s := fun P Q a b => zenon_and P Q b a.
-Definition zenon_or_s := fun P Q a b c => zenon_or P Q b c a.
-Definition zenon_imply_s := fun P Q a b c => zenon_imply P Q b c a.
-Definition zenon_equiv_s := fun P Q a b c => zenon_equiv P Q b c a.
-Definition zenon_notand_s := fun P Q a b c => zenon_notand P Q b c a.
-Definition zenon_notor_s := fun P Q a b => zenon_notor P Q b a.
-Definition zenon_notimply_s := fun P Q a b => zenon_notimply P Q b a.
-Definition zenon_notequiv_s := fun P Q a b c => zenon_notequiv P Q b c a.
-Definition zenon_ex_s := fun T P a b => zenon_ex T P b a.
-Definition zenon_notall_s := fun T P a b => zenon_notall T P b a.
-
-Definition zenon_pnotp_s := fun P Q a b c => zenon_pnotp P Q c a b.
-Definition zenon_notequal_s := fun T a b x y => zenon_notequal T a b y x.
-
-(* Ergo *)
-
-Set Implicit Arguments.
-Section congr.
-  Variable t:Type.
-Lemma ergo_eq_concat_1 :
-  forall (P:t -> Prop) (x y:t),
-    P x -> x = y -> P y.
-Proof.
-  intros; subst; auto.
-Qed.
-
-Lemma ergo_eq_concat_2 :
-  forall (P:t -> t -> Prop) (x1 x2 y1 y2:t),
-    P x1 x2 -> x1 = y1 -> x2 = y2 -> P y1 y2.
-Proof.
-  intros; subst; auto.
-Qed.
-
-End congr.
diff --git a/plugins/dp/TODO b/plugins/dp/TODO
deleted file mode 100644
index 44349e21..00000000
--- a/plugins/dp/TODO
+++ /dev/null
@@ -1,24 +0,0 @@
-
-TODO
-----
-
-- axiomes pour les prédicats récursifs comme
-
-  Fixpoint even (n:nat) : Prop :=
-  match n with 
-  O => True
-  | S O => False
-  | S (S p) => even p
-  end.
-
-  ou encore In sur les listes du module Coq List.
-
-- discriminate
-
-- inversion (Set et Prop)
-
-
-BUGS
-----
-
-
diff --git a/plugins/dp/dp.ml b/plugins/dp/dp.ml
deleted file mode 100644
index ceadd26e..00000000
--- a/plugins/dp/dp.ml
+++ /dev/null
@@ -1,1134 +0,0 @@
-(* Authors: Nicolas Ayache and Jean-Christophe Filliâtre *)
-(* Tactics to call decision procedures *)
-
-(* Works in two steps:
-
-   - first the Coq context and the current goal are translated in
-     Polymorphic First-Order Logic (see fol.mli in this directory)
-
-   - then the resulting query is passed to the Why tool that translates
-     it to the syntax of the selected prover (Simplify, CVC Lite, haRVey,
-     Zenon)
-*)
-
-open Util
-open Pp
-open Libobject
-open Summary
-open Term
-open Tacmach
-open Tactics
-open Tacticals
-open Fol
-open Names
-open Nameops
-open Namegen
-open Termops
-open Coqlib
-open Hipattern
-open Libnames
-open Declarations
-open Dp_why
-
-let debug = ref false
-let set_debug b = debug := b
-let trace = ref false
-let set_trace b = trace := b
-let timeout = ref 10
-let set_timeout n = timeout := n
-
-let (dp_timeout_obj,_) =
-  declare_object
-    {(default_object "Dp_timeout") with
-       cache_function = (fun (_,x) -> set_timeout x);
-       load_function = (fun _ (_,x) -> set_timeout x)}
-
-let dp_timeout x = Lib.add_anonymous_leaf (dp_timeout_obj x)
-
-let (dp_debug_obj,_) =
-  declare_object
-    {(default_object "Dp_debug") with
-       cache_function = (fun (_,x) -> set_debug x);
-       load_function = (fun _ (_,x) -> set_debug x)}
-
-let dp_debug x = Lib.add_anonymous_leaf (dp_debug_obj x)
-
-let (dp_trace_obj,_) =
-  declare_object
-    {(default_object "Dp_trace") with
-       cache_function = (fun (_,x) -> set_trace x);
-       load_function = (fun _ (_,x) -> set_trace x)}
-
-let dp_trace x = Lib.add_anonymous_leaf (dp_trace_obj x)
-
-let logic_dir = ["Coq";"Logic";"Decidable"]
-let coq_modules =
-  init_modules @ [logic_dir] @ arith_modules @ zarith_base_modules
-    @ [["Coq"; "ZArith"; "BinInt"];
-       ["Coq"; "Reals"; "Rdefinitions"];
-       ["Coq"; "Reals"; "Raxioms";];
-       ["Coq"; "Reals"; "Rbasic_fun";];
-       ["Coq"; "Reals"; "R_sqrt";];
-       ["Coq"; "Reals"; "Rfunctions";]]
-    @ [["Coq"; "omega"; "OmegaLemmas"]]
-
-let constant = gen_constant_in_modules "dp" coq_modules
-
-(* integers constants and operations *)
-let coq_Z = lazy (constant "Z")
-let coq_Zplus = lazy (constant "Zplus")
-let coq_Zmult = lazy (constant "Zmult")
-let coq_Zopp = lazy (constant "Zopp")
-let coq_Zminus = lazy (constant "Zminus")
-let coq_Zdiv = lazy (constant "Zdiv")
-let coq_Zs = lazy (constant "Zs")
-let coq_Zgt = lazy (constant "Zgt")
-let coq_Zle = lazy (constant "Zle")
-let coq_Zge = lazy (constant "Zge")
-let coq_Zlt = lazy (constant "Zlt")
-let coq_Z0 = lazy (constant "Z0")
-let coq_Zpos = lazy (constant "Zpos")
-let coq_Zneg = lazy (constant "Zneg")
-let coq_xH = lazy (constant "xH")
-let coq_xI = lazy (constant "xI")
-let coq_xO = lazy (constant "xO")
-let coq_iff = lazy (constant "iff")
-
-(* real constants and operations *)
-let coq_R = lazy (constant "R")
-let coq_R0 = lazy (constant "R0")
-let coq_R1 = lazy (constant "R1")
-let coq_Rgt = lazy (constant "Rgt")
-let coq_Rle = lazy (constant "Rle")
-let coq_Rge = lazy (constant "Rge")
-let coq_Rlt = lazy (constant "Rlt")
-let coq_Rplus = lazy (constant "Rplus")
-let coq_Rmult = lazy (constant "Rmult")
-let coq_Ropp = lazy (constant "Ropp")
-let coq_Rminus = lazy (constant "Rminus")
-let coq_Rdiv = lazy (constant "Rdiv")
-let coq_powerRZ = lazy (constant "powerRZ")
-
-(* not Prop typed expressions *)
-exception NotProp
-
-(* not first-order expressions *)
-exception NotFO
-
-(* Renaming of Coq globals *)
-
-let global_names = Hashtbl.create 97
-let used_names = Hashtbl.create 97
-
-let rename_global r =
-  try
-    Hashtbl.find global_names r
-  with Not_found ->
-    let rec loop id =
-      if Hashtbl.mem used_names id then
-	loop (lift_subscript id)
-      else begin
-	Hashtbl.add used_names id ();
-	let s = string_of_id id in
-	Hashtbl.add global_names r s;
-	s
-      end
-    in
-    loop (Nametab.basename_of_global r)
-
-let foralls =
-  List.fold_right
-    (fun (x,t) p -> Forall (x, t, p))
-
-let fresh_var = function
-  | Anonymous -> rename_global (VarRef (id_of_string "x"))
-  | Name x -> rename_global (VarRef x)
-
-(* coq_rename_vars env [(x1,t1);...;(xn,tn)] renames the xi outside of
-   env names, and returns the new variables together with the new
-   environment *)
-let coq_rename_vars env vars =
-  let avoid = ref (ids_of_named_context (Environ.named_context env)) in
-  List.fold_right
-    (fun (na,t) (newvars, newenv) ->
-       let id = next_name_away na !avoid in
-       avoid := id :: !avoid;
-       id :: newvars, Environ.push_named (id, None, t) newenv)
-    vars ([],env)
-
-(* extract the prenex type quantifications i.e.
-   type_quantifiers env (A1:Set)...(Ak:Set)t = A1...An, (env+Ai), t *)
-let decomp_type_quantifiers env t =
-  let rec loop vars t = match kind_of_term t with
-    | Prod (n, a, t) when is_Set a || is_Type a ->
-	loop ((n,a) :: vars) t
-    | _ ->
-	let vars, env = coq_rename_vars env vars in
-	let t = substl (List.map mkVar vars) t in
-	List.rev vars, env, t
-  in
-  loop [] t
-
-(* same thing with lambda binders (for axiomatize body) *)
-let decomp_type_lambdas env t =
-  let rec loop vars t = match kind_of_term t with
-    | Lambda (n, a, t) when is_Set a || is_Type a ->
-	loop ((n,a) :: vars) t
-    | _ ->
-	let vars, env = coq_rename_vars env vars in
-	let t = substl (List.map mkVar vars) t in
-	List.rev vars, env, t
-  in
-  loop [] t
-
-let decompose_arrows =
-  let rec arrows_rec l c = match kind_of_term c with
-    | Prod (_,t,c) when not (dependent (mkRel 1) c) -> arrows_rec (t :: l) c
-    | Cast (c,_,_) -> arrows_rec l c
-    | _ -> List.rev l, c
-  in
-  arrows_rec []
-
-let rec eta_expanse t vars env i =
-  assert (i >= 0);
-  if i = 0 then
-    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
-	  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
-	  eta_expanse t' (id :: vars) env' (pred i)
-      | _ ->
-	  assert false
-
-let rec skip_k_args k cl = match k, cl with
-  | 0, _ -> cl
-  | _, _ :: cl -> skip_k_args (k-1) cl
-  | _, [] -> raise NotFO
-
-(* Coq global references *)
-
-type global = Gnot_fo | Gfo of Fol.decl
-
-let globals = ref Refmap.empty
-let globals_stack = ref []
-
-(* synchronization *)
-let () =
-  Summary.declare_summary "Dp globals"
-    { Summary.freeze_function = (fun () -> !globals, !globals_stack);
-      Summary.unfreeze_function =
-	(fun (g,s) -> globals := g; globals_stack := s);
-      Summary.init_function = (fun () -> ()) }
-
-let add_global r d = globals := Refmap.add r d !globals
-let mem_global r = Refmap.mem r !globals
-let lookup_global r = match Refmap.find r !globals with
-  | Gnot_fo -> raise NotFO
-  | Gfo d -> d
-
-let locals = Hashtbl.create 97
-
-let lookup_local r =  match Hashtbl.find locals r with
-  | Gnot_fo -> raise NotFO
-  | Gfo d -> d
-
-let iter_all_constructors i f =
-  let _, oib = Global.lookup_inductive i in
-  Array.iteri
-    (fun j tj -> f j (mkConstruct (i, j+1)))
-    oib.mind_nf_lc
-
-
-(* injection c [t1,...,tn] adds the injection axiom
-     forall x1:t1,...,xn:tn,y1:t1,...,yn:tn.
-       c(x1,...,xn)=c(y1,...,yn) -> x1=y1 /\ ... /\ xn=yn *)
-
-let injection c l =
-  let i = ref 0 in
-  let var s = incr i; id_of_string (s ^ string_of_int !i) in
-  let xl = List.map (fun t -> rename_global (VarRef (var "x")), t) l in
-  i := 0;
-  let yl = List.map (fun t -> rename_global (VarRef (var "y")), t) l in
-  let f =
-    List.fold_right2
-      (fun (x,_) (y,_) p -> And (Fatom (Eq (App (x,[]),App (y,[]))), p))
-      xl yl True
-  in
-  let vars = List.map (fun (x,_) -> App(x,[])) in
-  let f = Imp (Fatom (Eq (App (c, vars xl), App (c, vars yl))), f) in
-  let foralls = List.fold_right (fun (x,t) p -> Forall (x, t, p)) in
-  let f = foralls xl (foralls yl f) in
-  let ax = Axiom ("injection_" ^ c, f) in
-  globals_stack := ax :: !globals_stack
-
-(* rec_names_for c [|n1;...;nk|] builds the list of constant names for
-   identifiers n1...nk with the same path as c, if they exist; otherwise
-   raises Not_found *)
-let rec_names_for c =
-  let mp,dp,_ = Names.repr_con c in
-  array_map_to_list
-    (function
-       | Name id ->
-	   let c' = Names.make_con mp dp (label_of_id id) in
-	   ignore (Global.lookup_constant c');
-	   msgnl (Printer.pr_constr (mkConst c'));
-	   c'
-       | Anonymous ->
-	   raise Not_found)
-
-(* abstraction tables *)
-
-let term_abstractions = Hashtbl.create 97
-
-let new_abstraction =
-  let r = ref 0 in fun () -> incr r; "abstraction_" ^ string_of_int !r
-
-(* Arithmetic constants *)
-
-exception NotArithConstant
-
-(* translates a closed Coq term p:positive into a FOL term of type int *)
-
-let big_two = Big_int.succ_big_int Big_int.unit_big_int
-
-let rec tr_positive p = match kind_of_term p with
-  | Term.Construct _ when p = Lazy.force coq_xH ->
-      Big_int.unit_big_int
-  | Term.App (f, [|a|]) when f = Lazy.force coq_xI ->
-(*
-      Plus (Mult (Cst 2, tr_positive a), Cst 1)
-*)
-      Big_int.succ_big_int (Big_int.mult_big_int big_two (tr_positive a))
-  | Term.App (f, [|a|]) when f = Lazy.force coq_xO ->
-(*
-      Mult (Cst 2, tr_positive a)
-*)
-      Big_int.mult_big_int big_two (tr_positive a)
-  | Term.Cast (p, _, _) ->
-      tr_positive p
-  | _ ->
-      raise NotArithConstant
-
-(* translates a closed Coq term t:Z or R into a FOL term of type int or real *)
-let rec tr_arith_constant t = match kind_of_term t with
-  | Term.Construct _ when t = Lazy.force coq_Z0 ->
-      Cst Big_int.zero_big_int
-  | Term.App (f, [|a|]) when f = Lazy.force coq_Zpos ->
-      Cst (tr_positive a)
-  | Term.App (f, [|a|]) when f = Lazy.force coq_Zneg ->
-      Cst (Big_int.minus_big_int (tr_positive a))
-  | Term.Const _ when t = Lazy.force coq_R0 ->
-      RCst Big_int.zero_big_int
-  | Term.Const _ when t = Lazy.force coq_R1 ->
-      RCst Big_int.unit_big_int
-  | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rplus ->
-      let ta = tr_arith_constant a in
-      let tb = tr_arith_constant b in
-      begin match ta,tb with
-        | RCst na, RCst nb -> RCst (Big_int.add_big_int na nb)
-        | _ -> raise NotArithConstant
-      end
-  | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rmult ->
-      let ta = tr_arith_constant a in
-      let tb = tr_arith_constant b in
-      begin match ta,tb with
-        | RCst na, RCst nb -> RCst (Big_int.mult_big_int na nb)
-        | _ -> raise NotArithConstant
-      end
-  | Term.App (f, [|a;b|]) when f = Lazy.force coq_powerRZ ->
-      tr_powerRZ a b
-  | Term.Cast (t, _, _) ->
-      tr_arith_constant t
-  | _ ->
-      raise NotArithConstant
-
-(* translates a constant of the form (powerRZ 2 int_constant) *)
-and tr_powerRZ a b =
-  (* checking first that a is (R1 + R1) *)
-  match kind_of_term a with
-  | Term.App (f, [|c;d|]) when f = Lazy.force coq_Rplus ->
-      begin
-      match kind_of_term c,kind_of_term d with
-        | Term.Const _, Term.Const _
-            when c = Lazy.force coq_R1 && d = Lazy.force coq_R1 ->
-            begin
-              match tr_arith_constant b with
-                | Cst n -> Power2 n
-                | _ -> raise NotArithConstant
-            end
-        | _ -> raise NotArithConstant
-      end
-  | _ -> raise NotArithConstant
-
-
-(* translate a Coq term t:Set into a FOL type expression;
-   tv = list of type variables *)
-and tr_type tv env t =
-  let t = Reductionops.nf_betadeltaiota env Evd.empty t in
-  if t = Lazy.force coq_Z then
-    Tid ("int", [])
-  else if t = Lazy.force coq_R then
-    Tid ("real", [])
-  else match kind_of_term t with
-    | Var x when List.mem x tv ->
-	Tvar (string_of_id x)
-    | _ ->
-	let f, cl = decompose_app t in
-	begin try
-	  let r = global_of_constr f in
-	  match tr_global env r with
-	    | DeclType (id, k) ->
-		assert (k = List.length cl); (* since t:Set *)
-		Tid (id, List.map (tr_type tv env) cl)
-	    | _ ->
-		raise NotFO
-	with
-	  | Not_found ->
-	      raise NotFO
-	  | NotFO ->
-	      (* we need to abstract some part of (f cl) *)
-	      (*TODO*)
-	      raise NotFO
-	end
-
-and make_term_abstraction tv env c =
-  let ty = Typing.type_of env Evd.empty c in
-  let id = new_abstraction () in
-  match tr_decl env id ty with
-    | DeclFun (id,_,_,_) as _d ->
-        raise NotFO
-        (* [CM 07/09/2009] deactivated because it generates
-           unbound identifiers 'abstraction_<number>'
-	begin try
-	  Hashtbl.find term_abstractions c
-	with Not_found ->
-	  Hashtbl.add term_abstractions c id;
-	  globals_stack := d :: !globals_stack;
-	  id
-	end
-        *)
-    | _ ->
-	raise NotFO
-
-(* translate a Coq declaration id:ty in a FOL declaration, that is either
-   - a type declaration : DeclType (id, n) where n:int is the type arity
-   - a function declaration : DeclFun (id, tl, t) ; that includes constants
-   - a predicate declaration : DeclPred (id, tl)
-   - an axiom : Axiom (id, p)
- *)
-and tr_decl env id ty =
-  let tv, env, t = decomp_type_quantifiers env ty in
-  if is_Set t || is_Type t then
-    DeclType (id, List.length tv)
-  else if is_Prop t then
-    DeclPred (id, List.length tv, [])
-  else
-    let s = Typing.type_of env Evd.empty t in
-    if is_Prop s then
-      Axiom (id, tr_formula tv [] env t)
-    else
-      let l, t = decompose_arrows t in
-      let l = List.map (tr_type tv env) l in
-      if is_Prop t then
-	DeclPred(id, List.length tv, l)
-      else
-	let s = Typing.type_of env Evd.empty t in
-	if is_Set s || is_Type s then
-	  DeclFun (id, List.length tv, l, tr_type tv env t)
-	else
-	  raise NotFO
-
-(* tr_global(r) = tr_decl(id(r),typeof(r)) + a cache mechanism *)
-and tr_global env r = match r with
-  | VarRef id ->
-      lookup_local id
-  | r ->
-      try
-	lookup_global r
-      with Not_found ->
-	try
-	  let ty = Global.type_of_global r in
-	  let id = rename_global r in
-	  let d = tr_decl env id ty in
-	  (* r can be already declared if it is a constructor *)
-	  if not (mem_global r) then begin
-	    add_global r (Gfo d);
-	    globals_stack := d :: !globals_stack
-	  end;
-	  begin try axiomatize_body env r id d with NotFO -> () end;
-	  d
-	with NotFO ->
-	  add_global r Gnot_fo;
-	  raise NotFO
-
-and axiomatize_body env r id d = match r with
-  | VarRef _ ->
-      assert false
-  | ConstRef c ->
-      begin match (Global.lookup_constant c).const_body with
-	| Some b ->
-	    let b = force b in
-	    let axioms =
-	      (match d with
-		 | DeclPred (id, _, []) ->
-		     let tv, env, b = decomp_type_lambdas env b in
-		     let value = tr_formula tv [] env b in
-		     [id, Iff (Fatom (Pred (id, [])), value)]
-		 | DeclFun (id, _, [], _) ->
-		     let tv, env, b = decomp_type_lambdas env b in
-		     let value = tr_term tv [] env b in
-		     [id, Fatom (Eq (Fol.App (id, []), value))]
-		 | DeclFun (id, _, l, _) | DeclPred (id, _, l) ->
-		     (*Format.eprintf "axiomatize_body %S@." id;*)
-		     let b = match kind_of_term b with
-		       (* a single recursive function *)
-		       | Fix (_, (_,_,[|b|])) ->
-			   subst1 (mkConst c) b
-                       (* mutually recursive functions *)
-		       | Fix ((_,i), (names,_,bodies)) ->
-                           (* we only deal with named functions *)
-			   begin try
-			     let l = rec_names_for c names in
-			     substl (List.rev_map mkConst l) bodies.(i)
-			   with Not_found ->
-			     b
-			   end
-		       | _ ->
-			   b
-		     in
-		     let tv, env, b = decomp_type_lambdas env b in
-		     let vars, t = decompose_lam b in
-		     let n = List.length l in
-		     let k = List.length vars in
-		     assert (k <= n);
-		     let vars, env = coq_rename_vars env vars in
-		     let t = substl (List.map mkVar vars) t in
-		     let t, vars, env = eta_expanse t vars env (n-k) in
-		     let vars = List.rev vars in
-		     let bv = vars in
-		     let vars = List.map (fun x -> string_of_id x) vars in
-		     let fol_var x = Fol.App (x, []) in
-		     let fol_vars = List.map fol_var vars in
-		     let vars = List.combine vars l in
-		     begin match d with
-		       | DeclFun (_, _, _, ty) ->
-			   begin match kind_of_term t with
-			     | Case (ci, _, e, br) ->
-				 equations_for_case env id vars tv bv ci e br
-			     | _ ->
-				 let t = tr_term tv bv env t in
-				 let ax =
-				   add_proof (Fun_def (id, vars, ty, t))
-				 in
-				 let p = Fatom (Eq (App (id, fol_vars), t)) in
-				 [ax, foralls vars p]
-			   end
-		       | DeclPred _ ->
-			   let value = tr_formula tv bv env t in
-			   let p = Iff (Fatom (Pred (id, fol_vars)), value) in
-			   [id, foralls vars p]
-		       | _ ->
-			   assert false
-		     end
-		 | DeclType _ ->
-		     raise NotFO
-		 | Axiom _ -> assert false)
-	    in
-	    let axioms = List.map (fun (id,ax) -> Axiom (id, ax)) axioms in
-	    globals_stack := axioms @ !globals_stack
-	| None ->
-	    () (* Coq axiom *)
-      end
-  | IndRef i ->
-      iter_all_constructors i
-	(fun _ c ->
-	   let rc = global_of_constr c in
-	   try
-	     begin match tr_global env rc with
-	       | DeclFun (_, _, [], _) -> ()
-	       | DeclFun (idc, _, al, _) -> injection idc al
-	       | _ -> ()
-	     end
-	   with NotFO ->
-	     ())
-  | _ -> ()
-
-and equations_for_case env id vars tv bv ci e br = match kind_of_term e with
-  | Var x when List.exists (fun (y, _) -> string_of_id x = y) vars ->
-      let eqs = ref [] in
-      iter_all_constructors ci.ci_ind
-	(fun j cj ->
-	   try
-	     let cjr = global_of_constr cj in
-	     begin match tr_global env cjr with
-	       | DeclFun (idc, _, l, _) ->
-		   let b = br.(j) in
-		   let rec_vars, b = decompose_lam b in
-		   let rec_vars, env = coq_rename_vars env rec_vars in
-		   let coq_rec_vars = List.map mkVar rec_vars in
-		   let b = substl coq_rec_vars b in
-		   let rec_vars = List.rev rec_vars in
-		   let coq_rec_term = applist (cj, List.rev coq_rec_vars) in
-		   let b = replace_vars [x, coq_rec_term] b in
-		   let bv = bv @ rec_vars in
-		   let rec_vars = List.map string_of_id rec_vars in
-		   let fol_var x = Fol.App (x, []) in
-		   let fol_rec_vars = List.map fol_var rec_vars in
-		   let fol_rec_term = App (idc, fol_rec_vars) in
-		   let rec_vars = List.combine rec_vars l in
-		   let fol_vars = List.map fst vars in
-		   let fol_vars = List.map fol_var fol_vars in
-		   let fol_vars = List.map (fun y -> match y with
-					      | App (id, _) ->
-						  if id = string_of_id x
-						  then fol_rec_term
-						  else y
-					      | _ -> y)
-				    fol_vars in
-		   let vars = vars @ rec_vars in
-		   let rec remove l e = match l with
-		     | [] -> []
-		     | (y, t)::l' -> if y = string_of_id e then l'
-		       else (y, t)::(remove l' e) in
-		   let vars = remove vars x in
-		   let p =
-		     Fatom (Eq (App (id, fol_vars),
-				tr_term tv bv env b))
-		   in
-		   eqs := (id ^ "_" ^ idc, foralls vars p) :: !eqs
-	       | _ ->
-		   assert false end
-	   with NotFO ->
-	     ());
-      !eqs
-  | _ ->
-      raise NotFO
-
-(* assumption: t:T:Set *)
-and tr_term tv bv env t =
-      try
-	tr_arith_constant t
-      with NotArithConstant ->
-  match kind_of_term t with
-    (* binary operations on integers *)
-  | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zplus ->
-      Plus (tr_term tv bv env a, tr_term tv bv env b)
-  | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zminus ->
-      Moins (tr_term tv bv env a, tr_term tv bv env b)
-  | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zmult ->
-      Mult (tr_term tv bv env a, tr_term tv bv env b)
-  | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zdiv ->
-      Div (tr_term tv bv env a, tr_term tv bv env b)
-  | Term.App (f, [|a|]) when f = Lazy.force coq_Zopp ->
-      Opp (tr_term tv bv env a)
-    (* binary operations on reals *)
-  | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rplus ->
-      Plus (tr_term tv bv env a, tr_term tv bv env b)
-  | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rminus ->
-      Moins (tr_term tv bv env a, tr_term tv bv env b)
-  | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rmult ->
-      Mult (tr_term tv bv env a, tr_term tv bv env b)
-  | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rdiv ->
-      Div (tr_term tv bv env a, tr_term tv bv env b)
-  | Term.Var id when List.mem id bv ->
-      App (string_of_id id, [])
-  | _ ->
-	let f, cl = decompose_app t in
-	begin try
-	  let r = global_of_constr f in
-	  match tr_global env r with
-	    | DeclFun (s, k, _, _) ->
-		let cl = skip_k_args k cl in
-		Fol.App (s, List.map (tr_term tv bv env) cl)
-	    | _ ->
-		raise NotFO
-	with
-	  | Not_found ->
-	      raise NotFO
-	  | NotFO -> (* we need to abstract some part of (f cl) *)
-	      let rec abstract app = function
-		| [] ->
-		    Fol.App (make_term_abstraction tv env app, [])
-		| x :: l as args ->
-		    begin try
-		      let s = make_term_abstraction tv env app in
-		      Fol.App (s, List.map (tr_term tv bv env) args)
-		    with NotFO ->
-		      abstract (applist (app, [x])) l
-		    end
-	      in
-	      let app,l = match cl with
-		| x :: l -> applist (f, [x]), l | [] -> raise NotFO
-	      in
-	      abstract app l
-	end
-
-and quantifiers n a b tv bv env =
-  let vars, env = coq_rename_vars env [n,a] in
-  let id = match vars with [x] -> x | _ -> assert false in
-  let b = subst1 (mkVar id) b in
-  let t = tr_type tv env a in
-  let bv = id :: bv in
-  id, t, bv, env, b
-
-(* assumption: f is of type Prop *)
-and tr_formula tv bv env f =
-  let c, args = decompose_app f in
-  match kind_of_term c, args with
-    | Var id, [] ->
-	Fatom (Pred (rename_global (VarRef id), []))
-    | _, [t;a;b] when c = build_coq_eq () ->
-	let ty = Typing.type_of env Evd.empty t in
-	if is_Set ty || is_Type ty then
-	  let _ = tr_type tv env t in
-	  Fatom (Eq (tr_term tv bv env a, tr_term tv bv env b))
-	else
-	  raise NotFO
-          (* comparisons on integers *)
-    | _, [a;b] when c = Lazy.force coq_Zle ->
-	Fatom (Le (tr_term tv bv env a, tr_term tv bv env b))
-    | _, [a;b] when c = Lazy.force coq_Zlt ->
-	Fatom (Lt (tr_term tv bv env a, tr_term tv bv env b))
-    | _, [a;b] when c = Lazy.force coq_Zge ->
-	Fatom (Ge (tr_term tv bv env a, tr_term tv bv env b))
-    | _, [a;b] when c = Lazy.force coq_Zgt ->
-	Fatom (Gt (tr_term tv bv env a, tr_term tv bv env b))
-          (* comparisons on reals *)
-    | _, [a;b] when c = Lazy.force coq_Rle ->
-	Fatom (Le (tr_term tv bv env a, tr_term tv bv env b))
-    | _, [a;b] when c = Lazy.force coq_Rlt ->
-	Fatom (Lt (tr_term tv bv env a, tr_term tv bv env b))
-    | _, [a;b] when c = Lazy.force coq_Rge ->
-	Fatom (Ge (tr_term tv bv env a, tr_term tv bv env b))
-    | _, [a;b] when c = Lazy.force coq_Rgt ->
-	Fatom (Gt (tr_term tv bv env a, tr_term tv bv env b))
-    | _, [] when c = build_coq_False () ->
-	False
-    | _, [] when c = build_coq_True () ->
-	True
-    | _, [a] when c = build_coq_not () ->
-	Not (tr_formula tv bv env a)
-    | _, [a;b] when c = build_coq_and () ->
-	And (tr_formula tv bv env a, tr_formula tv bv env b)
-    | _, [a;b] when c = build_coq_or () ->
-	Or (tr_formula tv bv env a, tr_formula tv bv env b)
-    | _, [a;b] when c = Lazy.force coq_iff ->
-	Iff (tr_formula tv bv env a, tr_formula tv bv env b)
-    | Prod (n, a, b), _ ->
-        if is_Prop (Typing.type_of env Evd.empty a) then
-	  Imp (tr_formula tv bv env a, tr_formula tv bv env b)
-	else
-	  let id, t, bv, env, b = quantifiers n a b tv bv env in
-	  Forall (string_of_id id, t, tr_formula tv bv env b)
-    | _, [_; a] when c = build_coq_ex () ->
-	begin match kind_of_term a with
-	  | Lambda(n, a, b) ->
-	      let id, t, bv, env, b = quantifiers n a b tv bv env in
-	      Exists (string_of_id id, t, tr_formula tv bv env b)
-	  | _ ->
-	      (* unusual case of the shape (ex p) *)
-	      raise NotFO (* TODO: we could eta-expanse *)
-	end
-    | _ ->
-	begin try
-	  let r = global_of_constr c in
-	  match tr_global env r with
-	    | DeclPred (s, k, _) ->
-		let args = skip_k_args k args in
-		Fatom (Pred (s, List.map (tr_term tv bv env) args))
-	    | _ ->
-		raise NotFO
-	with Not_found ->
-	  raise NotFO
-	end
-
-
-let tr_goal gl =
-  Hashtbl.clear locals;
-  let tr_one_hyp (id, ty) =
-    try
-      let s = rename_global (VarRef id) in
-      let d = tr_decl (pf_env gl) s ty in
-      Hashtbl.add locals id (Gfo d);
-      d
-    with NotFO ->
-      Hashtbl.add locals id Gnot_fo;
-      raise NotFO
-  in
-  let hyps =
-    List.fold_right
-      (fun h acc -> try tr_one_hyp h :: acc with NotFO -> acc)
-      (pf_hyps_types gl) []
-  in
-  let c = tr_formula [] [] (pf_env gl) (pf_concl gl) in
-  let hyps = List.rev_append !globals_stack (List.rev hyps) in
-  hyps, c
-
-
-type prover = Simplify | Ergo | Yices | CVCLite | Harvey | Zenon | Gwhy | CVC3 | Z3
-
-let remove_files = List.iter (fun f -> try Sys.remove f with _ -> ())
-
-let sprintf = Format.sprintf
-
-let file_contents f =
-  let buf = Buffer.create 1024 in
-  try
-    let c = open_in f in
-    begin try
-      while true do
-	let s = input_line c in Buffer.add_string buf s;
-	Buffer.add_char buf '\n'
-      done;
-      assert false
-    with End_of_file ->
-      close_in c;
-      Buffer.contents buf
-    end
-  with _ ->
-    sprintf "(cannot open %s)" f
-
-let timeout_sys_command cmd =
-  if !debug then Format.eprintf "command line: %s@." cmd;
-  let out = Filename.temp_file "out" "" in
-  let cmd = sprintf "why-cpulimit %d %s > %s 2>&1" !timeout cmd out in
-  let ret = Sys.command cmd in
-  if !debug then
-    Format.eprintf "Output file %s:@.%s@." out (file_contents out);
-  ret, out
-
-let timeout_or_failure c cmd out =
-  if c = 152 then
-    Timeout
-  else
-    Failure
-      (sprintf "command %s failed with output:\n%s " cmd (file_contents out))
-
-let call_prover ?(opt="") file =
-  if !debug then Format.eprintf "calling prover on %s@." file;
-  let out = Filename.temp_file "out" "" in
-  let cmd =
-    sprintf "why-dp -timeout %d -batch %s > %s 2>&1" !timeout file out in
-  match Sys.command cmd with
-      0 -> Valid None
-    | 1 -> Failure (sprintf "could not run why-dp\n%s" (file_contents out))
-    | 2 -> Invalid
-    | 3 -> DontKnow
-    | 4 -> Timeout
-    | 5 -> Failure (sprintf "prover failed:\n%s" (file_contents out))
-    | n -> Failure (sprintf "Unknown exit status of why-dp: %d" n)
-
-let prelude_files = ref ([] : string list)
-
-let set_prelude l = prelude_files := l
-
-let (dp_prelude_obj,_) =
-  declare_object
-    {(default_object "Dp_prelude") with
-       cache_function = (fun (_,x) -> set_prelude x);
-       load_function = (fun _ (_,x) -> set_prelude x)}
-
-let dp_prelude x = Lib.add_anonymous_leaf (dp_prelude_obj x)
-
-let why_files f = String.concat " " (!prelude_files @ [f])
-
-let call_simplify fwhy =
-  let cmd =
-    sprintf "why --simplify %s" (why_files fwhy)
-  in
-  if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed");
-  let fsx = Filename.chop_suffix fwhy ".why" ^ "_why.sx" in
-(*
-  let cmd =
-    sprintf "why-cpulimit %d Simplify %s > out 2>&1 && grep -q -w Valid out"
-      !timeout fsx
-  in
-  let out = Sys.command cmd in
-  let r =
-    if out = 0 then Valid None else if out = 1 then Invalid else Timeout
-  in
-*)
-  let r = call_prover fsx in
-  if not !debug then remove_files [fwhy; fsx];
-  r
-
-let call_ergo fwhy =
-  let cmd = sprintf "why --alt-ergo %s" (why_files fwhy) in
-  if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed");
-  let fwhy = Filename.chop_suffix fwhy ".why" ^ "_why.why" in
-  (*let ftrace = Filename.temp_file "ergo_trace" "" in*)
-  (*NB: why-dp can't handle -cctrace
-  let cmd =
-    if !trace then
-      sprintf "alt-ergo -cctrace %s %s" ftrace fwhy
-
-    else
-      sprintf "alt-ergo %s" fwhy
-  in*)
-  let r = call_prover fwhy in
-  if not !debug then remove_files [fwhy; (*out*)];
-  r
-
-
-let call_zenon fwhy =
-  let cmd =
-    sprintf "why --no-zenon-prelude --zenon %s" (why_files fwhy)
-  in
-  if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed");
-  let fznn = Filename.chop_suffix fwhy ".why" ^ "_why.znn" in
-(*  why-dp won't let us having coqterm...
-  let out = Filename.temp_file "dp_out" "" in
-  let cmd =
-    sprintf "timeout %d zenon -ocoqterm %s > %s 2>&1" !timeout fznn out
-  in
-  let c = Sys.command cmd in
-  if not !debug then remove_files [fwhy; fznn];
-  if c = 137 then
-    Timeout
-  else begin
-    if c <> 0 then anomaly ("command failed: " ^ cmd);
-    if Sys.command (sprintf "grep -q -w Error %s" out) = 0 then
-      error "Zenon failed";
-    let c = Sys.command (sprintf "grep -q PROOF-FOUND %s" out) in
-    if c = 0 then Valid (Some out) else Invalid
-  end
- *)
-   let r = call_prover fznn in
-   if not !debug then remove_files [fwhy; fznn];
-   r
-
-let call_smt ~smt fwhy =
-  let cmd = 
-    sprintf "why -smtlib --encoding sstrat %s" (why_files fwhy)
-  in
-  if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed");
-  let fsmt = Filename.chop_suffix fwhy ".why" ^ "_why.smt" in
-  let opt = "-smt-solver " ^ smt in
-  let r = call_prover ~opt fsmt in
-  if not !debug then remove_files [fwhy; fsmt];
-  r
-
-(*
-let call_yices fwhy =
-  let cmd =
-    sprintf "why -smtlib --encoding sstrat %s" (why_files fwhy)
-  in
-  if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed");
-  let fsmt = Filename.chop_suffix fwhy ".why" ^ "_why.smt" in
-  let cmd =
-    sprintf "why-cpulimit %d yices -pc 0 -smt %s > out 2>&1 && grep -q -w unsat out"
-      !timeout fsmt
-  in
-  let out = Sys.command cmd in
-  let r =
-    if out = 0 then Valid None else if out = 1 then Invalid else Timeout
-  in
-  if not !debug then remove_files [fwhy; fsmt];
-  r
-
-let call_cvc3 fwhy =
-  let cmd =
-    sprintf "why -smtlib --encoding sstrat %s" (why_files fwhy)
-  in
-  if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed");
-  let fsmt = Filename.chop_suffix fwhy ".why" ^ "_why.smt" in
-  let cmd =
-    sprintf "why-cpulimit %d cvc3 -lang smt %s > out 2>&1 && grep -q -w unsat out"
-      !timeout fsmt
-  in
-  let out = Sys.command cmd in
-  let r =
-    if out = 0 then Valid None else if out = 1 then Invalid else Timeout
-  in
-  if not !debug then remove_files [fwhy; fsmt];
-  r
-*)
-
-let call_cvcl fwhy =
-  let cmd =
-    sprintf "why --cvcl --encoding sstrat %s" (why_files fwhy)
-  in
-  if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed");
-  let fcvc = Filename.chop_suffix fwhy ".why" ^ "_why.cvc" in
-(*
-  let cmd =
-    sprintf "timeout %d cvcl < %s > out 2>&1 && grep -q -w Valid out"
-      !timeout fcvc
-  in
-  let out = Sys.command cmd in
-  let r =
-    if out = 0 then Valid None else if out = 1 then Invalid else Timeout
-  in
-*)
-  let r = call_prover fcvc in
-  if not !debug then remove_files [fwhy; fcvc];
-  r
-
-let call_harvey fwhy =
-  let cmd =
-    sprintf "why --harvey --encoding strat %s" (why_files fwhy)
-  in
-  if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed");
-  let frv = Filename.chop_suffix fwhy ".why" ^ "_why.rv" in
-(*
-  let out = Sys.command (sprintf "rvc -e -t %s > /dev/null 2>&1" frv) in
-  if out <> 0 then anomaly ("call to rvc -e -t " ^ frv ^ " failed");
-  let f = Filename.chop_suffix frv ".rv" ^ "-0.baf" in
-  let outf = Filename.temp_file "rv" ".out" in
-  let out =
-    Sys.command (sprintf "timeout %d rv -e\"-T 2000\" %s > %s 2>&1"
-		   !timeout f outf)
-  in
-  let r =
-    if out <> 0 then
-      Timeout
-    else
-      let cmd =
-	sprintf "grep \"Proof obligation in\" %s | grep -q \"is valid\"" outf
-      in
-      if Sys.command cmd = 0 then Valid None else Invalid
-  in
-  if not !debug then remove_files [fwhy; frv; outf];
-*)
-  let r = call_prover frv in
-  if not !debug then remove_files [fwhy; frv];
-  r
-
-let call_gwhy fwhy =
-  let cmd = sprintf "gwhy %s" (why_files fwhy) in
-  if Sys.command cmd <> 0 then ignore (Sys.command (sprintf "emacs %s" fwhy));
-  NoAnswer
-
-let ergo_proof_from_file f gl =
-  let s =
-    let buf = Buffer.create 1024 in
-    let c = open_in f in
-    try
-      while true do Buffer.add_string buf (input_line c) done; assert false
-    with End_of_file ->
-      close_in c;
-      Buffer.contents buf
-  in
-  let parsed_constr = Pcoq.parse_string Pcoq.Constr.constr s in
-  let t = Constrintern.interp_constr (project gl) (pf_env gl) parsed_constr in
-  exact_check t gl
-
-let call_prover prover q =
-  let fwhy = Filename.temp_file "coq_dp" ".why" in
-  Dp_why.output_file fwhy q;
-  match prover with
-    | Simplify -> call_simplify fwhy
-    | Ergo -> call_ergo fwhy
-    | CVC3 -> call_smt ~smt:"cvc3" fwhy
-    | Yices -> call_smt ~smt:"yices" fwhy
-    | Z3 -> call_smt ~smt:"z3" fwhy
-    | Zenon -> call_zenon fwhy
-    | CVCLite -> call_cvcl fwhy
-    | Harvey -> call_harvey fwhy
-    | Gwhy -> call_gwhy fwhy
-
-let dp prover gl =
-  Coqlib.check_required_library ["Coq";"ZArith";"ZArith"];
-  let concl_type = pf_type_of gl (pf_concl gl) in
-  if not (is_Prop concl_type) then error "Conclusion is not a Prop";
-  try
-    let q = tr_goal gl in
-    begin match call_prover prover q with
-      | Valid (Some f) when prover = Zenon -> Dp_zenon.proof_from_file f gl
-      | Valid (Some f) when prover = Ergo -> ergo_proof_from_file f gl
-      | Valid _ -> Tactics.admit_as_an_axiom gl
-      | Invalid -> error "Invalid"
-      | DontKnow -> error "Don't know"
-      | Timeout -> error "Timeout"
-      | Failure s -> error s
-      | NoAnswer -> Tacticals.tclIDTAC gl
-    end
-  with NotFO ->
-    error "Not a first order goal"
-
-
-let simplify = tclTHEN intros (dp Simplify)
-let ergo = tclTHEN intros (dp Ergo)
-let cvc3 = tclTHEN intros (dp CVC3)
-let yices = tclTHEN intros (dp Yices)
-let z3 = tclTHEN intros (dp Z3)
-let cvc_lite = tclTHEN intros (dp CVCLite)
-let harvey = dp Harvey
-let zenon = tclTHEN intros (dp Zenon)
-let gwhy = tclTHEN intros (dp Gwhy)
-
-let dp_hint l =
-  let env = Global.env () in
-  let one_hint (qid,r) =
-    if not (mem_global r) then begin
-      let ty = Global.type_of_global r in
-      let s = Typing.type_of env Evd.empty ty in
-      if is_Prop s then
-	try
-	  let id = rename_global r in
-	  let tv, env, ty = decomp_type_quantifiers env ty in
-	  let d = Axiom (id, tr_formula tv [] env ty) in
-	  add_global r (Gfo d);
-	  globals_stack := d :: !globals_stack
-	with NotFO ->
-	  add_global r Gnot_fo;
-	  msg_warning
-	    (pr_reference qid ++
-	     str " ignored (not a first order proposition)")
-	else begin
-	  add_global r Gnot_fo;
-	  msg_warning
-	    (pr_reference qid ++ str " ignored (not a proposition)")
-	end
-    end
-  in
-  List.iter one_hint (List.map (fun qid -> qid, Nametab.global qid) l)
-
-let (dp_hint_obj,_) =
-  declare_object
-    {(default_object "Dp_hint") with
-       cache_function = (fun (_,l) -> dp_hint l);
-       load_function = (fun _ (_,l) -> dp_hint l)}
-
-let dp_hint l = Lib.add_anonymous_leaf (dp_hint_obj l)
-
-let dp_predefined qid s =
-  let r = Nametab.global qid in
-  let ty = Global.type_of_global r in
-  let env = Global.env () in
-  let id = rename_global r in
-  try
-    let d = match tr_decl env id ty with
-      | DeclType (_, n) -> DeclType (s, n)
-      | DeclFun (_, n, tyl, ty) -> DeclFun (s, n, tyl, ty)
-      | DeclPred (_, n, tyl) -> DeclPred (s, n, tyl)
-      | Axiom _ as d -> d
-    in
-    match d with
-      | Axiom _ ->  msg_warning (str " ignored (axiom)")
-      | d -> add_global r (Gfo d)
-  with NotFO ->
-    msg_warning (str " ignored (not a first order declaration)")
-
-let (dp_predefined_obj,_) =
-  declare_object
-    {(default_object "Dp_predefined") with
-       cache_function = (fun (_,(id,s)) -> dp_predefined id s);
-       load_function = (fun _ (_,(id,s)) -> dp_predefined id s)}
-
-let dp_predefined id s = Lib.add_anonymous_leaf (dp_predefined_obj (id,s))
-
-let _ = declare_summary "Dp options"
-	  { freeze_function =
-	      (fun () -> !debug, !trace, !timeout, !prelude_files);
-	    unfreeze_function =
-	      (fun (d,tr,tm,pr) ->
-		debug := d; trace := tr; timeout := tm; prelude_files := pr);
-	    init_function =
-	      (fun () ->
-		debug := false; trace := false; timeout := 10;
-		prelude_files := []) }
diff --git a/plugins/dp/dp.mli b/plugins/dp/dp.mli
deleted file mode 100644
index f40f8688..00000000
--- a/plugins/dp/dp.mli
+++ /dev/null
@@ -1,20 +0,0 @@
-
-open Libnames
-open Proof_type
-
-val simplify : tactic
-val ergo : tactic
-val cvc3 : tactic
-val yices : tactic
-val cvc_lite : tactic
-val harvey : tactic
-val zenon : tactic
-val gwhy : tactic
-val z3: tactic
-
-val dp_hint : reference list -> unit
-val dp_timeout : int -> unit
-val dp_debug : bool -> unit
-val dp_trace : bool -> unit
-val dp_prelude : string list -> unit
-val dp_predefined : reference -> string -> unit
diff --git a/plugins/dp/dp_plugin.mllib b/plugins/dp/dp_plugin.mllib
deleted file mode 100644
index 63252d6a..00000000
--- a/plugins/dp/dp_plugin.mllib
+++ /dev/null
@@ -1,5 +0,0 @@
-Dp_why
-Dp_zenon
-Dp
-G_dp
-Dp_plugin_mod
diff --git a/plugins/dp/dp_why.ml b/plugins/dp/dp_why.ml
deleted file mode 100644
index 199c3087..00000000
--- a/plugins/dp/dp_why.ml
+++ /dev/null
@@ -1,185 +0,0 @@
-
-(* Pretty-print PFOL (see fol.mli) in Why syntax *)
-
-open Format
-open Fol
-
-type proof =
-  | Immediate of Term.constr
-  | Fun_def of string * (string * typ) list * typ * term
-
-let proofs = Hashtbl.create 97
-let proof_name =
-  let r = ref 0 in fun () -> incr r; "dp_axiom__" ^ string_of_int !r
-
-let add_proof pr = let n = proof_name () in Hashtbl.add proofs n pr; n
-
-let find_proof = Hashtbl.find proofs
-
-let rec print_list sep print fmt = function
-  | [] -> ()
-  | [x] -> print fmt x
-  | x :: r -> print fmt x; sep fmt (); print_list sep print fmt r
-
-let space fmt () = fprintf fmt "@ "
-let comma fmt () = fprintf fmt ",@ "
-
-let is_why_keyword =
-  let h = Hashtbl.create 17 in
-  List.iter
-    (fun s -> Hashtbl.add h s ())
-    ["absurd"; "and"; "array"; "as"; "assert"; "axiom"; "begin";
-     "bool"; "do"; "done"; "else"; "end"; "exception"; "exists";
-     "external"; "false"; "for"; "forall"; "fun"; "function"; "goal";
-     "if"; "in"; "int"; "invariant"; "label"; "let"; "logic"; "not";
-     "of"; "or"; "parameter"; "predicate"; "prop"; "raise"; "raises";
-     "reads"; "real"; "rec"; "ref"; "returns"; "then"; "true"; "try";
-     "type"; "unit"; "variant"; "void"; "while"; "with"; "writes" ];
-  Hashtbl.mem h
-
-let ident fmt s =
-  if is_why_keyword s then fprintf fmt "coq__%s" s else fprintf fmt "%s" s
-
-let rec print_typ fmt = function
-  | Tvar x -> fprintf fmt "'%a" ident x
-  | Tid ("int", []) -> fprintf fmt "int"
-  | Tid ("real", []) -> fprintf fmt "real"
-  | Tid (x, []) -> fprintf fmt "%a" ident x
-  | Tid (x, [t]) -> fprintf fmt "%a %a" print_typ t ident x
-  | Tid (x,tl) -> fprintf fmt "(%a) %a" (print_list comma print_typ) tl ident x
-
-let print_arg fmt (id,typ) = fprintf fmt "%a: %a" ident id print_typ typ
-
-let rec print_term fmt = function
-  | Cst n ->
-      fprintf fmt "%s" (Big_int.string_of_big_int n)
-  | RCst s ->
-      fprintf fmt "%s.0" (Big_int.string_of_big_int s)
-  | Power2 n ->
-      fprintf fmt "0x1p%s" (Big_int.string_of_big_int n)
-  | Plus (a, b) ->
-      fprintf fmt "@[(%a +@ %a)@]" print_term a print_term b
-  | Moins (a, b) ->
-      fprintf fmt "@[(%a -@ %a)@]" print_term a print_term b
-  | Mult (a, b) ->
-      fprintf fmt "@[(%a *@ %a)@]" print_term a print_term b
-  | Div (a, b) ->
-      fprintf fmt "@[(%a /@ %a)@]" print_term a print_term b
-  | Opp (a) ->
-      fprintf fmt "@[(-@ %a)@]" print_term a
-  | App (id, []) ->
-      fprintf fmt "%a" ident id
-  | App (id, tl) ->
-      fprintf fmt "@[%a(%a)@]" ident id print_terms tl
-
-and print_terms fmt tl =
-  print_list comma print_term fmt tl
-
-let rec print_predicate fmt p =
-  let pp = print_predicate in
-  match p with
-  | True ->
-      fprintf fmt "true"
-  | False ->
-      fprintf fmt "false"
-  | Fatom (Eq (a, b)) ->
-      fprintf fmt "@[(%a =@ %a)@]" print_term a print_term b
-  | Fatom (Le (a, b)) ->
-      fprintf fmt "@[(%a <=@ %a)@]" print_term a print_term b
-  | Fatom (Lt (a, b))->
-      fprintf fmt "@[(%a <@ %a)@]" print_term a print_term b
-  | Fatom (Ge (a, b)) ->
-      fprintf fmt "@[(%a >=@ %a)@]" print_term a print_term b
-  | Fatom (Gt (a, b)) ->
-      fprintf fmt "@[(%a >@ %a)@]" print_term a print_term b
-  | Fatom (Pred (id, [])) ->
-      fprintf fmt "%a" ident id
-  | Fatom (Pred (id, tl)) ->
-      fprintf fmt "@[%a(%a)@]" ident id print_terms tl
-  | Imp (a, b) ->
-      fprintf fmt "@[(%a ->@ %a)@]" pp a pp b
-  | Iff (a, b) ->
-      fprintf fmt "@[(%a <->@ %a)@]" pp a pp b
-  | And (a, b) ->
-      fprintf fmt "@[(%a and@ %a)@]" pp a pp b
-  | Or (a, b) ->
-      fprintf fmt "@[(%a or@ %a)@]" pp a pp b
-  | Not a ->
-      fprintf fmt "@[(not@ %a)@]" pp a
-  | Forall (id, t, p) ->
-      fprintf fmt "@[(forall %a:%a.@ %a)@]" ident id print_typ t pp p
-  | Exists (id, t, p) ->
-      fprintf fmt "@[(exists %a:%a.@ %a)@]" ident id print_typ t pp p
-
-let rec remove_iff args = function
-    Forall (id,t,p) -> remove_iff ((id,t)::args) p
-  | Iff(_,b) -> List.rev args, b
-  | _ -> raise Not_found
-
-let print_query fmt (decls,concl) =
-  let find_declared_preds l =
-    function
-        DeclPred (id,_,args) -> (id,args) :: l
-      | _ -> l
-  in
-  let find_defined_preds declared l = function
-      Axiom(id,f) ->
-        (try
-           let _decl = List.assoc id declared in
-           (id,remove_iff [] f)::l
-         with Not_found -> l)
-    | _ -> l
-  in
-  let declared_preds =
-    List.fold_left find_declared_preds [] decls in
-  let defined_preds =
-    List.fold_left (find_defined_preds declared_preds) [] decls
-  in
-  let print_dtype = function
-    | DeclType (id, 0) ->
-	fprintf fmt "@[type %a@]@\n@\n" ident id
-    | DeclType (id, 1) ->
-	fprintf fmt "@[type 'a %a@]@\n@\n" ident id
-    | DeclType (id, n) ->
-	fprintf fmt "@[type (";
-	for i = 1 to n do
-	  fprintf fmt "'a%d" i; if i < n then fprintf fmt ", "
-	done;
-	fprintf fmt ") %a@]@\n@\n" ident id
-    | DeclFun _ | DeclPred _ | Axiom _ ->
-	()
-  in
-  let print_dvar_dpred = function
-    | DeclFun (id, _, [], t) ->
-	fprintf fmt "@[logic %a : -> %a@]@\n@\n" ident id print_typ t
-    | DeclFun (id, _, l, t) ->
-	fprintf fmt "@[logic %a : %a -> %a@]@\n@\n"
-	  ident id (print_list comma print_typ) l print_typ t
-    | DeclPred (id, _, []) when not (List.mem_assoc id defined_preds) ->
-	fprintf fmt "@[logic %a : -> prop @]@\n@\n" ident id
-    | DeclPred (id, _, l) when not (List.mem_assoc id defined_preds) ->
-	fprintf fmt "@[logic %a : %a -> prop@]@\n@\n"
-	  ident id (print_list comma print_typ) l
-    | DeclType _ | Axiom _ | DeclPred _ ->
-	()
-  in
-  let print_assert = function
-    | Axiom(id,_) when List.mem_assoc id defined_preds ->
-        let args, def = List.assoc id defined_preds in
-        fprintf fmt "@[predicate %a(%a) =@\n%a@]@\n" ident id
-          (print_list comma print_arg) args print_predicate def  
-    | Axiom (id, f)  ->
-	fprintf fmt "@[<hov 2>axiom %a:@ %a@]@\n@\n" ident id print_predicate f
-    | DeclType _ | DeclFun _ | DeclPred _ ->
-	()
-  in
-  List.iter print_dtype decls;
-  List.iter print_dvar_dpred decls;
-  List.iter print_assert decls;
-  fprintf fmt "@[<hov 2>goal coq___goal: %a@]" print_predicate concl
-
-let output_file f q =
-  let c = open_out f in
-  let fmt = formatter_of_out_channel c in
-  fprintf fmt "@[%a@]@." print_query q;
-  close_out c
diff --git a/plugins/dp/dp_why.mli b/plugins/dp/dp_why.mli
deleted file mode 100644
index 0efa24a2..00000000
--- a/plugins/dp/dp_why.mli
+++ /dev/null
@@ -1,17 +0,0 @@
-
-open Fol
-
-(* generation of the Why file *)
-
-val output_file : string -> query -> unit
-
-(* table to translate the proofs back to Coq (used in dp_zenon) *)
-
-type proof =
-  | Immediate of Term.constr
-  | Fun_def of string * (string * typ) list * typ * term
-
-val add_proof : proof -> string
-val find_proof : string -> proof
-
-
diff --git a/plugins/dp/dp_zenon.mli b/plugins/dp/dp_zenon.mli
deleted file mode 100644
index 0a727d1f..00000000
--- a/plugins/dp/dp_zenon.mli
+++ /dev/null
@@ -1,7 +0,0 @@
-
-open Fol
-
-val set_debug : bool -> unit
-
-val proof_from_file : string -> Proof_type.tactic
-
diff --git a/plugins/dp/dp_zenon.mll b/plugins/dp/dp_zenon.mll
deleted file mode 100644
index 949e91e3..00000000
--- a/plugins/dp/dp_zenon.mll
+++ /dev/null
@@ -1,189 +0,0 @@
-
-{
-
-  open Lexing
-  open Pp
-  open Util
-  open Names
-  open Tacmach
-  open Dp_why
-  open Tactics
-  open Tacticals
-
-  let debug = ref false
-  let set_debug b = debug := b
-
-  let buf = Buffer.create 1024
-
-  let string_of_global env ref =
-    Libnames.string_of_qualid (Nametab.shortest_qualid_of_global env ref)
-
-  let axioms = ref []
-
-  (* we cannot interpret the terms as we read them (since some lemmas
-     may need other lemmas to be already interpreted) *)
-  type lemma = { l_id : string; l_type : string; l_proof : string }
-  type zenon_proof = lemma list * string
-
-}
-
-let ident = ['a'-'z' 'A'-'Z' '_' '0'-'9' '\'']+
-let space = [' ' '\t' '\r']
-
-rule start = parse
-| "(* BEGIN-PROOF *)" "\n" { scan lexbuf }
-| _ { start lexbuf }
-| eof { anomaly "malformed Zenon proof term" }
-
-(* here we read the lemmas and the main proof term;
-   meanwhile we maintain the set of axioms that were used *)
-
-and scan = parse
-| "Let" space (ident as id) space* ":"
-  { let t = read_coq_term lexbuf in
-    let p = read_lemma_proof lexbuf in
-    let l,pr = scan lexbuf in
-    { l_id = id; l_type = t; l_proof = p } :: l, pr }
-| "Definition theorem:"
-  { let t = read_main_proof lexbuf in [], t }
-| _ | eof
-  { anomaly "malformed Zenon proof term" }
-
-and read_coq_term = parse
-| "." "\n"
-  { let s = Buffer.contents buf in Buffer.clear buf; s }
-| "coq__" (ident as id) (* a Why keyword renamed *)
-  { Buffer.add_string buf id; read_coq_term lexbuf }
-| ("dp_axiom__" ['0'-'9']+) as id
-  { axioms := id :: !axioms; Buffer.add_string buf id; read_coq_term lexbuf }
-| _ as c
-  { Buffer.add_char buf c; read_coq_term lexbuf }
-| eof
-  { anomaly "malformed Zenon proof term" }
-
-and read_lemma_proof = parse
-| "Proof" space
-  { read_coq_term lexbuf }
-| _ | eof
-  { anomaly "malformed Zenon proof term" }
-
-(* skip the main proof statement and then read its term *)
-and read_main_proof = parse
-| ":=" "\n"
-  { read_coq_term lexbuf }
-| _
-  { read_main_proof lexbuf }
-| eof
-  { anomaly "malformed Zenon proof term" }
-
-
-{
-
-  let read_zenon_proof f =
-    Buffer.clear buf;
-    let c = open_in f in
-    let lb = from_channel c in
-    let p = start lb in
-    close_in c;
-    if not !debug then begin try Sys.remove f with _ -> () end;
-    p
-
-  let constr_of_string gl s =
-    let parse_constr = Pcoq.parse_string Pcoq.Constr.constr in
-    Constrintern.interp_constr (project gl) (pf_env gl) (parse_constr s)
-
-  (* we are lazy here: we build strings containing Coq terms using a *)
-  (* pretty-printer Fol -> Coq *)
-  module Coq = struct
-    open Format
-    open Fol
-
-    let rec print_list sep print fmt = function
-      | [] -> ()
-      | [x] -> print fmt x
-      | x :: r -> print fmt x; sep fmt (); print_list sep print fmt r
-
-    let space fmt () = fprintf fmt "@ "
-    let comma fmt () = fprintf fmt ",@ "
-
-    let rec print_typ fmt = function
-      | Tvar x -> fprintf fmt "%s" x
-      | Tid ("int", []) -> fprintf fmt "Z"
-      | Tid (x, []) -> fprintf fmt "%s" x
-      | Tid (x, [t]) -> fprintf fmt "(%s %a)" x print_typ t
-      | Tid (x,tl) ->
-	  fprintf fmt "(%s %a)" x (print_list comma print_typ) tl
-
-    let rec print_term fmt = function
-      | Cst n ->
-	  fprintf fmt "%s" (Big_int.string_of_big_int n)
-      | RCst s ->
-          fprintf fmt "%s" (Big_int.string_of_big_int s)
-      | Power2 n ->
-          fprintf fmt "@[(powerRZ 2 %s)@]" (Big_int.string_of_big_int n)
-
-          (* TODO: bug, it might be operations on reals *)
-      | Plus (a, b) ->
-	  fprintf fmt "@[(Zplus %a %a)@]" print_term a print_term b
-      | Moins (a, b) ->
-	  fprintf fmt "@[(Zminus %a %a)@]" print_term a print_term b
-      | Mult (a, b) ->
-	  fprintf fmt "@[(Zmult %a %a)@]" print_term a print_term b
-      | Div (a, b) ->
-	  fprintf fmt "@[(Zdiv %a %a)@]" print_term a print_term b
-      | Opp (a) ->
-	  fprintf fmt "@[(Zopp %a)@]" print_term a
-      | App (id, []) ->
-	  fprintf fmt "%s" id
-      | App (id, tl) ->
-	  fprintf fmt "@[(%s %a)@]" id print_terms tl
-
-    and print_terms fmt tl =
-      print_list space print_term fmt tl
-
-    (* builds the text for "forall vars, f vars = t" *)
-    let fun_def_axiom f vars t =
-      let binder fmt (x,t) = fprintf fmt "(%s: %a)" x print_typ t in
-      fprintf str_formatter
-	"@[(forall %a, %s %a = %a)@]@."
-	(print_list space binder) vars f
-	(print_list space (fun fmt (x,_) -> pp_print_string fmt x)) vars
-	print_term t;
-      flush_str_formatter ()
-
-  end
-
-  let prove_axiom id = match Dp_why.find_proof id with
-    | Immediate t ->
-	exact_check t
-    | Fun_def (f, vars, ty, t) ->
-	tclTHENS
-	  (fun gl ->
-	     let s = Coq.fun_def_axiom f vars t in
-	     if !debug then Format.eprintf "axiom fun def = %s@." s;
-	     let c = constr_of_string gl s in
-	     assert_tac (Name (id_of_string id)) c gl)
-	  [tclTHEN intros reflexivity; tclIDTAC]
-
-  let exact_string s gl =
-    let c = constr_of_string gl s in
-    exact_check c gl
-
-  let interp_zenon_proof (ll,p) =
-    let interp_lemma l gl =
-      let ty = constr_of_string gl l.l_type in
-      tclTHENS
-	(assert_tac (Name (id_of_string l.l_id)) ty)
-	[exact_string l.l_proof; tclIDTAC]
-	gl
-    in
-    tclTHEN (tclMAP interp_lemma ll) (exact_string p)
-
-  let proof_from_file f =
-    axioms := [];
-    msgnl (str "proof_from_file " ++ str f);
-    let zp = read_zenon_proof f in
-    msgnl (str "proof term is " ++ str (snd zp));
-    tclTHEN (tclMAP prove_axiom !axioms) (interp_zenon_proof zp)
-
-}
diff --git a/plugins/dp/fol.mli b/plugins/dp/fol.mli
deleted file mode 100644
index 4fb763a6..00000000
--- a/plugins/dp/fol.mli
+++ /dev/null
@@ -1,58 +0,0 @@
-
-(* Polymorphic First-Order Logic (that is Why's input logic) *)
-
-type typ =
-  | Tvar of string
-  | Tid of string * typ list
-
-type term =
-  | Cst of Big_int.big_int
-  | RCst of Big_int.big_int
-  | Power2 of Big_int.big_int
-  | Plus of term * term
-  | Moins of term * term
-  | Mult of term * term
-  | Div of term * term
-  | Opp of term
-  | App of string * term list
-
-and atom =
-  | Eq of term * term
-  | Le of term * term
-  | Lt of term * term
-  | Ge of term * term
-  | Gt of term * term
-  | Pred of string * term list
-
-and form =
-  | Fatom of atom
-  | Imp of form * form
-  | Iff of form * form
-  | And of form * form
-  | Or of form * form
-  | Not of form
-  | Forall of string * typ * form
-  | Exists of string * typ * form
-  | True
-  | False
-
-(* the integer indicates the number of type variables *)
-type decl =
-  | DeclType of string * int
-  | DeclFun of string * int * typ list * typ
-  | DeclPred of string * int * typ list
-  | Axiom of string * form
-
-type query = decl list * form
-
-
-(* prover result *)
-
-type prover_answer =
-  | Valid of string option
-  | Invalid
-  | DontKnow
-  | Timeout
-  | NoAnswer
-  | Failure of string
-
diff --git a/plugins/dp/g_dp.ml4 b/plugins/dp/g_dp.ml4
deleted file mode 100644
index fc957ea6..00000000
--- a/plugins/dp/g_dp.ml4
+++ /dev/null
@@ -1,79 +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*)
-
-(* $Id: g_dp.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
-open Dp
-
-TACTIC EXTEND Simplify
-  [ "simplify" ] -> [ simplify ]
-END
-
-TACTIC EXTEND Ergo
-  [ "ergo" ] -> [ ergo ]
-END
-
-TACTIC EXTEND Yices
-  [ "yices" ] -> [ yices ]
-END
-
-TACTIC EXTEND CVC3
-  [ "cvc3" ] -> [ cvc3 ]
-END
-
-TACTIC EXTEND Z3
-  [ "z3" ] -> [ z3 ]
-END
-
-TACTIC EXTEND CVCLite
-  [ "cvcl" ] -> [ cvc_lite ]
-END
-
-TACTIC EXTEND Harvey
-  [ "harvey" ] -> [ harvey ]
-END
-
-TACTIC EXTEND Zenon
-  [ "zenon" ] -> [ zenon ]
-END
-
-TACTIC EXTEND Gwhy
-  [ "gwhy" ] -> [ gwhy ]
-END
-
-(* should be part of basic tactics syntax *)
-TACTIC EXTEND admit
-  [ "admit"    ] -> [ Tactics.admit_as_an_axiom ]
-END
-
-VERNAC COMMAND EXTEND Dp_hint
-  [ "Dp_hint" ne_global_list(l) ] -> [ dp_hint l ]
-END
-
-VERNAC COMMAND EXTEND Dp_timeout
-| [ "Dp_timeout" natural(n) ] -> [ dp_timeout n ]
-END
-
-VERNAC COMMAND EXTEND Dp_prelude
-| [ "Dp_prelude" string_list(l) ] -> [ dp_prelude l ]
-END
-
-VERNAC COMMAND EXTEND Dp_predefined
-| [ "Dp_predefined" global(g) "=>" string(s) ] -> [ dp_predefined g s ]
-END
-
-VERNAC COMMAND EXTEND Dp_debug
-| [ "Dp_debug" ] -> [ dp_debug true; Dp_zenon.set_debug true ]
-END
-
-VERNAC COMMAND EXTEND Dp_trace
-| [ "Dp_trace" ] -> [ dp_trace true ]
-END
-
diff --git a/plugins/dp/test2.v b/plugins/dp/test2.v
deleted file mode 100644
index 0940b135..00000000
--- a/plugins/dp/test2.v
+++ /dev/null
@@ -1,80 +0,0 @@
-Require Import ZArith.
-Require Import Classical.
-Require Import List.
-
-Open Scope list_scope.
-Open Scope Z_scope.
-
-Dp_debug.
-Dp_timeout 3.
-Require Export zenon.
-
-Definition neg (z:Z) : Z := match z with
-  | Z0 => Z0
-  | Zpos p => Zneg p
-  | Zneg p => Zpos p
-  end.
-
-Goal forall z, neg (neg z) = z.
-  Admitted.
-
-Open Scope nat_scope.
-Print plus.
-
-Goal forall x, x+0=x.
-  induction x; ergo.
-  (* simplify resoud le premier, pas le second *)
-  Admitted.
-
-Goal 1::2::3::nil = 1::2::(1+2)::nil.
-  zenon.
-  Admitted.
-
-Definition T := nat.
-Parameter fct : T -> nat.
-Goal fct O = O.
- Admitted.
-
-Fixpoint even (n:nat) : Prop :=
-  match n with
-  O => True
-  | S O => False
-  | S (S p) => even p
-  end.
-
-Goal even 4%nat.
-  try zenon.
-  Admitted.
-
-Definition p (A B:Set) (a:A) (b:B) : list (A*B) := cons (a,b) nil.
-
-Definition head :=
-fun (A : Set) (l : list A) =>
-match l with
-| nil => None (A:=A)
-| x :: _ => Some x
-end.
-
-Goal forall x, head _ (p _ _ 1 2) = Some x -> fst x = 1.
-
-Admitted.
-
-(*
-BUG avec head prédéfini : manque eta-expansion sur A:Set
-
-Goal forall x, head _ (p _ _ 1 2) = Some x -> fst x = 1.
-
-Print value.
-Print Some.
-
-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].
-
-Goal forall x, forall (l:list nat), IN x l -> IN x (1%nat::l).
-  zenon.
-Print In.
diff --git a/plugins/dp/tests.v b/plugins/dp/tests.v
deleted file mode 100644
index dc85d2ee..00000000
--- a/plugins/dp/tests.v
+++ /dev/null
@@ -1,300 +0,0 @@
-
-Require Import ZArith.
-Require Import Classical.
-Require Export Reals.
-
-
-(* real numbers *)
-
-Lemma real_expr: (0 <= 9 * 4)%R.
-ergo.
-Qed.
-
-Lemma powerRZ_translation: (powerRZ 2 15 < powerRZ 2 17)%R.
-ergo.
-Qed.
-
-Dp_debug.
-Dp_timeout 3.
-
-(* module renamings *)
-
-Module M.
-  Parameter t : Set.
-End M.
-
-Lemma test_module_0 : forall x:M.t, x=x.
-ergo.
-Qed.
-
-Module N := M.
-
-Lemma test_module_renaming_0 : forall x:N.t, x=x.
-ergo.
-Qed.
-
-Dp_predefined M.t => "int".
-
-Lemma test_module_renaming_1 : forall x:N.t, x=x.
-ergo.
-Qed.
-
-(* Coq lists *)
-
-Require Export List.
-
-Lemma test_pol_0 : forall l:list nat, l=l.
-ergo.
-Qed.
-
-Parameter nlist: list nat -> Prop.
-
-Lemma poly_1 : forall l,  nlist l -> True.
-intros.
-simplify.
-Qed.
-
-(* user lists *)
-
-Inductive list (A:Set) : Set :=
-| nil : list A
-| cons: forall a:A, list A -> list A.
-
-Fixpoint app (A:Set) (l m:list A) {struct l} : list A :=
-match l with
-| nil => m
-| cons a l1 => cons A a (app A l1 m)
-end.
-
-Lemma entail: (nil Z) = app Z (nil Z) (nil Z) -> True.
-intros; ergo.
-Qed.
-
-(* polymorphism *)
-Require Import List.
-
-Inductive mylist (A:Set) : Set :=
-  mynil : mylist A
-| mycons : forall a:A, mylist A -> mylist A.
-
-Parameter my_nlist: mylist nat -> Prop.
-
- Goal forall l,  my_nlist l -> True.
- intros.
- simplify.
-Qed.
-
-(* First example with the 0 and the equality translated *)
-
-Goal 0 = 0.
-simplify.
-Qed.
-
-(* Examples in the Propositional Calculus
-   and theory of equality *)
-
-Parameter A C : Prop.
-
-Goal A -> A.
-simplify.
-Qed.
-
-
-Goal A -> (A \/ C).
-
-simplify.
-Qed.
-
-
-Parameter x y z : Z.
-
-Goal x = y -> y = z -> x = z.
-ergo.
-Qed.
-
-
-Goal ((((A -> C) -> A) -> A) -> C) -> C.
-
-ergo.
-Qed.
-
-(* Arithmetic *)
-Open Scope Z_scope.
-
-Goal 1 + 1 = 2.
-yices.
-Qed.
-
-
-Goal 2*x + 10 = 18 -> x = 4.
-
-simplify.
-Qed.
-
-
-(* Universal quantifier *)
-
-Goal (forall (x y : Z), x = y) -> 0=1.
-try zenon.
-ergo.
-Qed.
-
-Goal forall (x: nat), (x + 0 = x)%nat.
-
-induction x0; ergo.
-Qed.
-
-
-(* No decision procedure can solve this problem
-  Goal forall (x a b : Z), a * x + b = 0 -> x = - b/a.
-*)
-
-
-(* Functions definitions *)
-
-Definition fst (x y : Z) : Z := x.
-
-Goal forall (g : Z -> Z) (x y : Z), g (fst x y) = g x.
-
-simplify.
-Qed.
-
-
-(* Eta-expansion example *)
-
-Definition snd_of_3 (x y z : Z) : Z := y.
-
-Definition f : Z -> Z -> Z := snd_of_3 0.
-
-Goal forall (x y z z1 : Z), snd_of_3 x y z = f y z1.
-
-simplify.
-Qed.
-
-
-(* Inductive types definitions - call to dp/injection function *)
-
-Inductive even : Z -> Prop :=
-| even_0 : even 0
-| even_plus2 : forall z : Z, even z -> even (z + 2).
-
-
-(* Simplify and Zenon can't prove this goal before the timeout
-   unlike CVC Lite *)
-
-Goal even 4.
-ergo.
-Qed.
-
-
-Definition skip_z (z : Z) (n : nat) := n.
-
-Definition skip_z1 := skip_z.
-
-Goal forall (z : Z) (n : nat), skip_z z n = skip_z1 z n.
-yices.
-Qed.
-
-
-(* Axioms definitions and dp_hint *)
-
-Parameter add : nat -> nat -> nat.
-Axiom add_0 : forall (n : nat), add 0%nat n = n.
-Axiom add_S : forall (n1 n2 : nat), add (S n1) n2 = S (add n1 n2).
-
-Dp_hint add_0.
-Dp_hint add_S.
-
-(* Simplify can't prove this goal before the timeout
-   unlike zenon *)
-
-Goal forall n : nat, add n 0 = n.
-induction n ; yices.
-Qed.
-
-
-Definition pred (n : nat) : nat := match n with
-  | 0%nat => 0%nat
-  | S n' => n'
-end.
-
-Goal forall n : nat, n <> 0%nat -> pred (S n) <> 0%nat.
-yices.
-(*zenon.*)
-Qed.
-
-
-Fixpoint plus (n m : nat) {struct n} : nat :=
-  match n with
-  | 0%nat => m
-  | S n' => S (plus n' m)
-end.
-
-Goal forall n : nat, plus n 0%nat = n.
-
-induction n; ergo.
-Qed.
-
-
-(* Mutually recursive functions *)
-
-Fixpoint even_b (n : nat) : bool := match n with
-  | O => true
-  | S m => odd_b m
-end
-with odd_b (n : nat) : bool := match n with
-  | O => false
-  | S m => even_b m
-end.
-
-Goal even_b (S (S O)) = true.
-ergo.
-(*
-simplify.
-zenon.
-*)
-Qed.
-
-
-(* sorts issues *)
-
-Parameter foo : Set.
-Parameter ff : nat -> foo -> foo -> nat.
-Parameter g : foo -> foo.
-Goal (forall x:foo, ff 0 x x = O) -> forall y, ff 0 (g y) (g y) = O.
-yices.
-(*zenon.*)
-Qed.
-
-
-
-(* abstractions *)
-
-Parameter poly_f : forall A:Set, A->A.
-
-Goal forall x:nat, poly_f nat x = poly_f nat x.
-ergo.
-(*zenon.*)
-Qed.
-
-
-
-(* Anonymous mutually recursive functions : no equations are produced
-
-Definition mrf :=
-  fix even2 (n : nat) : bool := match n with
-    | O => true
-    | S m => odd2 m
-  end
-  with odd2 (n : nat) : bool := match n with
-    | O => false
-    | S m => even2 m
-  end for even.
-
-   Thus this goal is unsolvable
-
-Goal mrf (S (S O)) = true.
-
-zenon.
-
-*)
diff --git a/plugins/dp/vo.itarget b/plugins/dp/vo.itarget
deleted file mode 100644
index 4d282709..00000000
--- a/plugins/dp/vo.itarget
+++ /dev/null
@@ -1 +0,0 @@
-Dp.vo
diff --git a/plugins/dp/zenon.v b/plugins/dp/zenon.v
deleted file mode 100644
index f2400a7f..00000000
--- a/plugins/dp/zenon.v
+++ /dev/null
@@ -1,94 +0,0 @@
-(*  Copyright 2004 INRIA  *)
-(*  $Id: zenon.v 11996 2009-03-20 01:22:58Z letouzey $  *)
-
-Require Export Classical.
-
-Lemma zenon_nottrue :
-  (~True -> False).
-Proof. tauto. Qed.
-
-Lemma zenon_noteq : forall (T : Type) (t : T),
-  ((t <> t) -> False).
-Proof. tauto. Qed.
-
-Lemma zenon_and : forall P Q : Prop,
-  (P -> Q -> False) -> (P /\ Q -> False).
-Proof. tauto. Qed.
-
-Lemma zenon_or : forall P Q : Prop,
-  (P -> False) -> (Q -> False) -> (P \/ Q -> False).
-Proof. tauto. Qed.
-
-Lemma zenon_imply : forall P Q : Prop,
-  (~P -> False) -> (Q -> False) -> ((P -> Q) -> False).
-Proof. tauto. Qed.
-
-Lemma zenon_equiv : forall P Q : Prop,
-  (~P -> ~Q -> False) -> (P -> Q -> False) -> ((P <-> Q) -> False).
-Proof. tauto. Qed.
-
-Lemma zenon_notand : forall P Q : Prop,
-  (~P -> False) -> (~Q -> False) -> (~(P /\ Q) -> False).
-Proof. tauto. Qed.
-
-Lemma zenon_notor : forall P Q : Prop,
-  (~P -> ~Q -> False) -> (~(P \/ Q) -> False).
-Proof. tauto. Qed.
-
-Lemma zenon_notimply : forall P Q : Prop,
-  (P -> ~Q -> False) -> (~(P -> Q) -> False).
-Proof. tauto. Qed.
-
-Lemma zenon_notequiv : forall P Q : Prop,
-  (~P -> Q -> False) -> (P -> ~Q -> False) -> (~(P <-> Q) -> False).
-Proof. tauto. Qed.
-
-Lemma zenon_ex : forall (T : Type) (P : T -> Prop),
-  (forall z : T, ((P z) -> False)) -> ((exists x : T, (P x)) -> False).
-Proof. firstorder. Qed.
-
-Lemma zenon_all : forall (T : Type) (P : T -> Prop) (t : T),
-  ((P t) -> False) -> ((forall x : T, (P x)) -> False).
-Proof. firstorder. Qed.
-
-Lemma zenon_notex : forall (T : Type) (P : T -> Prop) (t : T),
-  (~(P t) -> False) -> (~(exists x : T, (P x)) -> False).
-Proof. firstorder. Qed.
-
-Lemma zenon_notall : forall (T : Type) (P : T -> Prop),
-  (forall z : T, (~(P z) -> False)) -> (~(forall x : T, (P x)) -> False).
-Proof. intros T P Ha Hb. apply Hb. intro. apply NNPP. exact (Ha x). Qed.
-
-Lemma zenon_equal_base : forall (T : Type) (f : T), f = f.
-Proof. auto. Qed.
-
-Lemma zenon_equal_step :
-  forall (S T : Type) (fa fb : S -> T) (a b : S),
-  (fa = fb) -> (a <> b -> False) -> ((fa a) = (fb b)).
-Proof. intros. rewrite (NNPP (a = b)). congruence. auto. Qed.
-
-Lemma zenon_pnotp : forall P Q : Prop,
-  (P = Q) -> (P -> ~Q -> False).
-Proof. intros P Q Ha. rewrite Ha. auto. Qed.
-
-Lemma zenon_notequal : forall (T : Type) (a b : T),
-  (a = b) -> (a <> b -> False).
-Proof. auto. Qed.
-
-Ltac zenon_intro id :=
-  intro id || let nid := fresh in (intro nid; clear nid)
-.
-
-Definition zenon_and_s := fun P Q a b => zenon_and P Q b a.
-Definition zenon_or_s := fun P Q a b c => zenon_or P Q b c a.
-Definition zenon_imply_s := fun P Q a b c => zenon_imply P Q b c a.
-Definition zenon_equiv_s := fun P Q a b c => zenon_equiv P Q b c a.
-Definition zenon_notand_s := fun P Q a b c => zenon_notand P Q b c a.
-Definition zenon_notor_s := fun P Q a b => zenon_notor P Q b a.
-Definition zenon_notimply_s := fun P Q a b => zenon_notimply P Q b a.
-Definition zenon_notequiv_s := fun P Q a b c => zenon_notequiv P Q b c a.
-Definition zenon_ex_s := fun T P a b => zenon_ex T P b a.
-Definition zenon_notall_s := fun T P a b => zenon_notall T P b a.
-
-Definition zenon_pnotp_s := fun P Q a b c => zenon_pnotp P Q c a b.
-Definition zenon_notequal_s := fun T a b x y => zenon_notequal T a b y x.
diff --git a/plugins/extraction/ExtrOcamlBasic.v b/plugins/extraction/ExtrOcamlBasic.v
index eab2f67c..3a54b252 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-2012     *)
 (*   \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..265fbc52 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-2012     *)
 (*   \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..cb866dc8 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-2012     *)
 (*   \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..fb45a8be 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-2012     *)
 (*   \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..956ece79 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,12 +8,16 @@
 
 (** 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
     by extracting [nat] into [int] is definitively *not* a good idea:
 
+    - This is just a syntactic adaptation, many things can go wrong,
+    such as name captures (e.g. if you have a constant named "int"
+    in your development, or a module named "Pervasives"). See bug #2878.
+
     - Since [int] is bounded while [nat] is (theoretically) infinite,
     you have to make sure by yourself that your program will not
     manipulate numbers greater than [max_int]. Otherwise you should
@@ -34,18 +38,18 @@ Require Import ExtrOcamlBasic.
 (** Mapping of [nat] into [int]. The last string corresponds to
     a [nat_case], see documentation of [Extract Inductive]. *)
 
-Extract Inductive nat => int [ "0" "succ" ]
+Extract Inductive nat => int [ "0" "Pervasives.succ" ]
  "(fun fO fS n -> if n=0 then fO () else fS (n-1))".
 
 (** Efficient (but uncertified) versions for usual [nat] functions *)
 
 Extract Constant plus => "(+)".
-Extract Constant pred => "fun n -> max 0 (n-1)".
-Extract Constant minus => "fun n m -> max 0 (n-m)".
+Extract Constant pred => "fun n -> Pervasives.max 0 (n-1)".
+Extract Constant minus => "fun n m -> Pervasives.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 max => "Pervasives.max".
+Extract Inlined Constant min => "Pervasives.min".
+(*Extract Inlined Constant nat_beq => "(=)".*)
 Extract Inlined Constant EqNat.beq_nat => "(=)".
 Extract Inlined Constant EqNat.eq_nat_decide => "(=)".
 
@@ -72,4 +76,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..3d86d712 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-2012     *)
 (*   \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..a6ba9aa2 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-2012     *)
 (*   \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,50 +36,52 @@ 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".
-
-(** Zdiv and Zmod are quite complex to define in terms of (/) and (mod).
+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".
+
+(** Z.div and Z.modulo are quite complex to define in terms of (/) and (mod).
     For the moment we don't even try *)
 
 (** Test:
 Require Import ZArith NArith.
 
 Extraction "/tmp/test.ml"
- Pplus Ppred Pminus Pmult Pcompare Npred Nminus Ndiv Nmod Ncompare
- Zplus Zmult BinInt.Zcompare Z_of_N Zabs_N Zdiv.Zdiv Zmod.
+ Pos.add Pos.pred Pos.sub Pos.mul Pos.compare N.pred N.sub N.div N.modulo N.compare
+ Z.add Z.mul Z.compare Z.of_N Z.abs_N Z.div Z.modulo.
 *)
diff --git a/plugins/extraction/ExtrOcamlZInt.v b/plugins/extraction/ExtrOcamlZInt.v
index a7046626..ab634329 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-2012     *)
 (*   \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,46 +33,48 @@ 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 => "Pervasives.succ".
+Extract Constant Pos.pred => "fun n -> Pervasives.max 1 (n-1)".
+Extract Constant Pos.sub => "fun n m -> Pervasives.max 1 (n-m)".
+Extract Constant Pos.mul => "( * )".
+Extract Constant Pos.min => "Pervasives.min".
+Extract Constant Pos.max => "Pervasives.max".
+Extract Constant Pos.compare =>
+ "fun x y -> if x=y then Eq else if x<y then Lt else Gt".
+Extract Constant Pos.compare_cont =>
  "fun x y c -> if x=y then c else if x<y then Lt else Gt".
 
 
-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 => "Pervasives.succ".
+Extract Constant N.pred => "fun n -> Pervasives.max 0 (n-1)".
+Extract Constant N.sub => "fun n m -> Pervasives.max 0 (n-m)".
+Extract Constant N.mul => "( * )".
+Extract Constant N.min => "Pervasives.min".
+Extract Constant N.max => "Pervasives.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 => "Pervasives.succ".
+Extract Constant Z.pred => "Pervasives.pred".
+Extract Constant Z.sub => "(-)".
+Extract Constant Z.mul => "( * )".
+Extract Constant Z.opp => "(~-)".
+Extract Constant Z.abs => "Pervasives.abs".
+Extract Constant Z.min => "Pervasives.min".
+Extract Constant Z.max => "Pervasives.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 => "Pervasives.abs".
 
-(** Zdiv and Zmod are quite complex to define in terms of (/) and (mod).
+(** Z.div and Z.modulo 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..ddb57a25 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-2012     *)
 (*   \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..92b5949e 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-2012     *)
 (*   \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
@@ -177,7 +197,7 @@ let empty_env () = [], get_global_ids ()
 let mktable autoclean =
   let h = Hashtbl.create 97 in
   if autoclean then register_cleanup (fun () -> Hashtbl.clear h);
-  (Hashtbl.add h, Hashtbl.find h, fun () -> Hashtbl.clear h)
+  (Hashtbl.replace h, Hashtbl.find h, fun () -> Hashtbl.clear h)
 
 (* We might have built [global_reference] whose canonical part is
    inaccurate. We must hence compare only the user part,
@@ -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..f5d90a43 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-2012     *)
 (*   \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..b7ee3c1a 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-2012     *)
 (*   \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,10 @@ 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 +175,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
@@ -179,13 +198,14 @@ let rec msid_of_seb = function
   | SEBwith (seb,_) -> msid_of_seb seb
   | _ -> assert false
 
-let env_for_mtb_with env mp seb idl =
+let env_for_mtb_with_def env mp seb idl =
   let sig_b = match seb with
     | SEBstruct(sig_b) -> sig_b
     | _ -> assert false
   in
   let l = label_of_id (List.hd idl) in
-  let before = fst (list_split_when (fun (l',_) -> l=l') sig_b) in
+  let spot = function (l',SFBconst _) -> l = l' | _ -> false in
+  let before = fst (list_split_when spot sig_b) in
   Modops.add_signature mp before empty_delta_resolver env
 
 (* From a [structure_body] (i.e. a list of [structure_field_body])
@@ -200,9 +220,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,15 +242,15 @@ 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 env' = env_for_mtb_with_def env (msid_of_seb seb') seb idl in
       let mt = extract_seb_spec env mp1 (seb,seb') in
       (match extract_with_type env' cb with (* cb peut contenir des kn  *)
 	 | 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 +302,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 +330,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 +364,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 *)
@@ -378,8 +397,10 @@ let mono_filename f =
 	in
 	let id =
 	  if lang () <> Haskell then default_id
-	  else try id_of_string (Filename.basename f)
-	  with _ -> error "Extraction: provided filename is not a valid identifier"
+	  else
+            try id_of_string (Filename.basename f)
+	    with e when Errors.noncritical e ->
+              error "Extraction: provided filename is not a valid identifier"
 	in
 	Some (f^d.file_suffix), Option.map ((^) f) d.sig_suffix, id
 
@@ -454,8 +475,8 @@ let print_structure_to_file (fn,si,mo) dry struc =
     msg_with ft (d.preamble mo opened unsafe_needs);
     msg_with ft (d.pp_struct struc);
     Option.iter close_out cout;
-  with e ->
-    Option.iter close_out cout; raise e
+  with reraise ->
+    Option.iter close_out cout; raise reraise
   end;
   if not dry then Option.iter info_file fn;
   (* Now, let's print the signature *)
@@ -468,8 +489,8 @@ let print_structure_to_file (fn,si,mo) dry struc =
 	 msg_with ft (d.sig_preamble mo opened unsafe_needs);
 	 msg_with ft (d.pp_sig (signature_of_structure struc));
 	 close_out cout;
-       with e ->
-	 close_out cout; raise e
+       with reraise ->
+	 close_out cout; raise reraise
        end;
        info_file si)
     (if dry then None else si);
@@ -488,13 +509,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 +529,10 @@ 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 e when Errors.noncritical e -> 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 +547,43 @@ 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
+let simple_extraction r =
+  Vernacentries.dump_global (Genarg.AN 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 +594,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 +608,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..75ac111d 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-2012     *)
 (*   \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..e5357336 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-2012     *)
 (*   \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:
@@ -134,7 +130,7 @@ let rec nb_default_params env c =
 
 (* Enriching a signature with implicit information *)
 
-let sign_with_implicits r s =
+let sign_with_implicits r s nb_params =
   let implicits = implicits_of_global r in
   let rec add_impl i = function
     | [] -> []
@@ -143,7 +139,7 @@ let sign_with_implicits r s =
 	  if sign = Keep && List.mem i implicits then Kill Kother else sign
 	in sign' :: add_impl (succ i) s
   in
-  add_impl 1 s
+  add_impl (1+nb_params) s
 
 (* Enriching a exception message *)
 
@@ -153,7 +149,7 @@ let rec handle_exn r n fn_name = function
 	 (fun i ->
 	    assert ((0 < i) && (i <= n));
 	    MLexn ("IMPLICIT "^ msg_non_implicit r (n+1-i) (fn_name i)))
-       with _ -> MLexn s)
+       with e when Errors.noncritical e -> MLexn s)
   | a -> ast_map (handle_exn r n fn_name) a
 
 (*S Management of type variable contexts. *)
@@ -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;
@@ -648,20 +667,23 @@ and extract_cst_app env mle mlt kn args =
   let head = put_magic_if magic1 (MLglob (ConstRef kn)) in
   (* Now, the extraction of the arguments. *)
   let s_full = type2signature env (snd schema) in
-  let s_full = sign_with_implicits (ConstRef kn) s_full in
+  let s_full = sign_with_implicits (ConstRef kn) s_full 0 in
   let s = sign_no_final_keeps s_full in
   let ls = List.length s in
   let la = List.length args in
   (* The ml arguments, already expunged from known logical ones *)
   let mla = make_mlargs env mle s args metas in
   let mla =
-    if not magic1 then
+    if magic1 || lang () <> Ocaml then mla
+    else
       try
+        (* for better optimisations later, we discard dependent args
+           of projections and replace them by fake args that will be
+           removed during final pretty-print. *)
 	let l,l' = list_chop (projection_arity (ConstRef kn)) mla in
 	if l' <> [] then (List.map (fun _ -> MLexn "Proj Args") l) @ l'
 	else mla
-      with _ -> mla
-    else mla
+      with e when Errors.noncritical e -> mla
   in
   (* For strict languages, purely logical signatures with at least
      one [Kill Kother] lead to a dummy lam. So a [MLdummy] is left
@@ -707,7 +729,7 @@ and extract_cons_app env mle mlt (((kn,i) as ip,j) as cp) args =
   let type_cons = instantiation (nb_tvars, type_cons) in
   (* Then, the usual variables [s], [ls], [la], ... *)
   let s = List.map (type2sign env) types in
-  let s = sign_with_implicits (ConstructRef cp) s in
+  let s = sign_with_implicits (ConstructRef cp) s params_nb in
   let ls = List.length s in
   let la = List.length args in
   assert (la <= ls + params_nb);
@@ -727,8 +749,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
@@ -786,28 +808,28 @@ and extract_case env mle ((kn,i) as ip,c,br) mlt =
 	let l = List.map f oi.ip_types.(i) in
 	(* the corresponding signature *)
 	let s = List.map (type2sign env) oi.ip_types.(i) in
-	let s = sign_with_implicits r s in
+	let s = sign_with_implicits r s mi.ind_nparams in
 	(* Extraction of the branch (in functional form). *)
 	let e = extract_maybe_term env mle (type_recomp (l,mlt)) br.(i) in
 	(* We suppress dummy arguments according to signature. *)
 	let ids,e = case_expunge s e in
 	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. *)
 
@@ -857,7 +879,7 @@ let extract_std_constant env kn body typ =
   let l,t' = type_decomp (expand env (var2var' t)) in
   let s = List.map (type2sign env) l in
   (* Check for user-declared implicit information *)
-  let s = sign_with_implicits (ConstRef kn) s in
+  let s = sign_with_implicits (ConstRef kn) s 0 in
   (* Decomposing the top level lambdas of [body].
      If there isn't enough, it's ok, as long as remaining args
      aren't to be pruned (and initial lambdas aren't to be all
@@ -869,7 +891,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 +900,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 +910,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
@@ -904,6 +926,19 @@ let extract_std_constant env kn body typ =
   in
   trm, type_expunge_from_sign env s t
 
+(* Extracts the type of an axiom, honors the Extraction Implicit declaration. *)
+let extract_axiom env kn typ =
+  reset_meta_count ();
+  (* The short type [t] (i.e. possibly with abbreviations). *)
+  let t = snd (record_constant_type env kn (Some typ)) in
+  (* The real type [t']: without head products, expanded, *)
+  (* and with [Tvar] translated to [Tvar'] (not instantiable). *)
+  let l,_ = type_decomp (expand env (var2var' t)) in
+  let s = List.map (type2sign env) l in
+  (* Check for user-declared implicit information *)
+  let s = sign_with_implicits (ConstRef kn) s 0 in
+  type_expunge_from_sign env s t
+
 let extract_fixpoint env vkn (fi,ti,ci) =
   let n = Array.length vkn in
   let types = Array.make n (Tdummy Kother)
@@ -925,34 +960,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 = extract_axiom env kn typ in
+    Dterm (r, MLaxiom, 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 +1009,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 +1023,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 +1045,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..1eb9ca8e 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-2012     *)
 (*   \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..7dabb560 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-2012     *)
 (*   \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..b6fc5ac8 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-2012     *)
 (*   \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,19 @@ 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))
+    | Tvar i ->
+      (try pr_id (List.nth vl (pred i))
+       with e when Errors.noncritical e -> (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 +113,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 +125,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 +135,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 +183,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 +285,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..5e76be48 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-2012     *)
 (*   \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..856a481e 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-2012     *)
 (*   \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..d0bf387a 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-2012     *)
 (*   \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
@@ -840,7 +879,7 @@ let is_program_branch = function
     (try
        ignore (int_of_string (String.sub s n (String.length s - n)));
        String.sub s 0 n = br
-     with _ -> false)
+     with e when Errors.noncritical e -> false)
   | Tmp _ | Dummy -> false
 
 let expand_linear_let o id e =
@@ -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 e when Errors.noncritical e -> 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..e10b6070 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-2012     *)
 (*   \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..bd997d2d 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-2012     *)
 (*   \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,9 +26,9 @@ 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 do_mp =
   let rec mt_iter = function
-    | MTident _ -> ()
+    | MTident mp -> do_mp mp
     | MTfunsig (_,mt,mt') -> mt_iter mt; mt_iter mt'
     | MTwith (mt,ML_With_type(idl,l,t))->
 	let mp_mt = msid_of_mt mt in
@@ -40,7 +38,12 @@ let struct_iter do_decl do_spec s =
 	in
 	let r = ConstRef (make_con mp_w empty_dirpath (label_of_id l')) in
 	mt_iter mt; do_decl (Dtype(r,l,t))
-    | MTwith (mt,_)->mt_iter mt
+    | MTwith (mt,ML_With_module(idl,mp))->
+        let mp_mt = msid_of_mt mt in
+        let mp_w =
+	  List.fold_left (fun mp l -> MPdot(mp,label_of_id l)) mp_mt idl
+	in
+	mt_iter mt; do_mp mp_w; do_mp mp
     | MTsig (_, sign) -> List.iter spec_iter sign
   and spec_iter = function
     | (_,Spec s) -> do_spec s
@@ -53,12 +56,16 @@ let struct_iter do_decl do_spec s =
 	me_iter m.ml_mod_expr; mt_iter m.ml_mod_type
     | (_,SEmodtype m) -> mt_iter m
   and me_iter = function
-    | MEident _ -> ()
+    | MEident mp -> do_mp mp
     | MEfunctor (_,mt,me) -> me_iter me; mt_iter mt
     | MEapply (me,me') -> me_iter me; me_iter me'
     | MEstruct (msid, sel) -> List.iter se_iter sel
   in
-  List.iter (function (_,sel) -> List.iter se_iter sel) s
+  se_iter
+
+let struct_iter do_decl do_spec do_mp s =
+  List.iter
+    (function (_,sel) -> List.iter (se_iter do_decl do_spec do_mp) sel) s
 
 (*s Apply some fonctions upon all references in [ml_type], [ml_ast],
   [ml_decl], [ml_spec] and [ml_structure]. *)
@@ -76,18 +83,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 +123,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
 
@@ -133,7 +147,7 @@ let decl_ast_search f = function
   | _ -> ()
 
 let struct_ast_search f s =
-  try struct_iter (decl_ast_search f) (fun _ -> ()) s; false
+  try struct_iter (decl_ast_search f) (fun _ -> ()) (fun _ -> ()) s; false
   with Found -> true
 
 let rec type_search f = function
@@ -157,7 +171,9 @@ let spec_type_search f = function
   | Sval (_,u) -> type_search f u
 
 let struct_type_search f s =
-  try struct_iter (decl_type_search f) (spec_type_search f) s; false
+  try
+    struct_iter (decl_type_search f) (spec_type_search f) (fun _ -> ()) s;
+    false
   with Found -> true
 
 
@@ -186,6 +202,15 @@ let signature_of_structure s =
 
 (*s Searching one [ml_decl] in a [ml_structure] by its [global_reference] *)
 
+let is_modular = function
+  | SEdecl _ -> false
+  | SEmodule _ | SEmodtype _ -> true
+
+let rec search_structure l m = function
+  | [] -> raise Not_found
+  | (lab,d)::_ when lab=l && is_modular d = m -> d
+  | _::fields -> search_structure l m fields
+
 let get_decl_in_structure r struc =
   try
     let base_mp,ll = labels_of_ref r in
@@ -194,7 +219,7 @@ let get_decl_in_structure r struc =
     let rec go ll sel = match ll with
       | [] -> assert false
       | l :: ll ->
-	  match List.assoc l sel with
+	  match search_structure l (ll<>[]) sel with
 	    | SEdecl d -> d
 	    | SEmodtype m -> assert false
 	    | SEmodule m ->
@@ -230,34 +255,32 @@ let dfix_to_mlfix rv av i =
   let c = Array.map (subst 0) av
   in MLfix(i, ids, c)
 
+(* [optim_se] applies the [normalize] function everywhere and does the
+   inlining of code. The inlined functions are kept for the moment in
+   order to preserve the global interface, later [depcheck_se] will get
+   rid of them if possible *)
+
 let rec optim_se top to_appear s = function
   | [] -> []
   | (l,SEdecl (Dterm (r,a,t))) :: lse ->
       let a = normalize (ast_glob_subst !s a) in
       let i = inline r a in
       if i then s := Refmap'.add r a !s;
-      if top && i && not (modular ()) && not (List.mem r to_appear)
-      then optim_se top to_appear s lse
-      else
-	let d = match optimize_fix a with
-	  | MLfix (0, _, [|c|]) ->
-	      Dfix ([|r|], [|ast_subst (MLglob r) c|], [|t|])
-	  | a -> Dterm (r, a, t)
-	in (l,SEdecl d) :: (optim_se top to_appear s lse)
+      let d = match optimize_fix a with
+	| MLfix (0, _, [|c|]) ->
+	  Dfix ([|r|], [|ast_subst (MLglob r) c|], [|t|])
+	| a -> Dterm (r, a, t)
+      in
+      (l,SEdecl d) :: (optim_se top to_appear s lse)
   | (l,SEdecl (Dfix (rv,av,tv))) :: lse ->
       let av = Array.map (fun a -> normalize (ast_glob_subst !s a)) av in
-      let all = ref true in
       (* This fake body ensures that no fixpoint will be auto-inlined. *)
       let fake_body = MLfix (0,[||],[||]) in
       for i = 0 to Array.length rv - 1 do
 	if inline rv.(i) fake_body
 	then s := Refmap'.add rv.(i) (dfix_to_mlfix rv av i) !s
-	else all := false
       done;
-      if !all && top && not (modular ())
-	&& (array_for_all (fun r -> not (List.mem r to_appear)) rv)
-      then optim_se top to_appear s lse
-      else (l,SEdecl (Dfix (rv, av, tv))) :: (optim_se top to_appear s lse)
+      (l,SEdecl (Dfix (rv, av, tv))) :: (optim_se top to_appear s lse)
   | (l,SEmodule m) :: lse ->
       let m = { m with ml_mod_expr = optim_me to_appear s m.ml_mod_expr}
       in (l,SEmodule m) :: (optim_se top to_appear s lse)
@@ -271,7 +294,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 definitions (no module pruning yet). *)
 
 exception NoDepCheck
 
@@ -281,15 +305,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 +328,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 +338,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 +354,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,14 +366,17 @@ 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 add_needed_mp t;
+    t :: se'
 
 let rec depcheck_struct = function
   | [] -> []
   | (mp,lse)::struc ->
       let struc' = depcheck_struct struc in
       let lse' = depcheck_se lse in
-      (mp,lse')::struc'
+      if lse' = [] then struc' else (mp,lse')::struc'
 
 let check_implicits = function
   | MLexn s ->
@@ -350,13 +392,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
+    List.filter (fun (_,lse) -> lse<>[]) 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..fb8d5e1b 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-2012     *)
 (*   \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..4e8d8145 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-2012     *)
 (*   \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 =
@@ -133,11 +119,13 @@ let rec pp_type par vl t =
   let rec pp_rec par = function
     | Tmeta _ | Tvar' _ | Taxiom -> assert false
     | Tvar i -> (try pp_tvar (List.nth vl (pred i))
-		 with _ -> (str "'a" ++ int i))
+		 with e when Errors.noncritical e ->
+                   (str "'a" ++ int i))
     | Tglob (r,[a1;a2]) when is_infix r ->
 	pp_par par (pp_rec true a1 ++ str (get_infix r) ++ pp_rec true a2)
     | Tglob (r,[]) -> pp_global Type r
-    | Tglob (IndRef(kn,0),l) when 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 +142,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 +164,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 +176,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))))
+	 with e when Errors.noncritical e -> apply (pp_global Term r))
     | MLfix (i,ids,defs) ->
 	let ids',env' = push_vars (List.rev (Array.to_list ids)) env in
-      	pp_fix par env' i (Array.of_list (List.rev ids'),defs) args
+	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 +202,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 +300,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 +329,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 +437,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 +445,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 +468,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..f55e2fd6 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-2012     *)
 (*   \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..7915bc82 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-2012     *)
 (*   \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..405842f0 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-2012     *)
 (*   \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..497ddf03 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-2012     *)
 (*   \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,29 +207,55 @@ 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)
- with _ -> string_of_id (safe_basename_of_global r)
+ with e when Errors.noncritical e -> string_of_id (safe_basename_of_global r)
 
 let safe_pr_global r = str (string_of_global r)
 
@@ -233,7 +263,7 @@ let safe_pr_global r = str (string_of_global r)
 
 let safe_pr_long_global r =
   try Printer.pr_global r
-  with _ -> match r with
+  with e when Errors.noncritical e -> match r with
     | ConstRef kn ->
 	let mp,_,l = repr_con kn in
 	str ((string_of_mp mp)^"."^(string_of_label l))
@@ -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" true
 
-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,8 @@ 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
+  Dumpglob.add_glob (loc_of_reference r) g;
   match g with
     | IndRef ((kn,i) as ip) ->
 	let mib = Global.lookup_mind kn in
@@ -805,5 +864,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..192426c3 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-2012     *)
 (*   \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..504304c6 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-2012     *)
 (*   \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..5e9ae430 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-2012     *)
 (*   \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..41d2998c 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-2012     *)
 (*   \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.
@@ -152,7 +150,7 @@ Ltac apply_assoc FT lvar trm :=
   match constr:(t = trm) with
   | (?X1 = ?X1) => idtac
   | _ =>
-      rewrite <- (assoc_correct FT trm); change (assoc trm) with t in |- *
+      rewrite <- (assoc_correct FT trm); change (assoc trm) with t
   end.
 
 (**** Distribution *****)
@@ -163,7 +161,7 @@ Ltac apply_distrib FT lvar trm :=
   | (?X1 = ?X1) => idtac
   | _ =>
       rewrite <- (distrib_correct FT trm);
-       change (distrib trm) with t in |- *
+       change (distrib trm) with t
   end.
 
 (**** Multiplication by the inverse product ****)
@@ -177,7 +175,7 @@ Ltac weak_reduce :=
   |  |- context [(interp_ExprA ?X1 ?X2 _)] =>
       cbv beta iota zeta
        delta [interp_ExprA assoc_2nd eq_nat_dec mult_of_list X1 X2 A Azero
-             Aone Aplus Amult Aopp Ainv] in |- *
+             Aone Aplus Amult Aopp Ainv]
   end.
 
 Ltac multiply mul :=
@@ -201,7 +199,7 @@ Ltac apply_multiply FT lvar trm :=
   | (?X1 = ?X1) => idtac
   | _ =>
       rewrite <- (multiply_correct FT trm);
-       change (multiply trm) with t in |- *
+       change (multiply trm) with t
   end.
 
 (**** Permutations and simplification ****)
@@ -212,7 +210,7 @@ Ltac apply_inverse mul FT lvar trm :=
   | (?X1 = ?X1) => idtac
   | _ =>
       rewrite <- (inverse_correct FT trm mul);
-       [ change (inverse_simplif mul trm) with t in |- * | assumption ]
+       [ change (inverse_simplif mul trm) with t | assumption ]
   end.
 (**** Inverse test ****)
 
@@ -254,11 +252,11 @@ Ltac apply_simplif sfun :=
 
 Ltac unfolds FT :=
   match get_component Aminus FT with
-  | Some ?X1 => unfold X1 in |- *
+  | Some ?X1 => unfold X1
   | _ => idtac
   end;
   match get_component Adiv FT with
-  | Some ?X1 => unfold X1 in |- *
+  | Some ?X1 => unfold X1
   | _ => idtac
   end.
 
@@ -269,8 +267,8 @@ Ltac reduce FT :=
   with AmultT := get_component Amult FT
   with AoppT := get_component Aopp FT
   with AinvT := get_component Ainv FT in
-  (cbv beta iota zeta delta -[AzeroT AoneT AplusT AmultT AoppT AinvT] in |- * ||
-     compute in |- *).
+  (cbv beta iota zeta delta -[AzeroT AoneT AplusT AmultT AoppT AinvT] ||
+     compute).
 
 Ltac field_gen_aux FT :=
   let AplusT := get_component Aplus FT in
@@ -282,7 +280,7 @@ Ltac field_gen_aux FT :=
       cut
         (let ft := FT in
          let vm := lvar in interp_ExprA ft vm trm1 = interp_ExprA ft vm trm2);
-        [ compute in |- *; auto
+        [ compute; auto
         | intros ft vm; apply_simplif apply_distrib;
            apply_simplif apply_assoc; multiply mul;
            [ apply_simplif apply_multiply;
diff --git a/plugins/field/LegacyField_Theory.v b/plugins/field/LegacyField_Theory.v
index 8d10bc8e..1d581a8f 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-2012     *)
 (*   \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.
@@ -46,20 +44,20 @@ Proof.
   elim (H1 e0); intro y; elim (H2 e); intro y0;
    try
     (left; rewrite y; rewrite y0; auto) ||
-      (right; red in |- *; intro; inversion H3; auto).
+      (right; red; intro; inversion H3; auto).
   elim (H1 e0); intro y; elim (H2 e); intro y0;
    try
     (left; rewrite y; rewrite y0; auto) ||
-      (right; red in |- *; intro; inversion H3; auto).
+      (right; red; intro; inversion H3; auto).
   elim (H0 e); intro y.
   left; rewrite y; auto.
-  right; red in |- *; intro; inversion H1; auto.
+  right; red; intro; inversion H1; auto.
   elim (H0 e); intro y.
   left; rewrite y; auto.
-  right; red in |- *; intro; inversion H1; auto.
+  right; red; intro; inversion H1; auto.
   elim (eq_nat_dec n n0); intro y.
   left; rewrite y; auto.
-  right; red in |- *; intro; inversion H; auto.
+  right; red; intro; inversion H; auto.
 Defined.
 
 Definition eq_nat_dec := Eval compute in eq_nat_dec.
@@ -154,7 +152,7 @@ Lemma r_AmultT_mult :
  forall r r1 r2:AT, AmultT r r1 = AmultT r r2 -> r <> AzeroT -> r1 = r2.
 Proof.
   intros; transitivity (AmultT (AmultT (AinvT r) r) r1).
-  rewrite Th_inv_defT; [ symmetry  in |- *; apply AmultT_1l; auto | auto ].
+  rewrite Th_inv_defT; [ symmetry ; apply AmultT_1l; auto | auto ].
   transitivity (AmultT (AmultT (AinvT r) r) r2).
   repeat rewrite AmultT_assoc; rewrite H; trivial.
   rewrite Th_inv_defT; [ apply AmultT_1l; auto | auto ].
@@ -183,7 +181,7 @@ Qed.
 Lemma Rmult_neq_0_reg :
  forall r1 r2:AT, AmultT r1 r2 <> AzeroT -> r1 <> AzeroT /\ r2 <> AzeroT.
 Proof.
-  intros r1 r2 H; split; red in |- *; intro; apply H; rewrite H0; legacy ring.
+  intros r1 r2 H; split; red; intro; apply H; rewrite H0; legacy ring.
 Qed.
 
 (************************)
@@ -264,11 +262,11 @@ Lemma merge_mult_correct1 :
 Proof.
 intros e1 e2; generalize e1; generalize e2; clear e1 e2.
 simple induction e2; auto; intros.
-unfold merge_mult at 1 in |- *; fold merge_mult in |- *;
- unfold interp_ExprA at 2 in |- *; fold interp_ExprA in |- *;
- rewrite (H0 e e3 lvar); unfold interp_ExprA at 1 in |- *;
- fold interp_ExprA in |- *; unfold interp_ExprA at 5 in |- *;
- fold interp_ExprA in |- *; auto.
+unfold merge_mult at 1; fold merge_mult;
+ unfold interp_ExprA at 2; fold interp_ExprA;
+ rewrite (H0 e e3 lvar); unfold interp_ExprA at 1;
+ fold interp_ExprA; unfold interp_ExprA at 5;
+ fold interp_ExprA; auto.
 Qed.
 
 Lemma merge_mult_correct :
@@ -276,7 +274,7 @@ Lemma merge_mult_correct :
    interp_ExprA lvar (merge_mult e1 e2) = interp_ExprA lvar (EAmult e1 e2).
 Proof.
 simple induction e1; auto; intros.
-elim e0; try (intros; simpl in |- *; legacy ring).
+elim e0; try (intros; simpl; legacy ring).
 unfold interp_ExprA in H2; fold interp_ExprA in H2;
  cut
   (AmultT (interp_ExprA lvar e2)
@@ -286,7 +284,7 @@ unfold interp_ExprA in H2; fold interp_ExprA in H2;
      (AmultT (AmultT (interp_ExprA lvar e) (interp_ExprA lvar e4))
         (interp_ExprA lvar e2)) (interp_ExprA lvar e3)).
 intro H3; rewrite H3; rewrite <- H2; rewrite merge_mult_correct1;
- simpl in |- *; legacy ring.
+ simpl; legacy ring.
 legacy ring.
 Qed.
 
@@ -297,8 +295,8 @@ Lemma assoc_mult_correct1 :
    interp_ExprA lvar (assoc_mult (EAmult e1 e2)).
 Proof.
 simple induction e1; auto; intros.
-rewrite <- (H e0 lvar); simpl in |- *; rewrite merge_mult_correct;
- simpl in |- *; rewrite merge_mult_correct; simpl in |- *;
+rewrite <- (H e0 lvar); simpl; rewrite merge_mult_correct;
+ simpl; rewrite merge_mult_correct; simpl;
  auto.
 Qed.
 
@@ -308,21 +306,21 @@ Lemma assoc_mult_correct :
 Proof.
 simple induction e; auto; intros.
 elim e0; intros.
-intros; simpl in |- *; legacy ring.
-simpl in |- *; rewrite (AmultT_1l (interp_ExprA lvar (assoc_mult e1)));
+intros; simpl; legacy ring.
+simpl; rewrite (AmultT_1l (interp_ExprA lvar (assoc_mult e1)));
  rewrite (AmultT_1l (interp_ExprA lvar e1)); apply H0.
-simpl in |- *; rewrite (H0 lvar); auto.
-simpl in |- *; rewrite merge_mult_correct; simpl in |- *;
- rewrite merge_mult_correct; simpl in |- *; rewrite AmultT_assoc;
- rewrite assoc_mult_correct1; rewrite H2; simpl in |- *;
+simpl; rewrite (H0 lvar); auto.
+simpl; rewrite merge_mult_correct; simpl;
+ rewrite merge_mult_correct; simpl; rewrite AmultT_assoc;
+ rewrite assoc_mult_correct1; rewrite H2; simpl;
  rewrite <- assoc_mult_correct1 in H1; unfold interp_ExprA at 3 in H1;
  fold interp_ExprA in H1; rewrite (H0 lvar) in H1;
  rewrite (AmultT_comm (interp_ExprA lvar e3) (interp_ExprA lvar e1));
  rewrite <- AmultT_assoc; rewrite H1; rewrite AmultT_assoc;
  legacy ring.
-simpl in |- *; rewrite (H0 lvar); auto.
-simpl in |- *; rewrite (H0 lvar); auto.
-simpl in |- *; rewrite (H0 lvar); auto.
+simpl; rewrite (H0 lvar); auto.
+simpl; rewrite (H0 lvar); auto.
+simpl; rewrite (H0 lvar); auto.
 Qed.
 
 Lemma merge_plus_correct1 :
@@ -332,11 +330,11 @@ Lemma merge_plus_correct1 :
 Proof.
 intros e1 e2; generalize e1; generalize e2; clear e1 e2.
 simple induction e2; auto; intros.
-unfold merge_plus at 1 in |- *; fold merge_plus in |- *;
- unfold interp_ExprA at 2 in |- *; fold interp_ExprA in |- *;
- rewrite (H0 e e3 lvar); unfold interp_ExprA at 1 in |- *;
- fold interp_ExprA in |- *; unfold interp_ExprA at 5 in |- *;
- fold interp_ExprA in |- *; auto.
+unfold merge_plus at 1; fold merge_plus;
+ unfold interp_ExprA at 2; fold interp_ExprA;
+ rewrite (H0 e e3 lvar); unfold interp_ExprA at 1;
+ fold interp_ExprA; unfold interp_ExprA at 5;
+ fold interp_ExprA; auto.
 Qed.
 
 Lemma merge_plus_correct :
@@ -344,7 +342,7 @@ Lemma merge_plus_correct :
    interp_ExprA lvar (merge_plus e1 e2) = interp_ExprA lvar (EAplus e1 e2).
 Proof.
 simple induction e1; auto; intros.
-elim e0; try intros; try (simpl in |- *; legacy ring).
+elim e0; try intros; try (simpl; legacy ring).
 unfold interp_ExprA in H2; fold interp_ExprA in H2;
  cut
   (AplusT (interp_ExprA lvar e2)
@@ -354,7 +352,7 @@ unfold interp_ExprA in H2; fold interp_ExprA in H2;
      (AplusT (AplusT (interp_ExprA lvar e) (interp_ExprA lvar e4))
         (interp_ExprA lvar e2)) (interp_ExprA lvar e3)).
 intro H3; rewrite H3; rewrite <- H2; rewrite merge_plus_correct1;
- simpl in |- *; legacy ring.
+ simpl; legacy ring.
 legacy ring.
 Qed.
 
@@ -364,8 +362,8 @@ Lemma assoc_plus_correct :
    interp_ExprA lvar (assoc (EAplus e1 e2)).
 Proof.
 simple induction e1; auto; intros.
-rewrite <- (H e0 lvar); simpl in |- *; rewrite merge_plus_correct;
- simpl in |- *; rewrite merge_plus_correct; simpl in |- *;
+rewrite <- (H e0 lvar); simpl; rewrite merge_plus_correct;
+ simpl; rewrite merge_plus_correct; simpl;
  auto.
 Qed.
 
@@ -375,11 +373,11 @@ Lemma assoc_correct :
 Proof.
 simple induction e; auto; intros.
 elim e0; intros.
-simpl in |- *; rewrite (H0 lvar); auto.
-simpl in |- *; rewrite (H0 lvar); auto.
-simpl in |- *; rewrite merge_plus_correct; simpl in |- *;
- rewrite merge_plus_correct; simpl in |- *; rewrite AplusT_assoc;
- rewrite assoc_plus_correct; rewrite H2; simpl in |- *;
+simpl; rewrite (H0 lvar); auto.
+simpl; rewrite (H0 lvar); auto.
+simpl; rewrite merge_plus_correct; simpl;
+ rewrite merge_plus_correct; simpl; rewrite AplusT_assoc;
+ rewrite assoc_plus_correct; rewrite H2; simpl;
  apply
   (r_AplusT_plus (interp_ExprA lvar (assoc e1))
      (AplusT (interp_ExprA lvar (assoc e2))
@@ -388,7 +386,7 @@ simpl in |- *; rewrite merge_plus_correct; simpl in |- *;
         (interp_ExprA lvar e1))); rewrite <- AplusT_assoc;
  rewrite
   (AplusT_comm (interp_ExprA lvar (assoc e1)) (interp_ExprA lvar (assoc e2)))
-  ; rewrite assoc_plus_correct; rewrite H1; simpl in |- *;
+  ; rewrite assoc_plus_correct; rewrite H1; simpl;
  rewrite (H0 lvar);
  rewrite <-
   (AplusT_assoc (AplusT (interp_ExprA lvar e2) (interp_ExprA lvar e1))
@@ -401,15 +399,15 @@ simpl in |- *; rewrite merge_plus_correct; simpl in |- *;
  rewrite <-
   (AplusT_assoc (interp_ExprA lvar e2) (interp_ExprA lvar e3)
      (interp_ExprA lvar e1)); apply AplusT_comm.
-unfold assoc in |- *; fold assoc in |- *; unfold interp_ExprA in |- *;
- fold interp_ExprA in |- *; rewrite assoc_mult_correct;
- rewrite (H0 lvar); simpl in |- *; auto.
-simpl in |- *; rewrite (H0 lvar); auto.
-simpl in |- *; rewrite (H0 lvar); auto.
-simpl in |- *; rewrite (H0 lvar); auto.
-unfold assoc in |- *; fold assoc in |- *; unfold interp_ExprA in |- *;
- fold interp_ExprA in |- *; rewrite assoc_mult_correct;
- simpl in |- *; auto.
+unfold assoc; fold assoc; unfold interp_ExprA;
+ fold interp_ExprA; rewrite assoc_mult_correct;
+ rewrite (H0 lvar); simpl; auto.
+simpl; rewrite (H0 lvar); auto.
+simpl; rewrite (H0 lvar); auto.
+simpl; rewrite (H0 lvar); auto.
+unfold assoc; fold assoc; unfold interp_ExprA;
+ fold interp_ExprA; rewrite assoc_mult_correct;
+ simpl; auto.
 Qed.
 
 (**** Distribution *****)
@@ -453,7 +451,7 @@ Lemma distrib_mult_right_correct :
    interp_ExprA lvar (distrib_mult_right e1 e2) =
    AmultT (interp_ExprA lvar e1) (interp_ExprA lvar e2).
 Proof.
-simple induction e1; try intros; simpl in |- *; auto.
+simple induction e1; try intros; simpl; auto.
 rewrite AmultT_comm; rewrite AmultT_AplusT_distr; rewrite (H e2 lvar);
  rewrite (H0 e2 lvar); legacy ring.
 Qed.
@@ -463,10 +461,10 @@ Lemma distrib_mult_left_correct :
    interp_ExprA lvar (distrib_mult_left e1 e2) =
    AmultT (interp_ExprA lvar e1) (interp_ExprA lvar e2).
 Proof.
-simple induction e1; try intros; simpl in |- *.
-rewrite AmultT_Ol; rewrite distrib_mult_right_correct; simpl in |- *;
+simple induction e1; try intros; simpl.
+rewrite AmultT_Ol; rewrite distrib_mult_right_correct; simpl;
  apply AmultT_Or.
-rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm.
+rewrite distrib_mult_right_correct; simpl; apply AmultT_comm.
 rewrite AmultT_comm;
  rewrite
   (AmultT_AplusT_distr (interp_ExprA lvar e2) (interp_ExprA lvar e)
@@ -474,10 +472,10 @@ rewrite AmultT_comm;
  rewrite (AmultT_comm (interp_ExprA lvar e2) (interp_ExprA lvar e));
  rewrite (AmultT_comm (interp_ExprA lvar e2) (interp_ExprA lvar e0));
  rewrite (H e2 lvar); rewrite (H0 e2 lvar); auto.
-rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm.
-rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm.
-rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm.
-rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm.
+rewrite distrib_mult_right_correct; simpl; apply AmultT_comm.
+rewrite distrib_mult_right_correct; simpl; apply AmultT_comm.
+rewrite distrib_mult_right_correct; simpl; apply AmultT_comm.
+rewrite distrib_mult_right_correct; simpl; apply AmultT_comm.
 Qed.
 
 Lemma distrib_correct :
@@ -485,13 +483,13 @@ Lemma distrib_correct :
    interp_ExprA lvar (distrib e) = interp_ExprA lvar e.
 Proof.
 simple induction e; intros; auto.
-simpl in |- *; rewrite <- (H lvar); rewrite <- (H0 lvar);
- unfold distrib in |- *; simpl in |- *; auto.
-simpl in |- *; rewrite <- (H lvar); rewrite <- (H0 lvar);
- unfold distrib in |- *; simpl in |- *; apply distrib_mult_left_correct.
-simpl in |- *; fold AoppT in |- *; rewrite <- (H lvar);
- unfold distrib in |- *; simpl in |- *; rewrite distrib_mult_right_correct;
- simpl in |- *; fold AoppT in |- *; legacy ring.
+simpl; rewrite <- (H lvar); rewrite <- (H0 lvar);
+ unfold distrib; simpl; auto.
+simpl; rewrite <- (H lvar); rewrite <- (H0 lvar);
+ unfold distrib; simpl; apply distrib_mult_left_correct.
+simpl; fold AoppT; rewrite <- (H lvar);
+ unfold distrib; simpl; rewrite distrib_mult_right_correct;
+ simpl; fold AoppT; legacy ring.
 Qed.
 
 (**** Multiplication by the inverse product ****)
@@ -502,7 +500,7 @@ Lemma mult_eq :
    interp_ExprA lvar (EAmult a e1) = interp_ExprA lvar (EAmult a e2) ->
    interp_ExprA lvar e1 = interp_ExprA lvar e2.
 Proof.
-  simpl in |- *; intros;
+  simpl; intros;
    apply
     (r_AmultT_mult (interp_ExprA lvar a) (interp_ExprA lvar e1)
        (interp_ExprA lvar e2)); assumption.
@@ -525,16 +523,16 @@ Lemma multiply_aux_correct :
    interp_ExprA lvar (multiply_aux a e) =
    AmultT (interp_ExprA lvar a) (interp_ExprA lvar e).
 Proof.
-simple induction e; simpl in |- *; intros; try rewrite merge_mult_correct;
+simple induction e; simpl; intros; try rewrite merge_mult_correct;
  auto.
-  simpl in |- *; rewrite (H0 lvar); legacy ring.
+  simpl; rewrite (H0 lvar); legacy ring.
 Qed.
 
 Lemma multiply_correct :
  forall (e:ExprA) (lvar:list (AT * nat)),
    interp_ExprA lvar (multiply e) = interp_ExprA lvar e.
 Proof.
-  simple induction e; simpl in |- *; auto.
+  simple induction e; simpl; auto.
   intros; apply multiply_aux_correct.
 Qed.
 
@@ -585,27 +583,27 @@ Lemma monom_remove_correct :
    AmultT (interp_ExprA lvar a) (interp_ExprA lvar e).
 Proof.
 simple induction e; intros.
-simpl in |- *; case (eqExprA EAzero (EAinv a)); intros;
- [ inversion e0 | simpl in |- *; trivial ].
-simpl in |- *; case (eqExprA EAone (EAinv a)); intros;
- [ inversion e0 | simpl in |- *; trivial ].
-simpl in |- *; case (eqExprA (EAplus e0 e1) (EAinv a)); intros;
- [ inversion e2 | simpl in |- *; trivial ].
-simpl in |- *; case (eqExprA e0 (EAinv a)); intros.
-rewrite e2; simpl in |- *; fold AinvT in |- *.
+simpl; case (eqExprA EAzero (EAinv a)); intros;
+ [ inversion e0 | simpl; trivial ].
+simpl; case (eqExprA EAone (EAinv a)); intros;
+ [ inversion e0 | simpl; trivial ].
+simpl; case (eqExprA (EAplus e0 e1) (EAinv a)); intros;
+ [ inversion e2 | simpl; trivial ].
+simpl; case (eqExprA e0 (EAinv a)); intros.
+rewrite e2; simpl; fold AinvT.
 rewrite <-
  (AmultT_assoc (interp_ExprA lvar a) (AinvT (interp_ExprA lvar a))
     (interp_ExprA lvar e1)); rewrite AinvT_r; [ legacy ring | assumption ].
-simpl in |- *; rewrite H0; auto; legacy ring.
-simpl in |- *; fold AoppT in |- *; case (eqExprA (EAopp e0) (EAinv a));
- intros; [ inversion e1 | simpl in |- *; trivial ].
-unfold monom_remove in |- *; case (eqExprA (EAinv e0) (EAinv a)); intros.
+simpl; rewrite H0; auto; legacy ring.
+simpl; fold AoppT; case (eqExprA (EAopp e0) (EAinv a));
+ intros; [ inversion e1 | simpl; trivial ].
+unfold monom_remove; case (eqExprA (EAinv e0) (EAinv a)); intros.
 case (eqExprA e0 a); intros.
-rewrite e2; simpl in |- *; fold AinvT in |- *; rewrite AinvT_r; auto.
-inversion e1; simpl in |- *; exfalso; auto.
-simpl in |- *; trivial.
-unfold monom_remove in |- *; case (eqExprA (EAvar n) (EAinv a)); intros;
- [ inversion e0 | simpl in |- *; trivial ].
+rewrite e2; simpl; fold AinvT; rewrite AinvT_r; auto.
+inversion e1; simpl; exfalso; auto.
+simpl; trivial.
+unfold monom_remove; case (eqExprA (EAvar n) (EAinv a)); intros;
+ [ inversion e0 | simpl; trivial ].
 Qed.
 
 Lemma monom_simplif_rem_correct :
@@ -614,7 +612,7 @@ Lemma monom_simplif_rem_correct :
    interp_ExprA lvar (monom_simplif_rem a e) =
    AmultT (interp_ExprA lvar a) (interp_ExprA lvar e).
 Proof.
-simple induction a; simpl in |- *; intros; try rewrite monom_remove_correct;
+simple induction a; simpl; intros; try rewrite monom_remove_correct;
  auto.
 elim (Rmult_neq_0_reg (interp_ExprA lvar e) (interp_ExprA lvar e0) H1);
  intros.
@@ -628,9 +626,9 @@ Lemma monom_simplif_correct :
    interp_ExprA lvar (monom_simplif a e) = interp_ExprA lvar e.
 Proof.
 simple induction e; intros; auto.
-simpl in |- *; case (eqExprA a e0); intros.
+simpl; case (eqExprA a e0); intros.
 rewrite <- e2; apply monom_simplif_rem_correct; auto.
-simpl in |- *; trivial.
+simpl; trivial.
 Qed.
 
 Lemma inverse_correct :
@@ -639,8 +637,8 @@ Lemma inverse_correct :
    interp_ExprA lvar (inverse_simplif a e) = interp_ExprA lvar e.
 Proof.
 simple induction e; intros; auto.
-simpl in |- *; rewrite (H0 a lvar H1); rewrite monom_simplif_correct; auto.
-unfold inverse_simplif in |- *; rewrite monom_simplif_correct; auto.
+simpl; rewrite (H0 a lvar H1); rewrite monom_simplif_correct; auto.
+unfold inverse_simplif; rewrite monom_simplif_correct; auto.
 Qed.
 
 End Theory_of_fields.
diff --git a/plugins/field/field.ml4 b/plugins/field/field.ml4
index 37aa457d..6c9fd325 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-2012     *)
 (*   \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..f0043140 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-2012     *)
 (*   \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..fe6238ab 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-2012     *)
 (*   \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..29d41b81 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-2012     *)
 (*   \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);
@@ -85,7 +85,7 @@ let gen_ground_tac flag taco ids bases gl=
 	extend_with_auto_hints bases (extend_with_ref_list ids seq gl) gl in
       let result=ground_tac solver startseq gl in
 	qflag:=backup;result
-    with e ->qflag:=backup;raise e
+    with reraise ->qflag:=backup;raise reraise
 
 (* special for compatibility with Intuition
 
@@ -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
@@ -135,8 +134,6 @@ TACTIC EXTEND firstorder
 |   [ "firstorder" tactic_opt(t) firstorder_using(l)
        "with" ne_preident_list(l') ] ->
       [ gen_ground_tac true (Option.map eval_tactic t) l l' ]
-|   [ "firstorder" tactic_opt(t) ] ->
-      [ gen_ground_tac true (Option.map eval_tactic t) [] [] ]
 END
 
 TACTIC EXTEND gintuition
diff --git a/plugins/firstorder/ground.ml b/plugins/firstorder/ground.ml
index 163b9891..4d907b2c 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-2012     *)
 (*   \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..8b2ba20c 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-2012     *)
 (*   \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..4b07c609 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-2012     *)
 (*   \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,13 +123,13 @@ 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)
-  with _ ->
+  with e when Errors.noncritical e ->
     error "Untypable instance, maybe higher-order non-prenex quantification" in
     decompose_lam_n_assum m ntt
 
@@ -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..edccf213 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-2012     *)
 (*   \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..33bb522f 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-2012     *)
 (*   \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..d56efbcb 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-2012     *)
 (*   \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..43de96ab 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-2012     *)
 (*   \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..9e99e23b 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-2012     *)
 (*   \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..73c7f79c 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-2012     *)
 (*   \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..a13709f4 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-2012     *)
 (*   \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..f37d0027 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-2012     *)
 (*   \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..b10c304c 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-2012     *)
 (*   \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".
 
@@ -18,7 +16,7 @@ intros; apply Rmult_lt_compat_l; assumption.
 Qed.
 
 Lemma Rfourier_le : forall x1 y1 a:R, x1 <= y1 -> 0 < a -> a * x1 <= a * y1.
-red in |- *.
+red.
 intros.
 case H; auto with real.
 Qed.
@@ -65,19 +63,19 @@ Lemma Rfourier_le_le :
    x1 <= y1 -> x2 <= y2 -> 0 < a -> x1 + a * x2 <= y1 + a * y2.
 intros x1 y1 x2 y2 a H H0 H1; try assumption.
 case H0; intros.
-red in |- *.
+red.
 left; try assumption.
 apply Rfourier_le_lt; auto with real.
 rewrite H2.
 case H; intros.
-red in |- *.
+red.
 left; try assumption.
 rewrite (Rplus_comm x1 (a * y2)).
 rewrite (Rplus_comm y1 (a * y2)).
 apply Rplus_lt_compat_l.
 try exact H3.
 rewrite H3.
-red in |- *.
+red.
 right; try assumption.
 auto with real.
 Qed.
@@ -86,7 +84,7 @@ Lemma Rlt_zero_pos_plus1 : forall x:R, 0 < x -> 0 < 1 + x.
 intros x H; try assumption.
 rewrite Rplus_comm.
 apply Rle_lt_0_plus_1.
-red in |- *; auto with real.
+red; auto with real.
 Qed.
 
 Lemma Rlt_mult_inv_pos : forall x y:R, 0 < x -> 0 < y -> 0 < x * / y.
@@ -103,12 +101,12 @@ Qed.
 Lemma Rle_zero_pos_plus1 : forall x:R, 0 <= x -> 0 <= 1 + x.
 intros x H; try assumption.
 case H; intros.
-red in |- *.
+red.
 left; try assumption.
 apply Rlt_zero_pos_plus1; auto with real.
 rewrite <- H0.
 replace (1 + 0) with 1.
-red in |- *; left.
+red; left.
 exact Rlt_zero_1.
 ring.
 Qed.
@@ -116,28 +114,28 @@ Qed.
 Lemma Rle_mult_inv_pos : forall x y:R, 0 <= x -> 0 < y -> 0 <= x * / y.
 intros x y H H0; try assumption.
 case H; intros.
-red in |- *; left.
+red; left.
 apply Rlt_mult_inv_pos; auto with real.
 rewrite <- H1.
-red in |- *; right; ring.
+red; right; ring.
 Qed.
 
 Lemma Rle_zero_1 : 0 <= 1.
-red in |- *; left.
+red; left.
 exact Rlt_zero_1.
 Qed.
 
 Lemma Rle_not_lt : forall n d:R, 0 <= n * / d -> ~ 0 < - n * / d.
-intros n d H; red in |- *; intros H0; try exact H0.
+intros n d H; red; intros H0; try exact H0.
 generalize (Rgt_not_le 0 (n * / d)).
 intros H1; elim H1; try assumption.
 replace (n * / d) with (- - (n * / d)).
 replace 0 with (- -0).
 replace (- (n * / d)) with (- n * / d).
 replace (-0) with 0.
-red in |- *.
+red.
 apply Ropp_gt_lt_contravar.
-red in |- *.
+red.
 exact H0.
 ring.
 ring.
@@ -164,7 +162,7 @@ ring.
 Qed.
 
 Lemma Rnot_lt_lt : forall x y:R, ~ 0 < y - x -> ~ x < y.
-unfold not in |- *; intros.
+unfold not; intros.
 apply H.
 apply Rplus_lt_reg_r with x.
 replace (x + 0) with x.
@@ -175,7 +173,7 @@ ring.
 Qed.
 
 Lemma Rnot_le_le : forall x y:R, ~ 0 <= y - x -> ~ x <= y.
-unfold not in |- *; intros.
+unfold not; intros.
 apply H.
 case H0; intros.
 left.
@@ -190,7 +188,7 @@ rewrite H1; ring.
 Qed.
 
 Lemma Rfourier_gt_to_lt : forall x y:R, y > x -> x < y.
-unfold Rgt in |- *; intros; assumption.
+unfold Rgt; intros; assumption.
 Qed.
 
 Lemma Rfourier_ge_to_le : forall x y:R, y >= x -> x <= y.
diff --git a/plugins/fourier/fourier.ml b/plugins/fourier/fourier.ml
index 1a92c716..1574e21e 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-2012     *)
 (*   \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
@@ -177,7 +175,7 @@ let unsolvable lie =
 			raise (Failure "contradiction found"))
           |_->assert false)
 			     lr)
-   with _ -> ());
+   with e when Errors.noncritical e -> ());
    !res
 ;;
 
diff --git a/plugins/fourier/fourierR.ml b/plugins/fourier/fourierR.ml
index 2cabcf52..e0e4f7d6 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-2012     *)
 (*   \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 Not_found -> 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);
 ;;
 
@@ -137,10 +141,12 @@ let rec flin_of_constr c =
 	     (try (let a=(rational_of_constr args.(0)) in
                      try (let b = (rational_of_constr args.(1)) in
 			    (flin_add_cste (flin_zero()) (rmult a b)))
-		     with _-> (flin_add (flin_zero())
+		     with e when Errors.noncritical e ->
+                       (flin_add (flin_zero())
 				 args.(1)
 				 a))
-	      with _-> (flin_add (flin_zero())
+	      with e when Errors.noncritical e ->
+                (flin_add (flin_zero())
 			  args.(0)
 			  (rational_of_constr args.(1))))
 	 | "Rinv"->
@@ -150,7 +156,8 @@ let rec flin_of_constr c =
 	     (let b=(rational_of_constr args.(1)) in
 		try (let a = (rational_of_constr args.(0)) in
 		       (flin_add_cste (flin_zero()) (rdiv a b)))
-		with _-> (flin_add (flin_zero())
+		with e when Errors.noncritical e ->
+                  (flin_add (flin_zero())
 		            args.(0)
                             (rinv b)))
          |_->assert false)
@@ -160,14 +167,15 @@ let rec flin_of_constr c =
               |"R0" -> flin_zero ()
               |_-> assert false)
   |_-> assert false)
-  with _ -> flin_add (flin_zero())
+  with e when Errors.noncritical e ->
+    flin_add (flin_zero())
                      c
 	             r1
 ;;
 
 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 +264,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
@@ -490,13 +498,13 @@ let rec fourier gl=
 	    |_->assert false)
         |_->assert false
       in tac gl)
-     with _ ->
+     with e when Errors.noncritical e ->
     (* les hypothèses *)
     let hyps = List.map (fun (h,t)-> (mkVar h,t))
                         (list_of_sign (pf_hyps gl)) in
     let lineq =ref [] in
     List.iter (fun h -> try (lineq:=(ineq1_of_constr h)@(!lineq))
-		        with _ -> ())
+		        with e when Errors.noncritical e -> ())
               hyps;
     (* lineq = les inéquations découlant des hypothèses *)
     if !lineq=[] then Util.error "No inequalities";
diff --git a/plugins/fourier/g_fourier.ml4 b/plugins/fourier/g_fourier.ml4
index ea766830..7c7cf64f 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-2012     *)
 (*   \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..b2955e90 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-2012     *)
 (*   \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..48205019 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
@@ -34,10 +33,14 @@ 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
+ with reraise ->
+   let e = Cerrors.process_vernac_interp_error reraise in
+   let goal =
+     try (Printer.pr_goal g)
+     with e when Errors.noncritical e -> assert false
+   in
    msgnl (str "observation "++ s++str " raised exception " ++
-	    Cerrors.explain_exn e ++ str " on goal " ++ goal );
+	    Errors.print e ++ str " on goal " ++ goal );
    raise e;;
 
 let observe_tac_stream s tac g =
@@ -119,7 +122,7 @@ let is_trivial_eq t =
 	    eq_constr t1 t2 && eq_constr a1 a2
 	| _ -> false
     end
-  with _ -> false
+  with e when Errors.noncritical e -> false
   in
 (*   observe (str "is_trivial_eq " ++ Printer.pr_lconstr t ++ (if res then str " true" else str " false")); *)
   res
@@ -145,7 +148,7 @@ let is_incompatible_eq t =
 	    (eq_constr u1 u2 &&
 	       incompatible_constructor_terms t1 t2)
 	| _ -> false
-    with _ -> false
+    with e when Errors.noncritical e -> false
   in
   if res then   observe (str "is_incompatible_eq " ++ Printer.pr_lconstr t);
   res
@@ -232,7 +235,7 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type  =
 	  then
 	    (jmeq_refl (),(args.(1),args.(0)),(args.(3),args.(2)),args.(0))
 	  else nochange "not an equality"
-      with _ -> nochange "not an equality"
+      with e when Errors.noncritical e -> nochange "not an equality"
     in
     if not ((closed0 (fst t1)) && (closed0 (snd t1)))then nochange "not a closed lhs";
     let rec compute_substitution sub t1 t2 =
@@ -263,7 +266,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 +289,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 +353,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 +391,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 +409,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 +464,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 +492,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 +592,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
@@ -608,8 +611,8 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos =
 let my_orelse tac1 tac2 g =
   try
     tac1 g
-  with e ->
-(*     observe (str "using snd tac since : " ++ Cerrors.explain_exn e); *)
+  with e when Errors.noncritical 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 +912,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 +939,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 +957,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 +967,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 +1012,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 +1055,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
@@ -1212,7 +1215,11 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams :
 	let ctxt,pte_app =  (decompose_prod_assum (pf_concl gl)) in
 	let pte,pte_args = (decompose_app pte_app) in
 	try
-	  let pte = try destVar pte with _ -> anomaly "Property is not a variable"  in
+	  let pte =
+            try destVar pte
+            with e when Errors.noncritical e ->
+              anomaly "Property is not a variable"
+          in
 	  let fix_info = Idmap.find  pte ptes_to_fix in
 	  let nb_args = fix_info.nb_realargs in
 	  tclTHENSEQ
@@ -1300,7 +1307,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
@@ -1371,7 +1378,7 @@ let prove_with_tcc tcc_lemma_constr eqs : tactic =
 (* 		 let ids = List.filter (fun id -> not (List.mem id ids)) ids' in  *)
 (* 		 rewrite *)
 (* 	      ) *)
-	      Eauto.gen_eauto false (false,5) [] (Some [])
+	      Eauto.gen_eauto (false,5) [] (Some [])
 	    ]
 	    gls
 
@@ -1400,10 +1407,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 +1423,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 +1445,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"
@@ -1449,9 +1456,8 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic =
 			   (
 			    tclCOMPLETE(
 				    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..04fcc8d4 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,16 +138,10 @@ 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
-  let rec has_dummy_var t  =
-    fold_constr
-      (fun b t -> b || (eq_constr t dummy_var) || (has_dummy_var t))
-      false
-      t
-  in
   let rec compute_new_princ_type remove env pre_princ : types*(constr list) =
     let (new_princ_type,_) as res =
       match kind_of_term pre_princ with
@@ -199,58 +191,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 +259,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 +275,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 +283,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
@@ -311,11 +302,8 @@ let defined () =
 	  "defined"
 	  ((try
 	      str "On goal : " ++ fnl () ++  pr_open_subgoals () ++ fnl ()
-	    with _ -> mt ()
+	    with e when Errors.noncritical e -> mt ()
 	   ) ++msg)
-    | e -> raise e
-
-
 
 let build_functional_principle interactive_proof old_princ_type sorts funs i proof_tac hook =
   (* First we get the type of the old graph principle *)
@@ -384,10 +372,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
@@ -411,7 +398,7 @@ let generate_functional_principle
      Don't forget to close the goal if an error is raised !!!!
   *)
   save false new_princ_name entry g_kind hook
-  with e ->
+  with e when Errors.noncritical e ->
     begin
       begin
 	try
@@ -423,7 +410,7 @@ let generate_functional_principle
 	  then Pfedit.delete_current_proof ()
 	  else ()
 	  else ()
-	with _ -> ()
+	with e when Errors.noncritical e -> ()
       end;
       raise (Defining_principle e)
     end
@@ -450,7 +437,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 +462,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 +480,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 +494,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
@@ -561,7 +551,7 @@ let make_scheme (fas : (constant*Rawterm.rawsort) list) : Entries.definition_ent
 	0
 	(prove_princ_for_struct false 0 (Array.of_list funs))
 	(fun _ _ _ -> ())
-  with e ->
+  with e when Errors.noncritical e ->
     begin
       begin
 	try
@@ -573,7 +563,7 @@ let make_scheme (fas : (constant*Rawterm.rawsort) list) : Entries.definition_ent
 	  then Pfedit.delete_current_proof ()
 	  else ()
 	  else ()
-	with _ -> ()
+	with e when Errors.noncritical e -> ()
       end;
       raise (Defining_principle e)
     end
@@ -584,7 +574,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 +629,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 +678,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..6b6e4838 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-2012     *)
 (*   \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 None "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
 
 
@@ -256,14 +208,14 @@ VERNAC COMMAND EXTEND NewFunctionalScheme
 		    try Functional_principles_types.build_scheme fas
 		    with Functional_principles_types.No_graph_found ->
 		      Util.error ("Cannot generate induction principle(s)")
-    		      | e ->
+    		      | e when Errors.noncritical e ->
 			  let names = List.map (fun (_,na,_) -> na) fas in
 			  warning_error names e
 
 		  end
 	      | _ -> assert false (* we can only have non empty  list *)
 	  end
-	  | e -> 
+	  | e when Errors.noncritical e ->
 	      let names = List.map (fun (_,na,_) -> na) fas in
 	      warning_error names e
       end
@@ -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..b9e0e62a 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)
 
@@ -308,26 +308,27 @@ let build_constructors_of_type ind' argl =
 		    (Global.env ())
 		    construct
 		in
-		let argl =
-		  if argl = []
-		  then
+		let argl = match argl with
+                | None ->
  		    Array.to_list
-		      (Array.init (cst_narg - npar) (fun _ -> mkRHole ())
+		      (Array.init cst_narg (fun _ -> mkGHole ())
 		      )
-		  else argl
+                | Some l ->
+	            Array.to_list
+		      (Array.init npar (fun _ -> mkGHole ()))@l
 		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 +351,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 +420,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 +446,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 +473,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 +482,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 +501,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 +526,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 +550,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 +568,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 +578,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 +612,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 +622,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,23 +638,23 @@ 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
+	let case_pats = build_constructors_of_type ind None in
 	assert (Array.length case_pats = 2);
 	let brl =
 	  list_map_i
@@ -663,19 +663,19 @@ 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 =
-	    List.map
+	  let nal_as_glob_constr =
+	    Some (List.map
 	      (function
-		   Name id -> mkRVar id
-		 | Anonymous -> mkRHole ()
+		   Name id -> mkGVar id
+		 | Anonymous -> mkGHole ()
 	      )
-	      nal
+	      nal)
 	  in
 	  let b_as_constr = Pretyping.Default.understand Evd.empty env b in
 	  let b_typ = Typing.type_of env Evd.empty b_as_constr in
@@ -683,26 +683,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 +761,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 +777,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 +834,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 +878,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 +904,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,19 +936,20 @@ 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
+		      try Pretyping.Default.understand Evd.empty env t
+                      with e when Errors.noncritical e -> raise Continue
 		    in
 		    let is_in_b = is_free_in id b in
 		    let _keep_eq =
@@ -968,7 +968,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 +979,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 +1051,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 +1069,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 +1078,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 +1091,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 +1107,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 +1121,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 +1147,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 +1173,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 +1200,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,13 +1242,13 @@ 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
 	)
 	rels_params.(0)
-    with _ ->
+    with e when Errors.noncritical e ->
       ()
   in
   List.rev !l
@@ -1261,15 +1261,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 +1286,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 +1294,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 +1325,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 +1346,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 +1360,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 +1389,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 +1402,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)
@@ -1454,7 +1454,7 @@ let do_build_inductive
 	in
 	observe (msg);
 	raise e
-    | e ->
+    | reraise ->
 	let _time3 = System.get_time () in
 (* 	Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *)
 	let repacked_rel_inds =
@@ -1465,16 +1465,16 @@ 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 reraise
 	in
  	observe msg;
-	raise e
+	raise reraise
 
 
 
 let build_inductive funnames funsargs returned_types rtl =
   try
     do_build_inductive funnames funsargs returned_types rtl
-  with e -> raise (Building_graph e)
+  with e when Errors.noncritical e -> raise (Building_graph 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..6cc932b1 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
@@ -538,7 +534,8 @@ let rec are_unifiable_aux  = function
 	     else
 	       let eqs' =
  		 try  ((List.combine cpl1 cpl2)@eqs)
-		 with _ -> anomaly "are_unifiable_aux"
+		 with e when Errors.noncritical e ->
+                   anomaly "are_unifiable_aux"
 	       in
 	       are_unifiable_aux eqs'
 
@@ -560,7 +557,8 @@ let rec eq_cases_pattern_aux  = function
 	     else
 	       let eqs' =
  		 try  ((List.combine cpl1 cpl2)@eqs)
-		 with _ -> anomaly "eq_cases_pattern_aux"
+		 with e when Errors.noncritical e ->
+                   anomaly "eq_cases_pattern_aux"
 	       in
 	       eq_cases_pattern_aux eqs'
 	 | _ -> raise NotUnifiable
@@ -586,28 +584,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 +614,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 +685,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..d2c065a0 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,14 +75,14 @@ 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 =
       List.fold_right
 	(fun a acc ->
 	  try Idset.add (destVar a) acc
-	  with _ -> acc
+	  with e when Errors.noncritical e -> acc
 	)
 	args
 	Idset.empty
@@ -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,94 +125,78 @@ 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
 	  )
           lnameargsardef
-	with e ->
-	States.unfreeze fs; raise e in
+	with reraise ->
+	States.unfreeze fs; raise reraise in
     States.unfreeze fs; def
   in
   recdef,rec_impls
 
-
-let compute_annot (name,annot,args,types,body) =
-  let names = List.map snd (Topconstr.names_of_local_assums args) in
-  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 ->
+    with e when Errors.noncritical 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 ())
-  with _ -> ()
+	(str "Cannot build inversion information" ++
+	   if do_observe () then (fnl() ++ Errors.print e') else mt ())
+  with e when Errors.noncritical e -> ()
 
 let warning_error names e =
+  let e = Cerrors.process_vernac_interp_error e in
   let e_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!")
@@ -363,24 +346,21 @@ let generate_principle  on_error
 	Array.iter (add_Function is_general) funs_kn;
 	()
       end
-  with e ->
+  with e when Errors.noncritical 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
@@ -433,7 +413,7 @@ let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas
 	   functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation
 	);
       derive_inversion [fname]
-    with e ->
+    with e when Errors.noncritical e ->
       (* No proof done *)
       ()
   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..827191b1 100644
--- a/plugins/funind/indfun_common.ml
+++ b/plugins/funind/indfun_common.ml
@@ -55,7 +55,6 @@ let locate_with_msg msg f x =
     f x
   with
     | Not_found -> raise (Util.UserError("", msg))
-    | e -> raise e
 
 
 let filter_map filter f =
@@ -76,8 +75,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 +89,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,10 +119,10 @@ 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)
-       with _ -> assert false)
+      (try (match Declarations.body_of_constant (Global.lookup_constant sp) with
+             | Some c -> Declarations.force c
+	     | _ -> assert false)
+       with e when Errors.noncritical e -> assert false)
     |_ -> assert false
 
 let coq_constant s =
@@ -158,6 +157,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 +180,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
@@ -253,13 +214,13 @@ let with_full_print f a =
     Dumpglob.continue ();
     res
   with
-    | e ->
+    | reraise ->
 	Impargs.make_implicit_args old_implicit_args;
 	Impargs.make_strict_implicit_args old_strict_implicit_args;
 	Impargs.make_contextual_implicit_args old_contextual_implicit_args;
 	Flags.raw_print := old_rawprint;
 	Dumpglob.continue ();
-	raise e
+	raise reraise
 
 
 
@@ -388,7 +349,8 @@ open Term
 let pr_info f_info =
   str "function_constant := " ++ Printer.pr_lconstr (mkConst f_info.function_constant)++ fnl () ++
     str "function_constant_type := " ++
-    (try Printer.pr_lconstr (Global.type_of_global (ConstRef f_info.function_constant)) with _ -> mt ()) ++ fnl () ++
+    (try Printer.pr_lconstr (Global.type_of_global (ConstRef f_info.function_constant))
+     with e when Errors.noncritical e -> mt ()) ++ fnl () ++
     str "equation_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.equation_lemma (mt ()) ) ++ fnl () ++
     str "completeness_lemma :=" ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.completeness_lemma (mt ()) ) ++ fnl () ++
     str "correctness_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.correctness_lemma (mt ()) ) ++ fnl () ++
@@ -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);
@@ -537,22 +502,22 @@ exception ToShow of exn
 let init_constant dir s =
   try
     Coqlib.gen_constant "Function" dir s
-  with e -> raise (ToShow e)
+  with e when Errors.noncritical e -> raise (ToShow e)
 
 let jmeq () =
   try
     (Coqlib.check_required_library ["Coq";"Logic";"JMeq"];
      init_constant ["Logic";"JMeq"] "JMeq")
-  with e -> raise (ToShow e)
+  with e when Errors.noncritical e -> raise (ToShow e)
 
 let jmeq_rec () =
   try
     Coqlib.check_required_library ["Coq";"Logic";"JMeq"];
 	  init_constant ["Logic";"JMeq"] "JMeq_rec"
-  with e -> raise (ToShow e)
+  with e when Errors.noncritical e -> raise (ToShow e)
 
 let jmeq_refl () =
   try
     Coqlib.check_required_library ["Coq";"Logic";"JMeq"];
     init_constant ["Logic";"JMeq"] "JMeq_refl"
-  with e -> raise (ToShow e)
+  with e when Errors.noncritical e -> raise (ToShow e)
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..7b5dd763 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-2012     *)
 (*   \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,13 +59,17 @@ 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 =
+    try Printer.pr_goal g
+    with e when Errors.noncritical e -> assert false
+  in
   try
     let v = tac g in msgnl (goal ++ fnl () ++ s ++(str " ")++(str "finished")); v
-  with e ->
+  with reraise ->
+    let e' = Cerrors.process_vernac_interp_error reraise in
     msgnl (str "observation "++ s++str " raised exception " ++
-	     Cerrors.explain_exn e ++ str " on goal " ++ goal );
-    raise e;;
+	     Errors.print e' ++ str " on goal " ++ goal );
+    raise reraise;;
 
 
 let observe_tac s tac g =
@@ -84,7 +87,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 +251,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 +316,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 +398,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 +427,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 +437,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 +529,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 +550,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,12 +566,12 @@ 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
 	    ]
 	| _ -> reflexivity
-    with _ -> reflexivity
+    with e when Errors.noncritical e -> reflexivity
   in
   let eq_ind =     Coqlib.build_coq_eq () in
   let discr_inject =
@@ -588,15 +591,15 @@ let rec reflexivity_with_destruct_cases g =
     )
   in
   (tclFIRST
-    [ reflexivity;
-      tclTHEN (tclPROGRESS discr_inject) (destruct_case ());
+    [ observe_tac "reflexivity_with_destruct_cases : reflexivity" reflexivity;
+      observe_tac "reflexivity_with_destruct_cases : destruct_case" ((destruct_case ()));
       (*  We reach this point ONLY if
 	  the same value is matched (at least) two times
 	  along binding path.
 	  In this case, either we have a discriminable hypothesis and we are done,
 	  either at least an injectable one and we do the injection before continuing
       *)
-      tclTHEN (tclPROGRESS discr_inject ) reflexivity_with_destruct_cases
+      observe_tac "reflexivity_with_destruct_cases : others" (tclTHEN (tclPROGRESS discr_inject ) reflexivity_with_destruct_cases)
     ])
     g
 
@@ -636,7 +639,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 +689,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 +736,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
@@ -752,6 +755,7 @@ let do_save () = Lemmas.save_named false
 *)
 
 let derive_correctness make_scheme functional_induction (funs: constant list) (graphs:inductive list) =
+  let previous_state = States.freeze () in
   let funs = Array.of_list funs and graphs = Array.of_list graphs in
   let funs_constr = Array.map mkConst funs  in
   try
@@ -763,7 +767,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 +788,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 =
@@ -793,22 +797,21 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g
     Array.iteri
       (fun i f_as_constant ->
 	 let f_id = id_of_label (con_label f_as_constant) in
-	 Lemmas.start_proof
-	   (*i The next call to mk_correct_id is valid since we are constructing the lemma
+	 (*i The next call to mk_correct_id is valid since we are constructing the lemma
 	     Ensures by: obvious
-	     i*)
-	   (mk_correct_id f_id)
+	 i*)
+	 let lem_id = mk_correct_id f_id in
+	 Lemmas.start_proof lem_id
 	   (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem))
 	   (fst lemmas_types_infos.(i))
 	   (fun _ _ -> ());
-	 Pfedit.by (observe_tac ("prove correctness ("^(string_of_id f_id)^")") (proving_tac i));
+	 Pfedit.by
+	   (observe_tac ("prove correctness ("^(string_of_id f_id)^")")
+	      (proving_tac i));
 	 do_save ();
 	 let finfo = find_Function_infos f_as_constant in
-	 update_Function
-	   {finfo with
-	      correctness_lemma = Some (destConst (Tacinterp.constr_of_id (Global.env ())(mk_correct_id f_id)))
-	   }
-
+	 let lem_cst = destConst (Constrintern.global_reference lem_id) in
+	 update_Function {finfo with correctness_lemma = Some lem_cst}
       )
       funs;
     let lemmas_types_infos =
@@ -818,7 +821,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
@@ -845,35 +848,28 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g
     Array.iteri
       (fun i f_as_constant ->
 	 let f_id = id_of_label (con_label f_as_constant) in
-	 Lemmas.start_proof
-	   (*i The next call to mk_complete_id is valid since we are constructing the lemma
+	 (*i The next call to mk_complete_id is valid since we are constructing the lemma
 	     Ensures by: obvious
-	     i*)
-	   (mk_complete_id f_id)
+	   i*)
+	 let lem_id = mk_complete_id f_id in
+	 Lemmas.start_proof lem_id
 	   (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem))
 	   (fst lemmas_types_infos.(i))
 	   (fun _ _ -> ());
-	 Pfedit.by (observe_tac ("prove completeness ("^(string_of_id f_id)^")") (proving_tac i));
+	 Pfedit.by
+	   (observe_tac ("prove completeness ("^(string_of_id f_id)^")")
+	      (proving_tac i));
 	 do_save ();
 	 let finfo = find_Function_infos f_as_constant in
-	 update_Function
-	   {finfo with
-	      completeness_lemma = Some (destConst (Tacinterp.constr_of_id (Global.env ())(mk_complete_id f_id)))
-	   }
+	 let lem_cst = destConst (Constrintern.global_reference lem_id) in
+	 update_Function {finfo with completeness_lemma = Some lem_cst}
       )
       funs;
-  with e ->
+  with reraise ->
     (* In case of problem, we reset all the lemmas *)
-    (*i The next call to mk_correct_id is valid since we are erasing the lemmas
-      Ensures by: obvious
-      i*)
-    let first_lemma_id =
-      let f_id = id_of_label (con_label funs.(0)) in
-
-      mk_correct_id f_id
-    in
-     ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,first_lemma_id) with _ -> ());
-    raise e
+    Pfedit.delete_all_proofs ();
+    States.unfreeze previous_state;
+    raise reraise
 
 
 
@@ -955,7 +951,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..bd1a1710 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-2012     *)
 (*   \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
@@ -71,7 +70,7 @@ let ident_global_exist id =
     let ans = CRef (Libnames.Ident (dummy_loc,id)) in
     let _ = ignore (Constrintern.intern_constr Evd.empty (Global.env()) ans) in
     true
-  with _ -> false
+  with e when Errors.noncritical e -> false
 
 (** [next_ident_fresh id] returns a fresh identifier (ie not linked in
     global env) with base [id]. *)
@@ -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,11 +792,11 @@ 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))
-    with _ -> [] in
+    try fst (glob_decompose_prod_n shift.nrecprms1 (List.hd lcstr1))
+    with e when Errors.noncritical e -> [] in
   let params2 =
-    try fst (raw_decompose_prod_n shift.nrecprms2 (List.hd lcstr2))
-    with _ -> [] in
+    try fst (glob_decompose_prod_n shift.nrecprms2 (List.hd lcstr2))
+    with e when Errors.noncritical e -> [] in
 
   let lcstr1 = List.combine (Array.to_list oib1.mind_consnames) lcstr1 in
   let lcstr2 = List.combine (Array.to_list oib2.mind_consnames) lcstr2 in
@@ -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 934bf683..9853fd73 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-2012     *)
 (*   \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 15069 2012-03-20 14:06:07Z 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
@@ -70,44 +67,38 @@ 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)
+  with reraise ->
+    if not (Stack.is_empty debug_queue)
     then
-      print_debug_queue e;
-    raise e
-
-(*let do_observe_tac s tac g =
-  let goal = begin (Printer.pr_goal (sig_it g)) end in
- try let v = tac g in msgnl (goal ++ fnl () ++ (str "recdef ") ++
-    (str s)++(str " ")++(str "finished")); v
- with e ->
-   msgnl (str "observation "++str s++str " raised exception " ++
-	    Cerrors.explain_exn e ++ str " on goal " ++ goal );
-   raise e;;
-*)
+      print_debug_queue true reraise;
+    raise reraise
 
 let observe_tac s tac g =
   if Tacinterp.get_debug () <> Tactic_debug.DebugOff
@@ -146,10 +137,10 @@ 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)
-       with _ ->
+      (try (match body_of_constant (Global.lookup_constant sp) with
+             | Some c -> Declarations.force c
+	     | _ -> assert false)
+       with e when Errors.noncritical e ->
 	 anomaly ("Cannot find definition of constant "^
 		    (string_of_id (id_of_label (con_label sp))))
       )
@@ -181,11 +172,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
@@ -194,7 +197,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
@@ -218,7 +221,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
@@ -228,40 +231,42 @@ 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"
+  | Meta(_) -> error "Found a metavariable. Can not treat such a term" 
+  | Evar(_) -> error "Found an evar. Can not treat such a term"
   | Sort(_)  -> (fun l -> expr), []
-  | Cast(b,_,_) -> find_call_occs nb_lam f b
-  | Prod(_,_,_) -> error "find_call_occs : Prod"
+  | Cast(b,_,_) -> find_call_occs nb_arg nb_lam f b
+  | Prod(na,t,b) -> 
+    error "Found a product. Can not treat such a term"
   | Lambda(na,t,b) ->
       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),[]
-	  | _ ->  error "find_call_occs : Lambda"
+	  | _ ->  error "Found a lambda which body contains a recursive call. Such terms are not allowed"
       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)) ->
 	      ((fun  l -> mkLetIn(na,v,t,cf l)),l)
 	  | (cf,(_::_ as l)),(_,[]) ->
 	      ((fun l -> mkLetIn(na,cf l,t,b)), l)
-	  | _ -> error "find_call_occs : LetIn"
+	  | _ -> error "Found a letin with recursive calls in both variable value and body. Such terms are not allowed."
       end
   | Const(_) -> (fun l -> expr), []
   | 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"
-  | CoFix(_) -> error "find_call_occs : CoFix";;
+  | Fix(_) -> error "Found a local fixpoint. Can not treat such a term"
+  | CoFix(_) -> error "Found a local cofixpoint : CoFix";;
 
 let coq_constant s =
   Coqlib.gen_constant_in_modules "RecursiveDefinition"
@@ -370,15 +375,19 @@ 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 e when Errors.noncritical e ->
+                         Pp.msgnl (Printer.pr_goal g1 ++ fnl () ++ pr_id teq ++ str ":" ++ Printer.pr_lconstr ty_teq); assert false
+                     in
 		     args.(1),args.(2)
 		   in
-	           cont_function (mkVar teq::eqs) (replace_term teq_lhs teq_rhs expr) g1
+	           cont_function (mkVar teq::eqs) (Termops.replace_term teq_lhs teq_rhs expr) g1
 		)
 	      ]
 	      
@@ -431,7 +440,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
@@ -530,8 +539,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)
@@ -573,7 +582,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
@@ -619,7 +628,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
@@ -658,13 +667,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
@@ -672,7 +681,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 =
@@ -684,24 +693,29 @@ 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 ))
+	       with reraise ->
+                 (msgerrnl (str "failure in base case");raise reraise ))
 	    | _, _::_ ->
 	      observe_tac "rec_leaf"
 	        (rec_leaf is_mes acc_inv hrec func eqs expr)) in
       v
-    with e -> begin msgerrnl(str "failure in proveterminate"); raise e end
+    with reraise ->
+      begin
+        msgerrnl(str "failure in proveterminate");
+        raise reraise
+      end
   in
   proveterminate
 
@@ -832,7 +846,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 =
@@ -865,6 +879,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
@@ -872,7 +887,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
 	   )
@@ -883,15 +898,29 @@ 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
   let conj_constr = coq_conj () in
   let mk_and p1 p2 =
     Term.mkApp(and_constr,[|p1;p2|]) in
+  let rec is_well_founded t = 
+    match kind_of_term t with 
+      | Prod(_,_,t') -> is_well_founded t'
+      | App(_,_) -> 
+	let (f,_) = decompose_app t in 
+	eq_constr f (well_founded ())
+      | _ -> assert false
+  in
+  let compare t1 t2 = 
+    let b1,b2= is_well_founded t1,is_well_founded t2 in 
+    if (b1&&b2) || not (b1 || b2) then 0
+    else if b1 && not b2 then 1 else -1
+  in
+  let l = List.sort compare l in 
   let rec f  = function
     | [] -> failwith "empty list of subgoals!"
     | [p] -> p,tclIDTAC,1
@@ -911,7 +940,7 @@ let is_rec_res id =
   let id_name = string_of_id id in
   try
     String.sub id_name 0 (String.length rec_res_name) = rec_res_name
-  with _ -> false
+  with e when Errors.noncritical e -> false
 
 let clear_goals =
   let rec clear_goal t =
@@ -919,7 +948,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
@@ -935,6 +964,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
@@ -942,22 +978,19 @@ let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_
     | Some s -> s
     | None   ->
 	try (add_suffix current_proof_name "_subproof")
-	with _ -> anomaly "open_new_goal with an unamed theorem"
+	with e when Errors.noncritical e ->
+          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
@@ -999,9 +1032,8 @@ let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_
 			  (eapply_with_bindings (mkVar (List.nth !lid !h_num), NoBindings))
 			  e_assumption;
 		      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]
 		      ]
 		    )
@@ -1102,38 +1134,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)])
+	  GVar(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)
-    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) =
@@ -1153,7 +1178,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))));
@@ -1195,7 +1220,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
@@ -1203,8 +1228,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
@@ -1259,7 +1284,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
 		     )
@@ -1294,12 +1319,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
@@ -1308,38 +1333,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
@@ -1350,7 +1372,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
@@ -1381,14 +1403,15 @@ let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta
 
 let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num eq
     generate_induction_principle using_lemmas : unit =
+  let previous_label = Lib.current_command_label () in
   let function_type = interp_constr Evd.empty (Global.env()) type_of_f in
   let env = push_named (function_name,None,function_type) (Global.env()) in
-(*   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
@@ -1407,7 +1430,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
@@ -1421,17 +1444,17 @@ 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)
-      with e ->
+      try com_eqn (List.length res_vars) equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type)
+      with e when Errors.noncritical 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 _ -> ()); *)
 	  stop := true;
 	end
     end;
@@ -1461,12 +1484,10 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num
       using_lemmas
       (List.length res_vars)
       hook
-  with e ->
+  with reraise ->
     begin
-      ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,functional_id) with _ -> ());
-(*       anomaly "Cannot create termination Lemma" *)
-      raise e
+      (try ignore (Backtrack.backto previous_label)
+       with e when Errors.noncritical e -> ());
+      (*       anomaly "Cannot create termination Lemma" *)
+      raise reraise
     end
-
-
-
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..fa780671 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-2012     *)
 (*   \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..caec7800 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -12,16 +12,9 @@
 (*                                                                      *)
 (************************************************************************)
 
-Require Import ZArith.
-Require Import Coq.Arith.Max.
-Require Import List.
+Require Import BinInt 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.
-*)
+Local Open Scope positive_scope.
 
 Section S.
 
@@ -29,154 +22,78 @@ Section S.
 
   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 (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 (e:Env) := nth 1 e.
 
-  Definition tail (e: Env) := jump xH e.
+  Definition tail (e:Env) := jump 1 e.
 
-  Lemma psucc : forall p,  (match p with
-                              | xI y' => xO (Psucc y')
-                              | xO y' => xI y'
-                              | 1%positive => 2%positive
-                            end) = (p+1)%positive.
+  Lemma jump_add i j l x : jump (i + j) l x = jump i (jump j l) x.
   Proof.
-    destruct p.
-    auto with zarith.
-    rewrite xI_succ_xO.
-    auto with zarith.
-    reflexivity.
+    unfold jump. f_equal. apply Pos.add_assoc.
   Qed.
 
-  Lemma jump_Pplus : forall i j l,
-    forall x, jump (i + j) l x = jump i (jump j l) x.
-  Proof.
-    unfold jump.
-    intros.
-    rewrite Pplus_assoc.
-    reflexivity.
-  Qed.
-
-  Lemma jump_simpl : forall p l,
-    forall x, jump p l x =
+  Lemma jump_simpl p l x :
+    jump p l x =
     match p with
       | xH => tail l x
       | xO p => jump p (jump p l) x
       | xI p  => jump p (jump p (tail l)) x
     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, forall x, tail (jump j l) x = jump j (tail l) x.
-  Proof.
-    unfold tail.
-    intros.
-    repeat rewrite <- jump_Pplus.
-    rewrite Pplus_comm.
-    reflexivity.
+    destruct p; unfold tail; rewrite <- ?jump_add; f_equal;
+    now rewrite Pos.add_diag.
   Qed.
 
-  Lemma jump_Psucc : forall j l,
-    forall x, (jump (Psucc j) l x) = (jump 1 (jump j l) x).
+  Lemma jump_tl j l x : tail (jump j l) x = jump j (tail l) x.
   Proof.
-    intros.
-    rewrite <- jump_Pplus.
-    rewrite Pplus_one_succ_r.
-    rewrite Pplus_comm.
-    reflexivity.
+    unfold tail. rewrite <- !jump_add. f_equal. apply Pos.add_comm.
   Qed.
 
-  Lemma jump_Pdouble_minus_one : forall i l,
-    forall x, (jump (Pdouble_minus_one i) (tail l)) x = (jump i (jump i l)) x.
+  Lemma jump_succ j l x : jump (Pos.succ j) l x = jump 1 (jump j l) x.
   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.
+    rewrite <- jump_add. f_equal. symmetry. apply Pos.add_1_l.
   Qed.
 
-  Lemma jump_x0_tail : forall p l, forall x, jump (xO p) (tail l) x = jump (xI p) l x.
+  Lemma jump_pred_double i l x :
+    jump (Pos.pred_double i) (tail l) x = jump i (jump i l) x.
   Proof.
-    intros.
-    unfold jump.
-    unfold tail.
-    unfold jump.
-    rewrite <- Pplus_assoc.
-    simpl.
-    reflexivity.
+    unfold tail. rewrite <- !jump_add. f_equal.
+    now rewrite Pos.add_1_r, Pos.succ_pred_double, Pos.add_diag.
   Qed.
 
-  Lemma nth_spec : forall p l x,
+  Lemma nth_spec p l :
     nth p l =
     match p with
-      | xH => hd x l
+      | xH => hd l
       | xO p => nth p (jump p l)
       | xI p => nth p (jump p (tail l))
     end.
   Proof.
-    unfold nth.
-    destruct p.
-    intros.
-    unfold jump, tail.
-    unfold jump.
-    rewrite Pplus_diag.
-    rewrite xI_succ_xO.
-    simpl.
-    reflexivity.
-    unfold jump.
-    rewrite Pplus_diag.
-    reflexivity.
-    unfold hd.
-    unfold nth.
-    reflexivity.
+    unfold hd, nth, tail, jump.
+    destruct p; f_equal; now rewrite Pos.add_diag.
   Qed.
 
-
-  Lemma nth_jump : forall p l x, nth p (tail l) = hd x (jump p l).
+  Lemma nth_jump p l : nth p (tail l) = hd (jump p l).
   Proof.
-    unfold tail.
-    unfold hd.
-    unfold jump.
-    unfold nth.
-    intros.
-    rewrite Pplus_comm.
-    reflexivity.
+    unfold hd, nth, tail, jump. f_equal. apply Pos.add_comm.
   Qed.
 
-  Lemma nth_Pdouble_minus_one :
-    forall p l, nth (Pdouble_minus_one p) (tail l) = nth p (jump p l).
+  Lemma nth_pred_double p l :
+    nth (Pos.pred_double p) (tail l) = nth p (jump p l).
   Proof.
-    intros.
-    unfold tail.
-    unfold nth, jump.
-    rewrite Pplus_diag.
-    rewrite <- Psucc_o_double_minus_one_eq_xO.
-    rewrite Pplus_one_succ_r.
-    reflexivity.
+    unfold nth, tail, jump. f_equal.
+    now rewrite Pos.add_1_r, Pos.succ_pred_double, Pos.add_diag.
   Qed.
 
 End S.
 
+Ltac jump_simpl :=
+  repeat
+    match goal with
+      | |- appcontext [jump xH] => rewrite (jump_simpl xH)
+      | |- appcontext [jump (xO ?p)] => rewrite (jump_simpl (xO p))
+      | |- appcontext [jump (xI ?p)] => rewrite (jump_simpl (xI p))
+    end.
diff --git a/plugins/micromega/EnvRing.v b/plugins/micromega/EnvRing.v
index 8968a014..786c3393 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -11,15 +11,10 @@
 
 
 Set Implicit Arguments.
-Require Import Setoid.
-Require Import BinList.
-Require Import Env.
-Require Import BinPos.
-Require Import BinNat.
-Require Import BinInt.
+Require Import Setoid Morphisms Env BinPos BinNat BinInt.
 Require Export Ring_theory.
 
-Open Local Scope positive_scope.
+Local Open Scope positive_scope.
 Import RingSyntax.
 
 Section MakeRingPol.
@@ -30,7 +25,7 @@ Section MakeRingPol.
  Variable req : R -> R -> Prop.
 
  (* Ring properties *)
- Variable Rsth : Setoid_Theory R req.
+ Variable Rsth : Equivalence req.
  Variable Reqe : ring_eq_ext radd rmul ropp req.
  Variable ARth : almost_ring_theory rO rI radd rmul rsub ropp req.
 
@@ -42,35 +37,55 @@ Section MakeRingPol.
  Variable CRmorph : ring_morph rO rI radd rmul rsub ropp req
                                 cO cI cadd cmul csub copp ceqb phi.
 
-  (* Power coefficients *)
- Variable Cpow : Set.
+ (* Power coefficients *)
+ Variable Cpow : Type.
  Variable Cp_phi : N -> Cpow.
  Variable rpow : R -> Cpow -> R.
  Variable pow_th : power_theory rI rmul req Cp_phi rpow.
 
-
  (* R notations *)
  Notation "0" := rO. Notation "1" := rI.
- Notation "x + y" := (radd x y).  Notation "x * y " := (rmul x y).
- Notation "x - y " := (rsub x y). Notation "- x" := (ropp x).
- Notation "x == y" := (req x y).
+ Infix "+" := radd. Infix "*" := rmul.
+ Infix "-" := rsub. Notation "- x" := (ropp x).
+ Infix "==" := req.
+ Infix "^" := (pow_pos rmul).
 
  (* C notations *)
- Notation "x +! y" := (cadd x y). Notation "x *! y " := (cmul x y).
- Notation "x -! y " := (csub x y). Notation "-! x" := (copp x).
- Notation " x ?=! y" := (ceqb x y). Notation "[ x ]" := (phi x).
-
- (* Usefull tactics *)
-  Add Setoid R req Rsth as R_set1.
- Ltac rrefl := gen_reflexivity Rsth.
-  Add Morphism radd : radd_ext.  exact (Radd_ext Reqe). Qed.
-  Add Morphism rmul : rmul_ext.  exact (Rmul_ext Reqe). Qed.
-  Add Morphism ropp : ropp_ext.  exact (Ropp_ext Reqe). Qed.
-  Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed.
+ Infix "+!" := cadd. Infix "*!" := cmul.
+ Infix "-! " := csub. Notation "-! x" := (copp x).
+ Infix "?=!" := ceqb. Notation "[ x ]" := (phi x).
+
+ (* Useful tactics *)
+ Add Morphism radd : radd_ext. exact (Radd_ext Reqe). Qed.
+ Add Morphism rmul : rmul_ext. exact (Rmul_ext Reqe). Qed.
+ Add Morphism ropp : ropp_ext. exact (Ropp_ext Reqe). Qed.
+ Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed.
  Ltac rsimpl := gen_srewrite Rsth Reqe ARth.
+
  Ltac add_push := gen_add_push radd Rsth Reqe ARth.
  Ltac mul_push := gen_mul_push rmul Rsth Reqe ARth.
 
+ Ltac add_permut_rec t :=
+   match t with
+   | ?x + ?y => add_permut_rec y || add_permut_rec x
+   | _ => add_push t; apply (Radd_ext Reqe); [|reflexivity]
+   end.
+
+ Ltac add_permut :=
+  repeat (reflexivity ||
+    match goal with |- ?t == _ => add_permut_rec t end).
+
+ Ltac mul_permut_rec t :=
+   match t with
+   | ?x * ?y => mul_permut_rec y || mul_permut_rec x
+   | _ => mul_push t; apply (Rmul_ext Reqe); [|reflexivity]
+   end.
+
+ Ltac mul_permut :=
+  repeat (reflexivity ||
+    match goal with |- ?t == _ => mul_permut_rec t end).
+
+
  (* Definition of multivariable polynomials with coefficients in C :
     Type [Pol] represents [X1 ... Xn].
     The representation is Horner's where a [n] variable polynomial
@@ -105,31 +120,31 @@ 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
   | _, _ => false
   end.
 
- Notation " P ?== P' " := (Peq P P').
+ Infix "?==" := Peq.
 
  Definition mkPinj j P :=
   match P with
   | Pc _ => P
-  | Pinj j' Q => Pinj ((j + j'):positive) Q
+  | Pinj j' Q => Pinj (j + j') Q
   | _ => Pinj j P
   end.
 
  Definition mkPinj_pred j P:=
   match j with
   | xH => P
-  | xO j => Pinj (Pdouble_minus_one j) P
+  | xO j => Pinj (Pos.pred_double j) P
   | xI j => Pinj (xO j) P
   end.
 
@@ -157,14 +172,14 @@ Section MakeRingPol.
 
  (** Addition et subtraction *)
 
- Fixpoint PaddC (P:Pol) (c:C) {struct P} : Pol :=
+ Fixpoint PaddC (P:Pol) (c:C) : Pol :=
   match P with
   | Pc c1 => Pc (c1 +! c)
   | Pinj j Q => Pinj j (PaddC Q c)
   | PX P i Q => PX P i (PaddC Q c)
   end.
 
- Fixpoint PsubC (P:Pol) (c:C) {struct P} : Pol :=
+ Fixpoint PsubC (P:Pol) (c:C) : Pol :=
   match P with
   | Pc c1 => Pc (c1 -! c)
   | Pinj j Q => Pinj j (PsubC Q c)
@@ -176,11 +191,11 @@ Section MakeRingPol.
   Variable Pop : Pol -> Pol -> Pol.
   Variable Q : Pol.
 
-  Fixpoint PaddI (j:positive) (P:Pol){struct P} : Pol :=
+  Fixpoint PaddI (j:positive) (P:Pol) : Pol :=
    match P with
    | Pc c => mkPinj j (PaddC Q c)
    | Pinj j' Q' =>
-     match ZPminus j' j with
+     match Z.pos_sub j' j with
      | Zpos k =>  mkPinj j (Pop (Pinj k Q') Q)
      | Z0 => mkPinj j (Pop Q' Q)
      | Zneg k => mkPinj j' (PaddI k Q')
@@ -188,16 +203,16 @@ Section MakeRingPol.
    | PX P i Q' =>
      match j with
      | xH => PX P i (Pop Q' Q)
-     | xO j => PX P i (PaddI (Pdouble_minus_one j) Q')
+     | xO j => PX P i (PaddI (Pos.pred_double j) Q')
      | xI j => PX P i (PaddI (xO j) Q')
      end
    end.
 
-  Fixpoint PsubI (j:positive) (P:Pol){struct P} : Pol :=
+  Fixpoint PsubI (j:positive) (P:Pol) : Pol :=
    match P with
    | Pc c => mkPinj j (PaddC (--Q) c)
    | Pinj j' Q' =>
-     match ZPminus j' j with
+     match Z.pos_sub j' j with
      | Zpos k =>  mkPinj j (Pop (Pinj k Q') Q)
      | Z0 => mkPinj j (Pop Q' Q)
      | Zneg k => mkPinj j' (PsubI k Q')
@@ -205,41 +220,41 @@ Section MakeRingPol.
    | PX P i Q' =>
      match j with
      | xH => PX P i (Pop Q' Q)
-     | xO j => PX P i (PsubI (Pdouble_minus_one j) Q')
+     | xO j => PX P i (PsubI (Pos.pred_double j) Q')
      | xI j => PX P i (PsubI (xO j) Q')
      end
    end.
 
  Variable P' : Pol.
 
- Fixpoint PaddX (i':positive) (P:Pol) {struct P} : Pol :=
+ Fixpoint PaddX (i':positive) (P:Pol) : Pol :=
   match P with
   | Pc c => PX P' i' P
   | Pinj j Q' =>
     match j with
     | xH =>  PX P' i' Q'
-    | xO j => PX P' i' (Pinj (Pdouble_minus_one j) Q')
+    | xO j => PX P' i' (Pinj (Pos.pred_double j) Q')
     | xI j => PX P' i' (Pinj (xO j) Q')
     end
   | PX P i Q' =>
-    match ZPminus i i' with
+    match Z.pos_sub i i' with
     | Zpos k => mkPX (Pop (PX P k P0) P') i' Q'
     | Z0 => mkPX (Pop P P') i Q'
     | Zneg k => mkPX (PaddX k P) i Q'
     end
   end.
 
- Fixpoint PsubX (i':positive) (P:Pol) {struct P} : Pol :=
+ Fixpoint PsubX (i':positive) (P:Pol) : Pol :=
   match P with
   | Pc c => PX (--P') i' P
   | Pinj j Q' =>
     match j with
     | xH =>  PX (--P') i' Q'
-    | xO j => PX (--P') i' (Pinj (Pdouble_minus_one j) Q')
+    | xO j => PX (--P') i' (Pinj (Pos.pred_double j) Q')
     | xI j => PX (--P') i' (Pinj (xO j) Q')
     end
   | PX P i Q' =>
-    match ZPminus i i' with
+    match Z.pos_sub i i' with
     | Zpos k => mkPX (Pop (PX P k P0) P') i' Q'
     | Z0 => mkPX (Pop P P') i Q'
     | Zneg k => mkPX (PsubX k P) i Q'
@@ -259,18 +274,18 @@ Section MakeRingPol.
     | Pinj j Q =>
       match j with
       | xH => PX P' i' (Padd Q Q')
-      | xO j => PX P' i' (Padd (Pinj (Pdouble_minus_one j) Q) Q')
+      | xO j => PX P' i' (Padd (Pinj (Pos.pred_double j) Q) Q')
       | xI j => PX P' i' (Padd (Pinj (xO j) Q) Q')
       end
     | PX P i Q =>
-      match ZPminus i i' with
+      match Z.pos_sub i i' with
       | Zpos k => mkPX (Padd (PX P k P0) P') i' (Padd Q Q')
       | Z0 => mkPX (Padd P P') i (Padd Q Q')
       | Zneg k => mkPX (PaddX Padd P' k P) i (Padd Q Q')
       end
     end
   end.
- Notation "P ++ P'" := (Padd P P').
+ Infix "++" := Padd.
 
  Fixpoint Psub (P P': Pol) {struct P'} : Pol :=
   match P' with
@@ -282,22 +297,22 @@ Section MakeRingPol.
     | Pinj j Q =>
       match j with
       | xH => PX (--P') i' (Psub Q Q')
-      | xO j => PX (--P') i' (Psub (Pinj (Pdouble_minus_one j) Q) Q')
+      | xO j => PX (--P') i' (Psub (Pinj (Pos.pred_double j) Q) Q')
       | xI j => PX (--P') i' (Psub (Pinj (xO j) Q) Q')
       end
     | PX P i Q =>
-      match ZPminus i i' with
+      match Z.pos_sub i i' with
       | Zpos k => mkPX (Psub (PX P k P0) P') i' (Psub Q Q')
       | Z0 => mkPX (Psub P P') i (Psub Q Q')
       | Zneg k => mkPX (PsubX Psub P' k P) i (Psub Q Q')
       end
     end
   end.
- Notation "P -- P'" := (Psub P P').
+ Infix "--" := Psub.
 
  (** Multiplication *)
 
- Fixpoint PmulC_aux (P:Pol) (c:C) {struct P} : Pol :=
+ Fixpoint PmulC_aux (P:Pol) (c:C) : Pol :=
   match P with
   | Pc c' => Pc (c' *! c)
   | Pinj j Q => mkPinj j (PmulC_aux Q c)
@@ -311,11 +326,11 @@ Section MakeRingPol.
  Section PmulI.
   Variable Pmul : Pol -> Pol -> Pol.
   Variable Q : Pol.
-  Fixpoint PmulI (j:positive) (P:Pol) {struct P} : Pol :=
+  Fixpoint PmulI (j:positive) (P:Pol) : Pol :=
    match P with
    | Pc c => mkPinj j (PmulC Q c)
    | Pinj j' Q' =>
-     match ZPminus j' j with
+     match Z.pos_sub j' j with
      | Zpos k => mkPinj j (Pmul (Pinj k Q') Q)
      | Z0 => mkPinj j (Pmul Q' Q)
      | Zneg k => mkPinj j' (PmulI k Q')
@@ -323,13 +338,12 @@ Section MakeRingPol.
    | PX P' i' Q' =>
      match j with
      | xH => mkPX (PmulI xH P') i' (Pmul Q' Q)
-     | xO j' => mkPX (PmulI j P') i' (PmulI (Pdouble_minus_one j') Q')
+     | xO j' => mkPX (PmulI j P') i' (PmulI (Pos.pred_double j') Q')
      | xI j' => mkPX (PmulI j P') i' (PmulI (xO j') Q')
      end
    end.
 
  End PmulI.
-(* A symmetric version of the multiplication *)
 
  Fixpoint Pmul (P P'' : Pol) {struct P''} : Pol :=
    match P'' with
@@ -342,7 +356,7 @@ Section MakeRingPol.
        let QQ' :=
          match j with
          | xH => Pmul Q Q'
-         | xO j => Pmul (Pinj (Pdouble_minus_one j) Q) Q'
+         | xO j => Pmul (Pinj (Pos.pred_double j) Q) Q'
          | xI j => Pmul (Pinj (xO j) Q) Q'
          end in
        mkPX (Pmul P P') i' QQ'
@@ -355,25 +369,7 @@ Section MakeRingPol.
      end
   end.
 
-(* Non symmetric *)
-(*
- Fixpoint Pmul_aux (P P' : Pol) {struct P'} : Pol :=
-  match P' with
-  | Pc c' => PmulC P c'
-  | Pinj j' Q' => PmulI Pmul_aux Q' j' P
-  | PX P' i' Q' =>
-     (mkPX (Pmul_aux P P') i' P0) ++ (PmulI Pmul_aux Q' xH P)
-  end.
-
- Definition Pmul P P' :=
-  match P with
-  | Pc c => PmulC P' c
-  | Pinj j Q => PmulI Pmul_aux Q j P'
-  | PX P i Q =>
-    (mkPX (Pmul_aux P P') i P0) ++ (PmulI Pmul_aux Q xH P')
-  end.
-*)
- Notation "P ** P'" := (Pmul P P').
+ Infix "**" := Pmul.
 
  Fixpoint Psquare (P:Pol) : Pol :=
    match P with
@@ -388,26 +384,26 @@ Section MakeRingPol.
 
  (** Monomial **)
 
+ (** A monomial is X1^k1...Xi^ki. Its representation
+     is a simplified version of the polynomial representation:
+
+     - [mon0] correspond to the polynom [P1].
+     - [(zmon j M)] corresponds to [(Pinj j ...)],
+       i.e. skip j variable indices.
+     - [(vmon i M)] is X^i*M with X the current variable,
+       its corresponds to (PX P1 i ...)]
+ *)
+
   Inductive Mon: Set :=
-    mon0: Mon
+  | mon0: Mon
   | zmon: positive -> Mon -> Mon
   | vmon: positive -> Mon -> Mon.
 
- Fixpoint Mphi(l:Env R) (M: Mon) {struct M} : R :=
-  match M with
-     mon0 => rI
-  | zmon j M1  => Mphi (jump j l) M1
-  | vmon i M1 =>
-     let x := hd 0 l in
-     let xi := pow_pos rmul x i in
-    (Mphi (tail l) M1) * xi
-  end.
-
  Definition mkZmon j M :=
    match M with mon0 => mon0 | _ => zmon j M end.
 
  Definition zmon_pred j M :=
-   match j with xH => M | _ => mkZmon (Ppred j) M end.
+   match j with xH => M | _ => mkZmon (Pos.pred j) M end.
 
  Definition mkVmon i M :=
    match M with
@@ -416,12 +412,12 @@ Section MakeRingPol.
    | vmon i' m => vmon (i+i') m
    end.
 
- Fixpoint MFactor (P: Pol) (M: Mon) {struct P}: Pol * Pol :=
+ Fixpoint MFactor (P: Pol) (M: Mon) : Pol * Pol :=
    match P, M with
         _, 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 +431,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
@@ -453,7 +449,7 @@ Section MakeRingPol.
     | _ => Some (Padd Q1 (Pmul P2 R1))
     end.
 
-  Fixpoint PNSubst1 (P1: Pol) (M1: Mon) (P2: Pol) (n: nat) {struct n}: Pol :=
+  Fixpoint PNSubst1 (P1: Pol) (M1: Mon) (P2: Pol) (n: nat) : Pol :=
     match POneSubst P1 M1 P2 with
      Some P3 => match n with S n1 => PNSubst1 P3 M1 P2 n1 | _ => P3 end
     | _ => P1
@@ -465,14 +461,13 @@ Section MakeRingPol.
     | _ => None
     end.
 
-  Fixpoint PSubstL1 (P1: Pol) (LM1: list (Mon * Pol)) (n: nat) {struct LM1}:
-     Pol :=
+  Fixpoint PSubstL1 (P1: Pol) (LM1: list (Mon * Pol)) (n: nat) : Pol :=
     match LM1 with
      cons (M1,P2) LM2 => PSubstL1 (PNSubst1 P1 M1 P2 n) LM2 n
     | _ => P1
     end.
 
-  Fixpoint PSubstL (P1: Pol) (LM1: list (Mon * Pol)) (n: nat) {struct LM1}: option Pol :=
+  Fixpoint PSubstL (P1: Pol) (LM1: list (Mon * Pol)) (n: nat) : option Pol :=
     match LM1 with
      cons (M1,P2) LM2 =>
       match PNSubst P1 M1 P2 n with
@@ -482,7 +477,7 @@ Section MakeRingPol.
     | _ => None
     end.
 
-  Fixpoint PNSubstL (P1: Pol) (LM1: list (Mon * Pol)) (m n: nat) {struct m}: Pol :=
+  Fixpoint PNSubstL (P1: Pol) (LM1: list (Mon * Pol)) (m n: nat) : Pol :=
     match PSubstL P1 LM1 n with
      Some P3 => match m with S m1 => PNSubstL P3 LM1 m1 n | _ => P3 end
     | _ => P1
@@ -490,726 +485,446 @@ Section MakeRingPol.
 
  (** Evaluation of a polynomial towards R *)
 
- Fixpoint Pphi(l:Env R) (P:Pol) {struct P} : R :=
+ Fixpoint Pphi(l:Env R) (P:Pol) : R :=
   match P with
   | Pc c => [c]
   | Pinj j Q => Pphi (jump j l) Q
-  | PX P i Q =>
-     let x := hd 0 l in
-     let xi := pow_pos rmul x i in
-    (Pphi l P) * xi + (Pphi (tail l) Q)
+  | PX P i Q => Pphi l P * (hd l) ^ i + Pphi (tail l) Q
   end.
 
  Reserved Notation "P @ l " (at level 10, no associativity).
  Notation "P @ l " := (Pphi l P).
+
+ (** Evaluation of a monomial towards R *)
+
+ Fixpoint Mphi(l:Env R) (M: Mon) : R :=
+  match M with
+  | mon0 => rI
+  | zmon j M1 => Mphi (jump j l) M1
+  | vmon i M1 => Mphi (tail l) M1 * (hd l) ^ i
+  end.
+
+ Notation "M @@ l" := (Mphi l M) (at level 10, no associativity).
+
  (** 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
+
+ Ltac destr_pos_sub :=
+  match goal with |- context [Z.pos_sub ?x ?y] =>
+   generalize (Z.pos_sub_discr x y); destruct (Z.pos_sub x y)
   end.
+
+ Lemma Peq_ok P P' : (P ?== P') = true -> forall l, P@l == P'@ l.
  Proof.
-  induction x;destruct y.
-  replace (ZPminus (xI x) (xI y)) with (Zdouble (ZPminus x y));trivial.
-  assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble;rewrite H;trivial.
-  replace (ZPminus (xI x) (xO y)) with (Zdouble_plus_one (ZPminus x y));trivial.
-  assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble_plus_one;rewrite H;trivial.
-  apply Pplus_xI_double_minus_one.
-  simpl;trivial.
-  replace (ZPminus (xO x) (xI y)) with (Zdouble_minus_one (ZPminus x y));trivial.
-  assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble_minus_one;rewrite H;trivial.
-  apply Pplus_xI_double_minus_one.
-  replace (ZPminus (xO x) (xO y)) with (Zdouble (ZPminus x y));trivial.
-  assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble;rewrite H;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.
+  revert P';induction P;destruct P';simpl; intros H l; try easy.
+  - now apply (morph_eq CRmorph).
+  - destruct (Pos.compare_spec p p0); [ subst | easy | easy ].
+    now rewrite IHP.
+  - specialize (IHP1 P'1); specialize (IHP2 P'2).
+    destruct (Pos.compare_spec p p0); [ subst | easy | easy ].
+    destruct (P2 ?== P'1); [|easy].
+    rewrite H in *.
+    now rewrite IHP1, IHP2.
  Qed.
 
- Lemma Peq_ok : forall P P',
-    (P ?== P') = true -> forall l, P@l == P'@ l.
+ Lemma Peq_spec P P' :
+   BoolSpec (forall l, P@l == P'@l) True (P ?== P').
  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);
-   try discriminate H.
-  rewrite (IHP P' H); rewrite H1;trivial;rrefl.
-  assert (H1 := Pcompare_Eq_eq p p0); destruct ((p ?= p0)%positive Eq);
-   try discriminate H.
-  rewrite H1;trivial. clear H1.
-  assert (H1 := IHP1 P'1);assert (H2 := IHP2 P'2);
-   destruct (P2 ?== P'1);[destruct (P3 ?== P'2); [idtac|discriminate H]
-                         |discriminate H].
-  rewrite (H1 H);rewrite (H2 H);rrefl.
+  generalize (Peq_ok P P'). destruct (P ?== P'); auto.
  Qed.
 
- Lemma Pphi0 : forall l, P0@l == 0.
+ Lemma Pphi0 l : P0@l == 0.
  Proof.
-  intros;simpl;apply (morph0 CRmorph).
+  simpl;apply (morph0 CRmorph).
  Qed.
 
-Lemma env_morph : forall p e1 e2, (forall x, e1 x = e2 x) ->
- p @ e1 = p @ e2.
+ Lemma Pphi1 l : P1@l == 1.
+ Proof.
+  simpl;apply (morph1 CRmorph).
+ Qed.
+
+Lemma env_morph p e1 e2 :
+  (forall x, e1 x = e2 x) -> p @ e1 = p @ e2.
 Proof.
-  induction p ; simpl.
-  reflexivity.
-  intros.
-  apply IHp.
-  intros.
-  unfold jump.
-  apply H.
-  intros.
-  rewrite (IHp1 e1 e2) ; auto.
-  rewrite (IHp2 (tail e1) (tail e2)) ; auto.
-  unfold hd. unfold nth.  rewrite H.  reflexivity.
-  unfold tail.  unfold jump. intros ; apply H.
+  revert e1 e2. induction p ; simpl.
+  - reflexivity.
+  - intros e1 e2 EQ. apply IHp. intros. apply EQ.
+  - intros e1 e2 EQ. f_equal; [f_equal|].
+    + now apply IHp1.
+    + f_equal. apply EQ.
+    + apply IHp2. intros; apply EQ.
 Qed.
 
-Lemma Pjump_Pplus : forall P i j l, P @ (jump (i + j) l ) = P @ (jump j (jump i l)).
+Lemma Pjump_add P i j l :
+  P @ (jump (i + j) l) = P @ (jump j (jump i l)).
 Proof.
-  intros. apply env_morph. intros. rewrite <- jump_Pplus.
-  rewrite Pplus_comm.
-  reflexivity.
+  apply env_morph. intros. rewrite <- jump_add. f_equal.
+  apply Pos.add_comm.
 Qed.
 
-Lemma Pjump_xO_tail : forall P p l,
+Lemma Pjump_xO_tail P p l :
   P @ (jump (xO p) (tail l)) = P @ (jump (xI p) l).
 Proof.
-  intros.
-  apply env_morph.
-  intros.
-  rewrite (@jump_simpl R (xI p)).
-  rewrite (@jump_simpl R (xO p)).
-  reflexivity.
+  apply env_morph. intros. now jump_simpl.
 Qed.
 
-Lemma Pjump_Pdouble_minus_one : forall P p l,
-  P @ (jump (Pdouble_minus_one p) (tail l)) = P @ (jump (xO p) l).
+Lemma Pjump_pred_double P p l :
+  P @ (jump (Pos.pred_double p) (tail l)) = P @ (jump (xO p) l).
 Proof.
-  intros.
-  apply env_morph.
-  intros.
-  rewrite jump_Pdouble_minus_one.
-  rewrite (@jump_simpl R (xO p)).
-  reflexivity.
+  apply env_morph. intros.
+  rewrite jump_pred_double. now jump_simpl.
 Qed.
 
-
-
- Lemma Pphi1 : forall l,  P1@l == 1.
+ Lemma mkPinj_ok j l P : (mkPinj j P)@l == P@(jump j l).
  Proof.
-  intros;simpl;apply (morph1 CRmorph).
+  destruct P;simpl;rsimpl.
+  now rewrite Pjump_add.
  Qed.
 
- Lemma mkPinj_ok : forall j l P, (mkPinj j P)@l == P@(jump j l).
+ Lemma pow_pos_add x i j : x^(j + i) == x^i * x^j.
  Proof.
-  intros j l p;destruct p;simpl;rsimpl.
-  rewrite Pjump_Pplus.
-  reflexivity.
+  rewrite Pos.add_comm.
+  apply (pow_pos_add Rsth Reqe.(Rmul_ext) ARth.(ARmul_assoc)).
  Qed.
 
- Let pow_pos_Pplus :=
-    pow_pos_Pplus rmul Rsth Reqe.(Rmul_ext) ARth.(ARmul_comm) ARth.(ARmul_assoc).
-
- Lemma mkPX_ok : forall l P i Q,
-  (mkPX P i Q)@l == P@l*(pow_pos rmul (hd 0 l) i) + Q@(tail l).
+ Lemma ceqb_spec c c' : BoolSpec ([c] == [c']) True (c ?=! c').
  Proof.
-  intros l P i Q;unfold mkPX.
-  destruct P;try (simpl;rrefl).
-  assert (H := morph_eq CRmorph c cO);destruct (c ?=! cO);simpl;try rrefl.
-  rewrite (H (refl_equal true));rewrite (morph0 CRmorph).
-  rewrite mkPinj_ok;rsimpl;simpl;rrefl.
-  assert (H := @Peq_ok P3 P0);destruct (P3 ?== P0);simpl;try rrefl.
-  rewrite (H (refl_equal true));trivial.
-  rewrite Pphi0.  rewrite pow_pos_Pplus;rsimpl.
+  generalize (morph_eq CRmorph c c').
+  destruct (c ?=! c'); auto.
  Qed.
 
-
- Ltac Esimpl :=
-  repeat (progress (
-   match goal with
-   | |- context [P0@?l] => rewrite (Pphi0 l)
-   | |- context [P1@?l] => rewrite (Pphi1 l)
-   | |- context [(mkPinj ?j ?P)@?l] => rewrite (mkPinj_ok j l P)
-   | |- context [(mkPX ?P ?i ?Q)@?l] => rewrite (mkPX_ok l P i Q)
-   | |- context [[cO]] => rewrite (morph0 CRmorph)
-   | |- context [[cI]] => rewrite (morph1 CRmorph)
-   | |- context [[?x +! ?y]] => rewrite ((morph_add CRmorph) x y)
-   | |- context [[?x *! ?y]] => rewrite ((morph_mul CRmorph) x y)
-   | |- context [[?x -! ?y]] => rewrite ((morph_sub CRmorph) x y)
-   | |- context [[-! ?x]] => rewrite ((morph_opp CRmorph) x)
-   end));
-  rsimpl; simpl.
-
- Lemma PaddC_ok : forall c P l, (PaddC P c)@l == P@l + [c].
+ Lemma mkPX_ok l P i Q :
+  (mkPX P i Q)@l == P@l * (hd l)^i + Q@(tail l).
  Proof.
-  induction P;simpl;intros;Esimpl;trivial.
-  rewrite IHP2;rsimpl.
+  unfold mkPX. destruct P.
+  - case ceqb_spec; intros H; simpl; try reflexivity.
+    rewrite H, (morph0 CRmorph), mkPinj_ok; rsimpl.
+  - reflexivity.
+  - case Peq_spec; intros H; simpl; try reflexivity.
+    rewrite H, Pphi0, Pos.add_comm, pow_pos_add; rsimpl.
  Qed.
 
- Lemma PsubC_ok : forall c P l, (PsubC P c)@l == P@l - [c].
+ Hint Rewrite
+  Pphi0
+  Pphi1
+  mkPinj_ok
+  mkPX_ok
+  (morph0 CRmorph)
+  (morph1 CRmorph)
+  (morph0 CRmorph)
+  (morph_add CRmorph)
+  (morph_mul CRmorph)
+  (morph_sub CRmorph)
+  (morph_opp CRmorph)
+  : Esimpl.
+
+ (* Quicker than autorewrite with Esimpl :-) *)
+ Ltac Esimpl := try rewrite_db Esimpl; rsimpl; simpl.
+
+ Lemma PaddC_ok c P l : (PaddC P c)@l == P@l + [c].
  Proof.
-  induction P;simpl;intros.
-  Esimpl.
-  rewrite IHP;rsimpl.
+  revert l;induction P;simpl;intros;Esimpl;trivial.
   rewrite IHP2;rsimpl.
  Qed.
 
- Lemma PmulC_aux_ok : forall c P l, (PmulC_aux P c)@l == P@l * [c].
+ Lemma PsubC_ok c P l : (PsubC P c)@l == P@l - [c].
  Proof.
-  induction P;simpl;intros;Esimpl;trivial.
-  rewrite IHP1;rewrite IHP2;rsimpl.
-  mul_push ([c]);rrefl.
+  revert l;induction P;simpl;intros.
+  - Esimpl.
+  - rewrite IHP;rsimpl.
+  - rewrite IHP2;rsimpl.
  Qed.
 
- Lemma PmulC_ok : forall c P l, (PmulC P c)@l == P@l * [c].
+ Lemma PmulC_aux_ok c P l : (PmulC_aux P c)@l == P@l * [c].
  Proof.
-  intros c P l; unfold PmulC.
-  assert (H:= morph_eq CRmorph c cO);destruct (c ?=! cO).
-  rewrite (H (refl_equal true));Esimpl.
-  assert (H1:= morph_eq CRmorph c cI);destruct (c ?=! cI).
-  rewrite (H1 (refl_equal true));Esimpl.
-  apply PmulC_aux_ok.
+  revert l;induction P;simpl;intros;Esimpl;trivial.
+  rewrite IHP1, IHP2;rsimpl. add_permut. mul_permut.
  Qed.
 
- Lemma Popp_ok : forall P l, (--P)@l == - P@l.
+ Lemma PmulC_ok c P l : (PmulC P c)@l == P@l * [c].
  Proof.
-  induction P;simpl;intros.
-  Esimpl.
-  apply IHP.
-  rewrite IHP1;rewrite IHP2;rsimpl.
+  unfold PmulC.
+  case ceqb_spec; intros H.
+  - rewrite H; Esimpl.
+  - case ceqb_spec; intros H'.
+    + rewrite H'; Esimpl.
+    + apply PmulC_aux_ok.
  Qed.
 
- Ltac Esimpl2 :=
-  Esimpl;
-  repeat (progress (
-   match goal with
-   | |- context [(PaddC ?P ?c)@?l] => rewrite (PaddC_ok c P l)
-   | |- context [(PsubC ?P ?c)@?l] => rewrite (PsubC_ok c P l)
-   | |- context [(PmulC ?P ?c)@?l] => rewrite (PmulC_ok c P l)
-   | |- context [(--?P)@?l] => rewrite (Popp_ok P l)
-   end)); Esimpl.
-
-
-
-
- Lemma Padd_ok : forall P' P l, (P ++ P')@l == P@l + P'@l.
+ Lemma Popp_ok P l : (--P)@l == - P@l.
  Proof.
-  induction P';simpl;intros;Esimpl2.
-  generalize P p l;clear P p l.
-  induction P;simpl;intros.
-  Esimpl2;apply (ARadd_comm ARth).
-  assert (H := ZPminus_spec p p0);destruct (ZPminus p p0).
-  rewrite H;Esimpl. rewrite IHP';rrefl.
-  rewrite H;Esimpl. rewrite IHP';Esimpl.
-  rewrite Pjump_Pplus. rrefl.
-  rewrite H;Esimpl. rewrite IHP.
-  rewrite Pjump_Pplus. rrefl.
-  destruct p0;simpl.
-  rewrite IHP2;simpl. rsimpl.
-  rewrite Pjump_xO_tail. Esimpl.
-  rewrite IHP2;simpl.
-  rewrite Pjump_Pdouble_minus_one.
-  rsimpl.
-  rewrite IHP'.
-  rsimpl.
-  destruct P;simpl.
-  Esimpl2;add_push [c];rrefl.
-  destruct p0;simpl;Esimpl2.
-  rewrite IHP'2;simpl.
-  rewrite Pjump_xO_tail.
-  rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));rrefl.
-  rewrite IHP'2;simpl.
-  rewrite Pjump_Pdouble_minus_one. rsimpl.
-  add_push (P'1@l * (pow_pos rmul (hd 0 l) p));rrefl.
-  rewrite IHP'2;rsimpl.
-  unfold tail.
-  add_push (P @ (jump 1 l));rrefl.
-  assert (H := ZPminus_spec p0 p);destruct (ZPminus p0 p);Esimpl2.
-  rewrite IHP'1;rewrite IHP'2;rsimpl.
-  add_push (P3 @ (tail l));rewrite H;rrefl.
-  rewrite IHP'1;rewrite IHP'2;simpl;Esimpl.
-  rewrite H;rewrite Pplus_comm.
-  rewrite pow_pos_Pplus;rsimpl.
-  add_push (P3 @ (tail l));rrefl.
-  assert (forall P k l,
-           (PaddX Padd P'1 k P) @ l == P@l + P'1@l * pow_pos rmul (hd 0 l) k).
-   induction P;simpl;intros;try apply (ARadd_comm ARth).
-   destruct p2; simpl; try apply (ARadd_comm ARth).
-   rewrite Pjump_xO_tail.
-   apply (ARadd_comm ARth).
-   rewrite Pjump_Pdouble_minus_one.
-   apply (ARadd_comm ARth).
-    assert (H1 := ZPminus_spec p2 k);destruct (ZPminus p2 k);Esimpl2.
-    rewrite IHP'1;rsimpl; rewrite H1;add_push (P5 @ (tail l0));rrefl.
-    rewrite IHP'1;simpl;Esimpl.
-    rewrite H1;rewrite Pplus_comm.
-    rewrite pow_pos_Pplus;simpl;Esimpl.
-    add_push (P5 @ (tail l0));rrefl.
-    rewrite IHP1;rewrite H1;rewrite Pplus_comm.
-    rewrite pow_pos_Pplus;simpl;rsimpl.
-    add_push (P5 @ (tail l0));rrefl.
-  rewrite H0;rsimpl.
-  add_push (P3 @ (tail l)).
-  rewrite H;rewrite Pplus_comm.
-  rewrite IHP'2;rewrite pow_pos_Pplus;rsimpl.
-  add_push (P3 @ (tail l));rrefl.
+  revert l;induction P;simpl;intros.
+  - Esimpl.
+  - apply IHP.
+  - rewrite IHP1, IHP2;rsimpl.
  Qed.
 
- Lemma Psub_ok : forall P' P l, (P -- P')@l == P@l - P'@l.
+ Hint Rewrite PaddC_ok PsubC_ok PmulC_ok Popp_ok : Esimpl.
+
+ Lemma PaddX_ok P' P k l :
+  (forall P l, (P++P')@l == P@l + P'@l) ->
+  (PaddX Padd P' k P) @ l == P@l + P'@l * (hd l)^k.
  Proof.
-  induction P';simpl;intros;Esimpl2;trivial.
-  generalize P p l;clear P p l.
-  induction P;simpl;intros.
-  Esimpl2;apply (ARadd_comm ARth).
-  assert (H := ZPminus_spec p p0);destruct (ZPminus p p0).
-  rewrite H;Esimpl. rewrite IHP';rsimpl.
-  rewrite H;Esimpl. rewrite IHP';Esimpl.
-  rewrite <- Pjump_Pplus;rewrite Pplus_comm;rrefl.
-  rewrite H;Esimpl. rewrite IHP.
-  rewrite <- Pjump_Pplus;rewrite Pplus_comm;rrefl.
-  destruct p0;simpl.
-  rewrite IHP2;simpl; try   rewrite Pjump_xO_tail ; rsimpl.
-  rewrite IHP2;simpl.
-  rewrite Pjump_Pdouble_minus_one;rsimpl.
-  unfold tail ; rsimpl.
-  rewrite IHP';rsimpl.
-  destruct P;simpl.
-  repeat rewrite Popp_ok;Esimpl2;rsimpl;add_push [c];try rrefl.
-  destruct p0;simpl;Esimpl2.
-  rewrite IHP'2;simpl;rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));trivial.
-  rewrite Pjump_xO_tail.
-  add_push (P @ ((jump (xI p0) l)));rrefl.
-  rewrite IHP'2;simpl;rewrite Pjump_Pdouble_minus_one;rsimpl.
-  add_push (- (P'1 @ l * pow_pos  rmul (hd 0 l) p));rrefl.
-  unfold tail.
-  rewrite IHP'2;rsimpl;add_push (P @ (jump 1 l));rrefl.
-  assert (H := ZPminus_spec p0 p);destruct (ZPminus p0 p);Esimpl2.
-  rewrite IHP'1; rewrite IHP'2;rsimpl.
-  add_push (P3 @ (tail l));rewrite H;rrefl.
-   rewrite IHP'1; rewrite IHP'2;rsimpl;simpl;Esimpl.
-  rewrite H;rewrite Pplus_comm.
-  rewrite pow_pos_Pplus;rsimpl.
-  add_push (P3 @ (tail l));rrefl.
-  assert (forall P k l,
-           (PsubX Psub P'1 k P) @ l == P@l + - P'1@l * pow_pos rmul (hd 0 l) k).
-   induction P;simpl;intros.
-   rewrite Popp_ok;rsimpl;apply (ARadd_comm ARth);trivial.
-   destruct p2;simpl; rewrite Popp_ok;rsimpl.
-   rewrite Pjump_xO_tail.
-   apply (ARadd_comm ARth);trivial.
-   rewrite Pjump_Pdouble_minus_one.
-   apply (ARadd_comm ARth);trivial.
-   apply (ARadd_comm ARth);trivial.
-    assert (H1 := ZPminus_spec p2 k);destruct (ZPminus p2 k);Esimpl2;rsimpl.
-    rewrite IHP'1;rsimpl;add_push (P5 @ (tail l0));rewrite H1;rrefl.
-    rewrite IHP'1;rewrite H1;rewrite Pplus_comm.
-    rewrite pow_pos_Pplus;simpl;Esimpl.
-    add_push (P5 @ (tail l0));rrefl.
-    rewrite IHP1;rewrite H1;rewrite Pplus_comm.
-    rewrite pow_pos_Pplus;simpl;rsimpl.
-    add_push (P5 @ (tail l0));rrefl.
-  rewrite H0;rsimpl.
-  rewrite IHP'2;rsimpl;add_push (P3 @ (tail l)).
-  rewrite H;rewrite Pplus_comm.
-  rewrite pow_pos_Pplus;rsimpl.
+  intros IHP'.
+  revert k l. induction P;simpl;intros.
+  - add_permut.
+  - destruct p; simpl;
+    rewrite ?Pjump_xO_tail, ?Pjump_pred_double; add_permut.
+  - destr_pos_sub; intros ->;Esimpl.
+    + rewrite IHP';rsimpl. add_permut.
+    + rewrite IHP', pow_pos_add;simpl;Esimpl. add_permut.
+    + rewrite IHP1, pow_pos_add;rsimpl. add_permut.
  Qed.
-(* Proof for the symmetric version *)
 
- Lemma PmulI_ok :
-  forall P',
-   (forall (P : Pol) (l : Env  R), (Pmul P P') @ l == P @ l * P' @ l) ->
-   forall (P : Pol) (p : positive) (l : Env R),
-    (PmulI Pmul P' p P) @ l == P @ l * P' @ (jump p l).
+ Lemma Padd_ok P' P l : (P ++ P')@l == P@l + P'@l.
  Proof.
-  induction P;simpl;intros.
-  Esimpl2;apply (ARmul_comm ARth).
-  assert (H1 := ZPminus_spec p p0);destruct (ZPminus p p0);Esimpl2.
-  rewrite H1; rewrite H;rrefl.
-  rewrite H1; rewrite H.
-  rewrite Pjump_Pplus;simpl;rrefl.
-  rewrite H1.
-  rewrite Pjump_Pplus;rewrite IHP;rrefl.
-  destruct p0;Esimpl2.
-  rewrite IHP1;rewrite IHP2;rsimpl.
-  rewrite Pjump_xO_tail.
-  mul_push (pow_pos rmul (hd 0 l) p);rrefl.
-  rewrite IHP1;rewrite IHP2;simpl;rsimpl.
-  mul_push (pow_pos rmul (hd 0 l) p); rewrite Pjump_Pdouble_minus_one.
-  rrefl.
-  rewrite IHP1;simpl;rsimpl.
-  mul_push (pow_pos rmul (hd 0 l) p).
-  rewrite H;rrefl.
+  revert P l; induction P';simpl;intros;Esimpl.
+  - revert p l; induction P;simpl;intros.
+    + Esimpl; add_permut.
+    + destr_pos_sub; intros ->;Esimpl.
+      * now rewrite IHP'.
+      * rewrite IHP';Esimpl. now rewrite Pjump_add.
+      * rewrite IHP. now rewrite Pjump_add.
+    + destruct p0;simpl.
+      * rewrite IHP2;simpl. rsimpl. rewrite Pjump_xO_tail. Esimpl.
+      * rewrite IHP2;simpl. rewrite Pjump_pred_double. rsimpl.
+      * rewrite IHP'. rsimpl.
+  - destruct P;simpl.
+    + Esimpl. add_permut.
+    + destruct p0;simpl;Esimpl; rewrite IHP'2; simpl.
+      * rewrite Pjump_xO_tail. rsimpl. add_permut.
+      * rewrite Pjump_pred_double. rsimpl. add_permut.
+      * rsimpl. unfold tail. add_permut.
+    + destr_pos_sub; intros ->; Esimpl.
+      * rewrite IHP'1, IHP'2;rsimpl. add_permut.
+      * rewrite IHP'1, IHP'2;simpl;Esimpl.
+        rewrite pow_pos_add;rsimpl. add_permut.
+      * rewrite PaddX_ok by trivial; rsimpl.
+        rewrite IHP'2, pow_pos_add; rsimpl. add_permut.
  Qed.
 
-(*
- Lemma PmulI_ok :
-  forall P',
-   (forall (P : Pol) (l : list R), (Pmul_aux P P') @ l == P @ l * P' @ l) ->
-   forall (P : Pol) (p : positive) (l : list R),
-    (PmulI Pmul_aux P' p P) @ l == P @ l * P' @ (jump p l).
+ Lemma PsubX_ok P' P k l :
+  (forall P l, (P--P')@l == P@l - P'@l) ->
+  (PsubX Psub P' k P) @ l == P@l - P'@l * (hd l)^k.
  Proof.
-  induction P;simpl;intros.
-  Esimpl2;apply (ARmul_comm ARth).
-  assert (H1 := ZPminus_spec p p0);destruct (ZPminus p p0);Esimpl2.
-  rewrite H1; rewrite H;rrefl.
-  rewrite H1; rewrite H.
-  rewrite Pplus_comm.
-  rewrite jump_Pplus;simpl;rrefl.
-  rewrite H1;rewrite Pplus_comm.
-  rewrite jump_Pplus;rewrite IHP;rrefl.
-  destruct p0;Esimpl2.
-  rewrite IHP1;rewrite IHP2;simpl;rsimpl.
-  mul_push (pow_pos rmul (hd 0 l) p);rrefl.
-  rewrite IHP1;rewrite IHP2;simpl;rsimpl.
-  mul_push (pow_pos rmul (hd 0 l) p); rewrite jump_Pdouble_minus_one;rrefl.
-  rewrite IHP1;simpl;rsimpl.
-  mul_push (pow_pos rmul (hd 0 l) p).
-  rewrite H;rrefl.
+  intros IHP'.
+  revert k l. induction P;simpl;intros.
+  - rewrite Popp_ok;rsimpl; add_permut.
+  - destruct p; simpl;
+    rewrite Popp_ok;rsimpl;
+    rewrite ?Pjump_xO_tail, ?Pjump_pred_double; add_permut.
+  - destr_pos_sub; intros ->; Esimpl.
+    + rewrite IHP';rsimpl. add_permut.
+    + rewrite IHP', pow_pos_add;simpl;Esimpl. add_permut.
+    + rewrite IHP1, pow_pos_add;rsimpl. add_permut.
  Qed.
 
- Lemma Pmul_aux_ok : forall P' P l,(Pmul_aux P P')@l == P@l * P'@l.
+ Lemma Psub_ok P' P l : (P -- P')@l == P@l - P'@l.
  Proof.
-  induction P';simpl;intros.
-  Esimpl2;trivial.
-  apply PmulI_ok;trivial.
-  rewrite Padd_ok;Esimpl2.
-  rewrite (PmulI_ok P'2 IHP'2). rewrite IHP'1. rrefl.
+  revert P l; induction P';simpl;intros;Esimpl.
+  - revert p l; induction P;simpl;intros.
+    + Esimpl; add_permut.
+    + destr_pos_sub; intros ->;Esimpl.
+      * rewrite IHP';rsimpl.
+      * rewrite IHP';Esimpl. now rewrite Pjump_add.
+      * rewrite IHP. now rewrite Pjump_add.
+    + destruct p0;simpl.
+      * rewrite IHP2;simpl. rsimpl. rewrite Pjump_xO_tail. Esimpl.
+      * rewrite IHP2;simpl. rewrite Pjump_pred_double. rsimpl.
+      * rewrite IHP'. rsimpl.
+  - destruct P;simpl.
+    + Esimpl; add_permut.
+    + destruct p0;simpl;Esimpl; rewrite IHP'2; simpl.
+      * rewrite Pjump_xO_tail. rsimpl. add_permut.
+      * rewrite Pjump_pred_double. rsimpl. add_permut.
+      * rsimpl. unfold tail. add_permut.
+    + destr_pos_sub; intros ->; Esimpl.
+      * rewrite IHP'1, IHP'2;rsimpl. add_permut.
+      * rewrite IHP'1, IHP'2;simpl;Esimpl.
+        rewrite pow_pos_add;rsimpl. add_permut.
+      * rewrite PsubX_ok by trivial;rsimpl.
+        rewrite IHP'2, pow_pos_add;rsimpl. add_permut.
  Qed.
-*)
 
-(* Proof for the symmetric version *)
- Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
+ Lemma PmulI_ok P' :
+   (forall P l, (Pmul P P') @ l == P @ l * P' @ l) ->
+   forall P p l, (PmulI Pmul P' p P) @ l == P @ l * P' @ (jump p l).
  Proof.
-  intros P P';generalize P;clear P;induction P';simpl;intros.
-  apply PmulC_ok. apply PmulI_ok;trivial.
-  destruct P.
-  rewrite (ARmul_comm ARth);Esimpl2;Esimpl2.
-  Esimpl2. rewrite IHP'1;Esimpl2.
-   assert (match p0 with
-           | xI j => Pinj (xO j) P ** P'2
-           | xO j => Pinj (Pdouble_minus_one j) P ** P'2
-           | 1 => P ** P'2
-           end @ (tail l) == P @ (jump p0 l) * P'2 @ (tail l)).
-   destruct p0;rewrite IHP'2;Esimpl.
-   rewrite Pjump_xO_tail. reflexivity.
-   rewrite Pjump_Pdouble_minus_one;Esimpl.
-   rewrite H;Esimpl.
-   rewrite Padd_ok; Esimpl2. rewrite Padd_ok; Esimpl2.
-   repeat (rewrite IHP'1 || rewrite IHP'2);simpl.
-   rewrite PmulI_ok;trivial.
-   unfold tail.
-   mul_push (P'1@l). simpl. mul_push (P'2 @ (jump 1 l)). Esimpl.
+  intros IHP'.
+  induction P;simpl;intros.
+  - Esimpl; mul_permut.
+  - destr_pos_sub; intros ->;Esimpl.
+    + now rewrite IHP'.
+    + now rewrite IHP', Pjump_add.
+    + now rewrite IHP, Pjump_add.
+  - destruct p0;Esimpl; rewrite ?IHP1, ?IHP2; rsimpl.
+    + rewrite Pjump_xO_tail. f_equiv. mul_permut.
+    + rewrite Pjump_pred_double. f_equiv. mul_permut.
+    + rewrite IHP'. f_equiv. mul_permut.
  Qed.
 
-(*
-Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
+ Lemma Pmul_ok P P' l : (P**P')@l == P@l * P'@l.
  Proof.
-  destruct P;simpl;intros.
-  Esimpl2;apply (ARmul_comm ARth).
-  rewrite (PmulI_ok P (Pmul_aux_ok P)).
-  apply (ARmul_comm ARth).
-  rewrite Padd_ok; Esimpl2.
-  rewrite (PmulI_ok P3 (Pmul_aux_ok P3));trivial.
-  rewrite Pmul_aux_ok;mul_push (P' @ l).
-  rewrite (ARmul_comm ARth (P' @ l));rrefl.
+  revert P l;induction P';simpl;intros.
+  - apply PmulC_ok.
+  - apply PmulI_ok;trivial.
+  - destruct P.
+    + rewrite (ARmul_comm ARth). Esimpl.
+    + Esimpl. rewrite IHP'1;Esimpl. f_equiv.
+      destruct p0;rewrite IHP'2;Esimpl.
+      * now rewrite Pjump_xO_tail.
+      * rewrite Pjump_pred_double; Esimpl.
+    + rewrite Padd_ok, !mkPX_ok, Padd_ok, !mkPX_ok,
+       !IHP'1, !IHP'2, PmulI_ok; trivial. simpl. Esimpl.
+      unfold tail.
+      add_permut; f_equiv; mul_permut.
  Qed.
-*)
 
- Lemma Psquare_ok : forall P l, (Psquare P)@l == P@l * P@l.
+ Lemma Psquare_ok P l : (Psquare P)@l == P@l * P@l.
  Proof.
-  induction P;simpl;intros;Esimpl2.
-  apply IHP. rewrite Padd_ok. rewrite Pmul_ok;Esimpl2.
-  rewrite IHP1;rewrite IHP2.
-  mul_push (pow_pos rmul (hd 0 l) p). mul_push (P2@l).
-  rrefl.
+  revert l;induction P;simpl;intros;Esimpl.
+  - apply IHP.
+  - rewrite Padd_ok, Pmul_ok;Esimpl.
+    rewrite IHP1, IHP2.
+    mul_push ((hd l)^p). now mul_push (P2@l).
  Qed.
 
- Lemma Mphi_morph : forall P env env', (forall x, env x = env' x ) ->
-   Mphi env P = Mphi env' P.
+ Lemma Mphi_morph M e1 e2 :
+  (forall x, e1 x = e2 x) -> M @@ e1 = M @@ e2.
  Proof.
-   induction P ; simpl.
-   reflexivity.
-   intros.
-   apply IHP.
-   intros.
-   unfold jump.
-   apply H.
-   (**)
-   intros.
-   replace (Mphi (tail env) P) with (Mphi (tail env') P).
-   unfold hd. unfold nth.
-   rewrite H.
-   reflexivity.
-   apply IHP.
-   unfold tail,jump.
-   intros. symmetry. apply H.
+   revert e1 e2; induction M; simpl; intros e1 e2 EQ; trivial.
+   - apply IHM. intros; apply EQ.
+   - f_equal.
+     * apply IHM. intros; apply EQ.
+     * f_equal. apply EQ.
  Qed.
 
-Lemma Mjump_xO_tail : forall M p l,
-  Mphi  (jump (xO p) (tail l)) M = Mphi (jump (xI p) l) M.
+Lemma Mjump_xO_tail M p l :
+  M @@ (jump (xO p) (tail l)) = M @@ (jump (xI p) l).
 Proof.
-  intros.
-  apply Mphi_morph.
-  intros.
-  rewrite (@jump_simpl R (xI p)).
-  rewrite (@jump_simpl R (xO p)).
-  reflexivity.
+  apply Mphi_morph. intros. now jump_simpl.
 Qed.
 
-Lemma Mjump_Pdouble_minus_one : forall M p l,
-  Mphi (jump (Pdouble_minus_one p) (tail l)) M = Mphi (jump (xO p) l) M.
+Lemma Mjump_pred_double M p l :
+  M @@ (jump (Pos.pred_double p) (tail l)) = M @@ (jump (xO p) l).
 Proof.
-  intros.
-  apply Mphi_morph.
-  intros.
-  rewrite jump_Pdouble_minus_one.
-  rewrite (@jump_simpl R (xO p)).
-  reflexivity.
+  apply Mphi_morph. intros.
+  rewrite jump_pred_double. now jump_simpl.
 Qed.
 
-Lemma Mjump_Pplus : forall M i j l, Mphi (jump (i + j) l ) M = Mphi (jump j (jump i l)) M.
+Lemma Mjump_add M i j l :
+  M @@ (jump (i + j) l) = M @@ (jump j (jump i l)).
 Proof.
-  intros. apply Mphi_morph. intros. rewrite <- jump_Pplus.
-  rewrite Pplus_comm.
-  reflexivity.
+  apply Mphi_morph. intros. now rewrite <- jump_add, Pos.add_comm.
 Qed.
 
-
-
- Lemma mkZmon_ok: forall M j l,
-   Mphi l (mkZmon j M) == Mphi l (zmon j M).
- intros M j l; case M; simpl; intros; rsimpl.
+ Lemma mkZmon_ok M j l :
+   (mkZmon j M) @@ l == (zmon j M) @@ l.
+ Proof.
+ destruct M; simpl; rsimpl.
  Qed.
 
- Lemma zmon_pred_ok : forall M j l,
-    Mphi (tail l) (zmon_pred j M) == Mphi l (zmon j M).
+ Lemma zmon_pred_ok M j l :
+   (zmon_pred j M) @@ (tail l) == (zmon j M) @@ l.
  Proof.
-   destruct j; simpl;intros l; rsimpl.
-   rewrite mkZmon_ok;rsimpl.
-   simpl.
-   rewrite Mjump_xO_tail.
-   reflexivity.
-   rewrite mkZmon_ok;simpl.
-   rewrite Mjump_Pdouble_minus_one; rsimpl.
+   destruct j; simpl; rewrite ?mkZmon_ok; simpl; rsimpl.
+   - now rewrite Mjump_xO_tail.
+   - rewrite Mjump_pred_double; rsimpl.
  Qed.
 
- Lemma mkVmon_ok : forall M i l, Mphi l (mkVmon i M) == Mphi l M*pow_pos rmul (hd 0 l) i.
+ Lemma mkVmon_ok M i l :
+   (mkVmon i M)@@l == M@@l * (hd l)^i.
  Proof.
   destruct M;simpl;intros;rsimpl.
-   rewrite zmon_pred_ok;simpl;rsimpl.
-  rewrite Pplus_comm;rewrite pow_pos_Pplus;rsimpl.
+  - rewrite zmon_pred_ok;simpl;rsimpl.
+  - rewrite pow_pos_add;rsimpl.
  Qed.
 
+ Ltac destr_mfactor R S := match goal with
+  | H : context [MFactor ?P _] |- context [MFactor ?P ?M] =>
+    specialize (H M); destruct MFactor as (R,S)
+ end.
 
- Lemma Mphi_ok: forall P M l,
-    let (Q,R) := MFactor P M in
-      P@l == Q@l + (Mphi l M) * (R@l).
+ Lemma Mphi_ok P M l :
+   let (Q,R) := MFactor P M in
+     P@l == Q@l + M@@l * R@l.
  Proof.
- intros P; elim P; simpl; auto; clear P.
-   intros c M l; case M; simpl; auto; try intro p; try intro m;
-   try rewrite (morph0 CRmorph); rsimpl.
-
-   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).
-       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));
-       case (MFactor P (zmon (j -i) M)); simpl.
-       intros P2 Q2 H; repeat rewrite mkPinj_ok; auto.
-       rewrite  <- (Pplus_minus _ _ (ZC2 _ _ He)).
-       rewrite Mjump_Pplus; auto.
-       rewrite (morph0 CRmorph); rsimpl.
-       intros P2 m; rewrite (morph0 CRmorph); rsimpl.
-
-   intros P2 Hrec1 i Q2 Hrec2 M l; case M; simpl; auto.
-   rewrite (morph0 CRmorph); rsimpl.
-   intros j M1.
-     generalize (Hrec1 (zmon j M1) l);
-     case (MFactor P2 (zmon j M1)).
-     intros R1 S1 H1.
-     generalize (Hrec2 (zmon_pred j M1) (tail l));
-     case (MFactor Q2 (zmon_pred j M1)); simpl.
-     intros R2 S2 H2; rewrite H1; rewrite H2.
-     repeat rewrite mkPX_ok; simpl.
-     rsimpl.
-     apply radd_ext; rsimpl.
-     rewrite (ARadd_comm ARth); rsimpl.
-     apply radd_ext; rsimpl.
-     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).
-       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.
-       repeat (rewrite <-(ARadd_assoc ARth)).
-       apply radd_ext; rsimpl.
-       rewrite (ARadd_comm ARth); rsimpl.
-       apply radd_ext; rsimpl.
-       repeat (rewrite <-(ARmul_assoc ARth)).
-       rewrite mkZmon_ok.
-       apply rmul_ext; rsimpl.
-       rewrite (ARmul_comm ARth); rsimpl.
-       generalize (Hrec1 (vmon (j - i) M1) l);
-             case (MFactor P2 (vmon (j - i) M1));
-        simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto.
-       rewrite H; rsimpl; repeat rewrite mkPinj_ok; auto.
-       rewrite mkPX_ok; rsimpl.
-       repeat (rewrite <-(ARadd_assoc ARth)).
-       apply radd_ext; rsimpl.
-       rewrite (ARadd_comm ARth); rsimpl.
-       apply radd_ext; rsimpl.
-       repeat (rewrite <-(ARmul_assoc ARth)).
-       apply rmul_ext; rsimpl.
-       rewrite (ARmul_comm ARth); rsimpl.
-       apply rmul_ext; rsimpl.
-       rewrite <- pow_pos_Pplus.
-       rewrite (Pplus_minus _ _ (ZC2 _ _ He)); rsimpl.
-       generalize (Hrec1 (mkZmon 1 M1) l);
-             case (MFactor P2 (mkZmon 1 M1));
-        simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto.
-       rewrite H; rsimpl.
-       rewrite mkPX_ok; rsimpl.
-       repeat (rewrite <-(ARadd_assoc ARth)).
-       apply radd_ext; rsimpl.
-       rewrite (ARadd_comm ARth); rsimpl.
-       apply radd_ext; rsimpl.
-       rewrite mkZmon_ok.
-       repeat (rewrite <-(ARmul_assoc ARth)).
-       apply rmul_ext; rsimpl.
-       rewrite (ARmul_comm ARth); rsimpl.
-       rewrite mkPX_ok; simpl; rsimpl.
-       rewrite (morph0 CRmorph); rsimpl.
-       repeat (rewrite <-(ARmul_assoc ARth)).
-       rewrite (ARmul_comm ARth (Q3@l)); rsimpl.
-       apply rmul_ext; rsimpl.
-       rewrite <- pow_pos_Pplus.
-       rewrite (Pplus_minus _ _ He); rsimpl.
+ revert M l; induction P; destruct M; intros l; simpl; auto; Esimpl.
+ - case Pos.compare_spec; intros He; simpl.
+   * destr_mfactor R1 S1. now rewrite IHP, He, !mkPinj_ok.
+   * destr_mfactor R1 S1. rewrite IHP; simpl.
+     now rewrite !mkPinj_ok, <- Mjump_add, Pos.add_comm, Pos.sub_add.
+   * Esimpl.
+ - destr_mfactor R1 S1. destr_mfactor R2 S2.
+   rewrite IHP1, IHP2, !mkPX_ok, zmon_pred_ok; simpl; rsimpl.
+   add_permut.
+ - case Pos.compare_spec; intros He; simpl; destr_mfactor R1 S1;
+   rewrite ?He, IHP1, mkPX_ok, ?mkZmon_ok; simpl; rsimpl;
+   unfold tail; add_permut; mul_permut.
+   * rewrite <- pow_pos_add, Pos.add_comm, Pos.sub_add by trivial; rsimpl.
+   * rewrite mkPX_ok. simpl. Esimpl. mul_permut.
+     rewrite <- pow_pos_add, Pos.sub_add by trivial; rsimpl.
  Qed.
 
-(* Proof for the symmetric version *)
-
- Lemma POneSubst_ok: forall P1 M1 P2 P3 l,
-    POneSubst P1 M1 P2 = Some P3 -> Mphi l M1 == P2@l -> P1@l == P3@l.
+ Lemma POneSubst_ok P1 M1 P2 P3 l :
+   POneSubst P1 M1 P2 = Some P3 -> M1@@l == P2@l ->
+   P1@l == P3@l.
  Proof.
- intros P2 M1 P3 P4 l; unfold POneSubst.
- generalize (Mphi_ok P2 M1 l); case (MFactor P2 M1); simpl; auto.
- intros Q1 R1; case R1.
-   intros c H; rewrite H.
-   generalize (morph_eq CRmorph c cO);
-        case (c ?=! cO); simpl; auto.
-   intros H1 H2; rewrite H1; auto; rsimpl.
-   discriminate.
-   intros _ H1 H2; injection H1; intros; subst.
-   rewrite H2; rsimpl.
- (* new version *)
-   rewrite Padd_ok; rewrite PmulC_ok; rsimpl.
- intros i P5 H; rewrite H.
-   intros HH H1; injection HH; intros; subst; rsimpl.
-   rewrite Padd_ok; rewrite PmulI_ok by (intros;apply Pmul_ok). rewrite H1; rsimpl.
- intros i P5 P6 H1 H2 H3; rewrite H1; rewrite H3.
-   assert (P4 = Q1 ++ P3 ** PX i P5 P6).
-   injection H2; intros; subst;trivial.
-  rewrite H;rewrite Padd_ok;rewrite Pmul_ok;rsimpl.
-Qed.
-(*
-  Lemma POneSubst_ok: forall P1 M1 P2 P3 l,
-    POneSubst P1 M1 P2 = Some P3 -> Mphi l M1 == P2@l -> P1@l == P3@l.
-Proof.
- intros P2 M1 P3 P4 l; unfold POneSubst.
- generalize (Mphi_ok P2 M1 l); case (MFactor P2 M1); simpl; auto.
- intros Q1 R1; case R1.
-   intros c H; rewrite H.
-   generalize (morph_eq CRmorph c cO);
-        case (c ?=! cO); simpl; auto.
-   intros H1 H2; rewrite H1; auto; rsimpl.
-   discriminate.
-   intros _ H1 H2; injection H1; intros; subst.
-   rewrite H2; rsimpl.
-  rewrite Padd_ok; rewrite Pmul_ok; rsimpl.
-  intros i P5 H; rewrite H.
-   intros HH H1; injection HH; intros; subst; rsimpl.
-   rewrite Padd_ok; rewrite Pmul_ok. rewrite H1; rsimpl.
-   intros i P5 P6 H1 H2 H3; rewrite H1; rewrite H3.
-   injection H2; intros; subst; rsimpl.
-   rewrite Padd_ok.
-   rewrite Pmul_ok; rsimpl.
+ unfold POneSubst.
+ assert (H := Mphi_ok P1). destr_mfactor R1 S1. rewrite H; clear H.
+ intros EQ EQ'. replace P3 with (R1 ++ P2 ** S1).
+ - rewrite EQ', Padd_ok, Pmul_ok; rsimpl.
+ - revert EQ. destruct S1; try now injection 1.
+   case ceqb_spec; now inversion 2.
  Qed.
-*)
- Lemma PNSubst1_ok: forall n P1 M1 P2 l,
-    Mphi l M1 == P2@l -> P1@l == (PNSubst1 P1 M1 P2 n)@l.
+
+ Lemma PNSubst1_ok n P1 M1 P2 l :
+    M1@@l == P2@l -> P1@l == (PNSubst1 P1 M1 P2 n)@l.
  Proof.
- intros n; elim n; simpl; auto.
-   intros P2 M1 P3 l H.
-   generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l);
-   case (POneSubst P2 M1 P3); [idtac | intros; rsimpl].
-   intros P4 Hrec; rewrite (Hrec P4); auto; rsimpl.
- intros n1 Hrec P2 M1 P3 l H.
-   generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l);
-   case (POneSubst P2 M1 P3); [idtac | intros; rsimpl].
-   intros P4 Hrec1; rewrite (Hrec1 P4); auto; rsimpl.
+ revert P1. induction n; simpl; intros P1;
+ generalize (POneSubst_ok P1 M1 P2); destruct POneSubst;
+   intros; rewrite <- ?IHn; auto; reflexivity.
  Qed.
 
- Lemma PNSubst_ok: forall n P1 M1 P2 l P3,
-    PNSubst P1 M1 P2 n = Some P3 -> Mphi l M1 == P2@l -> P1@l == P3@l.
+ Lemma PNSubst_ok n P1 M1 P2 l P3 :
+    PNSubst P1 M1 P2 n = Some P3 -> M1@@l == P2@l -> P1@l == P3@l.
  Proof.
- intros n P2 M1 P3 l P4; unfold PNSubst.
- generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l);
- case (POneSubst P2 M1 P3); [idtac | intros; discriminate].
- intros P5 H1; case n; try (intros; discriminate).
- intros n1 H2; injection H2; intros; subst.
- rewrite <- PNSubst1_ok; auto.
+ unfold PNSubst.
+ assert (H := POneSubst_ok P1 M1 P2); destruct POneSubst; try discriminate.
+ destruct n; inversion_clear 1.
+ intros. rewrite <- PNSubst1_ok; auto.
  Qed.
 
- Fixpoint MPcond (LM1: list (Mon * Pol)) (l: Env R) {struct LM1} : Prop :=
-    match LM1 with
-     cons (M1,P2) LM2 =>  (Mphi l M1 == P2@l) /\ (MPcond LM2 l)
-    | _ => True
-    end.
+ Fixpoint MPcond (LM1: list (Mon * Pol)) (l: Env R) : Prop :=
+   match LM1 with
+   | cons (M1,P2) LM2 => (M1@@l == P2@l) /\ MPcond LM2 l
+   | _ => True
+   end.
 
- Lemma PSubstL1_ok: forall n LM1 P1 l,
-    MPcond LM1 l ->  P1@l == (PSubstL1 P1 LM1 n)@l.
+ Lemma PSubstL1_ok n LM1 P1 l :
+   MPcond LM1 l -> P1@l == (PSubstL1 P1 LM1 n)@l.
  Proof.
- intros n LM1; elim LM1; simpl; auto.
-   intros; rsimpl.
- intros (M2,P2) LM2 Hrec P3 l [H H1].
- rewrite <- Hrec; auto.
- apply PNSubst1_ok; auto.
+ revert P1; induction LM1 as [|(M2,P2) LM2 IH]; simpl; intros.
+ - reflexivity.
+ - rewrite <- IH by intuition. now apply PNSubst1_ok.
  Qed.
 
- Lemma PSubstL_ok: forall n LM1 P1 P2 l,
-   PSubstL P1 LM1 n = Some P2 -> MPcond LM1 l ->  P1@l == P2@l.
+ Lemma PSubstL_ok n LM1 P1 P2 l :
+   PSubstL P1 LM1 n = Some P2 -> MPcond LM1 l -> P1@l == P2@l.
  Proof.
- intros n LM1; elim LM1; simpl; auto.
-   intros; discriminate.
- intros (M2,P2) LM2 Hrec P3 P4 l.
- generalize (PNSubst_ok n P3 M2 P2); case (PNSubst P3 M2 P2 n).
-   intros P5 H0 H1 [H2 H3]; injection H1; intros; subst.
-   rewrite <- PSubstL1_ok; auto.
- intros l1 H [H1 H2]; auto.
+ revert P1. induction LM1 as [|(M2,P2') LM2 IH]; simpl; intros.
+ - discriminate.
+ - assert (H':=PNSubst_ok n P3 M2 P2'). destruct PNSubst.
+   * injection H; intros <-. rewrite <- PSubstL1_ok; intuition.
+   * now apply IH.
  Qed.
 
- Lemma PNSubstL_ok: forall m n LM1 P1 l,
-    MPcond LM1 l ->  P1@l == (PNSubstL P1 LM1 m n)@l.
+ Lemma PNSubstL_ok m n LM1 P1 l :
+    MPcond LM1 l -> P1@l == (PNSubstL P1 LM1 m n)@l.
  Proof.
- intros m; elim m; simpl; auto.
-   intros n LM1 P2 l H; generalize (fun P3 => @PSubstL_ok n LM1 P2 P3 l);
-     case (PSubstL P2 LM1 n); intros; rsimpl; auto.
- intros m1 Hrec n LM1 P2 l H.
- generalize (fun P3 => @PSubstL_ok n LM1 P2 P3 l);
-     case (PSubstL P2 LM1 n); intros; rsimpl; auto.
- rewrite <- Hrec; auto.
+ revert LM1 P1. induction m; simpl; intros;
+ assert (H' := PSubstL_ok n LM1 P2); destruct PSubstL;
+ auto; try reflexivity.
+ rewrite <- IHm; auto.
  Qed.
 
  (** Definition of polynomial expressions *)
@@ -1228,7 +943,7 @@ Proof.
 
  (** evaluation of polynomial expressions towards R *)
 
- Fixpoint PEeval (l:Env R) (pe:PExpr) {struct pe} : R :=
+ Fixpoint PEeval (l:Env R) (pe:PExpr) : R :=
    match pe with
    | PEc c => phi c
    | PEX j => nth j l
@@ -1241,60 +956,23 @@ Proof.
 
  (** Correctness proofs *)
 
- Lemma mkX_ok : forall p l, nth  p l == (mk_X p) @ l.
+ Lemma mkX_ok p l : nth p l == (mk_X p) @ l.
  Proof.
   destruct p;simpl;intros;Esimpl;trivial.
   rewrite nth_spec ; auto.
   unfold hd.
-  rewrite <- nth_Pdouble_minus_one.
-  rewrite (nth_jump (Pdouble_minus_one p) l 1).
-  reflexivity.
+  now rewrite <- nth_pred_double, nth_jump.
  Qed.
 
- Ltac Esimpl3 :=
-  repeat match goal with
-  | |- context [(?P1 ++ ?P2)@?l] => rewrite (Padd_ok P2 P1 l)
-  | |- context [(?P1 -- ?P2)@?l] => rewrite (Psub_ok P2 P1 l)
-  end;Esimpl2;try rrefl;try apply (ARadd_comm ARth).
-
-(* Power using the chinise algorithm *)
-(*Section POWER.
-  Variable subst_l : Pol -> Pol.
-  Fixpoint Ppow_pos (P:Pol) (p:positive){struct p} : Pol :=
-   match p with
-   | xH => P
-   | xO p => subst_l (Psquare (Ppow_pos P p))
-   | xI p => subst_l (Pmul P (Psquare (Ppow_pos P p)))
-   end.
-
-  Definition Ppow_N P n :=
-   match n with
-   | N0 => P1
-   | Npos p => Ppow_pos P p
-   end.
-
-  Lemma Ppow_pos_ok : forall l, (forall P, subst_l P@l == P@l) ->
-         forall P p, (Ppow_pos P p)@l == (pow_pos Pmul P p)@l.
-  Proof.
-   intros l subst_l_ok P.
-   induction p;simpl;intros;try rrefl;try rewrite subst_l_ok.
-   repeat rewrite Pmul_ok;rewrite Psquare_ok;rewrite IHp;rrefl.
-   repeat rewrite Pmul_ok;rewrite Psquare_ok;rewrite IHp;rrefl.
-  Qed.
-
-  Lemma Ppow_N_ok : forall l,  (forall P, subst_l P@l == P@l) ->
-         forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l.
-  Proof.  destruct n;simpl. rrefl. apply Ppow_pos_ok. trivial.  Qed.
-
- End POWER. *)
+ Hint Rewrite Padd_ok Psub_ok : Esimpl.
 
 Section POWER.
   Variable subst_l : Pol -> Pol.
-  Fixpoint Ppow_pos (res P:Pol) (p:positive){struct p} : Pol :=
+  Fixpoint Ppow_pos (res P:Pol) (p:positive) : Pol :=
    match p with
-   | xH => subst_l (Pmul res P)
+   | xH => subst_l (res ** P)
    | xO p => Ppow_pos (Ppow_pos res P p) P p
-   | xI p => subst_l (Pmul  (Ppow_pos (Ppow_pos res P p) P p) P)
+   | xI p => subst_l ((Ppow_pos (Ppow_pos res P p) P p) ** P)
    end.
 
   Definition Ppow_N P n :=
@@ -1303,17 +981,23 @@ Section POWER.
    | Npos p => Ppow_pos P1 P p
    end.
 
-  Lemma Ppow_pos_ok : forall l, (forall P, subst_l P@l == P@l) ->
-         forall res P p, (Ppow_pos res P p)@l == res@l * (pow_pos Pmul P p)@l.
+  Lemma Ppow_pos_ok l :
+    (forall P, subst_l P@l == P@l) ->
+    forall res P p, (Ppow_pos res P p)@l == res@l * (pow_pos Pmul P p)@l.
   Proof.
-   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. mul_push (P@l);rsimpl. rsimpl. rrefl.
+   intros subst_l_ok res P p. revert res.
+   induction p;simpl;intros; rewrite ?subst_l_ok, ?Pmul_ok, ?IHp;
+    mul_permut.
   Qed.
 
-  Lemma Ppow_N_ok : forall l,  (forall P, subst_l P@l == P@l) ->
-         forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l.
-  Proof.  destruct n;simpl. rrefl. rewrite Ppow_pos_ok. trivial. Esimpl.  auto. Qed.
+  Lemma Ppow_N_ok l :
+    (forall P, subst_l P@l == P@l) ->
+    forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l.
+  Proof.
+  destruct n;simpl.
+  - reflexivity.
+  - rewrite Ppow_pos_ok by trivial. Esimpl.
+  Qed.
 
  End POWER.
 
@@ -1342,62 +1026,57 @@ Section POWER.
 
   Definition norm_subst pe := subst_l (norm_aux pe).
 
- (*
-  Fixpoint norm_subst (pe:PExpr) : Pol :=
+  (** Internally, [norm_aux] is expanded in a large number of cases.
+      To speed-up proofs, we use an alternative definition. *)
+
+  Definition get_PEopp pe :=
    match pe with
-   | PEc c => Pc c
-   | PEX j => subst_l (mk_X j)
-   | PEadd (PEopp pe1) pe2 => Psub (norm_subst pe2) (norm_subst pe1)
-   | PEadd pe1 (PEopp pe2) =>
-     Psub (norm_subst pe1) (norm_subst pe2)
-   | PEadd pe1 pe2 => Padd (norm_subst  pe1) (norm_subst pe2)
-   | PEsub pe1 pe2 => Psub (norm_subst pe1) (norm_subst pe2)
-   | PEmul pe1 pe2 => Pmul_subst (norm_subst pe1) (norm_subst pe2)
-   | PEopp pe1 => Popp (norm_subst pe1)
-   | PEpow pe1 n => Ppow_subst (norm_subst pe1) n
+   | PEopp pe' => Some pe'
+   | _ => None
    end.
 
-  Lemma norm_subst_spec :
-     forall l pe, MPcond lmp l ->
-       PEeval l pe == (norm_subst pe)@l.
+  Lemma norm_aux_PEadd pe1 pe2 :
+    norm_aux (PEadd pe1 pe2) =
+    match get_PEopp pe1, get_PEopp pe2 with
+    | Some pe1', _ => (norm_aux pe2) -- (norm_aux pe1')
+    | None, Some pe2' => (norm_aux pe1) -- (norm_aux pe2')
+    | None, None => (norm_aux pe1) ++ (norm_aux pe2)
+    end.
   Proof.
-   intros;assert (subst_l_ok:forall P, (subst_l P)@l == P@l).
-      unfold subst_l;intros.
-      rewrite <- PNSubstL_ok;trivial. rrefl.
-   assert (Pms_ok:forall P1 P2, (Pmul_subst P1 P2)@l == P1@l*P2@l).
-    intros;unfold Pmul_subst;rewrite subst_l_ok;rewrite Pmul_ok;rrefl.
-   induction pe;simpl;Esimpl3.
-   rewrite subst_l_ok;apply mkX_ok.
-   rewrite IHpe1;rewrite IHpe2;destruct pe1;destruct pe2;Esimpl3.
-   rewrite IHpe1;rewrite IHpe2;rrefl.
-   rewrite Pms_ok;rewrite IHpe1;rewrite IHpe2;rrefl.
-   rewrite IHpe;rrefl.
-   unfold Ppow_subst. rewrite Ppow_N_ok. trivial.
-   rewrite pow_th.(rpow_pow_N). destruct n0;Esimpl3.
-   induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok;
-      repeat rewrite Pmul_ok;rrefl.
+  simpl (norm_aux (PEadd _ _)).
+  destruct pe1; [ | | | | | reflexivity | ];
+   destruct pe2; simpl get_PEopp; reflexivity.
   Qed.
-*)
- Lemma norm_aux_spec :
-     forall l pe, (*MPcond lmp l ->*)
-       PEeval l pe == (norm_aux pe)@l.
+
+  Lemma norm_aux_PEopp pe :
+    match get_PEopp pe with
+    | Some pe' => norm_aux pe = -- (norm_aux pe')
+    | None => True
+    end.
   Proof.
-   intros.
-   induction pe;simpl;Esimpl3.
-   apply mkX_ok.
-   rewrite IHpe1;rewrite IHpe2;destruct pe1;destruct pe2;Esimpl3.
-   rewrite IHpe1;rewrite IHpe2;rrefl.
-   rewrite IHpe1;rewrite IHpe2. rewrite Pmul_ok. rrefl.
-   rewrite IHpe;rrefl.
-   rewrite Ppow_N_ok by reflexivity.
-   rewrite pow_th.(rpow_pow_N). destruct n0;Esimpl3.
-   induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok;
-      repeat rewrite Pmul_ok;rrefl.
+  now destruct pe.
   Qed.
 
+  Lemma norm_aux_spec l pe :
+    PEeval l pe == (norm_aux pe)@l.
+  Proof.
+   intros.
+   induction pe.
+   - reflexivity.
+   - apply mkX_ok.
+   - simpl PEeval. rewrite IHpe1, IHpe2.
+     assert (H1 := norm_aux_PEopp pe1).
+     assert (H2 := norm_aux_PEopp pe2).
+     rewrite norm_aux_PEadd.
+     do 2 destruct get_PEopp; rewrite ?H1, ?H2; Esimpl; add_permut.
+   - simpl. rewrite IHpe1, IHpe2. Esimpl.
+   - simpl. rewrite IHpe1, IHpe2. now rewrite Pmul_ok.
+   - simpl. rewrite IHpe. Esimpl.
+   - simpl. rewrite Ppow_N_ok by reflexivity.
+     rewrite pow_th.(rpow_pow_N). destruct n0; simpl; Esimpl.
+     induction p;simpl; now rewrite ?IHp, ?IHpe, ?Pms_ok, ?Pmul_ok.
+  Qed.
 
  End NORM_SUBST_REC.
 
-
 End MakeRingPol.
-
diff --git a/plugins/micromega/MExtraction.v b/plugins/micromega/MExtraction.v
index 5afe7e37..64181cde 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-2012     *)
 (*   \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..b260feab 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-2012     *)
 (*   \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..bcf84c6b 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-2012     *)
 (*   \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 Z.succ in * ;
+  (*cbv delta - [Z.add Z.sub Z.opp Z.mul Z.pow Z.gt Z.ge Z.le Z.lt iff not] ;*) xlia ;
   intros __wit __varmap __ff ;
     change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ;
       apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity.
 
+Ltac nia :=
+  zify ; unfold Z.succ in * ;
+  xnlia ;
+  intros __wit __varmap __ff ;
+    change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ;
+      apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity.
+
+
 (* Local Variables: *)
 (* coding: utf-8 *)
 (* End: *)
diff --git a/plugins/micromega/QMicromega.v b/plugins/micromega/QMicromega.v
index 5ff6a1a7..792e2c3c 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -60,7 +60,7 @@ Proof.
 Qed.
 
 
-(*Definition Zeval_expr :=  eval_pexpr 0 Zplus Zmult Zminus Zopp  (fun x => x) (fun x => Z_of_N x) (Zpower).*)
+(*Definition Zeval_expr :=  eval_pexpr 0 Z.add Z.mul Z.sub Z.opp  (fun x => x) (fun x => Z.of_N x) (Z.pow).*)
 Require Import EnvRing.
 
 Fixpoint Qeval_expr (env: PolEnv Q) (e: PExpr Q) : Q :=
@@ -71,7 +71,7 @@ Fixpoint Qeval_expr (env: PolEnv Q) (e: PExpr Q) : Q :=
     | PEsub pe1 pe2 => (Qeval_expr env pe1) - (Qeval_expr env pe2)
     | PEmul pe1 pe2 => (Qeval_expr env pe1) * (Qeval_expr env pe2)
     | PEopp pe1 => - (Qeval_expr env pe1)
-    | PEpow pe1 n => Qpower (Qeval_expr env pe1)  (Z_of_N n)
+    | PEpow pe1 n => Qpower (Qeval_expr env pe1)  (Z.of_N n)
   end.
 
 Lemma Qeval_expr_simpl : forall env e,
@@ -83,7 +83,7 @@ Lemma Qeval_expr_simpl : forall env e,
     | PEsub pe1 pe2 => (Qeval_expr env pe1) - (Qeval_expr env pe2)
     | PEmul pe1 pe2 => (Qeval_expr env pe1) * (Qeval_expr env pe2)
     | PEopp pe1 => - (Qeval_expr env pe1)
-    | PEpow pe1 n => Qpower (Qeval_expr env pe1)  (Z_of_N n)
+    | PEpow pe1 n => Qpower (Qeval_expr env pe1)  (Z.of_N n)
   end.
 Proof.
   destruct e ; reflexivity.
@@ -91,7 +91,7 @@ Qed.
 
 Definition Qeval_expr' := eval_pexpr  Qplus Qmult Qminus Qopp (fun x => x) (fun x => x) (pow_N 1 Qmult).
 
-Lemma QNpower : forall r n, r ^ Z_of_N n = pow_N 1 Qmult r n.
+Lemma QNpower : forall r n, r ^ Z.of_N n = pow_N 1 Qmult r n.
 Proof.
   destruct n ; reflexivity.
 Qed.
@@ -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..d6f67485 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-2012     *)
 (*   \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 (Pos.to_nat ?X)] |- _ =>
+      revert H ; 
+      let HH := fresh in
+        assert (HH := pos_INR_nat_of_P X) ; revert HH ; generalize (INR (Pos.to_nat X))
+    | |- context[INR (Pos.to_nat ?X)] =>
+      let HH := fresh in
+        assert (HH := pos_INR_nat_of_P X) ; revert HH ; generalize (INR (Pos.to_nat X))
+  end.
+
+Ltac add_eq expr val := set (temp := expr) ; 
+  generalize (eq_refl 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 Pos2Nat.inj_mul.
+  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 Pos2Nat.inj_mul.
+  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 Pos.mul_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 Z.opp_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 Z.mul_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.
+
+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 N.to_nat 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 N.to_nat pow R_of_Rcst.
+
+Definition QReval_formula := 
+  eval_formula  Rplus Rmult Rminus Ropp (@eq R) Rle Rlt IQR N.to_nat 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..43bfb4d7 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-2012     *)
 (*   \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..fccacc74 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -142,7 +142,7 @@ Qed.
 Definition PolC := Pol C. (* polynomials in generalized Horner form, defined in Ring_polynom or EnvRing *)
 Definition PolEnv := Env R. (* For interpreting PolC *)
 Definition eval_pol (env : PolEnv) (p:PolC) : R :=
-   Pphi 0 rplus rtimes phi env p.
+   Pphi rplus rtimes phi env p.
 
 Inductive Op1 : Set := (* relations with 0 *)
 | Equal (* == 0 *)
@@ -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,9 +318,9 @@ 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
+Definition Rops_wd := mk_reqe (*rplus rtimes ropp req*)
                        sor.(SORplus_wd)
                        sor.(SORtimes_wd)
                        sor.(SORopp_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'.
@@ -468,17 +469,11 @@ Fixpoint ge_bool (n m  : nat) : bool :=
              end
    end.
 
-Lemma ge_bool_cases : forall n m, (if ge_bool n m then n >= m else n < m)%nat.
+Lemma ge_bool_cases : forall n m,
+ (if ge_bool n m then n >= m else n < m)%nat.
 Proof.
-  induction n ; simpl.
-  destruct m ; simpl.
-  constructor.
-  omega.
-  destruct m.
-  constructor.
-  omega.
-  generalize (IHn m).
-  destruct (ge_bool n m) ; omega.
+  induction n; destruct m ; simpl; auto with arith.
+  specialize (IHn m). destruct (ge_bool); auto with arith.
 Qed.
 
 
@@ -490,6 +485,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) *)
@@ -499,7 +587,7 @@ Definition paddC := PaddC cplus.
 Definition psubC := PsubC cminus.
 
 Definition PsubC_ok : forall c P env, eval_pol env (psubC  P c) == eval_pol env P - [c] :=
-  let Rops_wd := mk_reqe rplus rtimes ropp req
+  let Rops_wd := mk_reqe (*rplus rtimes ropp req*)
                        sor.(SORplus_wd)
                        sor.(SORtimes_wd)
                        sor.(SORopp_wd) in
@@ -507,7 +595,7 @@ Definition PsubC_ok : forall c P env, eval_pol env (psubC  P c) == eval_pol env
                 addon.(SORrm).
 
 Definition PaddC_ok : forall c P env, eval_pol env (paddC  P c) == eval_pol env P + [c] :=
-  let Rops_wd := mk_reqe rplus rtimes ropp req
+  let Rops_wd := mk_reqe (*rplus rtimes ropp req*)
                        sor.(SORplus_wd)
                        sor.(SORtimes_wd)
                        sor.(SORopp_wd) in
@@ -546,6 +634,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 +681,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 +700,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 +713,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 +749,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 +763,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 +777,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 +795,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 +820,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 +833,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);
@@ -786,13 +876,14 @@ Qed.
 Fixpoint xdenorm (jmp : positive) (p: Pol C) : PExpr C :=
   match p with
     | Pc c => PEc c
-    | Pinj j p => xdenorm  (Pplus j jmp ) p
+    | Pinj j p => xdenorm  (Pos.add j jmp ) p
     | PX p j q   => PEadd
       (PEmul (xdenorm jmp p) (PEpow (PEX _  jmp) (Npos j)))
-      (xdenorm (Psucc jmp) q)
+      (xdenorm (Pos.succ jmp) q)
   end.
 
-Lemma xdenorm_correct : forall p i  env, eval_pol (jump i env)  p == eval_pexpr env (xdenorm (Psucc i) p).
+Lemma xdenorm_correct : forall p i env,
+  eval_pol (jump i env) p == eval_pexpr env (xdenorm (Pos.succ i) p).
 Proof.
   unfold eval_pol.
   induction p.
@@ -800,22 +891,21 @@ Proof.
   (* Pinj *)
   simpl.
   intros.
-  rewrite Pplus_succ_permute_r.
+  rewrite Pos.add_succ_r.
   rewrite <- IHp.
   symmetry.
-  rewrite Pplus_comm.
-  rewrite Pjump_Pplus. reflexivity.
+  rewrite Pos.add_comm.
+  rewrite Pjump_add. reflexivity.
   (* PX *)
   simpl.
   intros.
-  rewrite <- IHp1.
-  rewrite <- IHp2.
+  rewrite <- IHp1, <- IHp2.
   unfold Env.tail , Env.hd.
-  rewrite <- Pjump_Pplus.
-  rewrite <- Pplus_one_succ_r.
+  rewrite <- Pjump_add.
+  rewrite Pos.add_1_r.
   unfold Env.nth.
   unfold jump at 2.
-  rewrite Pplus_one_succ_l.
+  rewrite <- Pos.add_1_l.
   rewrite addon.(SORpower).(rpow_pow_N).
   unfold pow_N. ring.
 Qed.
@@ -828,19 +918,76 @@ Proof.
   induction p.
   reflexivity.
   simpl.
-  rewrite <- Pplus_one_succ_r.
+  rewrite Pos.add_1_r.
   apply xdenorm_correct.
   simpl.
   intros.
   rewrite IHp1.
   unfold Env.tail.
   rewrite xdenorm_correct.
-  change (Psucc xH) with 2%positive.
+  change (Pos.succ xH) with 2%positive.
   rewrite addon.(SORpower).(rpow_pow_N).
   simpl. reflexivity.
 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 +1028,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..440070a1 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-2012     *)
 (*   \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..9ff8044e 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-2012     *)
 (*   \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..e30295e6 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -109,7 +109,7 @@ Qed.
 
 Lemma Zring_morph :
   ring_morph 0 1 rplus rtimes rminus ropp req
-             0%Z 1%Z Zplus Zmult Zminus Zopp
+             0%Z 1%Z Z.add Z.mul Z.sub Z.opp
              Zeq_bool gen_order_phi_Z.
 Proof.
 exact (gen_phiZ_morph sor.(SORsetoid) ring_ops_wd sor.(SORrt)).
@@ -122,7 +122,7 @@ try apply (Rplus_pos_pos sor); try apply (Rtimes_pos_pos sor); try apply (Rplus_
 try apply (Rlt_0_1 sor); assumption.
 Qed.
 
-Lemma phi_pos1_succ : forall x : positive, phi_pos1 (Psucc x) == 1 + phi_pos1 x.
+Lemma phi_pos1_succ : forall x : positive, phi_pos1 (Pos.succ x) == 1 + phi_pos1 x.
 Proof.
 exact (ARgen_phiPOS_Psucc sor.(SORsetoid) ring_ops_wd
         (Rth_ARth sor.(SORsetoid) ring_ops_wd sor.(SORrt))).
@@ -130,7 +130,7 @@ Qed.
 
 Lemma clt_pos_morph : forall x y : positive, (x < y)%positive -> phi_pos1 x < phi_pos1 y.
 Proof.
-intros x y H. pattern y; apply Plt_ind with x.
+intros x y H. pattern y; apply Pos.lt_ind with x.
 rewrite phi_pos1_succ; apply (Rlt_succ_r sor).
 clear y H; intros y _ H. rewrite phi_pos1_succ. now apply (Rlt_lt_succ sor).
 assumption.
@@ -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,13 +146,13 @@ 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].
+Lemma Zcleb_morph : forall x y : Z, Z.leb x y = true -> [x] <= [y].
 Proof.
-unfold Zle_bool; intros x y H.
+unfold Z.leb; intros x y H.
 case_eq (x ?= y)%Z; intro H1; rewrite H1 in H.
 le_equal. apply Zring_morph.(morph_eq). unfold Zeq_bool; now rewrite H1.
 le_less. now apply clt_morph.
@@ -162,9 +162,9 @@ Qed.
 Lemma Zcneqb_morph : forall x y : Z, Zeq_bool x y = false -> [x] ~= [y].
 Proof.
 intros x y H. unfold Zeq_bool in H.
-case_eq (Zcompare x y); intro H1; rewrite H1 in *; (discriminate || clear H).
+case_eq (Z.compare x y); intro H1; rewrite H1 in *; (discriminate || clear H).
 apply (Rlt_neq sor). now apply clt_morph.
-fold (x > y)%Z in H1. rewrite Zgt_iff_lt in H1.
+fold (x > y)%Z in H1. rewrite Z.gt_lt_iff in H1.
 apply (Rneq_symm sor). apply (Rlt_neq sor). now apply clt_morph.
 Qed.
 
diff --git a/plugins/micromega/ZMicromega.v b/plugins/micromega/ZMicromega.v
index d6245681..bdc4671d 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-2012     *)
 (*   \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                             *)
 (*                                                                      *)
 (************************************************************************)
 
@@ -34,20 +34,20 @@ Require Import EnvRing.
 
 Open Scope Z_scope.
 
-Lemma Zsor : SOR 0 1 Zplus Zmult Zminus Zopp (@eq Z) Zle Zlt.
+Lemma Zsor : SOR 0 1 Z.add Z.mul Z.sub Z.opp (@eq Z) Z.le Z.lt.
 Proof.
   constructor ; intros ; subst ; try (intuition (auto  with zarith)).
   apply Zsth.
   apply Zth.
-  destruct (Ztrichotomy n m) ; intuition (auto with zarith).
-  apply Zmult_lt_0_compat ; auto.
+  destruct (Z.lt_trichotomy n m) ; intuition.
+  apply Z.mul_pos_pos ; auto.
 Qed.
 
 Lemma ZSORaddon :
-  SORaddon 0 1 Zplus Zmult Zminus Zopp  (@eq Z) Zle (* ring elements *)
-  0%Z 1%Z Zplus Zmult Zminus Zopp (* coefficients *)
-  Zeq_bool Zle_bool
-  (fun x => x) (fun x => x) (pow_N 1 Zmult).
+  SORaddon 0 1 Z.add Z.mul Z.sub Z.opp  (@eq Z) Z.le (* ring elements *)
+  0%Z 1%Z Z.add Z.mul Z.sub Z.opp (* coefficients *)
+  Zeq_bool Z.leb
+  (fun x => x) (fun x => x) (pow_N 1 Z.mul).
 Proof.
   constructor.
   constructor ; intros ; try reflexivity.
@@ -65,20 +65,20 @@ Fixpoint Zeval_expr (env : PolEnv Z) (e: PExpr Z) : Z :=
     | PEX x => env x
     | PEadd e1 e2 => Zeval_expr env e1 + Zeval_expr env e2
     | PEmul e1 e2 => Zeval_expr env e1 * Zeval_expr env e2
-    | PEpow e1 n  => Zpower (Zeval_expr env e1) (Z_of_N n)
+    | PEpow e1 n  => Z.pow (Zeval_expr env e1) (Z.of_N n)
     | PEsub e1 e2 => (Zeval_expr env e1) - (Zeval_expr env e2)
-    | PEopp e   => Zopp (Zeval_expr env e)
+    | PEopp e   => Z.opp (Zeval_expr env e)
   end.
 
-Definition eval_expr := eval_pexpr  Zplus Zmult Zminus Zopp (fun x => x) (fun x => x) (pow_N 1 Zmult).
+Definition eval_expr := eval_pexpr  Z.add Z.mul Z.sub Z.opp (fun x => x) (fun x => x) (pow_N 1 Z.mul).
 
-Lemma ZNpower : forall r n, r ^ Z_of_N n = pow_N 1 Zmult r n.
+Lemma ZNpower : forall r n, r ^ Z.of_N n = pow_N 1 Z.mul r n.
 Proof.
   destruct n.
   reflexivity.
   simpl.
-  unfold Zpower_pos.
-  replace (pow_pos Zmult r p) with (1 * (pow_pos Zmult r p)) by ring.
+  unfold Z.pow_pos.
+  replace (pow_pos Z.mul r p) with (1 * (pow_pos Z.mul r p)) by ring.
   generalize 1.
   induction p; simpl ; intros ; repeat rewrite IHp ; ring.
 Qed.
@@ -94,10 +94,10 @@ Definition Zeval_op2 (o : Op2) : Z -> Z -> Prop :=
 match o with
 | OpEq =>  @eq Z
 | OpNEq => fun x y  => ~ x = y
-| OpLe => Zle
-| OpGe => Zge
-| OpLt => Zlt
-| OpGt => Zgt
+| OpLe => Z.le
+| OpGe => Z.ge
+| OpLt => Z.lt
+| OpGt => Z.gt
 end.
 
 Definition Zeval_formula (env : PolEnv Z) (f : Formula Z):=
@@ -105,23 +105,23 @@ Definition Zeval_formula (env : PolEnv Z) (f : Formula Z):=
     (Zeval_op2 op) (Zeval_expr env lhs) (Zeval_expr env rhs).
 
 Definition Zeval_formula' :=
-  eval_formula  Zplus Zmult Zminus Zopp (@eq Z) Zle Zlt (fun x => x) (fun x => x) (pow_N 1 Zmult).
+  eval_formula  Z.add Z.mul Z.sub Z.opp (@eq Z) Z.le Z.lt (fun x => x) (fun x => x) (pow_N 1 Z.mul).
 
 Lemma Zeval_formula_compat : forall env f, Zeval_formula env f <-> Zeval_formula' env f.
 Proof.
   destruct f ; simpl.
   rewrite Zeval_expr_compat. rewrite Zeval_expr_compat.
   unfold eval_expr.
-  generalize (eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x)
-        (fun x : N => x) (pow_N 1 Zmult) env Flhs).
-  generalize ((eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x)
-        (fun x : N => x) (pow_N 1 Zmult) env Frhs)).
+  generalize (eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x)
+        (fun x : N => x) (pow_N 1 Z.mul) env Flhs).
+  generalize ((eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x)
+        (fun x : N => x) (pow_N 1 Z.mul) env Frhs)).
   destruct Fop ; simpl; intros ; intuition (auto with zarith).
 Qed.
 
 
 Definition eval_nformula :=
-  eval_nformula 0 Zplus Zmult  (@eq Z) Zle Zlt (fun x => x) .
+  eval_nformula 0 Z.add Z.mul  (@eq Z) Z.le Z.lt (fun x => x) .
 
 Definition Zeval_op1 (o : Op1) : Z -> Prop :=
 match o with
@@ -140,7 +140,7 @@ Qed.
 
 Definition ZWitness := Psatz Z.
 
-Definition ZWeakChecker := check_normalised_formulas 0 1 Zplus Zmult Zeq_bool Zle_bool.
+Definition ZWeakChecker := check_normalised_formulas 0 1 Z.add Z.mul Zeq_bool Z.leb.
 
 Lemma ZWeakChecker_sound :   forall (l : list (NFormula Z)) (cm : ZWitness),
   ZWeakChecker l cm = true ->
@@ -154,13 +154,13 @@ Proof.
   exact H.
 Qed.
 
-Definition psub  := psub Z0  Zplus Zminus Zopp Zeq_bool.
+Definition psub  := psub Z0  Z.add Z.sub Z.opp Zeq_bool.
 
-Definition padd  := padd Z0  Zplus Zeq_bool.
+Definition padd  := padd Z0  Z.add Zeq_bool.
 
-Definition norm  := norm 0 1 Zplus Zmult Zminus Zopp Zeq_bool.
+Definition norm  := norm 0 1 Z.add Z.mul Z.sub Z.opp Zeq_bool.
 
-Definition eval_pol := eval_pol 0  Zplus Zmult (fun x => x).
+Definition eval_pol := eval_pol Z.add Z.mul (fun x => x).
 
 Lemma eval_pol_sub : forall env lhs rhs, eval_pol env (psub  lhs rhs) = eval_pol env lhs - eval_pol env rhs.
 Proof.
@@ -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);
-  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;
+  generalize (   eval_pexpr  Z.add Z.mul Z.sub Z.opp (fun x : Z => x)
+    (fun x : N => x) (pow_N 1 Z.mul) env lhs);
+  generalize (eval_pexpr  Z.add Z.mul Z.sub Z.opp (fun x : Z => x)
+    (fun x : N => x) (pow_N 1 Z.mul) env rhs) ; intros z1 z2 ; intros ; subst;
     intuition (auto with zarith).
   Transparent padd.
 Qed.
@@ -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);
-  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;
+  generalize (   eval_pexpr  Z.add Z.mul Z.sub Z.opp (fun x : Z => x)
+    (fun x : N => x) (pow_N 1 Z.mul) env lhs);
+  generalize (eval_pexpr  Z.add Z.mul Z.sub Z.opp (fun x : Z => x)
+    (fun x : N => x) (pow_N 1 Z.mul) env rhs) ; intros z1 z2 ; intros ; subst;
     intuition (auto with zarith).
   Transparent padd.
 Qed.
 
+Definition Zunsat := check_inconsistent 0  Zeq_bool Z.leb.
+
+Definition Zdeduce := nformula_plus_nformula 0 Z.add 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 *)
 
@@ -267,36 +270,47 @@ Require Import Zdiv.
 Open Scope Z_scope.
 
 Definition ceiling (a b:Z) : Z :=
-  let (q,r) := Zdiv_eucl a b in
+  let (q,r) := Z.div_eucl a b in
     match r with
       | Z0 => q
       | _  => q + 1
     end.
 
-Lemma narrow_interval_lower_bound : forall a b x, a > 0 -> a * x  >= b -> x >= ceiling b a.
+
+Require Import Znumtheory.
+
+Lemma Zdivide_ceiling : forall a b, (b | a) -> ceiling a b = Z.div a b.
 Proof.
   unfold ceiling.
   intros.
-  generalize (Z_div_mod b a H).
-  destruct (Zdiv_eucl b a).
+  apply Zdivide_mod in H.
+  case_eq (Z.div_eucl a b).
   intros.
-  destruct H1.
-  destruct H2.
-  subst.
-  destruct (Ztrichotomy z0 0) as [ HH1 | [HH2 | HH3]]; destruct z0 ; try auto with zarith ; try discriminate.
-  assert (HH :x >= z \/ x < z) by (destruct (Ztrichotomy x z) ; auto with zarith).
-  destruct HH ;auto.
-  generalize (Zmult_lt_compat_l _ _ _ H3 H1).
-  auto with zarith.
-  clear H2.
-  assert (HH :x >= z +1 \/ x <= z) by (destruct (Ztrichotomy x z) ; intuition (auto with zarith)).
-  destruct HH ;auto.
-  assert (0 < a) by auto with zarith.
-  generalize (Zmult_lt_0_le_compat_r _ _ _ H2 H1).
-  intros.
-  rewrite Zmult_comm  in H4.
-  rewrite (Zmult_comm z)  in H4.
-  auto with zarith.
+  change z with (fst (z,z0)).
+  rewrite <- H0.
+  change (fst (Z.div_eucl a b)) with (Z.div a b).
+  change z0 with (snd (z,z0)).
+  rewrite <- H0.
+  change (snd (Z.div_eucl a b)) with (Z.modulo a b).
+  rewrite H.
+  reflexivity.
+Qed.
+
+Lemma narrow_interval_lower_bound a b x :
+  a > 0 -> a * x  >= b -> x >= ceiling b a.
+Proof.
+  rewrite !Z.ge_le_iff.
+  unfold ceiling.
+  intros Ha H.
+  generalize (Z_div_mod b a Ha).
+  destruct (Z.div_eucl b a) as (q,r). intros (->,(H1,H2)).
+  destruct r as [|r|r].
+  - rewrite Z.add_0_r in H.
+    apply Z.mul_le_mono_pos_l in H; auto with zarith.
+  - assert (0 < Z.pos r) by easy.
+    rewrite Z.add_1_r, Z.le_succ_l.
+    apply Z.mul_lt_mono_pos_l with a; auto with zarith.
+  - now elim H1.
 Qed.
 
 (** NB: narrow_interval_upper_bound is Zdiv.Zdiv_le_lower_bound *)
@@ -307,40 +321,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).
-
-(* 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).
+| EnumProof : ZWitness -> ZWitness -> list ZArithProof -> ZArithProof
+(*| SplitProof :   PolC Z -> ZArithProof -> ZArithProof -> ZArithProof*).
 
-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
@@ -364,7 +351,7 @@ Proof.
   destruct x ; simpl ; intuition congruence.
 Qed.
 
-Definition ZgcdM (x y : Z) := Zmax (Zgcd x y) 1.
+Definition ZgcdM (x y : Z) := Z.max (Z.gcd x y) 1.
 
 
 Fixpoint Zgcd_pol (p : PolC Z) : (Z * Z) :=
@@ -382,7 +369,7 @@ Fixpoint Zgcd_pol (p : PolC Z) : (Z * Z) :=
 
 Fixpoint Zdiv_pol (p:PolC Z) (x:Z) : PolC Z :=
   match p with
-    | Pc c => Pc (Zdiv c x)
+    | Pc c => Pc (Z.div c x)
     | Pinj j p => Pinj j (Zdiv_pol p x)
     | PX p j q => PX (Zdiv_pol p x) j (Zdiv_pol q x)
   end.
@@ -425,10 +412,10 @@ Proof.
   intros.
   simpl.
   unfold ZgcdM.
-  generalize (Zgcd_is_pos z1 z2).
-  generalize (Zmax_spec (Zgcd z1 z2) 1).
-  generalize (Zgcd_is_pos (Zmax (Zgcd z1 z2) 1) z).
-  generalize (Zmax_spec (Zgcd (Zmax (Zgcd z1 z2) 1) z) 1).
+  generalize (Z.gcd_nonneg z1 z2).
+  generalize (Zmax_spec (Z.gcd z1 z2) 1).
+  generalize (Z.gcd_nonneg (Z.max (Z.gcd z1 z2) 1) z).
+  generalize (Zmax_spec (Z.gcd (Z.max (Z.gcd z1 z2) 1) z) 1).
   auto with zarith.
 Qed.
 
@@ -437,7 +424,7 @@ Proof.
   intros.
   induction H.
   constructor.
-  apply Zdivide_trans with (1:= H0) ; assumption.
+  apply Z.divide_trans with (1:= H0) ; assumption.
   constructor. auto.
   constructor ; auto.
 Qed.
@@ -448,20 +435,20 @@ Proof.
   exists c. ring.
 Qed.
 
-Lemma Zgcd_minus : forall a b c, (a | c - b ) -> (Zgcd a b | c).
+Lemma Zgcd_minus : forall a b c, (a | c - b ) -> (Z.gcd a b | c).
 Proof.
   intros a b c (q,Hq).
   destruct (Zgcd_is_gcd a b) as [(a',Ha) (b',Hb) _].
-  set (g:=Zgcd a b) in *; clearbody g.
+  set (g:=Z.gcd a b) in *; clearbody g.
   exists (q * a' + b').
-  symmetry in Hq. rewrite <- Zeq_plus_swap in Hq.
+  symmetry in Hq. rewrite <- Z.add_move_r in Hq.
   rewrite <- Hq, Hb, Ha. ring.
 Qed.
 
 Lemma Zdivide_pol_sub : forall p a b,
-  0 < Zgcd a b ->
-  Zdivide_pol a (PsubC Zminus p b) ->
-   Zdivide_pol (Zgcd a b) p.
+  0 < Z.gcd a b ->
+  Zdivide_pol a (PsubC Z.sub p b) ->
+   Zdivide_pol (Z.gcd a b) p.
 Proof.
   induction p.
   simpl.
@@ -481,7 +468,7 @@ Proof.
 Qed.
 
 Lemma Zdivide_pol_sub_0 : forall p a,
-  Zdivide_pol a (PsubC Zminus p 0) ->
+  Zdivide_pol a (PsubC Z.sub p 0) ->
    Zdivide_pol a p.
 Proof.
   induction p.
@@ -500,7 +487,7 @@ Qed.
 
 
 Lemma Zgcd_pol_div : forall p g c,
-  Zgcd_pol p = (g, c) -> Zdivide_pol g (PsubC Zminus p c).
+  Zgcd_pol p = (g, c) -> Zdivide_pol g (PsubC Z.sub p c).
 Proof.
   induction p ; simpl.
   (* Pc *)
@@ -515,12 +502,12 @@ Proof.
   case_eq (Zgcd_pol p1) ; case_eq (Zgcd_pol p3) ; intros.
   inv H1.
   unfold ZgcdM at 1.
-  destruct (Zmax_spec (Zgcd (ZgcdM z1 z2) z) 1) as [HH1 | HH1];
+  destruct (Zmax_spec (Z.gcd (ZgcdM z1 z2) z) 1) as [HH1 | HH1];
   destruct HH1 as [HH1 HH1'] ; rewrite HH1'.
   constructor.
   apply Zdivide_pol_Zdivide with (x:= ZgcdM z1 z2).
   unfold ZgcdM.
-  destruct (Zmax_spec  (Zgcd z1 z2)  1) as [HH2 | HH2].
+  destruct (Zmax_spec  (Z.gcd z1 z2)  1) as [HH2 | HH2].
   destruct HH2.
   rewrite H2.
   apply Zdivide_pol_sub ; auto.
@@ -528,9 +515,9 @@ Proof.
   destruct HH2. rewrite H2.
   apply Zdivide_pol_one.
   unfold ZgcdM in HH1. unfold ZgcdM.
-  destruct (Zmax_spec  (Zgcd z1 z2)  1) as [HH2 | HH2].
+  destruct (Zmax_spec  (Z.gcd z1 z2)  1) as [HH2 | HH2].
   destruct HH2. rewrite H2 in *.
-  destruct (Zgcd_is_gcd (Zgcd z1 z2) z); auto.
+  destruct (Zgcd_is_gcd (Z.gcd z1 z2) z); auto.
   destruct HH2. rewrite H2.
   destruct (Zgcd_is_gcd 1  z); auto.
   apply Zdivide_pol_Zdivide with (x:= z).
@@ -543,7 +530,7 @@ Qed.
 
 
 
-Lemma Zgcd_pol_correct_lt : forall p env g c, Zgcd_pol p = (g,c) -> 0 < g -> eval_pol env p = g * (eval_pol env (Zdiv_pol (PsubC Zminus p c) g))  + c.
+Lemma Zgcd_pol_correct_lt : forall p env g c, Zgcd_pol p = (g,c) -> 0 < g -> eval_pol env p = g * (eval_pol env (Zdiv_pol (PsubC Z.sub p c) g))  + c.
 Proof.
   intros.
   rewrite <- Zdiv_pol_correct ; auto.
@@ -557,8 +544,8 @@ Qed.
 
 Definition makeCuttingPlane (p : PolC Z) : PolC  Z * Z :=
   let (g,c) := Zgcd_pol p in
-    if Zgt_bool g Z0
-      then (Zdiv_pol (PsubC Zminus p c) g , Zopp (ceiling (Zopp c) g))
+    if Z.gtb g Z0
+      then (Zdiv_pol (PsubC Z.sub p c) g , Z.opp (ceiling (Z.opp c) g))
       else (p,Z0).
 
 
@@ -566,11 +553,13 @@ 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 (Z.gtb g Z0) (andb (negb (Zeq_bool c Z0)) (negb (Zeq_bool (Z.gcd 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
+      | Strict   =>  let (p,c) := makeCuttingPlane (PsubC Z.sub e 1) in
         Some (p,c,NonStrict)
       | NonStrict => let (p,c) := makeCuttingPlane e  in
         Some (p,c,NonStrict)
@@ -596,16 +585,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.
+  eval_Psatz 0 1 Z.add Z.mul Zeq_bool Z.leb.
 
 
+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 +603,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 +616,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 Z.gtb lb ub then true else false
+                       | pf::rsr => andb (ZChecker  ((psub e1 (Pc lb), Equal) :: l) pf) (label rsr (Z.add lb 1%Z) ub)
+                     end)   pf (Z.opp z1)  z2
+                  else false
+              |   _    ,   _   => true
+           end
+          |   _   ,  _ => false
+    end
+end.
 
 
 
@@ -702,7 +686,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)).
@@ -717,19 +701,18 @@ Proof.
   unfold makeCuttingPlane in H0.
   revert H0.
   case_eq (Zgcd_pol e) ; intros g c0.
-  generalize (Zgt_cases g 0) ; destruct (Zgt_bool g 0).
+  generalize (Zgt_cases g 0) ; destruct (Z.gtb g 0).
   intros.
   inv H2.
-  change (RingMicromega.eval_pol 0 Zplus Zmult (fun x : Z => x)) with eval_pol in *.
+  change (RingMicromega.eval_pol Z.add Z.mul (fun x : Z => x)) with eval_pol in *.
   apply Zgcd_pol_correct_lt with (env:=env) in H1.
-  generalize (narrow_interval_lower_bound g (- c0) (eval_pol env (Zdiv_pol (PsubC Zminus e c0) g)) H0).
+  generalize (narrow_interval_lower_bound g (- c0) (eval_pol env (Zdiv_pol (PsubC Z.sub e c0) g)) H0).
   auto with zarith.
   auto with zarith.
   (* g <= 0 *)
   intros. inv H2. auto with zarith.
 Qed.
 
-
 Lemma cutting_plane_sound : forall env f p,
   eval_nformula env f ->
   genCuttingPlane f = Some p ->
@@ -741,13 +724,50 @@ 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 (Z.gtb g 0 && (negb (Zeq_bool c 0) && negb (Zeq_bool (Z.gcd 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 (Z.gtb 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 Z.sub 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 Z.add_0_r, Z.mul_eq_0 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 Z.sub_move_0_r.
+  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.
@@ -759,10 +779,10 @@ Proof.
   simpl. auto with zarith.
   (* Strict *)
   destruct p as [[e' z] op].
-  case_eq (makeCuttingPlane (PsubC Zminus e 1)).
+  case_eq (makeCuttingPlane (PsubC Z.sub 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 +791,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,25 +803,26 @@ 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 (Z.gtb g 0 && (negb (Zeq_bool c 0) && negb (Zeq_bool (Z.gcd 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.
+  set (x:=eval_pol env (Zdiv_pol (PsubC Z.sub 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.
+  rewrite Z.mul_opp_l, Z.mul_comm; auto with zarith.
   (**)
+  destruct (makeCuttingPlane p);  discriminate.
   discriminate.
-  discriminate.
-  destruct (makeCuttingPlane (PsubC Zminus p 1)) ; discriminate.
+  destruct (makeCuttingPlane (PsubC Z.sub p 1)) ; discriminate.
   destruct (makeCuttingPlane p) ; discriminate.
 Qed.
 
@@ -816,11 +837,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,60 +889,59 @@ 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 Z.add Z.mul (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 Z.add Z.mul (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.
+      ZChecker  ((PsubC Z.sub p1 x,Equal) :: l) pr = true)%Z).
+  clear HZ0 Hop1 Hop2 HCutL HCutR H0 H1.
+  revert Hfix.
   generalize (-z1). clear z1. intro z1.
   revert z1 z2.
   induction pf;simpl ;intros.
   generalize (Zgt_cases z1 z2).
-  destruct (Zgt_bool z1 z2).
+  destruct (Z.gtb z1 z2).
   intros.
   apply False_ind ; omega.
   discriminate.
@@ -931,16 +951,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]].
-  assert (make_impl (eval_nformula env) ((PsubC Zminus p1 (eval_pol env p1),Equal) :: l) False).
+  destruct (HH _ H1) as [pr [Hin Hcheker]].
+  assert (make_impl (eval_nformula env) ((PsubC Z.sub 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 +974,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 +998,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 +1053,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..a5b0da9c 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-2012     *)
 (*   \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,210 @@ 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 when Errors.noncritical 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)
+ try linear_prover n_spec l
+ with x when x <> Sys.Break ->
+   (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 +406,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 +498,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 +512,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 +533,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 +545,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 +571,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 +580,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..ff08aeb3 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-2012     *)
 (*   \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,15 @@ struct
       ["Coq";"Reals" ; "Rpow_def"];
       ["LRing_normalise"]]
 
+  let bin_module = [["Coq";"Numbers";"BinNums"]]
+
+  let r_modules =
+    [["Coq";"Reals" ; "Rdefinitions"];
+     ["Coq";"Reals" ; "Rpow_def"] ;
+]
+
+  let z_modules = [["Coq";"ZArith";"BinInt"]]
+
   (**
     * Initialization : a large amount of Caml symbols are derived from
     * ZMicromega.v
@@ -227,6 +309,9 @@ 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 z_constant = gen_constant_in_modules "ZMicromega" z_modules
   (* let constant = gen_constant_in_modules "Omicron" coq_modules *)
 
   let coq_and = lazy (init_constant "and")
@@ -244,34 +329,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 (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_pair = lazy (init_constant "pair")
+  let coq_None = lazy (init_constant "None")
+  let coq_option = lazy (init_constant "option")
 
-  let coq_N0 = lazy (constant "N0")
-  let coq_N0 = lazy (constant "Npos")
+  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_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")
 
@@ -281,17 +374,17 @@ struct
   let coq_cutProof = lazy (constant "CutProof")
   let coq_enumProof = lazy (constant "EnumProof")
 
-  let coq_Zgt = lazy (constant "Zgt")
-  let coq_Zge = lazy (constant "Zge")
-  let coq_Zle = lazy (constant "Zle")
-  let coq_Zlt = lazy (constant "Zlt")
+  let coq_Zgt = lazy (z_constant "Z.gt")
+  let coq_Zge = lazy (z_constant "Z.ge")
+  let coq_Zle = lazy (z_constant "Z.le")
+  let coq_Zlt = lazy (z_constant "Z.lt")
   let coq_Eq  = lazy (init_constant "eq")
 
-  let coq_Zplus = lazy (constant "Zplus")
-  let coq_Zminus = lazy (constant "Zminus")
-  let coq_Zopp = lazy (constant "Zopp")
-  let coq_Zmult = lazy (constant "Zmult")
-  let coq_Zpower = lazy (constant "Zpower")
+  let coq_Zplus = lazy (z_constant "Z.add")
+  let coq_Zminus = lazy (z_constant "Z.sub")
+  let coq_Zopp = lazy (z_constant "Z.opp")
+  let coq_Zmult = lazy (z_constant "Z.mul")
+  let coq_Zpower = lazy (z_constant "Z.pow")
 
   let coq_Qgt = lazy (constant "Qgt")
   let coq_Qge = lazy (constant "Qge")
@@ -305,16 +398,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 +541,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 +586,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 +605,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 +623,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
@@ -766,14 +898,21 @@ struct
   let parse_expr parse_constant parse_exp ops_spec env term =
     if debug
     then (Pp.pp (Pp.str "parse_expr: ");
-          Pp.pp_flush ();Pp.pp (Printer.prterm term); Pp.pp_flush ());
+          Pp.pp (Printer.prterm term);
+          Pp.pp (Pp.str "\n");
+          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 +920,35 @@ 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 e when e <> Sys.Break ->
+                           (* if the exponent is a variable *)
+                           let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env)
+                       end
+                   | Ukn  s ->
+                       if debug
+                       then (Printf.printf "unknown op: %s\n" s; flush stdout;);
+                       let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env)
                )
-            |   _ -> constant_or_variable env term
-          )
-       | _ -> constant_or_variable env term in
+		   |   _ -> parse_variable env term
+               )
+	   | _ -> parse_variable env term in
      parse_expr env term
 
   let zop_spec =
@@ -836,27 +978,63 @@ 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
+            (* the evaluation order is important in the following *)
+            let f = assoc_const op rconst_assoc in
+            let a = rconstant args.(0) in
+            let b = rconstant args.(1) in
+            f a b
+	  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 (Pp.str "\n");
+          Pp.pp_flush ());
+    let res = rconstant term in
+      if debug then 
+	(Printf.printf "rconstant -> %a\n" 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 +1048,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
 
@@ -886,6 +1064,7 @@ struct
    then (Pp.pp_flush ();
          Pp.pp (Pp.str "parse_arith: ");
          Pp.pp (Printer.prterm  cstr);
+         Pp.pp (Pp.str "\n");
          Pp.pp_flush ());
    match kind_of_term cstr with
     | App(op,args) ->
@@ -932,26 +1111,30 @@ 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
+    let parse_atom env tg t =
+      try
+        let (at,env) = parse_atom env t in
+        (A(at,tg,t), env,Tag.next tg)
+      with e when e <> Sys.Break -> (X(t),env,tg)
+    in
 
     let rec xparse_formula env tg term =
      match kind_of_term term with
       | App(l,rst) ->
           (match rst with
-           | [|a;b|] when l = Lazy.force coq_and ->
+           | [|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 +1143,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 =
@@ -1011,7 +1194,8 @@ let same_proof sg cl1 cl2 =
  let rec xsame_proof sg =
   match sg with
    | [] -> true
-   | n::sg -> (try List.nth cl1 n = List.nth cl2 n with _ -> false)
+   | n::sg ->
+     (try List.nth cl1 n = List.nth cl2 n with e when e <> Sys.Break -> false)
       && (xsame_proof sg ) in
   xsame_proof sg
 
@@ -1024,9 +1208,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
 
@@ -1075,7 +1259,7 @@ let btree_of_array typ a  =
 let btree_of_array typ a =
  try
   btree_of_array typ a
- with x ->
+ with x when x <> Sys.Break ->
   failwith (Printf.sprintf "btree of array : %s" (Printexc.to_string x))
 
 let dump_varmap typ env =
@@ -1103,6 +1287,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
 
 
@@ -1123,7 +1328,7 @@ let rec parse_hyps parse_arith env tg hyps =
       try
        let (c,env,tg) = parse_formula parse_arith env  tg t in
 	((i,c)::lhyps, env,tg)
-      with _ -> 		(lhyps,env,tg)
+      with e when e <> Sys.Break -> 		(lhyps,env,tg)
        (*(if debug then Printf.printf "parse_arith : %s\n" x);*)
 
 
@@ -1139,13 +1344,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 +1368,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,15 +1464,15 @@ 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 ;
-    let res = try prover.compact prf remap with x ->
+      end ; *)
+    let res = try prover.compact prf remap with x when x <> Sys.Break ->
       if debug then Printf.fprintf stdout "Proof compaction %s" (Printexc.to_string x) ;
       (* This should not happen -- this is the recovery plan... *)
       match prover.prover (List.map fst new_cl) with
@@ -1327,6 +1531,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 +1557,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 +1585,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 +1620,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 +1765,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 +1910,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 +1932,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 +1954,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 +1971,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 reraise -> (*Printexc.print_backtrace stdout ;*) raise reraise
+
+let xnlia gl =
+  try 
+    micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec
+      [ nlinear_Z ] gl
+  with reraise -> (*Printexc.print_backtrace stdout ;*) raise reraise
+
+
 
 (* Local Variables: *)
 (* coding: utf-8 *)
diff --git a/plugins/micromega/csdpcert.ml b/plugins/micromega/csdpcert.ml
index 3b47007c..0f26575c 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-2012     *)
 (*   \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"
@@ -150,7 +150,7 @@ let real_nonlinear_prover d l =
    S (Some proof)
  with
   | Sos_lib.TooDeep -> S None
-  |    x        ->   F (Printexc.to_string x)
+  | x when x <> Sys.Break -> F (Printexc.to_string x)
 
 (* This is somewhat buggy, over Z, strict inequality vanish... *)
 let pure_sos  l =
@@ -174,7 +174,7 @@ let pure_sos  l =
     S (Some proof)
  with
 (*   | Sos.CsdpNotFound -> F "Sos.CsdpNotFound" *)
-   |  x        -> (* May be that could be refined *) S None
+   | x when x <> Sys.Break -> (* May be that could be refined *) S None
 
 
 
@@ -203,7 +203,7 @@ let main () =
       Marshal.to_channel  chan (cert:csdp_certificate) [] ;
       flush chan ;
       exit 0
-  with  x -> (Printf.fprintf chan "error %s" (Printexc.to_string x)  ; exit 1)
+  with any -> (Printf.fprintf chan "error %s" (Printexc.to_string any)  ; exit 1)
 
 ;;
 
diff --git a/plugins/micromega/g_micromega.ml4 b/plugins/micromega/g_micromega.ml4
index 9b6842bd..0d888f85 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-2012     *)
 (*   \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..6effa4c4 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
 
 
 
@@ -848,7 +728,8 @@ struct
 	    try
 	      Some (bound_of_variable IMap.empty fresh s.sys)
 	    with
-		x -> Printf.printf "optimise Exception : %s" (Printexc.to_string x) ; None
+	      x when x <> Sys.Break ->
+                Printf.printf "optimise Exception : %s" (Printexc.to_string x) ; None
 
 
   let find_point cstrs =
@@ -913,7 +794,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..3129e54d 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,20 +8,31 @@
 (*                                                                      *)
 (* 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
       rst () ; res
-  with x ->
+  with reraise ->
     (try rst ()
-    with _  -> raise x
-    ); raise x
+    with any  -> raise reraise
+    ); raise reraise
 
 let map_option f x =
   match x with
@@ -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,22 @@ 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 when x <> Sys.Break ->
+                          failwith (Printf.sprintf "command \"%s\" exited %s" exe_path (Printexc.to_string x))
+                  end
+	    | Unix.WEXITED i   -> failwith (Printf.sprintf "command \"%s\" exited %i" exe_path i)
 	    | Unix.WSIGNALED i -> failwith (Printf.sprintf "command \"%s\" killed %i" exe_path i)
-	    | Unix.WSTOPPED  i -> failwith (Printf.sprintf "command \"%s\" stopped %i" exe_path i))
+	    | 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 e when e <> Sys.Break -> ())
+            [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..6d1a2927 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-2012     *)
 (*   \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
   }
@@ -85,10 +82,10 @@ let finally f rst =
   try
     let res = f () in
       rst () ; res
-  with x ->
+  with reraise ->
     (try rst ()
-    with _  -> raise x
-    ); raise x
+    with any  -> raise reraise
+    ); raise reraise
 
 
 let read_key_elem inch =
@@ -96,12 +93,32 @@ let read_key_elem inch =
     Some (Marshal.from_channel inch)
   with
     | End_of_file -> None
-    |    _        -> raise InvalidTableFormat
+    | e when e <> Sys.Break -> raise InvalidTableFormat
+
+(** In win32, it seems that we should unlock the exact zone
+    that has been locked, and not the whole file *)
+
+let locked_start = ref 0
+
+let lock fd =
+  locked_start := lseek fd 0 SEEK_CUR;
+  lockf fd F_LOCK 0
+
+let rlock fd =
+  locked_start := lseek fd 0 SEEK_CUR;
+  lockf fd F_RLOCK 0
+
+let unlock fd =
+  let pos = lseek fd 0 SEEK_CUR in
+  ignore (lseek fd !locked_start SEEK_SET);
+  lockf fd F_ULOCK 0;
+  ignore (lseek fd pos SEEK_SET)
 
 let open_in f =
-  let flags = [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 +126,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 *)
+      rlock finch;
+      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
+	  lock out;
+	  (try 
+	    Table.iter 
+	      (fun k e -> Marshal.to_channel outch (k,e) [Marshal.No_sharing]) htbl;
+	    flush outch ; 
+	  with e when e <> Sys.Break -> () )
+	    ;
+	    unlock out ; 
+	    { outch = outch ;
+	      status = Open ;
+	      htbl   = htbl
+	    }
       end
 
 
@@ -147,9 +175,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]
+	lock fd;
+	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..36b05a72
--- /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-2012     *)
+(*   \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..bc08d3c9 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-2012     *)
 (*   \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..f9d2fb0b 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-2012     *)
 (*   \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..4f4f2039 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-2012     *)
 (*   \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,28 +49,30 @@ 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 Z.add Zeq_bool.
 
 Definition PolZmul : PolZ -> PolZ -> PolZ :=
-  @Pmul Z 0%Z 1%Z Zplus Zmult Zeq_bool.
+  @Pmul  Z 0%Z 1%Z Z.add Z.mul Zeq_bool.
 
 Definition PolZeq := @Peq Z Zeq_bool.
 
 Definition norm :=
-  @norm_aux Z 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool.
+  @norm_aux Z 0%Z 1%Z Z.add Z.mul Z.sub Z.opp Zeq_bool.
 
 Fixpoint mult_l (la : list PEZ) (lp: list PolZ) : PolZ :=
  match la, lp with
@@ -140,53 +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)
+         N.to_nat 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 Rset : Setoid_Theory R ring_eq.
+Lemma Rext: ring_eq_ext add mul opp _==_.
+Proof.
+constructor; solve_proper.
+Qed.
+
+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 _==_ N.to_nat pow.
+apply Ring_theory.mkpow_th. unfold pow. intros. rewrite Nnat.N2Nat.id.
+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)
-    with (lmp:= List.nil).
- compute;trivial.
+ intros;apply (norm_aux_spec Rset Rext (Rth_ARth Rset Rext Rtheory)
+           (gen_phiZ_morph Rset Rext Rtheory) R_power_theory).
 Qed.
 
 Lemma PolZeq_correct : forall P P' l,
@@ -194,7 +160,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 +173,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 +208,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 (N.to_nat t2)
   | (PEc t1) => (IZR1 t1)
-  | (PEX n) => List.nth (pred (nat_of_P n)) fv 0
+  | (PEX n) => List.nth (pred (Pos.to_nat 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 +287,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 _;
@@ -364,58 +306,20 @@ Ltac nsatz_call radicalmax info nparam p lp kont :=
     lazymatch n with
     | 0%N => fail
     | _ =>
-        (let r := eval compute in (Nminus radicalmax (Npred n)) in
+        (let r := eval compute in (N.sub radicalmax (N.pred n)) in
          nsatz_call_n info nparam p r lp kont) ||
-         let n' := eval compute in (Npred n) in try_n n'
+         let n' := eval compute in (N.pred n) in try_n n'
     end in
   try_n radicalmax.
 
 
-Set Implicit Arguments.
-Class Cclosed_seq T (l:list T) := {}.
-Instance Iclosed_nil T : Cclosed_seq (T:=T) nil.
-Instance Iclosed_cons T t l `{Cclosed_seq (T:=T) l} : Cclosed_seq (T:=T) (t::l).
-
-Class Cfind_at (R:Type) (b:R) (l:list R) (i:nat) := {}.
-Instance  Ifind0 (R:Type) (b:R) l: Cfind_at b (b::l) 0.
-Instance  IfindS (R:Type) (b2 b1:R) l i `{Cfind_at R b1 l i} : Cfind_at b1 (b2::l) (S i) | 1.
-Definition Ifind0' := Ifind0.
-Definition IfindS' := IfindS.
-
-Definition li_find_at (R:Type) (b:R) l i `{Cfind_at R b l i} {H:Cclosed_seq (T:=R) l} := (l,i).
-
-Class Creify (R:Type) (e:PExpr Z) (l:list R) (b:R) := {}.
-Instance  Ireify_zero (R:Type) (Rd:Domain R) l : Creify (PEc 0%Z) l ring0.
-Instance  Ireify_one (R:Type)  (Rd:Domain R) l : Creify (PEc 1%Z) l ring1.
-Instance  Ireify_plus (R:Type)  (Rd:Domain R) e1 l b1 e2 b2 `{Creify R e1 l b1} `{Creify R e2 l b2} 
- : Creify (PEadd e1 e2) l (ring_plus b1 b2).
-Instance  Ireify_mult (R:Type)  (Rd:Domain R) e1 l b1 e2 b2 `{Creify R e1 l b1} `{Creify R e2 l b2}
- : Creify (PEmul e1 e2) l (ring_mult b1 b2).
-Instance  Ireify_sub (R:Type) (Rd:Domain R) e1 l b1 e2 b2 `{Creify R e1 l b1} `{Creify R e2 l b2}
- : Creify (PEsub e1 e2) l (ring_sub b1 b2).
-Instance  Ireify_opp (R:Type) (Rd:Domain R) e1 l b1 `{Creify R e1 l b1}
- : Creify (PEopp e1) l (ring_opp b1).
-Instance  Ireify_var (R:Type) b l i `{Cfind_at R b l i}
- : Creify (PEX _ (P_of_succ_nat i)) l b | 100.
-
-
-Class Creifylist (R:Type) (le:list (PExpr Z)) (l:list R) (lb:list R) := {}.
-Instance Creify_nil (R:Type) l : Creifylist nil l (@nil R).
-Instance Creify_cons (R:Type) e1 l b1 le2 lb2 `{Creify R e1 l b1} `{Creifylist R le2 l lb2} 
- : Creifylist (e1::le2) l (b1::lb2).
-
-Definition li_reifyl (R:Type) le l lb `{Creifylist R le l lb}
- {H:Cclosed_seq (T:=R) l} := (l,le).
-
-Unset Implicit Arguments.
-
 Ltac lterm_goal g :=
   match g with
-  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 +327,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) (N.to_nat 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_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.
+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.
+
+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.
+Lemma Rsth : Setoid_Theory R (@eq R).
+constructor;red;intros;subst;trivial.
 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].
+Instance Rops: (@Ring_ops R 0%R 1%R Rplus Rmult Rminus Ropp (@eq R)).
 
-Ltac nsatz_domainR:= 
-  nsatz_domainpv ltac:pretacR 6%N 1%Z (@Datatypes.nil R) (@Datatypes.nil R)
-    ltac:simplR Rdi;
-  discrR.
+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.
 
-
-Goal forall x y:R, x = y -> (x*x-x+1)%R = ((y*y-y)+1+0)%R.
-nsatz_domainR.
-Qed.
-
-
-(* 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}.
-
-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.
+Instance Rcri: (Cring (Rr:=Rri)).
+red. exact Rmult_comm. Defined.
 
-Ltac pretacZ :=
-replaceZ;
-replace Zri with (@domain_ring _ Zdi) in *; [idtac | reflexivity].
+Instance Rdi : (Integral_domain (Rcr:=Rcri)). 
+constructor. 
+exact Rmult_integral. exact R_one_zero. Defined.
 
-Ltac nsatz_domainZ:= 
-nsatz_domainpv ltac:pretacZ 6%N 1%Z (@Datatypes.nil Z) (@Datatypes.nil Z) ltac:simplZ Zdi.
-
-
-(* 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].
-
-Ltac nsatz_domainQ:= 
-nsatz_domainpv ltac:pretacQ 6%N 1%Z (@Datatypes.nil Q) (@Datatypes.nil Q) ltac:simplQ Qdi.
-
-(* 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.
+Instance Zcri: (Cring (Rr:=Zr)).
+red. exact Z.mul_comm. Defined.
 
-Goal forall x y:Z, x = y -> (x*x-x+1)%Z = ((y*y-y)+1+0)%Z.
-nsatz.
-Qed.
+Instance Zdi : (Integral_domain (Rcr:=Zcri)). 
+constructor. 
+exact Zmult_integral. exact Z_one_zero. Defined.
 
-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..68fb2626 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -237,7 +237,8 @@ open Format
 
 let getvar lv i =
   try (nth lv i)
-  with _ -> (fold_left (fun r x -> r^" "^x) "lv= " lv)
+  with e when Errors.noncritical e ->
+    (fold_left (fun r x -> r^" "^x) "lv= " lv)
     ^" i="^(string_of_int i)
 
 let string_of_pol zeroP hdP tlP coefterm monterm string_of_coef
@@ -363,7 +364,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;
@@ -590,7 +591,7 @@ let coefpoldep = Hashtbl.create 51
 (* coef of q in p = sum_i c_i*q_i *)
 let coefpoldep_find p q =
   try (Hashtbl.find coefpoldep (p.num,q.num))
-  with _ -> []
+  with Not_found -> []
 
 let coefpoldep_remove p q =
   Hashtbl.remove coefpoldep (p.num,q.num)
@@ -992,7 +993,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..14c7609d 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-2012     *)
 (*   \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
 
 
@@ -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..fdc8e865 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -173,7 +173,7 @@ let rec equal p q =
 			       then failwith "raté")
 		    p1;
 		  true)
-	     with _ -> false)
+	     with e when Errors.noncritical e -> false)
     | (_,_) -> false
 
 (* normalize polynomial: remove head zeros, coefficients are normalized
@@ -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
@@ -525,7 +524,7 @@ let div_pol_rat p q=
 		   q x in
          (* degueulasse, mais c 'est pour enlever un warning *)
          if s==s then true else true)
-    with _ -> false
+    with e when Errors.noncritical e -> false
 
 (***********************************************************************
   5. Pseudo-division and gcd with subresultants.
diff --git a/plugins/nsatz/polynom.mli b/plugins/nsatz/polynom.mli
index 980a8306..0643327f 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/plugins/nsatz/utile.ml b/plugins/nsatz/utile.ml
index c16bd425..17c8654b 100644
--- a/plugins/nsatz/utile.ml
+++ b/plugins/nsatz/utile.ml
@@ -33,10 +33,11 @@ let set_of_list_eq eq l =
 
 let memos s memoire nf f x =
    try (let v = Hashtbl.find memoire (nf x) in pr s;v)
-   with _ -> (pr "#";
-	      let v = f x in
-	      Hashtbl.add memoire (nf x) v;
-	      v)
+   with e when Errors.noncritical e ->
+     (pr "#";
+      let v = f x in
+      Hashtbl.add memoire (nf x) v;
+      v)
 
 
 (**********************************************************************
@@ -64,7 +65,7 @@ let facteurs_liste div constant lp =
                                    if not (constant r)
 				   then l1:=r::(!l1)
                                    else p_dans_lmin:=true)
-			      with _ -> ())
+			      with e when Errors.noncritical e -> ())
                      lmin;
           if !p_dans_lmin
           then factor lmin lp1
@@ -75,7 +76,8 @@ let facteurs_liste div constant lp =
                 List.iter (fun q -> try (let r = div q p in
 					 if not (constant r)
 					 then l1:=r::(!l1))
-				    with _ -> lmin1:=q::(!lmin1))
+				    with e when Errors.noncritical e ->
+                                      lmin1:=q::(!lmin1))
                           lmin;
 	        factor (List.rev (p::(!lmin1))) !l1)
           (* au moins un q de lmin divise p non trivialement *)
@@ -105,7 +107,7 @@ let factorise_tableau div zero c f l1 =
       	                       li:=j::(!li);
                                r:=rr;
 			   done)
-                      with _ -> ())
+                      with e when Errors.noncritical e -> ())
                   l1;
       res.(i)<-(!r,!li))
      f;
diff --git a/plugins/omega/Omega.v b/plugins/omega/Omega.v
index c8a06265..ea5a8cb7 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -13,17 +13,15 @@
 (*                                                                        *)
 (**************************************************************************)
 
-(* $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.
 Require Export PreOmega.
 Declare ML Module "omega_plugin".
 
-Hint Resolve Zle_refl Zplus_comm Zplus_assoc Zmult_comm Zmult_assoc Zplus_0_l
-  Zplus_0_r Zmult_1_l Zplus_opp_l Zplus_opp_r Zmult_plus_distr_l
-  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_r
+  Z.mul_add_distr_l: zarith.
 
 Require Export Zhints.
 
diff --git a/plugins/omega/OmegaLemmas.v b/plugins/omega/OmegaLemmas.v
index ec9faedd..1872f576 100644
--- a/plugins/omega/OmegaLemmas.v
+++ b/plugins/omega/OmegaLemmas.v
@@ -6,234 +6,192 @@
 (*         *       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.
+Require Import BinInt Znat.
+Local Open Scope Z_scope.
 
 (** Factorization lemmas *)
 
-Theorem Zred_factor0 : forall n:Z, n = n * 1.
-  intro x; rewrite (Zmult_1_r x); reflexivity.
+Theorem Zred_factor0 n : n = n * 1.
+Proof.
+  now Z.nzsimpl.
 Qed.
 
-Theorem Zred_factor1 : forall n:Z, n + n = n * 2.
+Theorem Zred_factor1 n : n + n = n * 2.
 Proof.
-  exact Zplus_diag_eq_mult_2.
+  rewrite Z.mul_comm. apply Z.add_diag.
 Qed.
 
-Theorem Zred_factor2 : forall n m:Z, n + n * m = n * (1 + m).
+Theorem Zred_factor2 n m : n + n * m = n * (1 + m).
 Proof.
-  intros x y; pattern x at 1 in |- *; rewrite <- (Zmult_1_r x);
-    rewrite <- Zmult_plus_distr_r; trivial with arith.
+  rewrite Z.mul_add_distr_l; now Z.nzsimpl.
 Qed.
 
-Theorem Zred_factor3 : forall n m:Z, n * m + n = n * (1 + m).
+Theorem Zred_factor3 n m : n * m + n = n * (1 + m).
 Proof.
-  intros x y; pattern x at 2 in |- *; rewrite <- (Zmult_1_r x);
-    rewrite <- Zmult_plus_distr_r; rewrite Zplus_comm;
-      trivial with arith.
+  now Z.nzsimpl.
 Qed.
 
-Theorem Zred_factor4 : forall n m p:Z, n * m + n * p = n * (m + p).
+Theorem Zred_factor4 n m p : n * m + n * p = n * (m + p).
 Proof.
-  intros x y z; symmetry  in |- *; apply Zmult_plus_distr_r.
+  symmetry; apply Z.mul_add_distr_l.
 Qed.
 
-Theorem Zred_factor5 : forall n m:Z, n * 0 + m = m.
+Theorem Zred_factor5 n m : n * 0 + m = m.
 Proof.
-  intros x y; rewrite <- Zmult_0_r_reverse; auto with arith.
+  now Z.nzsimpl.
 Qed.
 
-Theorem Zred_factor6 : forall n:Z, n = n + 0.
+Theorem Zred_factor6 n : n = n + 0.
 Proof.
-  intro; rewrite Zplus_0_r; trivial with arith.
+  now Z.nzsimpl.
 Qed.
 
 (** Other specific variants of theorems dedicated for the Omega tactic *)
 
 Lemma new_var : forall x : Z, exists y : Z, x = y.
-intros x; exists x; trivial with arith.
+Proof.
+intros x; now exists x.
 Qed.
 
-Lemma OMEGA1 : forall x y : Z, x = y -> 0 <= x -> 0 <= y.
-intros x y H; rewrite H; auto with arith.
+Lemma OMEGA1 x y : x = y -> 0 <= x -> 0 <= y.
+Proof.
+now intros ->.
 Qed.
 
-Lemma OMEGA2 : forall x y : Z, 0 <= x -> 0 <= y -> 0 <= x + y.
-exact Zplus_le_0_compat.
+Lemma OMEGA2 x y : 0 <= x -> 0 <= y -> 0 <= x + y.
+Proof.
+Z.order_pos.
 Qed.
 
-Lemma OMEGA3 : forall x y k : Z, k > 0 -> x = y * k -> x = 0 -> y = 0.
-
-intros x y k H1 H2 H3; apply (Zmult_integral_l k);
- [ unfold not in |- *; intros H4; absurd (k > 0);
-    [ rewrite H4; unfold Zgt in |- *; simpl in |- *; discriminate
-    | assumption ]
- | rewrite <- H2; assumption ].
+Lemma OMEGA3 x y k : k > 0 -> x = y * k -> x = 0 -> y = 0.
+Proof.
+intros LT -> EQ. apply Z.mul_eq_0 in EQ. destruct EQ; now subst.
 Qed.
 
-Lemma OMEGA4 : forall x y z : Z, x > 0 -> y > x -> z * y + x <> 0.
-
-unfold not in |- *; intros x y z H1 H2 H3; cut (y > 0);
- [ intros H4; cut (0 <= z * y + x);
-    [ intros H5; generalize (Zmult_le_approx y z x H4 H2 H5); intros H6;
-       absurd (z * y + x > 0);
-       [ rewrite H3; unfold Zgt in |- *; simpl in |- *; discriminate
-       | apply Zle_gt_trans with x;
-          [ pattern x at 1 in |- *; rewrite <- (Zplus_0_l x);
-             apply Zplus_le_compat_r; rewrite Zmult_comm;
-             generalize H4; unfold Zgt in |- *; case y;
-             [ simpl in |- *; intros H7; discriminate H7
-             | intros p H7; rewrite <- (Zmult_0_r (Zpos p));
-                unfold Zle in |- *; rewrite Zcompare_mult_compat;
-                exact H6
-             | simpl in |- *; intros p H7; discriminate H7 ]
-          | assumption ] ]
-    | rewrite H3; unfold Zle in |- *; simpl in |- *; discriminate ]
- | apply Zgt_trans with x; [ assumption | assumption ] ].
+Lemma OMEGA4 x y z : x > 0 -> y > x -> z * y + x <> 0.
+Proof.
+Z.swap_greater. intros Hx Hxy.
+rewrite Z.add_move_0_l, <- Z.mul_opp_l.
+destruct (Z.lt_trichotomy (-z) 1) as [LT|[->|GT]].
+- intro. revert LT. apply Z.le_ngt, (Z.le_succ_l 0).
+  apply Z.mul_pos_cancel_r with y; Z.order.
+- Z.nzsimpl. Z.order.
+- rewrite (Z.mul_lt_mono_pos_r y), Z.mul_1_l in GT; Z.order.
 Qed.
 
-Lemma OMEGA5 : forall x y z : Z, x = 0 -> y = 0 -> x + y * z = 0.
-
-intros x y z H1 H2; rewrite H1; rewrite H2; simpl in |- *; trivial with arith.
+Lemma OMEGA5 x y z : x = 0 -> y = 0 -> x + y * z = 0.
+Proof.
+now intros -> ->.
 Qed.
 
-Lemma OMEGA6 : forall x y z : Z, 0 <= x -> y = 0 -> 0 <= x + y * z.
-
-intros x y z H1 H2; rewrite H2; simpl in |- *; rewrite Zplus_0_r; assumption.
+Lemma OMEGA6 x y z : 0 <= x -> y = 0 -> 0 <= x + y * z.
+Proof.
+intros H ->. now Z.nzsimpl.
 Qed.
 
-Lemma OMEGA7 :
- forall x y z t : Z, z > 0 -> t > 0 -> 0 <= x -> 0 <= y -> 0 <= x * z + y * t.
-
-intros x y z t H1 H2 H3 H4; rewrite <- (Zplus_0_l 0); apply Zplus_le_compat;
- apply Zmult_gt_0_le_0_compat; assumption.
+Lemma OMEGA7 x y z t :
+ z > 0 -> t > 0 -> 0 <= x -> 0 <= y -> 0 <= x * z + y * t.
+Proof.
+intros. Z.swap_greater. Z.order_pos.
 Qed.
 
-Lemma OMEGA8 : forall x y : Z, 0 <= x -> 0 <= y -> x = - y -> x = 0.
-
-intros x y H1 H2 H3; elim (Zle_lt_or_eq 0 x H1);
- [ intros H4; absurd (0 < x);
-    [ change (0 >= x) in |- *; apply Zle_ge; apply Zplus_le_reg_l with y;
-       rewrite H3; rewrite Zplus_opp_r; rewrite Zplus_0_r;
-       assumption
-    | assumption ]
- | intros H4; rewrite H4; trivial with arith ].
+Lemma OMEGA8 x y : 0 <= x -> 0 <= y -> x = - y -> x = 0.
+Proof.
+intros H1 H2 H3. rewrite <- Z.opp_nonpos_nonneg in H2. Z.order.
 Qed.
 
-Lemma OMEGA9 : forall x y z t : Z, y = 0 -> x = z -> y + (- x + z) * t = 0.
-
-intros x y z t H1 H2; rewrite H2; rewrite Zplus_opp_l; rewrite Zmult_0_l;
- rewrite Zplus_0_r; assumption.
+Lemma OMEGA9 x y z t : y = 0 -> x = z -> y + (- x + z) * t = 0.
+Proof.
+intros. subst. now rewrite Z.add_opp_diag_l.
 Qed.
 
-Lemma OMEGA10 :
- forall v c1 c2 l1 l2 k1 k2 : Z,
+Lemma OMEGA10 v c1 c2 l1 l2 k1 k2 :
  (v * c1 + l1) * k1 + (v * c2 + l2) * k2 =
  v * (c1 * k1 + c2 * k2) + (l1 * k1 + l2 * k2).
-
-intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r;
- repeat rewrite Zmult_assoc; repeat elim Zplus_assoc;
- rewrite (Zplus_permute (l1 * k1) (v * c2 * k2)); trivial with arith.
+Proof.
+rewrite ?Z.mul_add_distr_r, ?Z.mul_add_distr_l, ?Z.mul_assoc.
+rewrite <- !Z.add_assoc. f_equal. apply Z.add_shuffle3.
 Qed.
 
-Lemma OMEGA11 :
- forall v1 c1 l1 l2 k1 : Z,
+Lemma OMEGA11 v1 c1 l1 l2 k1 :
  (v1 * c1 + l1) * k1 + l2 = v1 * (c1 * k1) + (l1 * k1 + l2).
-
-intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r;
- repeat rewrite Zmult_assoc; repeat elim Zplus_assoc;
- trivial with arith.
+Proof.
+rewrite ?Z.mul_add_distr_r, ?Z.mul_add_distr_l, ?Z.mul_assoc.
+now rewrite Z.add_assoc.
 Qed.
 
-Lemma OMEGA12 :
- forall v2 c2 l1 l2 k2 : Z,
+Lemma OMEGA12 v2 c2 l1 l2 k2 :
  l1 + (v2 * c2 + l2) * k2 = v2 * (c2 * k2) + (l1 + l2 * k2).
-
-intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r;
- repeat rewrite Zmult_assoc; repeat elim Zplus_assoc;
- rewrite Zplus_permute; trivial with arith.
+Proof.
+rewrite ?Z.mul_add_distr_r, ?Z.mul_add_distr_l, ?Z.mul_assoc.
+apply Z.add_shuffle3.
 Qed.
 
-Lemma OMEGA13 :
- forall (v l1 l2 : Z) (x : positive),
+Lemma OMEGA13 (v l1 l2 : Z) (x : positive) :
  v * Zpos x + l1 + (v * Zneg x + l2) = l1 + l2.
-
-intros; rewrite Zplus_assoc; rewrite (Zplus_comm (v * Zpos x) l1);
- rewrite (Zplus_assoc_reverse l1); rewrite <- Zmult_plus_distr_r;
- rewrite <- Zopp_neg; rewrite (Zplus_comm (- Zneg x) (Zneg x));
- rewrite Zplus_opp_r; rewrite Zmult_0_r; rewrite Zplus_0_r;
- trivial with arith.
+Proof.
+ rewrite Z.add_shuffle1.
+ rewrite <- Z.mul_add_distr_l, <- Pos2Z.opp_neg, Z.add_opp_diag_r.
+ now Z.nzsimpl.
 Qed.
 
-Lemma OMEGA14 :
- forall (v l1 l2 : Z) (x : positive),
+Lemma OMEGA14 (v l1 l2 : Z) (x : positive) :
  v * Zneg x + l1 + (v * Zpos x + l2) = l1 + l2.
-
-intros; rewrite Zplus_assoc; rewrite (Zplus_comm (v * Zneg x) l1);
- rewrite (Zplus_assoc_reverse l1); rewrite <- Zmult_plus_distr_r;
- rewrite <- Zopp_neg; rewrite Zplus_opp_r; rewrite Zmult_0_r;
- rewrite Zplus_0_r; trivial with arith.
+Proof.
+ rewrite Z.add_shuffle1.
+ rewrite <- Z.mul_add_distr_l, <- Pos2Z.opp_neg, Z.add_opp_diag_r.
+ now Z.nzsimpl.
 Qed.
-Lemma OMEGA15 :
- forall v c1 c2 l1 l2 k2 : Z,
- v * c1 + l1 + (v * c2 + l2) * k2 = v * (c1 + c2 * k2) + (l1 + l2 * k2).
 
-intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r;
- repeat rewrite Zmult_assoc; repeat elim Zplus_assoc;
- rewrite (Zplus_permute l1 (v * c2 * k2)); trivial with arith.
+Lemma OMEGA15 v c1 c2 l1 l2 k2 :
+ v * c1 + l1 + (v * c2 + l2) * k2 = v * (c1 + c2 * k2) + (l1 + l2 * k2).
+Proof.
+ rewrite ?Z.mul_add_distr_r, ?Z.mul_add_distr_l, ?Z.mul_assoc.
+ apply Z.add_shuffle1.
 Qed.
 
-Lemma OMEGA16 : forall v c l k : Z, (v * c + l) * k = v * (c * k) + l * k.
-
-intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r;
- repeat rewrite Zmult_assoc; repeat elim Zplus_assoc;
- trivial with arith.
+Lemma OMEGA16 v c l k : (v * c + l) * k = v * (c * k) + l * k.
+Proof.
+ now rewrite ?Z.mul_add_distr_r, ?Z.mul_add_distr_l, ?Z.mul_assoc.
 Qed.
 
-Lemma OMEGA17 : forall x y z : Z, Zne x 0 -> y = 0 -> Zne (x + y * z) 0.
-
-unfold Zne, not in |- *; intros x y z H1 H2 H3; apply H1;
- apply Zplus_reg_l with (y * z); rewrite Zplus_comm;
- rewrite H3; rewrite H2; auto with arith.
+Lemma OMEGA17 x y z : Zne x 0 -> y = 0 -> Zne (x + y * z) 0.
+Proof.
+ unfold Zne, not. intros NE EQ. subst. now Z.nzsimpl.
 Qed.
 
-Lemma OMEGA18 : forall x y k : Z, x = y * k -> Zne x 0 -> Zne y 0.
-
-unfold Zne, not in |- *; intros x y k H1 H2 H3; apply H2; rewrite H1;
- rewrite H3; auto with arith.
+Lemma OMEGA18 x y k : x = y * k -> Zne x 0 -> Zne y 0.
+Proof.
+ unfold Zne, not. intros. subst; auto.
 Qed.
 
-Lemma OMEGA19 : forall x : Z, Zne x 0 -> 0 <= x + -1 \/ 0 <= x * -1 + -1.
-
-unfold Zne in |- *; intros x H; elim (Zle_or_lt 0 x);
- [ intros H1; elim Zle_lt_or_eq with (1 := H1);
-    [ intros H2; left; change (0 <= Zpred x) in |- *; apply Zsucc_le_reg;
-       rewrite <- Zsucc_pred; apply Zlt_le_succ; assumption
-    | intros H2; absurd (x = 0); auto with arith ]
- | intros H1; right; rewrite <- Zopp_eq_mult_neg_1; rewrite Zplus_comm;
-    apply Zle_left; apply Zsucc_le_reg; simpl in |- *;
-    apply Zlt_le_succ; auto with arith ].
+Lemma OMEGA19 x : Zne x 0 -> 0 <= x + -1 \/ 0 <= x * -1 + -1.
+Proof.
+ unfold Zne. intros Hx. apply Z.lt_gt_cases in Hx.
+ destruct Hx as [LT|GT].
+ - right. change (-1) with (-(1)).
+   rewrite Z.mul_opp_r, <- Z.opp_add_distr. Z.nzsimpl.
+   rewrite Z.opp_nonneg_nonpos. now apply Z.le_succ_l.
+ - left. now apply Z.lt_le_pred.
 Qed.
 
-Lemma OMEGA20 : forall x y z : Z, Zne x 0 -> y = 0 -> Zne (x + y * z) 0.
-
-unfold Zne, not in |- *; intros x y z H1 H2 H3; apply H1; rewrite H2 in H3;
- simpl in H3; rewrite Zplus_0_r in H3; trivial with arith.
+Lemma OMEGA20 x y z : Zne x 0 -> y = 0 -> Zne (x + y * z) 0.
+Proof.
+ unfold Zne, not. intros H1 H2 H3; apply H1; rewrite H2 in H3;
+ simpl in H3; rewrite Z.add_0_r in H3; trivial with arith.
 Qed.
 
 Definition fast_Zplus_comm (x y : Z) (P : Z -> Prop)
-  (H : P (y + x)) := eq_ind_r P H (Zplus_comm x y).
+  (H : P (y + x)) := eq_ind_r P H (Z.add_comm x y).
 
 Definition fast_Zplus_assoc_reverse (n m p : Z) (P : Z -> Prop)
   (H : P (n + (m + p))) := eq_ind_r P H (Zplus_assoc_reverse n m p).
 
 Definition fast_Zplus_assoc (n m p : Z) (P : Z -> Prop)
-  (H : P (n + m + p)) := eq_ind_r P H (Zplus_assoc n m p).
+  (H : P (n + m + p)) := eq_ind_r P H (Z.add_assoc n m p).
 
 Definition fast_Zplus_permute (n m p : Z) (P : Z -> Prop)
-  (H : P (m + (n + p))) := eq_ind_r P H (Zplus_permute n m p).
+  (H : P (m + (n + p))) := eq_ind_r P H (Z.add_shuffle3 n m p).
 
 Definition fast_OMEGA10 (v c1 c2 l1 l2 k1 k2 : Z) (P : Z -> Prop)
   (H : P (v * (c1 * k1 + c2 * k2) + (l1 * k1 + l2 * k2))) :=
@@ -261,24 +219,24 @@ Definition fast_Zred_factor0 (x : Z) (P : Z -> Prop)
   (H : P (x * 1)) := eq_ind_r P H (Zred_factor0 x).
 
 Definition fast_Zopp_eq_mult_neg_1 (x : Z) (P : Z -> Prop)
-  (H : P (x * -1)) := eq_ind_r P H (Zopp_eq_mult_neg_1 x).
+  (H : P (x * -1)) := eq_ind_r P H (Z.opp_eq_mul_m1 x).
 
 Definition fast_Zmult_comm (x y : Z) (P : Z -> Prop)
-  (H : P (y * x)) := eq_ind_r P H (Zmult_comm x y).
+  (H : P (y * x)) := eq_ind_r P H (Z.mul_comm x y).
 
 Definition fast_Zopp_plus_distr (x y : Z) (P : Z -> Prop)
-  (H : P (- x + - y)) := eq_ind_r P H (Zopp_plus_distr x y).
+  (H : P (- x + - y)) := eq_ind_r P H (Z.opp_add_distr x y).
 
 Definition fast_Zopp_involutive (x : Z) (P : Z -> Prop) (H : P x) :=
-  eq_ind_r P H (Zopp_involutive x).
+  eq_ind_r P H (Z.opp_involutive x).
 
 Definition fast_Zopp_mult_distr_r (x y : Z) (P : Z -> Prop)
   (H : P (x * - y)) := eq_ind_r P H (Zopp_mult_distr_r x y).
 
 Definition fast_Zmult_plus_distr_l (n m p : Z) (P : Z -> Prop)
-  (H : P (n * p + m * p)) := eq_ind_r P H (Zmult_plus_distr_l n m p).
+  (H : P (n * p + m * p)) := eq_ind_r P H (Z.mul_add_distr_r n m p).
 Definition fast_Zmult_opp_comm (x y : Z) (P : Z -> Prop)
-  (H : P (x * - y)) := eq_ind_r P H (Zmult_opp_comm x y).
+  (H : P (x * - y)) := eq_ind_r P H (Z.mul_opp_comm x y).
 
 Definition fast_Zmult_assoc_reverse (n m p : Z) (P : Z -> Prop)
   (H : P (n * (m * p))) := eq_ind_r P H (Zmult_assoc_reverse n m p).
@@ -300,3 +258,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 Z.mul_1_r, Z.add_0_r. apply Nat2Z.is_nonneg.
+Qed.
diff --git a/plugins/omega/OmegaPlugin.v b/plugins/omega/OmegaPlugin.v
index 69a6ea72..433db414 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-2012     *)
 (*   \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..60e606a6 100644
--- a/plugins/omega/PreOmega.v
+++ b/plugins/omega/PreOmega.v
@@ -1,6 +1,14 @@
-Require Import Arith Max Min ZArith_base NArith Nnat.
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
 
-Open Local Scope Z_scope.
+Require Import Arith Max Min BinInt BinNat Znat Nnat.
+
+Local Open Scope Z_scope.
 
 
 (** * zify: the Z-ification tactic *)
@@ -15,20 +23,20 @@ Open Local Scope Z_scope.
      - { eq, le, lt, ge, gt } on { Z, positive, N, nat }
 
    Recognized operations:
-     - on Z: Zmin, Zmax, Zabs, Zsgn are translated in term of <= < =
-     - on nat: + * - S O pred min max nat_of_P nat_of_N Zabs_nat
-     - on positive: Zneg Zpos xI xO xH + * - Psucc Ppred Pmin Pmax P_of_succ_nat
-     - on N: N0 Npos + * - Nsucc Nmin Nmax N_of_nat Zabs_N
+     - on Z: Z.min, Z.max, Z.abs, Z.sgn are translated in term of <= < =
+     - on nat: + * - S O pred min max Pos.to_nat N.to_nat Z.abs_nat
+     - on positive: Zneg Zpos xI xO xH + * - Pos.succ Pos.pred Pos.min Pos.max Pos.of_succ_nat
+     - on N: N0 Npos + * - N.succ N.min N.max N.of_nat Z.abs_N
 *)
 
 
 
 
-(** I) translation of Zmax, Zmin, Zabs, Zsgn into recognized equations *)
+(** I) translation of Z.max, Z.min, Z.abs, Z.sgn into recognized equations *)
 
 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.
 
@@ -48,7 +56,7 @@ Ltac zify_unop t thm a :=
  end.
 
 Ltac zify_unop_nored t thm a :=
- (* in this version, we don't try to reduce the unop (that can be (Zplus x)) *)
+ (* in this version, we don't try to reduce the unop (that can be (Z.add x)) *)
  let isz := isZcst a in
  match isz with
   | true => zify_unop_core t thm a
@@ -72,14 +80,14 @@ Ltac zify_binop t thm a b:=
 
 Ltac zify_op_1 :=
   match goal with
-   | |- context [ Zmax ?a ?b ] => zify_binop Zmax Zmax_spec a b
-   | H : context [ Zmax ?a ?b ] |- _ => zify_binop Zmax Zmax_spec a b
-   | |- context [ Zmin ?a ?b ] => zify_binop Zmin Zmin_spec a b
-   | H : context [ Zmin ?a ?b ] |- _ => zify_binop Zmin Zmin_spec a b
-   | |- context [ Zsgn ?a ] => zify_unop Zsgn Zsgn_spec a
-   | H : context [ Zsgn ?a ] |- _ => zify_unop Zsgn Zsgn_spec a
-   | |- context [ Zabs ?a ] => zify_unop Zabs Zabs_spec a
-   | H : context [ Zabs ?a ] |- _ => zify_unop Zabs Zabs_spec a
+   | |- context [ Z.max ?a ?b ] => zify_binop Z.max Z.max_spec a b
+   | H : context [ Z.max ?a ?b ] |- _ => zify_binop Z.max Z.max_spec a b
+   | |- context [ Z.min ?a ?b ] => zify_binop Z.min Z.min_spec a b
+   | H : context [ Z.min ?a ?b ] |- _ => zify_binop Z.min Z.min_spec a b
+   | |- context [ Z.sgn ?a ] => zify_unop Z.sgn Z.sgn_spec a
+   | H : context [ Z.sgn ?a ] |- _ => zify_unop Z.sgn Z.sgn_spec a
+   | |- context [ Z.abs ?a ] => zify_unop Z.abs Z.abs_spec a
+   | H : context [ Z.abs ?a ] |- _ => zify_unop Z.abs Z.abs_spec a
   end.
 
 Ltac zify_op := repeat zify_op_1.
@@ -91,113 +99,95 @@ Ltac zify_op := repeat zify_op_1.
 (** II) Conversion from nat to Z *)
 
 
-Definition Z_of_nat' := Z_of_nat.
+Definition Z_of_nat' := Z.of_nat.
 
 Ltac hide_Z_of_nat t :=
-  let z := fresh "z" in set (z:=Z_of_nat t) in *;
-  change Z_of_nat with Z_of_nat' in z;
+  let z := fresh "z" in set (z:=Z.of_nat t) in *;
+  change Z.of_nat with Z_of_nat' in z;
   unfold z in *; clear z.
 
 Ltac zify_nat_rel :=
  match goal with
   (* I: equalities *)
-  | H : (@eq nat ?a ?b) |- _ => generalize (inj_eq _ _ H); clear H; intro H
-  | |- (@eq nat ?a ?b) => apply (inj_eq_rev a b)
-  | H : context [ @eq nat ?a ?b ] |- _ => rewrite (inj_eq_iff a b) in H
-  | |- context [ @eq nat ?a ?b ] =>       rewrite (inj_eq_iff a b)
+  | |- (@eq nat ?a ?b) => apply (Nat2Z.inj a b) (* shortcut *)
+  | H : context [ @eq nat ?a ?b ] |- _ => rewrite <- (Nat2Z.inj_iff a b) in H
+  | |- context [ @eq nat ?a ?b ] =>       rewrite <- (Nat2Z.inj_iff a b)
   (* II: less than *)
-  | H : (lt ?a ?b) |- _ => generalize (inj_lt _ _ H); clear H; intro H
-  | |- (lt ?a ?b) => apply (inj_lt_rev a b)
-  | H : context [ lt ?a ?b ] |- _ => rewrite (inj_lt_iff a b) in H
-  | |- context [ lt ?a ?b ] =>       rewrite (inj_lt_iff a b)
+  | H : context [ lt ?a ?b ] |- _ => rewrite (Nat2Z.inj_lt a b) in H
+  | |- context [ lt ?a ?b ] =>       rewrite (Nat2Z.inj_lt a b)
   (* III: less or equal *)
-  | H : (le ?a ?b) |- _ => generalize (inj_le _ _ H); clear H; intro H
-  | |- (le ?a ?b) => apply (inj_le_rev a b)
-  | H : context [ le ?a ?b ] |- _ => rewrite (inj_le_iff a b) in H
-  | |- context [ le ?a ?b ] =>       rewrite (inj_le_iff a b)
+  | H : context [ le ?a ?b ] |- _ => rewrite (Nat2Z.inj_le a b) in H
+  | |- context [ le ?a ?b ] =>       rewrite (Nat2Z.inj_le a b)
   (* IV: greater than *)
-  | H : (gt ?a ?b) |- _ => generalize (inj_gt _ _ H); clear H; intro H
-  | |- (gt ?a ?b) => apply (inj_gt_rev a b)
-  | H : context [ gt ?a ?b ] |- _ => rewrite (inj_gt_iff a b) in H
-  | |- context [ gt ?a ?b ] =>       rewrite (inj_gt_iff a b)
+  | H : context [ gt ?a ?b ] |- _ => rewrite (Nat2Z.inj_gt a b) in H
+  | |- context [ gt ?a ?b ] =>       rewrite (Nat2Z.inj_gt a b)
   (* V: greater or equal *)
-  | H : (ge ?a ?b) |- _ => generalize (inj_ge _ _ H); clear H; intro H
-  | |- (ge ?a ?b) => apply (inj_ge_rev a b)
-  | H : context [ ge ?a ?b ] |- _ => rewrite (inj_ge_iff a b) in H
-  | |- context [ ge ?a ?b ] =>       rewrite (inj_ge_iff a b)
+  | H : context [ ge ?a ?b ] |- _ => rewrite (Nat2Z.inj_ge a b) in H
+  | |- context [ ge ?a ?b ] =>       rewrite (Nat2Z.inj_ge a b)
  end.
 
 Ltac zify_nat_op :=
  match goal with
   (* misc type conversions: positive/N/Z to nat *)
-  | H : context [ Z_of_nat (nat_of_P ?a) ] |- _ => rewrite <- (Zpos_eq_Z_of_nat_o_nat_of_P a) in H
-  | |- context [ Z_of_nat (nat_of_P ?a) ] => rewrite <- (Zpos_eq_Z_of_nat_o_nat_of_P a)
-  | H : context [ Z_of_nat (nat_of_N ?a) ] |- _ => rewrite (Z_of_nat_of_N a) in H
-  | |- context [ Z_of_nat (nat_of_N ?a) ] => rewrite (Z_of_nat_of_N a)
-  | H : context [ Z_of_nat (Zabs_nat ?a) ] |- _ => rewrite (inj_Zabs_nat a) in H
-  | |- context [ Z_of_nat (Zabs_nat ?a) ] => rewrite (inj_Zabs_nat a)
-
-  (* plus -> Zplus *)
-  | H : context [ Z_of_nat (plus ?a ?b) ] |- _ => rewrite (inj_plus a b) in H
-  | |- context [ Z_of_nat (plus ?a ?b) ] => rewrite (inj_plus a b)
-
-  (* min -> Zmin *)
-  | H : context [ Z_of_nat (min ?a ?b) ] |- _ => rewrite (inj_min a b) in H
-  | |- context [ Z_of_nat (min ?a ?b) ] => rewrite (inj_min a b)
-
-  (* max -> Zmax *)
-  | H : context [ Z_of_nat (max ?a ?b) ] |- _ => rewrite (inj_max a b) in H
-  | |- context [ Z_of_nat (max ?a ?b) ] => rewrite (inj_max a b)
-
-  (* minus -> Zmax (Zminus ... ...) 0 *)
-  | H : context [ Z_of_nat (minus ?a ?b) ] |- _ => rewrite (inj_minus a b) in H
-  | |- context [ Z_of_nat (minus ?a ?b) ] => rewrite (inj_minus a b)
-
-  (* pred -> minus ... -1 -> Zmax (Zminus ... -1) 0 *)
-  | H : context [ Z_of_nat (pred ?a) ] |- _ => rewrite (pred_of_minus a) in H
-  | |- context [ Z_of_nat (pred ?a) ] => rewrite (pred_of_minus a)
-
-  (* mult -> Zmult and a positivity hypothesis *)
-  | H : context [ Z_of_nat (mult ?a ?b) ] |- _ =>
-        let H:= fresh "H" in
-        assert (H:=Zle_0_nat (mult a b)); rewrite (inj_mult a b) in *
-  | |- context [ Z_of_nat (mult ?a ?b) ] =>
-        let H:= fresh "H" in
-        assert (H:=Zle_0_nat (mult a b)); rewrite (inj_mult a b) in *
+  | H : context [ Z.of_nat (Pos.to_nat ?a) ] |- _ => rewrite (positive_nat_Z a) in H
+  | |- context [ Z.of_nat (Pos.to_nat ?a) ] => rewrite (positive_nat_Z a)
+  | H : context [ Z.of_nat (N.to_nat ?a) ] |- _ => rewrite (N_nat_Z a) in H
+  | |- context [ Z.of_nat (N.to_nat ?a) ] => rewrite (N_nat_Z a)
+  | H : context [ Z.of_nat (Z.abs_nat ?a) ] |- _ => rewrite (Zabs2Nat.id_abs a) in H
+  | |- context [ Z.of_nat (Z.abs_nat ?a) ] => rewrite (Zabs2Nat.id_abs a)
+
+  (* plus -> Z.add *)
+  | H : context [ Z.of_nat (plus ?a ?b) ] |- _ => rewrite (Nat2Z.inj_add a b) in H
+  | |- context [ Z.of_nat (plus ?a ?b) ] => rewrite (Nat2Z.inj_add a b)
+
+  (* min -> Z.min *)
+  | H : context [ Z.of_nat (min ?a ?b) ] |- _ => rewrite (Nat2Z.inj_min a b) in H
+  | |- context [ Z.of_nat (min ?a ?b) ] => rewrite (Nat2Z.inj_min a b)
+
+  (* max -> Z.max *)
+  | H : context [ Z.of_nat (max ?a ?b) ] |- _ => rewrite (Nat2Z.inj_max a b) in H
+  | |- context [ Z.of_nat (max ?a ?b) ] => rewrite (Nat2Z.inj_max a b)
+
+  (* minus -> Z.max (Z.sub ... ...) 0 *)
+  | H : context [ Z.of_nat (minus ?a ?b) ] |- _ => rewrite (Nat2Z.inj_sub_max a b) in H
+  | |- context [ Z.of_nat (minus ?a ?b) ] => rewrite (Nat2Z.inj_sub_max a b)
+
+  (* pred -> minus ... -1 -> Z.max (Z.sub ... -1) 0 *)
+  | H : context [ Z.of_nat (pred ?a) ] |- _ => rewrite (pred_of_minus a) in H
+  | |- context [ Z.of_nat (pred ?a) ] => rewrite (pred_of_minus a)
+
+  (* mult -> Z.mul and a positivity hypothesis *)
+  | H : context [ Z.of_nat (mult ?a ?b) ] |- _ =>
+        pose proof (Nat2Z.is_nonneg (mult a b));
+        rewrite (Nat2Z.inj_mul a b) in *
+  | |- context [ Z.of_nat (mult ?a ?b) ] =>
+        pose proof (Nat2Z.is_nonneg (mult a b));
+        rewrite (Nat2Z.inj_mul a b) in *
 
   (* O -> Z0 *)
-  | H : context [ Z_of_nat O ] |- _ => simpl (Z_of_nat O) in H
-  | |- context [ Z_of_nat O ] => simpl (Z_of_nat O)
+  | H : context [ Z.of_nat O ] |- _ => simpl (Z.of_nat O) in H
+  | |- context [ Z.of_nat O ] => simpl (Z.of_nat O)
 
-  (* S -> number or Zsucc *)
-  | H : context [ Z_of_nat (S ?a) ] |- _ =>
+  (* S -> number or Z.succ *)
+  | H : context [ Z.of_nat (S ?a) ] |- _ =>
      let isnat := isnatcst a in
      match isnat with
-      | true => simpl (Z_of_nat (S a)) in H
-      | _ => rewrite (inj_S a) in H
+      | true => simpl (Z.of_nat (S a)) in H
+      | _ => rewrite (Nat2Z.inj_succ a) in H
      end
-  | |- context [ Z_of_nat (S ?a) ] =>
+  | |- context [ Z.of_nat (S ?a) ] =>
      let isnat := isnatcst a in
      match isnat with
-      | true => simpl (Z_of_nat (S a))
-      | _ => rewrite (inj_S a)
+      | true => simpl (Z.of_nat (S a))
+      | _ => rewrite (Nat2Z.inj_succ a)
      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 (Nat2Z.is_nonneg a); hide_Z_of_nat a
+  | |- context [ Z.of_nat ?a ] =>
+    pose proof (Nat2Z.is_nonneg a); hide_Z_of_nat a
  end.
 
 Ltac zify_nat := repeat zify_nat_rel; repeat zify_nat_op; unfold Z_of_nat' in *.
@@ -218,22 +208,21 @@ Ltac hide_Zpos t :=
 Ltac zify_positive_rel :=
  match goal with
   (* I: equalities *)
-  | H : (@eq positive ?a ?b) |- _ => generalize (Zpos_eq _ _ H); clear H; intro H
-  | |- (@eq positive ?a ?b) => apply (Zpos_eq_rev a b)
-  | 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)
+  | |- (@eq positive ?a ?b) => apply Pos2Z.inj
+  | H : context [ @eq positive ?a ?b ] |- _ => rewrite <- (Pos2Z.inj_iff a b) in H
+  | |- context [ @eq positive ?a ?b ] =>       rewrite <- (Pos2Z.inj_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 :=
@@ -253,66 +242,66 @@ Ltac zify_positive_op :=
      end
 
   (* misc type conversions: nat to positive *)
-  | H : context [ Zpos (P_of_succ_nat ?a) ] |- _ => rewrite (Zpos_P_of_succ_nat a) in H
-  | |- context [ Zpos (P_of_succ_nat ?a) ] => rewrite (Zpos_P_of_succ_nat a)
+  | H : context [ Zpos (Pos.of_succ_nat ?a) ] |- _ => rewrite (Zpos_P_of_succ_nat a) in H
+  | |- context [ Zpos (Pos.of_succ_nat ?a) ] => rewrite (Zpos_P_of_succ_nat a)
 
-  (* Pplus -> Zplus *)
-  | H : context [ Zpos (Pplus ?a ?b) ] |- _ => change (Zpos (Pplus a b)) with (Zplus (Zpos a) (Zpos b)) in H
-  | |- context [ Zpos (Pplus ?a ?b) ] => change (Zpos (Pplus a b)) with (Zplus (Zpos a) (Zpos b))
+  (* Pos.add -> Z.add *)
+  | H : context [ Zpos (?a + ?b) ] |- _ => change (Zpos (a+b)) with (Zpos a + Zpos b) in H
+  | |- context [ Zpos (?a + ?b) ] => change (Zpos (a+b)) with (Zpos a + Zpos b)
 
-  (* Pmin -> Zmin *)
-  | H : context [ Zpos (Pmin ?a ?b) ] |- _ => rewrite (Zpos_min a b) in H
-  | |- context [ Zpos (Pmin ?a ?b) ] => rewrite (Zpos_min a b)
+  (* Pos.min -> Z.min *)
+  | H : context [ Zpos (Pos.min ?a ?b) ] |- _ => rewrite (Pos2Z.inj_min a b) in H
+  | |- context [ Zpos (Pos.min ?a ?b) ] => rewrite (Pos2Z.inj_min a b)
 
-  (* Pmax -> Zmax *)
-  | H : context [ Zpos (Pmax ?a ?b) ] |- _ => rewrite (Zpos_max a b) in H
-  | |- context [ Zpos (Pmax ?a ?b) ] => rewrite (Zpos_max a b)
+  (* Pos.max -> Z.max *)
+  | H : context [ Zpos (Pos.max ?a ?b) ] |- _ => rewrite (Pos2Z.inj_max a b) in H
+  | |- context [ Zpos (Pos.max ?a ?b) ] => rewrite (Pos2Z.inj_max a b)
 
-  (* Pminus -> Zmax 1 (Zminus ... ...) *)
-  | H : context [ Zpos (Pminus ?a ?b) ] |- _ => rewrite (Zpos_minus a b) in H
-  | |- context [ Zpos (Pminus ?a ?b) ] => rewrite (Zpos_minus a b)
+  (* Pos.sub -> Z.max 1 (Z.sub ... ...) *)
+  | H : context [ Zpos (Pos.sub ?a ?b) ] |- _ => rewrite (Pos2Z.inj_sub a b) in H
+  | |- context [ Zpos (Pos.sub ?a ?b) ] => rewrite (Pos2Z.inj_sub a b)
 
-  (* Psucc -> Zsucc *)
-  | H : context [ Zpos (Psucc ?a) ] |- _ => rewrite (Zpos_succ_morphism a) in H
-  | |- context [ Zpos (Psucc ?a) ] => rewrite (Zpos_succ_morphism a)
+  (* Pos.succ -> Z.succ *)
+  | H : context [ Zpos (Pos.succ ?a) ] |- _ => rewrite (Pos2Z.inj_succ a) in H
+  | |- context [ Zpos (Pos.succ ?a) ] => rewrite (Pos2Z.inj_succ a)
 
-  (* Ppred -> Pminus ... -1 -> Zmax 1 (Zminus ... - 1) *)
-  | H : context [ Zpos (Ppred ?a) ] |- _ => rewrite (Ppred_minus a) in H
-  | |- context [ Zpos (Ppred ?a) ] => rewrite (Ppred_minus a)
+  (* Pos.pred -> Pos.sub ... -1 -> Z.max 1 (Z.sub ... - 1) *)
+  | H : context [ Zpos (Pos.pred ?a) ] |- _ => rewrite <- (Pos.sub_1_r a) in H
+  | |- context [ Zpos (Pos.pred ?a) ] => rewrite <- (Pos.sub_1_r a)
 
-  (* 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 *
-  | |- 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 *
+  (* Pos.mul -> Z.mul and a positivity hypothesis *)
+  | H : context [ Zpos (?a * ?b) ] |- _ =>
+        pose proof (Pos2Z.is_pos (Pos.mul a b));
+        change (Zpos (a*b)) with (Zpos a * Zpos b) in *
+  | |- context [ Zpos (?a * ?b) ] =>
+        pose proof (Pos2Z.is_pos (Pos.mul a b));
+        change (Zpos (a*b)) with (Zpos a * Zpos b) in *
 
   (* xO *)
   | H : context [ Zpos (xO ?a) ] |- _ =>
      let isp := isPcst a in
      match isp with
       | true => change (Zpos (xO a)) with (Zpos' (xO a)) in H
-      | _ => rewrite (Zpos_xO a) in H
+      | _ => rewrite (Pos2Z.inj_xO a) in H
      end
   | |- context [ Zpos (xO ?a) ] =>
      let isp := isPcst a in
      match isp with
       | true => change (Zpos (xO a)) with (Zpos' (xO a))
-      | _ => rewrite (Zpos_xO a)
+      | _ => rewrite (Pos2Z.inj_xO a)
      end
   (* xI *)
   | H : context [ Zpos (xI ?a) ] |- _ =>
      let isp := isPcst a in
      match isp with
       | true => change (Zpos (xI a)) with (Zpos' (xI a)) in H
-      | _ => rewrite (Zpos_xI a) in H
+      | _ => rewrite (Pos2Z.inj_xI a) in H
      end
   | |- context [ Zpos (xI ?a) ] =>
      let isp := isPcst a in
      match isp with
       | true => change (Zpos (xI a)) with (Zpos' (xI a))
-      | _ => rewrite (Zpos_xI a)
+      | _ => rewrite (Pos2Z.inj_xI a)
      end
 
   (* xI : nothing to do, just prevent adding a useless positivity condition *)
@@ -320,18 +309,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
+  | _ : 0 < Zpos ?a |- _ => hide_Zpos a
+  | _ : context [ Zpos ?a ] |- _ => pose proof (Pos2Z.is_pos a); hide_Zpos a
+  | |- context [ Zpos ?a ] => pose proof (Pos2Z.is_pos a); hide_Zpos a
  end.
 
 Ltac zify_positive :=
@@ -343,95 +323,75 @@ Ltac zify_positive :=
 
 (* IV) conversion from N to Z *)
 
-Definition Z_of_N' := Z_of_N.
+Definition Z_of_N' := Z.of_N.
 
 Ltac hide_Z_of_N t :=
-  let z := fresh "z" in set (z:=Z_of_N t) in *;
-  change Z_of_N with Z_of_N' in z;
+  let z := fresh "z" in set (z:=Z.of_N t) in *;
+  change Z.of_N with Z_of_N' in z;
   unfold z in *; clear z.
 
 Ltac zify_N_rel :=
  match goal with
   (* I: equalities *)
-  | H : (@eq N ?a ?b) |- _ => generalize (Z_of_N_eq _ _ H); clear H; intro H
-  | |- (@eq N ?a ?b) => apply (Z_of_N_eq_rev a b)
-  | 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)
+  | |- (@eq N ?a ?b) => apply (N2Z.inj a b) (* shortcut *)
+  | H : context [ @eq N ?a ?b ] |- _ => rewrite <- (N2Z.inj_iff a b) in H
+  | |- context [ @eq N ?a ?b ] =>       rewrite <- (N2Z.inj_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 : context [ (?a < ?b)%N ] |- _ => rewrite (N2Z.inj_lt a b) in H
+  | |- context [ (?a < ?b)%N ] =>       rewrite (N2Z.inj_lt 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 : context [ (?a <= ?b)%N ] |- _ => rewrite (N2Z.inj_le a b) in H
+  | |- context [ (?a <= ?b)%N ] =>       rewrite (N2Z.inj_le 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 : context [ (?a > ?b)%N ] |- _ => rewrite (N2Z.inj_gt a b) in H
+  | |- context [ (?a > ?b)%N ] =>       rewrite (N2Z.inj_gt 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 : context [ (?a >= ?b)%N ] |- _ => rewrite (N2Z.inj_ge a b) in H
+  | |- context [ (?a >= ?b)%N ] =>       rewrite (N2Z.inj_ge a b)
  end.
 
 Ltac zify_N_op :=
  match goal with
   (* misc type conversions: nat to positive *)
-  | H : context [ Z_of_N (N_of_nat ?a) ] |- _ => rewrite (Z_of_N_of_nat a) in H
-  | |- context [ Z_of_N (N_of_nat ?a) ] => rewrite (Z_of_N_of_nat a)
-  | H : context [ Z_of_N (Zabs_N ?a) ] |- _ => rewrite (Z_of_N_abs a) in H
-  | |- context [ Z_of_N (Zabs_N ?a) ] => rewrite (Z_of_N_abs a)
-  | H : context [ Z_of_N (Npos ?a) ] |- _ => rewrite (Z_of_N_pos a) in H
-  | |- context [ Z_of_N (Npos ?a) ] => rewrite (Z_of_N_pos a)
-  | H : context [ Z_of_N N0 ] |- _ => change (Z_of_N N0) with Z0 in H
-  | |- context [ Z_of_N N0 ] => change (Z_of_N N0) with Z0
-
-  (* Nplus -> Zplus *)
-  | H : context [ Z_of_N (Nplus ?a ?b) ] |- _ => rewrite (Z_of_N_plus a b) in H
-  | |- context [ Z_of_N (Nplus ?a ?b) ] => rewrite (Z_of_N_plus a b)
-
-  (* Nmin -> Zmin *)
-  | H : context [ Z_of_N (Nmin ?a ?b) ] |- _ => rewrite (Z_of_N_min a b) in H
-  | |- context [ Z_of_N (Nmin ?a ?b) ] => rewrite (Z_of_N_min a b)
-
-  (* Nmax -> Zmax *)
-  | H : context [ Z_of_N (Nmax ?a ?b) ] |- _ => rewrite (Z_of_N_max a b) in H
-  | |- context [ Z_of_N (Nmax ?a ?b) ] => rewrite (Z_of_N_max a b)
-
-  (* Nminus -> Zmax 0 (Zminus ... ...) *)
-  | H : context [ Z_of_N (Nminus ?a ?b) ] |- _ => rewrite (Z_of_N_minus a b) in H
-  | |- context [ Z_of_N (Nminus ?a ?b) ] => rewrite (Z_of_N_minus a b)
-
-  (* Nsucc -> Zsucc *)
-  | H : context [ Z_of_N (Nsucc ?a) ] |- _ => rewrite (Z_of_N_succ a) in H
-  | |- context [ Z_of_N (Nsucc ?a) ] => rewrite (Z_of_N_succ a)
-
-  (* Nmult -> Zmult and a positivity hypothesis *)
-  | H : context [ Z_of_N (Nmult ?a ?b) ] |- _ =>
-        let H:= fresh "H" in
-        assert (H:=Z_of_N_le_0 (Nmult a b)); rewrite (Z_of_N_mult a b) in *
-  | |- context [ Z_of_N  (Nmult ?a ?b) ] =>
-        let H:= fresh "H" in
-        assert (H:=Z_of_N_le_0 (Nmult a b)); rewrite (Z_of_N_mult a b) in *
+  | H : context [ Z.of_N (N.of_nat ?a) ] |- _ => rewrite (nat_N_Z a) in H
+  | |- context [ Z.of_N (N.of_nat ?a) ] => rewrite (nat_N_Z a)
+  | H : context [ Z.of_N (Z.abs_N ?a) ] |- _ => rewrite (N2Z.inj_abs_N a) in H
+  | |- context [ Z.of_N (Z.abs_N ?a) ] => rewrite (N2Z.inj_abs_N a)
+  | H : context [ Z.of_N (Npos ?a) ] |- _ => rewrite (N2Z.inj_pos a) in H
+  | |- context [ Z.of_N (Npos ?a) ] => rewrite (N2Z.inj_pos a)
+  | H : context [ Z.of_N N0 ] |- _ => change (Z.of_N N0) with Z0 in H
+  | |- context [ Z.of_N N0 ] => change (Z.of_N N0) with Z0
+
+  (* N.add -> Z.add *)
+  | H : context [ Z.of_N (N.add ?a ?b) ] |- _ => rewrite (N2Z.inj_add a b) in H
+  | |- context [ Z.of_N (N.add ?a ?b) ] => rewrite (N2Z.inj_add a b)
+
+  (* N.min -> Z.min *)
+  | H : context [ Z.of_N (N.min ?a ?b) ] |- _ => rewrite (N2Z.inj_min a b) in H
+  | |- context [ Z.of_N (N.min ?a ?b) ] => rewrite (N2Z.inj_min a b)
+
+  (* N.max -> Z.max *)
+  | H : context [ Z.of_N (N.max ?a ?b) ] |- _ => rewrite (N2Z.inj_max a b) in H
+  | |- context [ Z.of_N (N.max ?a ?b) ] => rewrite (N2Z.inj_max a b)
+
+  (* N.sub -> Z.max 0 (Z.sub ... ...) *)
+  | H : context [ Z.of_N (N.sub ?a ?b) ] |- _ => rewrite (N2Z.inj_sub_max a b) in H
+  | |- context [ Z.of_N (N.sub ?a ?b) ] => rewrite (N2Z.inj_sub_max a b)
+
+  (* N.succ -> Z.succ *)
+  | H : context [ Z.of_N (N.succ ?a) ] |- _ => rewrite (N2Z.inj_succ a) in H
+  | |- context [ Z.of_N (N.succ ?a) ] => rewrite (N2Z.inj_succ a)
+
+  (* N.mul -> Z.mul and a positivity hypothesis *)
+  | H : context [ Z.of_N (N.mul ?a ?b) ] |- _ =>
+        pose proof (N2Z.is_nonneg (N.mul a b)); rewrite (N2Z.inj_mul a b) in *
+  | |- context [ Z.of_N  (N.mul ?a ?b) ] =>
+        pose proof (N2Z.is_nonneg (N.mul a b)); rewrite (N2Z.inj_mul 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 (N2Z.is_nonneg a); hide_Z_of_N a
+  | |- context [ Z.of_N ?a ] => pose proof (N2Z.is_nonneg 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..ffa99fc7 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-2012     *)
 (*   \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,11 @@ 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"]]
+let zbase_constant =
+  gen_constant_in_modules "Omega" [["Coq";"ZArith";"BinInt"]]
+
+
 (* Zarith *)
 let coq_xH = lazy (constant "xH")
 let coq_xO = lazy (constant "xO")
@@ -179,25 +184,26 @@ let coq_Zneg = lazy (constant "Zneg")
 let coq_Z = lazy (constant "Z")
 let coq_comparison = lazy (constant "comparison")
 let coq_Gt = lazy (constant "Gt")
-let coq_Zplus = lazy (constant "Zplus")
-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_Zgt = lazy (constant "Zgt")
-let coq_Zle = lazy (constant "Zle")
-let coq_Z_of_nat = lazy (constant "Z_of_nat")
-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_Zplus = lazy (zbase_constant "Z.add")
+let coq_Zmult = lazy (zbase_constant "Z.mul")
+let coq_Zopp = lazy (zbase_constant "Z.opp")
+let coq_Zminus = lazy (zbase_constant "Z.sub")
+let coq_Zsucc = lazy (zbase_constant "Z.succ")
+let coq_Zpred = lazy (zbase_constant "Z.pred")
+let coq_Zgt = lazy (zbase_constant "Z.gt")
+let coq_Zle = lazy (zbase_constant "Z.le")
+let coq_Z_of_nat = lazy (zbase_constant "Z.of_nat")
+let coq_inj_plus = lazy (z_constant "Nat2Z.inj_add")
+let coq_inj_mult = lazy (z_constant "Nat2Z.inj_mul")
+let coq_inj_minus1 = lazy (z_constant "Nat2Z.inj_sub")
 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 "Nat2Z.inj_succ")
+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")
@@ -247,24 +253,25 @@ let coq_Zle_left = lazy (constant "Zle_left")
 let coq_new_var = lazy (constant "new_var")
 let coq_intro_Z = lazy (constant "intro_Z")
 
-let coq_dec_eq = lazy (constant "dec_eq")
+let coq_dec_eq = lazy (zbase_constant "Z.eq_decidable")
 let coq_dec_Zne = lazy (constant "dec_Zne")
-let coq_dec_Zle = lazy (constant "dec_Zle")
-let coq_dec_Zlt = lazy (constant "dec_Zlt")
+let coq_dec_Zle = lazy (zbase_constant "Z.le_decidable")
+let coq_dec_Zlt = lazy (zbase_constant "Z.lt_decidable")
 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")
 let coq_Znot_gt_le = lazy (constant "Znot_gt_le")
 let coq_neq = lazy (constant "neq")
 let coq_Zne = lazy (constant "Zne")
-let coq_Zle = lazy (constant "Zle")
-let coq_Zgt = lazy (constant "Zgt")
-let coq_Zge = lazy (constant "Zge")
-let coq_Zlt = lazy (constant "Zlt")
+let coq_Zle = lazy (zbase_constant "Z.le")
+let coq_Zgt = lazy (zbase_constant "Z.gt")
+let coq_Zge = lazy (zbase_constant "Z.ge")
+let coq_Zlt = lazy (zbase_constant "Z.lt")
 
 (* Peano/Datatypes *)
 let coq_le = lazy (init_constant "le")
@@ -322,12 +329,13 @@ let evaluable_ref_of_constr s c = match kind_of_term (Lazy.force c) with
       EvalConstRef kn
   | _ -> anomaly ("Coq_omega: "^s^" is not an evaluable constant")
 
-let sp_Zsucc =     lazy (evaluable_ref_of_constr "Zsucc" coq_Zsucc)
-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)
-let sp_Zge = lazy (evaluable_ref_of_constr "Zge" coq_Zge)
-let sp_Zlt = lazy (evaluable_ref_of_constr "Zlt" coq_Zlt)
+let sp_Zsucc =     lazy (evaluable_ref_of_constr "Z.succ" coq_Zsucc)
+let sp_Zpred =     lazy (evaluable_ref_of_constr "Z.pred" coq_Zpred)
+let sp_Zminus = lazy (evaluable_ref_of_constr "Z.sub" coq_Zminus)
+let sp_Zle = lazy (evaluable_ref_of_constr "Z.le" coq_Zle)
+let sp_Zgt = lazy (evaluable_ref_of_constr "Z.gt" coq_Zgt)
+let sp_Zge = lazy (evaluable_ref_of_constr "Z.ge" coq_Zge)
+let sp_Zlt = lazy (evaluable_ref_of_constr "Z.lt" coq_Zlt)
 let sp_not = lazy (evaluable_ref_of_constr "not" (lazy (build_coq_not ())))
 
 let mk_var v = mkVar (id_of_string v)
@@ -356,7 +364,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 +384,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 +425,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 =
@@ -869,7 +885,7 @@ let rec transform p t =
     try
       let v,th,_ = find_constr t' in
       [clever_rewrite_base p (mkVar v) (mkVar th)], Oatom v
-    with _ ->
+    with e when Errors.noncritical e ->
       let v = new_identifier_var ()
       and th = new_identifier () in
       hide_constr t' v th isnat;
@@ -891,6 +907,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
@@ -904,7 +924,8 @@ let rec transform p t =
          | _ -> default false t
        end
    | Kapp((Zpos|Zneg|Z0),_) ->
-       (try ([],Oz(recognize_number t)) with _ -> default false t)
+       (try ([],Oz(recognize_number t))
+        with e when Errors.noncritical e -> default false t)
    | Kvar s -> [],Oatom s
    | Kapp(Zopp,[t]) ->
        let tac,t' = transform (P_APP 1 :: p) t in
@@ -1548,6 +1569,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 +1613,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 +1641,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 +1662,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 +1695,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 +1779,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 +1797,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..1542b60c 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-2012     *)
 (*   \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..98cad09e 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-2012     *)
 (*   \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..787995ed 100644
--- a/plugins/pluginsbyte.itarget
+++ b/plugins/pluginsbyte.itarget
@@ -1,13 +1,13 @@
 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
 romega/romega_plugin.cma
 omega/omega_plugin.cma
 micromega/micromega_plugin.cma
-dp/dp_plugin.cma
 xml/xml_plugin.cma
 subtac/subtac_plugin.cma
 ring/ring_plugin.cma
diff --git a/plugins/pluginsdyn.itarget b/plugins/pluginsdyn.itarget
index 5d502411..bd3cec01 100644
--- a/plugins/pluginsdyn.itarget
+++ b/plugins/pluginsdyn.itarget
@@ -1,13 +1,13 @@
 field/field_plugin.cmxs
 setoid_ring/newring_plugin.cmxs
 extraction/extraction_plugin.cmxs
+decl_mode/decl_mode_plugin.cmxs
 firstorder/ground_plugin.cmxs
 rtauto/rtauto_plugin.cmxs
 fourier/fourier_plugin.cmxs
 romega/romega_plugin.cmxs
 omega/omega_plugin.cmxs
 micromega/micromega_plugin.cmxs
-dp/dp_plugin.cmxs
 xml/xml_plugin.cmxs
 subtac/subtac_plugin.cmxs
 ring/ring_plugin.cmxs
diff --git a/plugins/pluginsopt.itarget b/plugins/pluginsopt.itarget
index 2f72dab8..5264ba37 100644
--- a/plugins/pluginsopt.itarget
+++ b/plugins/pluginsopt.itarget
@@ -1,13 +1,13 @@
 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
 romega/romega_plugin.cmxa
 omega/omega_plugin.cmxa
 micromega/micromega_plugin.cmxa
-dp/dp_plugin.cmxa
 xml/xml_plugin.cmxa
 subtac/subtac_plugin.cmxa
 ring/ring_plugin.cmxa
diff --git a/plugins/pluginsvo.itarget b/plugins/pluginsvo.itarget
index db56534c..bab15ad0 100644
--- a/plugins/pluginsvo.itarget
+++ b/plugins/pluginsvo.itarget
@@ -1,4 +1,3 @@
-dp/vo.otarget
 field/vo.otarget
 fourier/vo.otarget
 funind/vo.otarget
@@ -10,4 +9,4 @@ ring/vo.otarget
 romega/vo.otarget
 rtauto/vo.otarget
 setoid_ring/vo.otarget
-extraction/vo.otarget
\ No newline at end of file
+extraction/vo.otarget
diff --git a/plugins/quote/Quote.v b/plugins/quote/Quote.v
index 55bb8bae..2206aedf 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-2012     *)
 (*   \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.
 
@@ -70,7 +67,7 @@ Fixpoint index_lt (n m:index) {struct m} : bool :=
   end.
 
 Lemma index_eq_prop : forall n m:index, index_eq n m = true -> n = m.
-  simple induction n; simple induction m; simpl in |- *; intros.
+  simple induction n; simple induction m; simpl; intros.
   rewrite (H i0 H1); reflexivity.
   discriminate.
   discriminate.
diff --git a/plugins/quote/g_quote.ml4 b/plugins/quote/g_quote.ml4
index 3c51223a..09b780fd 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-2012     *)
 (*   \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..216a719d 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-2012     *)
 (*   \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) ->
@@ -224,7 +221,10 @@ let compute_rhs bodyi index_of_f =
 (*s Now the function [compute_ivs] itself *)
 
 let compute_ivs gl f cs =
-  let cst = try destConst f with _ -> i_can't_do_that () in
+  let cst =
+    try destConst f
+    with e when Errors.noncritical e -> i_can't_do_that ()
+  in
   let body = Environ.constant_value (Global.env()) cst in
   match decomp_term body with
     | Fix(([| len |], 0), ([| name |], [| typ |], [| body2 |])) ->
@@ -243,7 +243,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 +373,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 +393,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 +422,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 +430,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 +478,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..089dec02 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-2012     *)
 (*   \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.
@@ -15,9 +13,9 @@ Require Export LegacyRing.
 Require Export Arith.
 Require Import Eqdep_dec.
 
-Open Local Scope nat_scope.
+Local Open 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'
@@ -77,14 +75,14 @@ Ltac rewrite_S_to_plus :=
        (**)  (**)
        rewrite_S_to_plus_term X1
        with t2 := rewrite_S_to_plus_term X2 in
-       change (t1 = t2) in |- *
+       change (t1 = t2)
   |  |- (?X1 = ?X2) =>
       try
        let t1 :=
        (**)  (**)
        rewrite_S_to_plus_term X1
        with t2 := rewrite_S_to_plus_term X2 in
-       change (t1 = t2) in |- *
+       change (t1 = t2)
   end.
 
 Ltac ring_nat := rewrite_S_to_plus; ring.
diff --git a/plugins/ring/LegacyNArithRing.v b/plugins/ring/LegacyNArithRing.v
index ae7e62e0..7f1597a1 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-2012     *)
 (*   \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
@@ -24,23 +22,22 @@ Unboxed Definition Neq (n m:N) :=
 
 Lemma Neq_prop : forall n m:N, Is_true (Neq n m) -> n = m.
   intros n m H; unfold Neq in H.
-  apply Ncompare_Eq_eq.
+  apply N.compare_eq.
   destruct (n ?= m)%N; [ reflexivity | contradiction | contradiction ].
 Qed.
 
-Definition NTheory : Semi_Ring_Theory Nplus Nmult 1%N 0%N Neq.
+Definition NTheory : Semi_Ring_Theory N.add N.mul 1%N 0%N Neq.
   split.
-    apply Nplus_comm.
-    apply Nplus_assoc.
-    apply Nmult_comm.
-    apply Nmult_assoc.
-    apply Nplus_0_l.
-    apply Nmult_1_l.
-    apply Nmult_0_l.
-    apply Nmult_plus_distr_r.
-(*    apply Nplus_reg_l.*)
+    apply N.add_comm.
+    apply N.add_assoc.
+    apply N.mul_comm.
+    apply N.mul_assoc.
+    apply N.add_0_l.
+    apply N.mul_1_l.
+    apply N.mul_0_l.
+    apply N.mul_add_distr_r.
     apply Neq_prop.
 Qed.
 
 Add Legacy Semi Ring
-  N Nplus Nmult 1%N 0%N Neq NTheory [ Npos 0%N xO xI 1%positive ].
+  N N.add N.mul 1%N 0%N Neq NTheory [ Npos 0%N xO xI 1%positive ].
diff --git a/plugins/ring/LegacyRing.v b/plugins/ring/LegacyRing.v
index e53e60d3..d4f40081 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-2012     *)
 (*   \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.
@@ -21,7 +19,7 @@ Declare ML Module "ring_plugin".
 
 Definition BoolTheory :
   Ring_Theory xorb andb true false (fun b:bool => b) eqb.
-split; simpl in |- *.
+split; simpl.
 destruct n; destruct m; reflexivity.
 destruct n; destruct m; destruct p; reflexivity.
 destruct n; destruct m; reflexivity.
@@ -30,7 +28,7 @@ destruct n; reflexivity.
 destruct n; reflexivity.
 destruct n; reflexivity.
 destruct n; destruct m; destruct p; reflexivity.
-destruct x; destruct y; reflexivity || simpl in |- *; tauto.
+destruct x; destruct y; reflexivity || simpl; tauto.
 Defined.
 
 Add Legacy Ring bool xorb andb true false (fun b:bool => b) eqb BoolTheory
diff --git a/plugins/ring/LegacyRing_theory.v b/plugins/ring/LegacyRing_theory.v
index bf61aee1..09de1bb4 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-2012     *)
 (*   \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.
@@ -60,22 +58,22 @@ Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left
 (* Lemmas whose form is x=y are also provided in form y=x because Auto does
   not symmetry *)
 Lemma SR_mult_assoc2 : forall n m p:A, n * m * p = n * (m * p).
-symmetry  in |- *; eauto. Qed.
+symmetry ; eauto. Qed.
 
 Lemma SR_plus_assoc2 : forall n m p:A, n + m + p = n + (m + p).
-symmetry  in |- *; eauto. Qed.
+symmetry ; eauto. Qed.
 
 Lemma SR_plus_zero_left2 : forall n:A, n = 0 + n.
-symmetry  in |- *; eauto. Qed.
+symmetry ; eauto. Qed.
 
 Lemma SR_mult_one_left2 : forall n:A, n = 1 * n.
-symmetry  in |- *; eauto. Qed.
+symmetry ; eauto. Qed.
 
 Lemma SR_mult_zero_left2 : forall n:A, 0 = 0 * n.
-symmetry  in |- *; eauto. Qed.
+symmetry ; eauto. Qed.
 
 Lemma SR_distr_left2 : forall n m p:A, n * p + m * p = (n + m) * p.
-symmetry  in |- *; eauto. Qed.
+symmetry ; eauto. Qed.
 
 Lemma SR_plus_permute : forall n m p:A, n + (m + p) = m + (n + p).
 intros.
@@ -102,7 +100,7 @@ eauto.
 Qed.
 
 Lemma SR_distr_right2 : forall n m p:A, n * m + n * p = n * (m + p).
-symmetry  in |- *; apply SR_distr_right. Qed.
+symmetry ; apply SR_distr_right. Qed.
 
 Lemma SR_mult_zero_right : forall n:A, n * 0 = 0.
 intro; rewrite mult_comm; eauto.
@@ -178,22 +176,22 @@ Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left
 (* Lemmas whose form is x=y are also provided in form y=x because Auto does
   not symmetry *)
 Lemma Th_mult_assoc2 : forall n m p:A, n * m * p = n * (m * p).
-symmetry  in |- *; eauto. Qed.
+symmetry ; eauto. Qed.
 
 Lemma Th_plus_assoc2 : forall n m p:A, n + m + p = n + (m + p).
-symmetry  in |- *; eauto. Qed.
+symmetry ; eauto. Qed.
 
 Lemma Th_plus_zero_left2 : forall n:A, n = 0 + n.
-symmetry  in |- *; eauto. Qed.
+symmetry ; eauto. Qed.
 
 Lemma Th_mult_one_left2 : forall n:A, n = 1 * n.
-symmetry  in |- *; eauto. Qed.
+symmetry ; eauto. Qed.
 
 Lemma Th_distr_left2 : forall n m p:A, n * p + m * p = (n + m) * p.
-symmetry  in |- *; eauto. Qed.
+symmetry ; eauto. Qed.
 
 Lemma Th_opp_def2 : forall n:A, 0 = n + - n.
-symmetry  in |- *; eauto. Qed.
+symmetry ; eauto. Qed.
 
 Lemma Th_plus_permute : forall n m p:A, n + (m + p) = m + (n + p).
 intros.
@@ -216,7 +214,7 @@ Hint Resolve Th_plus_permute Th_mult_permute.
 Lemma aux1 : forall a:A, a + a = a -> a = 0.
 intros.
 generalize (opp_def a).
-pattern a at 1 in |- *.
+pattern a at 1.
 rewrite <- H.
 rewrite <- plus_assoc.
 rewrite opp_def.
@@ -235,7 +233,7 @@ Qed.
 Hint Resolve Th_mult_zero_left.
 
 Lemma Th_mult_zero_left2 : forall n:A, 0 = 0 * n.
-symmetry  in |- *; eauto. Qed.
+symmetry ; eauto. Qed.
 
 Lemma aux2 : forall x y z:A, x + y = 0 -> x + z = 0 -> y = z.
 intros.
@@ -257,7 +255,7 @@ Qed.
 Hint Resolve Th_opp_mult_left.
 
 Lemma Th_opp_mult_left2 : forall x y:A, - x * y = - (x * y).
-symmetry  in |- *; eauto. Qed.
+symmetry ; eauto. Qed.
 
 Lemma Th_mult_zero_right : forall n:A, n * 0 = 0.
 intro; elim mult_comm; eauto.
@@ -308,14 +306,14 @@ Qed.
 Hint Resolve Th_opp_opp.
 
 Lemma Th_opp_opp2 : forall n:A, n = - - n.
-symmetry  in |- *; eauto. Qed.
+symmetry ; eauto. Qed.
 
 Lemma Th_mult_opp_opp : forall x y:A, - x * - y = x * y.
 intros; rewrite <- Th_opp_mult_left; rewrite <- Th_opp_mult_right; auto.
 Qed.
 
 Lemma Th_mult_opp_opp2 : forall x y:A, x * y = - x * - y.
-symmetry  in |- *; apply Th_mult_opp_opp. Qed.
+symmetry ; apply Th_mult_opp_opp. Qed.
 
 Lemma Th_opp_zero : - 0 = 0.
 rewrite <- (plus_zero_left (- 0)).
@@ -344,7 +342,7 @@ eauto.
 Qed.
 
 Lemma Th_distr_right2 : forall n m p:A, n * m + n * p = n * (m + p).
-symmetry  in |- *; apply Th_distr_right.
+symmetry ; apply Th_distr_right.
 Qed.
 
 End Theory_of_rings.
@@ -359,7 +357,7 @@ Definition Semi_Ring_Theory_of :
     Ring_Theory Aplus Amult Aone Azero Aopp Aeq ->
     Semi_Ring_Theory Aplus Amult Aone Azero Aeq.
 intros until 1; case H.
-split; intros; simpl in |- *; eauto.
+split; intros; simpl; eauto.
 Defined.
 
 (* Every ring can be viewed as a semi-ring : this property will be used
diff --git a/plugins/ring/LegacyZArithRing.v b/plugins/ring/LegacyZArithRing.v
index d1412104..3f01a5c3 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-2012     *)
 (*   \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
@@ -23,15 +21,15 @@ Unboxed Definition Zeq (x y:Z) :=
 
 Lemma Zeq_prop : forall x y:Z, Is_true (Zeq x y) -> x = y.
   intros x y H; unfold Zeq in H.
-  apply Zcompare_Eq_eq.
+  apply Z.compare_eq.
   destruct (x ?= y)%Z; [ reflexivity | contradiction | contradiction ].
 Qed.
 
-Definition ZTheory : Ring_Theory Zplus Zmult 1%Z 0%Z Zopp Zeq.
+Definition ZTheory : Ring_Theory Z.add Z.mul 1%Z 0%Z Z.opp Zeq.
   split; intros; eauto with zarith.
   apply Zeq_prop; assumption.
 Qed.
 
 (* NatConstants and NatTheory are defined in Ring_theory.v *)
-Add Legacy Ring Z Zplus Zmult 1%Z 0%Z Zopp Zeq ZTheory
+Add Legacy Ring Z Z.add Z.mul 1%Z 0%Z Z.opp Zeq ZTheory
  [ Zpos Zneg 0%Z xO xI 1%positive ].
diff --git a/plugins/ring/Ring_abstract.v b/plugins/ring/Ring_abstract.v
index e6e2dda9..a00b7bcd 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-2012     *)
 (*   \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 :=
@@ -141,14 +137,13 @@ Hint Resolve (SR_plus_zero_right2 T).
 Hint Resolve (SR_mult_one_right T).
 Hint Resolve (SR_mult_one_right2 T).
 (*Hint Resolve (SR_plus_reg_right T).*)
-Hint Resolve refl_equal sym_equal trans_equal.
-(*Hints Resolve refl_eqT sym_eqT trans_eqT.*)
+Hint Resolve eq_refl eq_sym eq_trans.
 Hint Immediate T.
 
 Remark iacs_aux_ok :
  forall (x:A) (s:abstract_sum), iacs_aux x s = Aplus x (interp_acs s).
 Proof.
-  simple induction s; simpl in |- *; intros.
+  simple induction s; simpl; intros.
   trivial.
   reflexivity.
 Qed.
@@ -163,8 +158,8 @@ Lemma abstract_varlist_insert_ok :
   simple induction s.
   trivial.
 
-  simpl in |- *; intros.
-  elim (varlist_lt l v); simpl in |- *.
+  simpl; intros.
+  elim (varlist_lt l v); simpl.
   eauto.
   rewrite iacs_aux_ok.
   rewrite H; auto.
@@ -182,13 +177,13 @@ Proof.
 
   auto.
 
-  simpl in |- *; elim (varlist_lt v v0); simpl in |- *.
+  simpl; elim (varlist_lt v v0); simpl.
   repeat rewrite iacs_aux_ok.
-  rewrite H; simpl in |- *; auto.
+  rewrite H; simpl; auto.
 
   simpl in H0.
   repeat rewrite iacs_aux_ok.
-  rewrite H0. simpl in |- *; auto.
+  rewrite H0. simpl; auto.
 Qed.
 
 Lemma abstract_sum_scalar_ok :
@@ -197,9 +192,9 @@ Lemma abstract_sum_scalar_ok :
    Amult (interp_vl Amult Aone Azero vm l) (interp_acs s).
 Proof.
   simple induction s.
-  simpl in |- *; eauto.
+  simpl; eauto.
 
-  simpl in |- *; intros.
+  simpl; intros.
   rewrite iacs_aux_ok.
   rewrite abstract_varlist_insert_ok.
   rewrite H.
@@ -213,22 +208,22 @@ Lemma abstract_sum_prod_ok :
 
 Proof.
   simple induction x.
-  intros; simpl in |- *; eauto.
+  intros; simpl; eauto.
 
   destruct y as [| v0 a0]; intros.
 
-  simpl in |- *; rewrite H; eauto.
+  simpl; rewrite H; eauto.
 
-  unfold abstract_sum_prod in |- *; fold abstract_sum_prod in |- *.
+  unfold abstract_sum_prod; fold abstract_sum_prod.
   rewrite abstract_sum_merge_ok.
   rewrite abstract_sum_scalar_ok.
-  rewrite H; simpl in |- *; auto.
+  rewrite H; simpl; auto.
 Qed.
 
 Theorem aspolynomial_normalize_ok :
  forall x:aspolynomial, interp_asp x = interp_acs (aspolynomial_normalize x).
 Proof.
-  simple induction x; simpl in |- *; intros; trivial.
+  simple induction x; simpl; intros; trivial.
   rewrite abstract_sum_merge_ok.
   rewrite H; rewrite H0; eauto.
   rewrite abstract_sum_prod_ok.
@@ -450,14 +445,13 @@ Hint Resolve (Th_plus_zero_right2 T).
 Hint Resolve (Th_mult_one_right T).
 Hint Resolve (Th_mult_one_right2 T).
 (*Hint Resolve (Th_plus_reg_right T).*)
-Hint Resolve refl_equal sym_equal trans_equal.
-(*Hints Resolve refl_eqT sym_eqT trans_eqT.*)
+Hint Resolve eq_refl eq_sym eq_trans.
 Hint Immediate T.
 
 Lemma isacs_aux_ok :
  forall (x:A) (s:signed_sum), isacs_aux x s = Aplus x (interp_sacs s).
 Proof.
-  simple induction s; simpl in |- *; intros.
+  simple induction s; simpl; intros.
   trivial.
   reflexivity.
   reflexivity.
@@ -466,15 +460,15 @@ Qed.
 Hint Extern 10 (_ = _ :>A) => rewrite isacs_aux_ok: core.
 
 Ltac solve1 v v0 H H0 :=
-  simpl in |- *; elim (varlist_lt v v0); simpl in |- *; rewrite isacs_aux_ok;
-   [ rewrite H; simpl in |- *; auto | simpl in H0; rewrite H0; auto ].
+  simpl; elim (varlist_lt v v0); simpl; rewrite isacs_aux_ok;
+   [ rewrite H; simpl; auto | simpl in H0; rewrite H0; auto ].
 
 Lemma signed_sum_merge_ok :
  forall x y:signed_sum,
    interp_sacs (signed_sum_merge x y) = Aplus (interp_sacs x) (interp_sacs y).
 
   simple induction x.
-  intro; simpl in |- *; auto.
+  intro; simpl; auto.
 
   simple induction y; intros.
 
@@ -482,8 +476,8 @@ Lemma signed_sum_merge_ok :
 
   solve1 v v0 H H0.
 
-  simpl in |- *; generalize (varlist_eq_prop v v0).
-  elim (varlist_eq v v0); simpl in |- *.
+  simpl; generalize (varlist_eq_prop v v0).
+  elim (varlist_eq v v0); simpl.
 
   intro Heq; rewrite (Heq I).
   rewrite H.
@@ -503,8 +497,8 @@ Lemma signed_sum_merge_ok :
 
   auto.
 
-  simpl in |- *; generalize (varlist_eq_prop v v0).
-  elim (varlist_eq v v0); simpl in |- *.
+  simpl; generalize (varlist_eq_prop v v0).
+  elim (varlist_eq v v0); simpl.
 
   intro Heq; rewrite (Heq I).
   rewrite H.
@@ -522,7 +516,7 @@ Lemma signed_sum_merge_ok :
 Qed.
 
 Ltac solve2 l v H :=
-  elim (varlist_lt l v); simpl in |- *; rewrite isacs_aux_ok;
+  elim (varlist_lt l v); simpl; rewrite isacs_aux_ok;
    [ auto | rewrite H; auto ].
 
 Lemma plus_varlist_insert_ok :
@@ -534,12 +528,12 @@ Proof.
   simple induction s.
   trivial.
 
-  simpl in |- *; intros.
+  simpl; intros.
   solve2 l v H.
 
-  simpl in |- *; intros.
+  simpl; intros.
   generalize (varlist_eq_prop l v).
-  elim (varlist_eq l v); simpl in |- *.
+  elim (varlist_eq l v); simpl.
 
   intro Heq; rewrite (Heq I).
   repeat rewrite isacs_aux_ok.
@@ -561,9 +555,9 @@ Proof.
   simple induction s.
   trivial.
 
-  simpl in |- *; intros.
+  simpl; intros.
   generalize (varlist_eq_prop l v).
-  elim (varlist_eq l v); simpl in |- *.
+  elim (varlist_eq l v); simpl.
 
   intro Heq; rewrite (Heq I).
   repeat rewrite isacs_aux_ok.
@@ -574,10 +568,10 @@ Proof.
   rewrite (Th_opp_def T).
   auto.
 
-  simpl in |- *; intros.
+  simpl; intros.
   solve2 l v H.
 
-  simpl in |- *; intros; solve2 l v H.
+  simpl; intros; solve2 l v H.
 
 Qed.
 
@@ -585,9 +579,9 @@ Lemma signed_sum_opp_ok :
  forall s:signed_sum, interp_sacs (signed_sum_opp s) = Aopp (interp_sacs s).
 Proof.
 
-  simple induction s; simpl in |- *; intros.
+  simple induction s; simpl; intros.
 
-  symmetry  in |- *; apply (Th_opp_zero T).
+  symmetry ; apply (Th_opp_zero T).
 
   repeat rewrite isacs_aux_ok.
   rewrite H.
@@ -611,14 +605,14 @@ Proof.
   simple induction s.
   trivial.
 
-  simpl in |- *; intros.
+  simpl; intros.
   rewrite plus_varlist_insert_ok.
   rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T).
   repeat rewrite isacs_aux_ok.
   rewrite H.
   auto.
 
-  simpl in |- *; intros.
+  simpl; intros.
   rewrite minus_varlist_insert_ok.
   repeat rewrite isacs_aux_ok.
   rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T).
@@ -635,11 +629,11 @@ Lemma minus_sum_scalar_ok :
    Aopp (Amult (interp_vl Amult Aone Azero vm l) (interp_sacs s)).
 Proof.
 
-  simple induction s; simpl in |- *; intros.
+  simple induction s; simpl; intros.
 
-  rewrite (Th_mult_zero_right T); symmetry  in |- *; apply (Th_opp_zero T).
+  rewrite (Th_mult_zero_right T); symmetry ; apply (Th_opp_zero T).
 
-  simpl in |- *; intros.
+  simpl; intros.
   rewrite minus_varlist_insert_ok.
   rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T).
   repeat rewrite isacs_aux_ok.
@@ -648,7 +642,7 @@ Proof.
   rewrite (Th_plus_opp_opp T).
   reflexivity.
 
-  simpl in |- *; intros.
+  simpl; intros.
   rewrite plus_varlist_insert_ok.
   repeat rewrite isacs_aux_ok.
   rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T).
@@ -668,16 +662,16 @@ Proof.
 
   simple induction x.
 
-  simpl in |- *; eauto 1.
+  simpl; eauto 1.
 
-  intros; simpl in |- *.
+  intros; simpl.
   rewrite signed_sum_merge_ok.
   rewrite plus_sum_scalar_ok.
   repeat rewrite isacs_aux_ok.
   rewrite H.
   auto.
 
-  intros; simpl in |- *.
+  intros; simpl.
   repeat rewrite isacs_aux_ok.
   rewrite signed_sum_merge_ok.
   rewrite minus_sum_scalar_ok.
@@ -691,7 +685,7 @@ Qed.
 Theorem apolynomial_normalize_ok :
  forall p:apolynomial, interp_sacs (apolynomial_normalize p) = interp_ap p.
 Proof.
-  simple induction p; simpl in |- *; auto 1.
+  simple induction p; simpl; auto 1.
   intros.
     rewrite signed_sum_merge_ok.
     rewrite H; rewrite H0; reflexivity.
diff --git a/plugins/ring/Ring_normalize.v b/plugins/ring/Ring_normalize.v
index dd4e7314..d286208a 100644
--- a/plugins/ring/Ring_normalize.v
+++ b/plugins/ring/Ring_normalize.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-2012     *)
 (*   \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.
   intros.
   apply index_eq_prop.
   generalize H.
-  case (index_eq n m); simpl in |- *; trivial; intros.
+  case (index_eq n m); simpl; trivial; intros.
   contradiction.
 Qed.
 
@@ -368,14 +365,13 @@ Hint Resolve (SR_plus_zero_right2 T).
 Hint Resolve (SR_mult_one_right T).
 Hint Resolve (SR_mult_one_right2 T).
 (*Hint Resolve (SR_plus_reg_right T).*)
-Hint Resolve refl_equal sym_equal trans_equal.
-(* Hints Resolve refl_eqT sym_eqT trans_eqT. *)
+Hint Resolve eq_refl eq_sym eq_trans.
 Hint Immediate T.
 
 Lemma varlist_eq_prop : forall x y:varlist, Is_true (varlist_eq x y) -> x = y.
 Proof.
   simple induction x; simple induction y; contradiction || (try reflexivity).
-  simpl in |- *; intros.
+  simpl; intros.
   generalize (andb_prop2 _ _ H1); intros; elim H2; intros.
   rewrite (index_eq_prop _ _ H3); rewrite (H v0 H4); reflexivity.
 Qed.
@@ -384,7 +380,7 @@ Remark ivl_aux_ok :
  forall (v:varlist) (i:index),
    ivl_aux i v = Amult (interp_var i) (interp_vl v).
 Proof.
-  simple induction v; simpl in |- *; intros.
+  simple induction v; simpl; intros.
   trivial.
   rewrite H; trivial.
 Qed.
@@ -394,14 +390,14 @@ Lemma varlist_merge_ok :
    interp_vl (varlist_merge x y) = Amult (interp_vl x) (interp_vl y).
 Proof.
   simple induction x.
-  simpl in |- *; trivial.
+  simpl; trivial.
   simple induction y.
-  simpl in |- *; trivial.
-  simpl in |- *; intros.
-  elim (index_lt i i0); simpl in |- *; intros.
+  simpl; trivial.
+  simpl; intros.
+  elim (index_lt i i0); simpl; intros.
 
   repeat rewrite ivl_aux_ok.
-  rewrite H. simpl in |- *.
+  rewrite H. simpl.
   rewrite ivl_aux_ok.
   eauto.
 
@@ -414,7 +410,7 @@ Qed.
 Remark ics_aux_ok :
  forall (x:A) (s:canonical_sum), ics_aux x s = Aplus x (interp_cs s).
 Proof.
-  simple induction s; simpl in |- *; intros.
+  simple induction s; simpl; intros.
   trivial.
   reflexivity.
   reflexivity.
@@ -424,7 +420,7 @@ Remark interp_m_ok :
  forall (x:A) (l:varlist), interp_m x l = Amult x (interp_vl l).
 Proof.
   destruct l as [| i v].
-  simpl in |- *; trivial.
+  simpl; trivial.
   reflexivity.
 Qed.
 
@@ -432,10 +428,10 @@ Lemma canonical_sum_merge_ok :
  forall x y:canonical_sum,
    interp_cs (canonical_sum_merge x y) = Aplus (interp_cs x) (interp_cs y).
 
-simple induction x; simpl in |- *.
+simple induction x; simpl.
 trivial.
 
-simple induction y; simpl in |- *; intros.
+simple induction y; simpl; intros.
 (* monom and nil *)
 eauto.
 
@@ -443,25 +439,25 @@ eauto.
 generalize (varlist_eq_prop v v0).
 elim (varlist_eq v v0).
 intros; rewrite (H1 I).
-simpl in |- *; repeat rewrite ics_aux_ok; rewrite H.
+simpl; repeat rewrite ics_aux_ok; rewrite H.
 repeat rewrite interp_m_ok.
 rewrite (SR_distr_left T).
 repeat rewrite <- (SR_plus_assoc T).
 apply f_equal with (f := Aplus (Amult a (interp_vl v0))).
 trivial.
 
-elim (varlist_lt v v0); simpl in |- *.
+elim (varlist_lt v v0); simpl.
 repeat rewrite ics_aux_ok.
-rewrite H; simpl in |- *; rewrite ics_aux_ok; eauto.
+rewrite H; simpl; rewrite ics_aux_ok; eauto.
 
-rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl in |- *;
+rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl;
  eauto.
 
 (* monom and varlist *)
 generalize (varlist_eq_prop v v0).
 elim (varlist_eq v v0).
 intros; rewrite (H1 I).
-simpl in |- *; repeat rewrite ics_aux_ok; rewrite H.
+simpl; repeat rewrite ics_aux_ok; rewrite H.
 repeat rewrite interp_m_ok.
 rewrite (SR_distr_left T).
 repeat rewrite <- (SR_plus_assoc T).
@@ -469,13 +465,13 @@ apply f_equal with (f := Aplus (Amult a (interp_vl v0))).
 rewrite (SR_mult_one_left T).
 trivial.
 
-elim (varlist_lt v v0); simpl in |- *.
+elim (varlist_lt v v0); simpl.
 repeat rewrite ics_aux_ok.
-rewrite H; simpl in |- *; rewrite ics_aux_ok; eauto.
-rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl in |- *;
+rewrite H; simpl; rewrite ics_aux_ok; eauto.
+rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl;
  eauto.
 
-simple induction y; simpl in |- *; intros.
+simple induction y; simpl; intros.
 (* varlist and nil *)
 trivial.
 
@@ -483,7 +479,7 @@ trivial.
 generalize (varlist_eq_prop v v0).
 elim (varlist_eq v v0).
 intros; rewrite (H1 I).
-simpl in |- *; repeat rewrite ics_aux_ok; rewrite H.
+simpl; repeat rewrite ics_aux_ok; rewrite H.
 repeat rewrite interp_m_ok.
 rewrite (SR_distr_left T).
 repeat rewrite <- (SR_plus_assoc T).
@@ -491,17 +487,17 @@ rewrite (SR_mult_one_left T).
 apply f_equal with (f := Aplus (interp_vl v0)).
 trivial.
 
-elim (varlist_lt v v0); simpl in |- *.
+elim (varlist_lt v v0); simpl.
 repeat rewrite ics_aux_ok.
-rewrite H; simpl in |- *; rewrite ics_aux_ok; eauto.
-rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl in |- *;
+rewrite H; simpl; rewrite ics_aux_ok; eauto.
+rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl;
  eauto.
 
 (* varlist and varlist *)
 generalize (varlist_eq_prop v v0).
 elim (varlist_eq v v0).
 intros; rewrite (H1 I).
-simpl in |- *; repeat rewrite ics_aux_ok; rewrite H.
+simpl; repeat rewrite ics_aux_ok; rewrite H.
 repeat rewrite interp_m_ok.
 rewrite (SR_distr_left T).
 repeat rewrite <- (SR_plus_assoc T).
@@ -509,10 +505,10 @@ rewrite (SR_mult_one_left T).
 apply f_equal with (f := Aplus (interp_vl v0)).
 trivial.
 
-elim (varlist_lt v v0); simpl in |- *.
+elim (varlist_lt v v0); simpl.
 repeat rewrite ics_aux_ok.
-rewrite H; simpl in |- *; rewrite ics_aux_ok; eauto.
-rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl in |- *;
+rewrite H; simpl; rewrite ics_aux_ok; eauto.
+rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl;
  eauto.
 Qed.
 
@@ -522,24 +518,24 @@ Lemma monom_insert_ok :
    Aplus (Amult a (interp_vl l)) (interp_cs s).
 intros; generalize s; simple induction s0.
 
-simpl in |- *; rewrite interp_m_ok; trivial.
+simpl; rewrite interp_m_ok; trivial.
 
-simpl in |- *; intros.
+simpl; intros.
 generalize (varlist_eq_prop l v); elim (varlist_eq l v).
-intro Hr; rewrite (Hr I); simpl in |- *; rewrite interp_m_ok;
+intro Hr; rewrite (Hr I); simpl; rewrite interp_m_ok;
  repeat rewrite ics_aux_ok; rewrite interp_m_ok; rewrite (SR_distr_left T);
  eauto.
-elim (varlist_lt l v); simpl in |- *;
+elim (varlist_lt l v); simpl;
  [ repeat rewrite interp_m_ok; rewrite ics_aux_ok; eauto
  | repeat rewrite interp_m_ok; rewrite ics_aux_ok; rewrite H;
     rewrite ics_aux_ok; eauto ].
 
-simpl in |- *; intros.
+simpl; intros.
 generalize (varlist_eq_prop l v); elim (varlist_eq l v).
-intro Hr; rewrite (Hr I); simpl in |- *; rewrite interp_m_ok;
+intro Hr; rewrite (Hr I); simpl; rewrite interp_m_ok;
  repeat rewrite ics_aux_ok; rewrite (SR_distr_left T);
  rewrite (SR_mult_one_left T); eauto.
-elim (varlist_lt l v); simpl in |- *;
+elim (varlist_lt l v); simpl;
  [ repeat rewrite interp_m_ok; rewrite ics_aux_ok; eauto
  | repeat rewrite interp_m_ok; rewrite ics_aux_ok; rewrite H;
     rewrite ics_aux_ok; eauto ].
@@ -550,24 +546,24 @@ Lemma varlist_insert_ok :
    interp_cs (varlist_insert l s) = Aplus (interp_vl l) (interp_cs s).
 intros; generalize s; simple induction s0.
 
-simpl in |- *; trivial.
+simpl; trivial.
 
-simpl in |- *; intros.
+simpl; intros.
 generalize (varlist_eq_prop l v); elim (varlist_eq l v).
-intro Hr; rewrite (Hr I); simpl in |- *; rewrite interp_m_ok;
+intro Hr; rewrite (Hr I); simpl; rewrite interp_m_ok;
  repeat rewrite ics_aux_ok; rewrite interp_m_ok; rewrite (SR_distr_left T);
  rewrite (SR_mult_one_left T); eauto.
-elim (varlist_lt l v); simpl in |- *;
+elim (varlist_lt l v); simpl;
  [ repeat rewrite interp_m_ok; rewrite ics_aux_ok; eauto
  | repeat rewrite interp_m_ok; rewrite ics_aux_ok; rewrite H;
     rewrite ics_aux_ok; eauto ].
 
-simpl in |- *; intros.
+simpl; intros.
 generalize (varlist_eq_prop l v); elim (varlist_eq l v).
-intro Hr; rewrite (Hr I); simpl in |- *; rewrite interp_m_ok;
+intro Hr; rewrite (Hr I); simpl; rewrite interp_m_ok;
  repeat rewrite ics_aux_ok; rewrite (SR_distr_left T);
  rewrite (SR_mult_one_left T); eauto.
-elim (varlist_lt l v); simpl in |- *;
+elim (varlist_lt l v); simpl;
  [ repeat rewrite interp_m_ok; rewrite ics_aux_ok; eauto
  | repeat rewrite interp_m_ok; rewrite ics_aux_ok; rewrite H;
     rewrite ics_aux_ok; eauto ].
@@ -577,9 +573,9 @@ Lemma canonical_sum_scalar_ok :
  forall (a:A) (s:canonical_sum),
    interp_cs (canonical_sum_scalar a s) = Amult a (interp_cs s).
 simple induction s.
-simpl in |- *; eauto.
+simpl; eauto.
 
-simpl in |- *; intros.
+simpl; intros.
 repeat rewrite ics_aux_ok.
 repeat rewrite interp_m_ok.
 rewrite H.
@@ -587,7 +583,7 @@ rewrite (SR_distr_right T).
 repeat rewrite <- (SR_mult_assoc T).
 reflexivity.
 
-simpl in |- *; intros.
+simpl; intros.
 repeat rewrite ics_aux_ok.
 repeat rewrite interp_m_ok.
 rewrite H.
@@ -600,9 +596,9 @@ Lemma canonical_sum_scalar2_ok :
  forall (l:varlist) (s:canonical_sum),
    interp_cs (canonical_sum_scalar2 l s) = Amult (interp_vl l) (interp_cs s).
 simple induction s.
-simpl in |- *; trivial.
+simpl; trivial.
 
-simpl in |- *; intros.
+simpl; intros.
 rewrite monom_insert_ok.
 repeat rewrite ics_aux_ok.
 repeat rewrite interp_m_ok.
@@ -614,7 +610,7 @@ repeat rewrite <- (SR_plus_assoc T).
 rewrite (SR_mult_permute T a (interp_vl l) (interp_vl v)).
 reflexivity.
 
-simpl in |- *; intros.
+simpl; intros.
 rewrite varlist_insert_ok.
 repeat rewrite ics_aux_ok.
 repeat rewrite interp_m_ok.
@@ -631,9 +627,9 @@ Lemma canonical_sum_scalar3_ok :
    interp_cs (canonical_sum_scalar3 c l s) =
    Amult c (Amult (interp_vl l) (interp_cs s)).
 simple induction s.
-simpl in |- *; repeat rewrite (SR_mult_zero_right T); reflexivity.
+simpl; repeat rewrite (SR_mult_zero_right T); reflexivity.
 
-simpl in |- *; intros.
+simpl; intros.
 rewrite monom_insert_ok.
 repeat rewrite ics_aux_ok.
 repeat rewrite interp_m_ok.
@@ -645,7 +641,7 @@ repeat rewrite <- (SR_plus_assoc T).
 rewrite (SR_mult_permute T a (interp_vl l) (interp_vl v)).
 reflexivity.
 
-simpl in |- *; intros.
+simpl; intros.
 rewrite monom_insert_ok.
 repeat rewrite ics_aux_ok.
 repeat rewrite interp_m_ok.
@@ -661,7 +657,7 @@ Qed.
 Lemma canonical_sum_prod_ok :
  forall x y:canonical_sum,
    interp_cs (canonical_sum_prod x y) = Amult (interp_cs x) (interp_cs y).
-simple induction x; simpl in |- *; intros.
+simple induction x; simpl; intros.
 trivial.
 
 rewrite canonical_sum_merge_ok.
@@ -670,7 +666,7 @@ rewrite ics_aux_ok.
 rewrite interp_m_ok.
 rewrite H.
 rewrite (SR_mult_assoc T a (interp_vl v) (interp_cs y)).
-symmetry  in |- *.
+symmetry .
 eauto.
 
 rewrite canonical_sum_merge_ok.
@@ -682,7 +678,7 @@ Qed.
 
 Theorem spolynomial_normalize_ok :
  forall p:spolynomial, interp_cs (spolynomial_normalize p) = interp_sp p.
-simple induction p; simpl in |- *; intros.
+simple induction p; simpl; intros.
 
 reflexivity.
 reflexivity.
@@ -703,7 +699,7 @@ simple induction s.
 reflexivity.
 
 (* cons_monom *)
-simpl in |- *; intros.
+simpl; intros.
 generalize (SR_eq_prop T a Azero).
 elim (Aeq a Azero).
 intro Heq; rewrite (Heq I).
@@ -713,25 +709,25 @@ rewrite interp_m_ok.
 rewrite (SR_mult_zero_left T).
 trivial.
 
-intros; simpl in |- *.
+intros; simpl.
 generalize (SR_eq_prop T a Aone).
 elim (Aeq a Aone).
 intro Heq; rewrite (Heq I).
-simpl in |- *.
+simpl.
 repeat rewrite ics_aux_ok.
 rewrite interp_m_ok.
 rewrite H.
 rewrite (SR_mult_one_left T).
 reflexivity.
 
-simpl in |- *.
+simpl.
 repeat rewrite ics_aux_ok.
 rewrite interp_m_ok.
 rewrite H.
 reflexivity.
 
 (* cons_varlist *)
-simpl in |- *; intros.
+simpl; intros.
 repeat rewrite ics_aux_ok.
 rewrite H.
 reflexivity.
@@ -741,7 +737,7 @@ Qed.
 Theorem spolynomial_simplify_ok :
  forall p:spolynomial, interp_cs (spolynomial_simplify p) = interp_sp p.
 intro.
-unfold spolynomial_simplify in |- *.
+unfold spolynomial_simplify.
 rewrite canonical_sum_simplify_ok.
 apply spolynomial_normalize_ok.
 Qed.
@@ -749,11 +745,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.
 
@@ -797,8 +793,7 @@ Hint Resolve (Th_plus_zero_right2 T).
 Hint Resolve (Th_mult_one_right T).
 Hint Resolve (Th_mult_one_right2 T).
 (*Hint Resolve (Th_plus_reg_right T).*)
-Hint Resolve refl_equal sym_equal trans_equal.
-(*Hints Resolve refl_eqT sym_eqT trans_eqT.*)
+Hint Resolve eq_refl eq_sym eq_trans.
 Hint Immediate T.
 
 (*** Definitions *)
@@ -855,7 +850,7 @@ Unset Implicit Arguments.
 Lemma spolynomial_of_ok :
  forall p:polynomial,
    interp_p p = interp_sp Aplus Amult Azero vm (spolynomial_of p).
-simple induction p; reflexivity || (simpl in |- *; intros).
+simple induction p; reflexivity || (simpl; intros).
 rewrite H; rewrite H0; reflexivity.
 rewrite H; rewrite H0; reflexivity.
 rewrite H.
@@ -868,23 +863,23 @@ Theorem polynomial_normalize_ok :
  forall p:polynomial,
    polynomial_normalize p =
    spolynomial_normalize Aplus Amult Aone (spolynomial_of p).
-simple induction p; reflexivity || (simpl in |- *; intros).
+simple induction p; reflexivity || (simpl; intros).
 rewrite H; rewrite H0; reflexivity.
 rewrite H; rewrite H0; reflexivity.
-rewrite H; simpl in |- *.
+rewrite H; simpl.
 elim
  (canonical_sum_scalar3 Aplus Amult Aone (Aopp Aone) Nil_var
     (spolynomial_normalize Aplus Amult Aone (spolynomial_of p0)));
  [ reflexivity
- | simpl in |- *; intros; rewrite H0; reflexivity
- | simpl in |- *; intros; rewrite H0; reflexivity ].
+ | simpl; intros; rewrite H0; reflexivity
+ | simpl; intros; rewrite H0; reflexivity ].
 Qed.
 
 Theorem polynomial_simplify_ok :
  forall p:polynomial,
    interp_cs Aplus Amult Aone Azero vm (polynomial_simplify p) = interp_p p.
 intro.
-unfold polynomial_simplify in |- *.
+unfold polynomial_simplify.
 rewrite spolynomial_of_ok.
 rewrite polynomial_normalize_ok.
 rewrite (canonical_sum_simplify_ok A Aplus Amult Aone Azero Aeq vm T).
diff --git a/plugins/ring/Setoid_ring.v b/plugins/ring/Setoid_ring.v
index da4e3756..4717edc9 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-2012     *)
 (*   \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..b0d790e0 100644
--- a/plugins/ring/Setoid_ring_normalize.v
+++ b/plugins/ring/Setoid_ring_normalize.v
@@ -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-2012     *)
 (*   \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.
-  simple induction n; simple induction m; simpl in |- *;
+  simple induction n; simple induction m; simpl;
    try reflexivity || contradiction.
   intros; rewrite (H i0); trivial.
   intros; rewrite (H i0); trivial.
@@ -390,14 +387,13 @@ Hint Resolve (SSR_plus_zero_right2 S T).
 Hint Resolve (SSR_mult_one_right S T).
 Hint Resolve (SSR_mult_one_right2 S T).
 Hint Resolve (SSR_plus_reg_right S T).
-Hint Resolve refl_equal sym_equal trans_equal.
-(*Hints Resolve refl_eqT sym_eqT trans_eqT.*)
+Hint Resolve eq_refl eq_sym eq_trans.
 Hint Immediate T.
 
 Lemma varlist_eq_prop : forall x y:varlist, Is_true (varlist_eq x y) -> x = y.
 Proof.
   simple induction x; simple induction y; contradiction || (try reflexivity).
-  simpl in |- *; intros.
+  simpl; intros.
   generalize (andb_prop2 _ _ H1); intros; elim H2; intros.
   rewrite (index_eq_prop _ _ H3); rewrite (H v0 H4); reflexivity.
 Qed.
@@ -406,7 +402,7 @@ Remark ivl_aux_ok :
  forall (v:varlist) (i:index),
    Aequiv (ivl_aux i v) (Amult (interp_var i) (interp_vl v)).
 Proof.
-  simple induction v; simpl in |- *; intros.
+  simple induction v; simpl; intros.
   trivial.
   rewrite (H i); trivial.
 Qed.
@@ -416,17 +412,17 @@ Lemma varlist_merge_ok :
    Aequiv (interp_vl (varlist_merge x y)) (Amult (interp_vl x) (interp_vl y)).
 Proof.
   simple induction x.
-  simpl in |- *; trivial.
+  simpl; trivial.
   simple induction y.
-  simpl in |- *; trivial.
-  simpl in |- *; intros.
-  elim (index_lt i i0); simpl in |- *; intros.
+  simpl; trivial.
+  simpl; intros.
+  elim (index_lt i i0); simpl; intros.
 
   rewrite (ivl_aux_ok v i).
   rewrite (ivl_aux_ok v0 i0).
   rewrite (ivl_aux_ok (varlist_merge v (Cons_var i0 v0)) i).
   rewrite (H (Cons_var i0 v0)).
-  simpl in |- *.
+  simpl.
   rewrite (ivl_aux_ok v0 i0).
   eauto.
 
@@ -451,7 +447,7 @@ Remark ics_aux_ok :
  forall (x:A) (s:canonical_sum),
    Aequiv (ics_aux x s) (Aplus x (interp_setcs s)).
 Proof.
- simple induction s; simpl in |- *; intros; trivial.
+ simple induction s; simpl; intros; trivial.
 Qed.
 
 Remark interp_m_ok :
@@ -471,16 +467,16 @@ Lemma canonical_sum_merge_ok :
    Aequiv (interp_setcs (canonical_sum_merge x y))
      (Aplus (interp_setcs x) (interp_setcs y)).
 Proof.
-simple induction x; simpl in |- *.
+simple induction x; simpl.
 trivial.
 
-simple induction y; simpl in |- *; intros.
+simple induction y; simpl; intros.
 eauto.
 
 generalize (varlist_eq_prop v v0).
 elim (varlist_eq v v0).
 intros; rewrite (H1 I).
-simpl in |- *.
+simpl.
 rewrite (ics_aux_ok (interp_m a v0) c).
 rewrite (ics_aux_ok (interp_m a0 v0) c0).
 rewrite (ics_aux_ok (interp_m (Aplus a a0) v0) (canonical_sum_merge c c0)).
@@ -507,14 +503,14 @@ setoid_replace
  [ idtac | trivial ].
 auto.
 
-elim (varlist_lt v v0); simpl in |- *.
+elim (varlist_lt v v0); simpl.
 intro.
 rewrite
  (ics_aux_ok (interp_m a v) (canonical_sum_merge c (Cons_monom a0 v0 c0)))
  .
 rewrite (ics_aux_ok (interp_m a v) c).
 rewrite (ics_aux_ok (interp_m a0 v0) c0).
-rewrite (H (Cons_monom a0 v0 c0)); simpl in |- *.
+rewrite (H (Cons_monom a0 v0 c0)); simpl.
 rewrite (ics_aux_ok (interp_m a0 v0) c0); auto.
 
 intro.
@@ -540,13 +536,13 @@ rewrite
         end) c0)).
 rewrite H0.
 rewrite (ics_aux_ok (interp_m a v) c);
- rewrite (ics_aux_ok (interp_m a0 v0) c0); simpl in |- *;
+ rewrite (ics_aux_ok (interp_m a0 v0) c0); simpl;
  auto.
 
 generalize (varlist_eq_prop v v0).
 elim (varlist_eq v v0).
 intros; rewrite (H1 I).
-simpl in |- *.
+simpl.
 rewrite (ics_aux_ok (interp_m (Aplus a Aone) v0) (canonical_sum_merge c c0));
  rewrite (ics_aux_ok (interp_m a v0) c);
  rewrite (ics_aux_ok (interp_vl v0) c0).
@@ -573,13 +569,13 @@ setoid_replace (Amult Aone (interp_vl v0)) with (interp_vl v0);
  [ idtac | trivial ].
 auto.
 
-elim (varlist_lt v v0); simpl in |- *.
+elim (varlist_lt v v0); simpl.
 intro.
 rewrite
  (ics_aux_ok (interp_m a v) (canonical_sum_merge c (Cons_varlist v0 c0)))
  ; rewrite (ics_aux_ok (interp_m a v) c);
  rewrite (ics_aux_ok (interp_vl v0) c0).
-rewrite (H (Cons_varlist v0 c0)); simpl in |- *.
+rewrite (H (Cons_varlist v0 c0)); simpl.
 rewrite (ics_aux_ok (interp_vl v0) c0).
 auto.
 
@@ -605,16 +601,16 @@ rewrite
              else Cons_varlist l2 (csm_aux t2)
         end) c0)); rewrite H0.
 rewrite (ics_aux_ok (interp_m a v) c); rewrite (ics_aux_ok (interp_vl v0) c0);
- simpl in |- *.
+ simpl.
 auto.
 
-simple induction y; simpl in |- *; intros.
+simple induction y; simpl; intros.
 trivial.
 
 generalize (varlist_eq_prop v v0).
 elim (varlist_eq v v0).
 intros; rewrite (H1 I).
-simpl in |- *.
+simpl.
 rewrite (ics_aux_ok (interp_m (Aplus Aone a) v0) (canonical_sum_merge c c0));
  rewrite (ics_aux_ok (interp_vl v0) c);
  rewrite (ics_aux_ok (interp_m a v0) c0); rewrite (H c0).
@@ -638,12 +634,12 @@ setoid_replace
  [ idtac | trivial ].
 auto.
 
-elim (varlist_lt v v0); simpl in |- *; intros.
+elim (varlist_lt v v0); simpl; intros.
 rewrite
  (ics_aux_ok (interp_vl v) (canonical_sum_merge c (Cons_monom a v0 c0)))
  ; rewrite (ics_aux_ok (interp_vl v) c);
  rewrite (ics_aux_ok (interp_m a v0) c0).
-rewrite (H (Cons_monom a v0 c0)); simpl in |- *.
+rewrite (H (Cons_monom a v0 c0)); simpl.
 rewrite (ics_aux_ok (interp_m a v0) c0); auto.
 
 rewrite
@@ -667,11 +663,11 @@ rewrite
              else Cons_varlist l2 (csm_aux2 t2)
         end) c0)); rewrite H0.
 rewrite (ics_aux_ok (interp_vl v) c); rewrite (ics_aux_ok (interp_m a v0) c0);
- simpl in |- *; auto.
+ simpl; auto.
 
 generalize (varlist_eq_prop v v0).
 elim (varlist_eq v v0); intros.
-rewrite (H1 I); simpl in |- *.
+rewrite (H1 I); simpl.
 rewrite
  (ics_aux_ok (interp_m (Aplus Aone Aone) v0) (canonical_sum_merge c c0))
  ; rewrite (ics_aux_ok (interp_vl v0) c);
@@ -695,12 +691,12 @@ setoid_replace
 [ idtac | trivial ].
 setoid_replace (Amult Aone (interp_vl v0)) with (interp_vl v0); auto.
 
-elim (varlist_lt v v0); simpl in |- *.
+elim (varlist_lt v v0); simpl.
 rewrite
  (ics_aux_ok (interp_vl v) (canonical_sum_merge c (Cons_varlist v0 c0)))
  ; rewrite (ics_aux_ok (interp_vl v) c);
  rewrite (ics_aux_ok (interp_vl v0) c0); rewrite (H (Cons_varlist v0 c0));
- simpl in |- *.
+ simpl.
 rewrite (ics_aux_ok (interp_vl v0) c0); auto.
 
 rewrite
@@ -724,7 +720,7 @@ rewrite
              else Cons_varlist l2 (csm_aux2 t2)
         end) c0)); rewrite H0.
 rewrite (ics_aux_ok (interp_vl v) c); rewrite (ics_aux_ok (interp_vl v0) c0);
- simpl in |- *; auto.
+ simpl; auto.
 Qed.
 
 Lemma monom_insert_ok :
@@ -733,10 +729,10 @@ Lemma monom_insert_ok :
      (Aplus (Amult a (interp_vl l)) (interp_setcs s)).
 Proof.
 simple induction s; intros.
-simpl in |- *; rewrite (interp_m_ok a l); trivial.
+simpl; rewrite (interp_m_ok a l); trivial.
 
-simpl in |- *; generalize (varlist_eq_prop l v); elim (varlist_eq l v).
-intro Hr; rewrite (Hr I); simpl in |- *.
+simpl; generalize (varlist_eq_prop l v); elim (varlist_eq l v).
+intro Hr; rewrite (Hr I); simpl.
 rewrite (ics_aux_ok (interp_m (Aplus a a0) v) c);
  rewrite (ics_aux_ok (interp_m a0 v) c).
 rewrite (interp_m_ok (Aplus a a0) v); rewrite (interp_m_ok a0 v).
@@ -745,7 +741,7 @@ setoid_replace (Amult (Aplus a a0) (interp_vl v)) with
  [ idtac | trivial ].
 auto.
 
-elim (varlist_lt l v); simpl in |- *; intros.
+elim (varlist_lt l v); simpl; intros.
 rewrite (ics_aux_ok (interp_m a0 v) c).
 rewrite (interp_m_ok a0 v); rewrite (interp_m_ok a l).
 auto.
@@ -754,9 +750,9 @@ rewrite (ics_aux_ok (interp_m a0 v) (monom_insert a l c));
  rewrite (ics_aux_ok (interp_m a0 v) c); rewrite H.
 auto.
 
-simpl in |- *.
+simpl.
 generalize (varlist_eq_prop l v); elim (varlist_eq l v).
-intro Hr; rewrite (Hr I); simpl in |- *.
+intro Hr; rewrite (Hr I); simpl.
 rewrite (ics_aux_ok (interp_m (Aplus a Aone) v) c);
  rewrite (ics_aux_ok (interp_vl v) c).
 rewrite (interp_m_ok (Aplus a Aone) v).
@@ -767,7 +763,7 @@ setoid_replace (Amult Aone (interp_vl v)) with (interp_vl v);
  [ idtac | trivial ].
 auto.
 
-elim (varlist_lt l v); simpl in |- *; intros; auto.
+elim (varlist_lt l v); simpl; intros; auto.
 rewrite (ics_aux_ok (interp_vl v) (monom_insert a l c)); rewrite H.
 rewrite (ics_aux_ok (interp_vl v) c); auto.
 Qed.
@@ -777,11 +773,11 @@ Lemma varlist_insert_ok :
    Aequiv (interp_setcs (varlist_insert l s))
      (Aplus (interp_vl l) (interp_setcs s)).
 Proof.
-simple induction s; simpl in |- *; intros.
+simple induction s; simpl; intros.
 trivial.
 
 generalize (varlist_eq_prop l v); elim (varlist_eq l v).
-intro Hr; rewrite (Hr I); simpl in |- *.
+intro Hr; rewrite (Hr I); simpl.
 rewrite (ics_aux_ok (interp_m (Aplus Aone a) v) c);
  rewrite (ics_aux_ok (interp_m a v) c).
 rewrite (interp_m_ok (Aplus Aone a) v); rewrite (interp_m_ok a v).
@@ -790,14 +786,14 @@ setoid_replace (Amult (Aplus Aone a) (interp_vl v)) with
  [ idtac | trivial ].
 setoid_replace (Amult Aone (interp_vl v)) with (interp_vl v); auto.
 
-elim (varlist_lt l v); simpl in |- *; intros; auto.
+elim (varlist_lt l v); simpl; intros; auto.
 rewrite (ics_aux_ok (interp_m a v) (varlist_insert l c));
  rewrite (ics_aux_ok (interp_m a v) c).
 rewrite (interp_m_ok a v).
 rewrite H; auto.
 
 generalize (varlist_eq_prop l v); elim (varlist_eq l v).
-intro Hr; rewrite (Hr I); simpl in |- *.
+intro Hr; rewrite (Hr I); simpl.
 rewrite (ics_aux_ok (interp_m (Aplus Aone Aone) v) c);
  rewrite (ics_aux_ok (interp_vl v) c).
 rewrite (interp_m_ok (Aplus Aone Aone) v).
@@ -806,7 +802,7 @@ setoid_replace (Amult (Aplus Aone Aone) (interp_vl v)) with
  [ idtac | trivial ].
 setoid_replace (Amult Aone (interp_vl v)) with (interp_vl v); auto.
 
-elim (varlist_lt l v); simpl in |- *; intros; auto.
+elim (varlist_lt l v); simpl; intros; auto.
 rewrite (ics_aux_ok (interp_vl v) (varlist_insert l c)).
 rewrite H.
 rewrite (ics_aux_ok (interp_vl v) c); auto.
@@ -817,7 +813,7 @@ Lemma canonical_sum_scalar_ok :
    Aequiv (interp_setcs (canonical_sum_scalar a s))
      (Amult a (interp_setcs s)).
 Proof.
-simple induction s; simpl in |- *; intros.
+simple induction s; simpl; intros.
 trivial.
 
 rewrite (ics_aux_ok (interp_m (Amult a a0) v) (canonical_sum_scalar a c));
@@ -840,7 +836,7 @@ Lemma canonical_sum_scalar2_ok :
    Aequiv (interp_setcs (canonical_sum_scalar2 l s))
      (Amult (interp_vl l) (interp_setcs s)).
 Proof.
-simple induction s; simpl in |- *; intros; auto.
+simple induction s; simpl; intros; auto.
 rewrite (monom_insert_ok a (varlist_merge l v) (canonical_sum_scalar2 l c)).
 rewrite (ics_aux_ok (interp_m a v) c).
 rewrite (interp_m_ok a v).
@@ -865,7 +861,7 @@ Lemma canonical_sum_scalar3_ok :
    Aequiv (interp_setcs (canonical_sum_scalar3 c l s))
      (Amult c (Amult (interp_vl l) (interp_setcs s))).
 Proof.
-simple induction s; simpl in |- *; intros.
+simple induction s; simpl; intros.
 rewrite (SSR_mult_zero_right S T (interp_vl l)).
 auto.
 
@@ -914,7 +910,7 @@ Lemma canonical_sum_prod_ok :
    Aequiv (interp_setcs (canonical_sum_prod x y))
      (Amult (interp_setcs x) (interp_setcs y)).
 Proof.
-simple induction x; simpl in |- *; intros.
+simple induction x; simpl; intros.
 trivial.
 
 rewrite
@@ -948,7 +944,7 @@ Theorem setspolynomial_normalize_ok :
  forall p:setspolynomial,
    Aequiv (interp_setcs (setspolynomial_normalize p)) (interp_setsp p).
 Proof.
-simple induction p; simpl in |- *; intros; trivial.
+simple induction p; simpl; intros; trivial.
 rewrite
  (canonical_sum_merge_ok (setspolynomial_normalize s)
     (setspolynomial_normalize s0)).
@@ -964,12 +960,12 @@ Lemma canonical_sum_simplify_ok :
  forall s:canonical_sum,
    Aequiv (interp_setcs (canonical_sum_simplify s)) (interp_setcs s).
 Proof.
-simple induction s; simpl in |- *; intros.
+simple induction s; simpl; intros.
 trivial.
 
 generalize (SSR_eq_prop T a Azero).
 elim (Aeq a Azero).
-simpl in |- *.
+simpl.
 intros.
 rewrite (ics_aux_ok (interp_m a v) c).
 rewrite (interp_m_ok a v).
@@ -979,19 +975,19 @@ setoid_replace (Amult Azero (interp_vl v)) with Azero;
 rewrite H.
 trivial.
 
-intros; simpl in |- *.
+intros; simpl.
 generalize (SSR_eq_prop T a Aone).
 elim (Aeq a Aone).
 intros.
 rewrite (ics_aux_ok (interp_m a v) c).
 rewrite (interp_m_ok a v).
 rewrite (H1 I).
-simpl in |- *.
+simpl.
 rewrite (ics_aux_ok (interp_vl v) (canonical_sum_simplify c)).
 rewrite H.
 auto.
 
-simpl in |- *.
+simpl.
 intros.
 rewrite (ics_aux_ok (interp_m a v) (canonical_sum_simplify c)).
 rewrite (ics_aux_ok (interp_m a v) c).
@@ -1007,18 +1003,18 @@ Theorem setspolynomial_simplify_ok :
    Aequiv (interp_setcs (setspolynomial_simplify p)) (interp_setsp p).
 Proof.
 intro.
-unfold setspolynomial_simplify in |- *.
+unfold setspolynomial_simplify.
 rewrite (canonical_sum_simplify_ok (setspolynomial_normalize p)).
 exact (setspolynomial_normalize_ok p).
 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.
 
 
 
@@ -1055,8 +1051,7 @@ Hint Resolve (STh_plus_zero_right2 S T).
 Hint Resolve (STh_mult_one_right S T).
 Hint Resolve (STh_mult_one_right2 S T).
 Hint Resolve (STh_plus_reg_right S plus_morph T).
-Hint Resolve refl_equal sym_equal trans_equal.
-(*Hints Resolve refl_eqT sym_eqT trans_eqT.*)
+Hint Resolve eq_refl eq_sym eq_trans.
 Hint Immediate T.
 
 
@@ -1113,7 +1108,7 @@ Unset Implicit Arguments.
 Lemma setspolynomial_of_ok :
  forall p:setpolynomial,
    Aequiv (interp_setp p) (interp_setsp vm (setspolynomial_of p)).
-simple induction p; trivial; simpl in |- *; intros.
+simple induction p; trivial; simpl; intros.
 rewrite H; rewrite H0; trivial.
 rewrite H; rewrite H0; trivial.
 rewrite H.
@@ -1127,23 +1122,23 @@ Qed.
 Theorem setpolynomial_normalize_ok :
  forall p:setpolynomial,
    setpolynomial_normalize p = setspolynomial_normalize (setspolynomial_of p).
-simple induction p; trivial; simpl in |- *; intros.
+simple induction p; trivial; simpl; intros.
 rewrite H; rewrite H0; reflexivity.
 rewrite H; rewrite H0; reflexivity.
-rewrite H; simpl in |- *.
+rewrite H; simpl.
 elim
  (canonical_sum_scalar3 (Aopp Aone) Nil_var
     (setspolynomial_normalize (setspolynomial_of s)));
  [ reflexivity
- | simpl in |- *; intros; rewrite H0; reflexivity
- | simpl in |- *; intros; rewrite H0; reflexivity ].
+ | simpl; intros; rewrite H0; reflexivity
+ | simpl; intros; rewrite H0; reflexivity ].
 Qed.
 
 Theorem setpolynomial_simplify_ok :
  forall p:setpolynomial,
    Aequiv (interp_setcs vm (setpolynomial_simplify p)) (interp_setp p).
 intro.
-unfold setpolynomial_simplify in |- *.
+unfold setpolynomial_simplify.
 rewrite (setspolynomial_of_ok p).
 rewrite setpolynomial_normalize_ok.
 rewrite
diff --git a/plugins/ring/Setoid_ring_theory.v b/plugins/ring/Setoid_ring_theory.v
index f07cbaf6..52f5968b 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-2012     *)
 (*   \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.
 
@@ -408,7 +406,7 @@ Unset Implicit Arguments.
 Definition Semi_Setoid_Ring_Theory_of :
   Setoid_Ring_Theory -> Semi_Setoid_Ring_Theory.
 intros until 1; case H.
-split; intros; simpl in |- *; eauto.
+split; intros; simpl; eauto.
 Defined.
 
 Coercion Semi_Setoid_Ring_Theory_of : Setoid_Ring_Theory >->
diff --git a/plugins/ring/g_ring.ml4 b/plugins/ring/g_ring.ml4
index c5a33f39..8953b88f 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-2012     *)
 (*   \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..7b0d96bb 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-2012     *)
 (*   \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);
@@ -295,7 +292,8 @@ let unbox = function
 (* Protects the convertibility test against undue exceptions when using it
    with untyped terms *)
 
-let safe_pf_conv_x gl c1 c2 = try pf_conv_x gl c1 c2 with _ -> false
+let safe_pf_conv_x gl c1 c2 =
+  try pf_conv_x gl c1 c2 with e when Errors.noncritical e -> false
 
 
 (* Add a Ring or a Semi-Ring to the database after a type verification *)
@@ -380,8 +378,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 +399,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 +441,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 =
@@ -446,7 +450,7 @@ let build_polynom gl th lc =
 	  mkLApp(coq_Pplus, [|th.th_a; aux c1; aux c2 |])
       | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult ->
 	  mkLApp(coq_Pmult, [|th.th_a; aux c1; aux c2 |])
-      (* The special case of Zminus *)
+      (* The special case of Z.sub *)
       | App (binop, [|c1; c2|])
 	  when safe_pf_conv_x gl c
             (mkApp (th.th_plus, [|c1; mkApp(unbox th.th_opp, [|c2|])|])) ->
@@ -458,14 +462,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 +505,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 +519,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 +559,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 =
@@ -564,7 +568,7 @@ let build_apolynom gl th lc =
 	  mkLApp(coq_APplus, [| aux c1; aux c2 |])
       | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult ->
 	  mkLApp(coq_APmult, [| aux c1; aux c2 |])
-      (* The special case of Zminus *)
+      (* The special case of Z.sub *)
       | App (binop, [|c1; c2|])
 	  when safe_pf_conv_x gl c
             (mkApp(th.th_plus, [|c1; mkApp(unbox th.th_opp,[|c2|]) |])) ->
@@ -575,14 +579,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 +620,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 =
@@ -625,7 +629,7 @@ let build_setpolynom gl th lc =
 	  mkLApp(coq_SetPplus, [|th.th_a; aux c1; aux c2 |])
       | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult ->
 	  mkLApp(coq_SetPmult, [|th.th_a; aux c1; aux c2 |])
-      (* The special case of Zminus *)
+      (* The special case of Z.sub *)
       | App (binop, [|c1; c2|])
 	  when safe_pf_conv_x gl c
 	    (mkApp(th.th_plus, [|c1; mkApp(unbox th.th_opp,[|c2|])|])) ->
@@ -637,14 +641,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 +687,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 +699,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 +827,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 04eac3a8..ab424c22 100644
--- a/plugins/romega/ReflOmegaCore.v
+++ b/plugins/romega/ReflOmegaCore.v
@@ -14,14 +14,14 @@ Delimit Scope Int_scope with I.
 
 Module Type Int.
 
-  Parameter int : Set.
+  Parameter t : Set.
 
-  Parameter zero : int.
-  Parameter one : int.
-  Parameter plus : int -> int -> int.
-  Parameter opp : int -> int.
-  Parameter minus : int -> int -> int.
-  Parameter mult : int -> int -> int.
+  Parameter zero : t.
+  Parameter one : t.
+  Parameter plus : t -> t -> t.
+  Parameter opp : t -> t.
+  Parameter minus : t -> t -> t.
+  Parameter mult : t -> t -> t.
 
   Notation "0" := zero : Int_scope.
   Notation "1" := one : Int_scope.
@@ -33,14 +33,14 @@ Module Type Int.
   Open Scope Int_scope.
 
   (* First, int is a ring: *)
-  Axiom ring : @ring_theory int 0 1 plus mult minus opp (@eq int).
+  Axiom ring : @ring_theory t 0 1 plus mult minus opp (@eq t).
 
   (* int should also be ordered: *)
 
-  Parameter le : int -> int -> Prop.
-  Parameter lt : int -> int -> Prop.
-  Parameter ge : int -> int -> Prop.
-  Parameter gt : int -> int -> Prop.
+  Parameter le : t -> t -> Prop.
+  Parameter lt : t -> t -> Prop.
+  Parameter ge : t -> t -> Prop.
+  Parameter gt : t -> t -> Prop.
   Notation "x <= y" := (le x y): Int_scope.
   Notation "x < y" := (lt x y) : Int_scope.
   Notation "x >= y" := (ge x y) : Int_scope.
@@ -61,7 +61,7 @@ Module Type Int.
    forall i j k, 0 < k -> i < j -> k*i<k*j.
 
   (* We should have a way to decide the equality and the order*)
-  Parameter compare : int -> int -> comparison.
+  Parameter compare : t -> t -> comparison.
   Infix "?=" := compare (at level 70, no associativity) : Int_scope.
   Axiom compare_Eq : forall i j, compare i j = Eq <-> i=j.
   Axiom compare_Lt : forall i j, compare i j = Lt <-> i<j.
@@ -83,76 +83,53 @@ Module Z_as_Int <: Int.
 
   Open Scope Z_scope.
 
-  Definition int := Z.
+  Definition t := Z.
   Definition zero := 0.
   Definition one := 1.
-  Definition plus := Zplus.
-  Definition opp := Zopp.
-  Definition minus := Zminus.
-  Definition mult := Zmult.
+  Definition plus := Z.add.
+  Definition opp := Z.opp.
+  Definition minus := Z.sub.
+  Definition mult := Z.mul.
 
-  Lemma ring : @ring_theory int zero one plus mult minus opp (@eq int).
+  Lemma ring : @ring_theory t zero one plus mult minus opp (@eq t).
   Proof.
   constructor.
-  exact Zplus_0_l.
-  exact Zplus_comm.
-  exact Zplus_assoc.
-  exact Zmult_1_l.
-  exact Zmult_comm.
-  exact Zmult_assoc.
-  exact Zmult_plus_distr_l.
-  unfold minus, Zminus; auto.
-  exact Zplus_opp_r.
+  exact Z.add_0_l.
+  exact Z.add_comm.
+  exact Z.add_assoc.
+  exact Z.mul_1_l.
+  exact Z.mul_comm.
+  exact Z.mul_assoc.
+  exact Z.mul_add_distr_r.
+  unfold minus, Z.sub; auto.
+  exact Z.add_opp_diag_r.
   Qed.
 
-  Definition le := Zle.
-  Definition lt := Zlt.
-  Definition ge := Zge.
-  Definition gt := Zgt.
-  Lemma le_lt_iff : forall i j, (i<=j) <-> ~(j<i).
-  Proof.
-   split; intros.
-   apply Zle_not_lt; auto.
-   rewrite <- Zge_iff_le.
-   apply Znot_lt_ge; auto.
-  Qed.
-  Definition ge_le_iff := Zge_iff_le.
-  Definition gt_lt_iff := Zgt_iff_lt.
+  Definition le := Z.le.
+  Definition lt := Z.lt.
+  Definition ge := Z.ge.
+  Definition gt := Z.gt.
+  Definition le_lt_iff := Z.le_ngt.
+  Definition ge_le_iff := Z.ge_le_iff.
+  Definition gt_lt_iff := Z.gt_lt_iff.
 
-  Definition lt_trans := Zlt_trans.
-  Definition lt_not_eq := Zlt_not_eq.
+  Definition lt_trans := Z.lt_trans.
+  Definition lt_not_eq := Z.lt_neq.
 
-  Definition lt_0_1 := Zlt_0_1.
-  Definition plus_le_compat := Zplus_le_compat.
+  Definition lt_0_1 := Z.lt_0_1.
+  Definition plus_le_compat := Z.add_le_mono.
   Definition mult_lt_compat_l := Zmult_lt_compat_l.
-  Lemma opp_le_compat : forall i j, i<=j -> (-j)<=(-i).
-  Proof.
-  unfold Zle; intros; rewrite <- Zcompare_opp; auto.
-  Qed.
+  Lemma opp_le_compat i j : i<=j -> (-j)<=(-i).
+  Proof. apply -> Z.opp_le_mono. Qed.
 
-  Definition compare := Zcompare.
-  Definition compare_Eq := Zcompare_Eq_iff_eq.
-  Lemma compare_Lt : forall i j, compare i j = Lt <-> i<j.
-  Proof. intros; unfold compare, Zlt; intuition. Qed.
-  Lemma compare_Gt : forall i j, compare i j = Gt <-> i>j.
-  Proof. intros; unfold compare, Zgt; intuition. Qed.
+  Definition compare := Z.compare.
+  Definition compare_Eq := Z.compare_eq_iff.
+  Lemma compare_Lt i j : compare i j = Lt <-> i<j.
+  Proof. reflexivity. Qed.
+  Lemma compare_Gt i j : compare i j = Gt <-> i>j.
+  Proof. reflexivity. Qed.
 
-  Lemma le_lt_int : forall x y, x<y <-> x<=y+-(1).
-  Proof.
-   intros; split; intros.
-   generalize (Zlt_left _ _ H); simpl; intros.
-   apply Zle_left_rev; auto.
-   apply Zlt_0_minus_lt.
-   generalize (Zplus_le_lt_compat x (y+-1) (-x) (-x+1) H).
-   rewrite Zplus_opp_r.
-   rewrite <-Zplus_assoc.
-   rewrite (Zplus_permute (-1)).
-   simpl in *.
-   rewrite Zplus_0_r.
-   intro H'; apply H'.
-   replace (-x+1) with (Zsucc (-x)); auto.
-   apply Zlt_succ.
-  Qed.
+  Definition le_lt_int := Z.lt_le_pred.
 
 End Z_as_Int.
 
@@ -161,6 +138,7 @@ End Z_as_Int.
 
 Module IntProperties (I:Int).
  Import I.
+ Local Notation int := I.t.
 
  (* Primo, some consequences of being a ring theory... *)
 
@@ -363,7 +341,7 @@ Module IntProperties (I:Int).
 
  Lemma sum1 : forall a b c d : int, 0 = a -> 0 = b -> 0 = a * c + b * d.
  Proof.
- intros; elim H; elim H0; simpl in |- *; auto.
+ intros; elim H; elim H0; simpl; auto.
  now rewrite mult_0_l, mult_0_l, plus_0_l.
  Qed.
 
@@ -850,6 +828,7 @@ Module IntOmega (I:Int).
 Import I.
 Module IP:=IntProperties(I).
 Import IP.
+Local Notation int := I.t.
 
 (* \subsubsection{Definition of reified integer expressions}
    Terms are either:
@@ -868,11 +847,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].
+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 +993,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
@@ -1060,52 +1039,24 @@ Close Scope romega_scope.
 
 Theorem eq_term_true : forall t1 t2 : term, eq_term t1 t2 = true -> t1 = t2.
 Proof.
- simple induction t1; intros until t2; case t2; simpl in *;
- try (intros; discriminate; fail);
- [ intros; elim beq_true with (1 := H); trivial
- | intros t21 t22 H3; elim andb_prop with (1 := H3); intros H4 H5;
-    elim H with (1 := H4); elim H0 with (1 := H5);
-    trivial
- | intros t21 t22 H3; elim andb_prop with (1 := H3); intros H4 H5;
-    elim H with (1 := H4); elim H0 with (1 := H5);
-    trivial
- | intros t21 t22 H3; elim andb_prop with (1 := H3); intros H4 H5;
-    elim H with (1 := H4); elim H0 with (1 := H5);
-    trivial
- | intros t21 H3; elim H with (1 := H3); trivial
- | intros; elim beq_nat_true with (1 := H); trivial ].
+ induction t1; destruct t2; simpl in *; try discriminate;
+ (rewrite andb_true_iff; intros (H1,H2)) || intros H; f_equal;
+ auto using beq_true, beq_nat_true.
 Qed.
 
-Ltac trivial_case := unfold not in |- *; intros; discriminate.
+Theorem eq_term_refl : forall t0 : term, eq_term t0 t0 = true.
+Proof.
+ induction t0; simpl in *; try (apply andb_true_iff; split); trivial.
+ - now apply beq_iff.
+ - now apply beq_nat_true_iff.
+Qed.
+
+Ltac trivial_case := unfold not; intros; discriminate.
 
 Theorem eq_term_false :
  forall t1 t2 : term, eq_term t1 t2 = false -> t1 <> t2.
 Proof.
- simple induction t1;
- [ intros z t2; case t2; try trivial_case; simpl in |- *; unfold not in |- *;
-    intros; elim beq_false with (1 := H); simplify_eq H0;
-    auto
- | intros t11 H1 t12 H2 t2; case t2; try trivial_case; simpl in |- *;
-    intros t21 t22 H3; unfold not in |- *; intro H4;
-    elim andb_false_elim with (1 := H3); intros H5;
-    [ elim H1 with (1 := H5); simplify_eq H4; auto
-    | elim H2 with (1 := H5); simplify_eq H4; auto ]
- | intros t11 H1 t12 H2 t2; case t2; try trivial_case; simpl in |- *;
-    intros t21 t22 H3; unfold not in |- *; intro H4;
-    elim andb_false_elim with (1 := H3); intros H5;
-    [ elim H1 with (1 := H5); simplify_eq H4; auto
-    | elim H2 with (1 := H5); simplify_eq H4; auto ]
- | intros t11 H1 t12 H2 t2; case t2; try trivial_case; simpl in |- *;
-    intros t21 t22 H3; unfold not in |- *; intro H4;
-    elim andb_false_elim with (1 := H3); intros H5;
-    [ elim H1 with (1 := H5); simplify_eq H4; auto
-    | elim H2 with (1 := H5); simplify_eq H4; auto ]
- | intros t11 H1 t2; case t2; try trivial_case; simpl in |- *; intros t21 H3;
-    unfold not in |- *; intro H4; elim H1 with (1 := H3);
-    simplify_eq H4; auto
- | intros n t2; case t2; try trivial_case; simpl in |- *; unfold not in |- *;
-    intros; elim beq_nat_false with (1 := H); simplify_eq H0;
-    auto ].
+ intros t1 t2 H E. subst t2. now rewrite eq_term_refl in H.
 Qed.
 
 (* \subsubsection{Tactiques pour éliminer ces tests}
@@ -1123,17 +1074,17 @@ Qed.
    avait utilisé le test précédent et fait une elimination dessus. *)
 
 Ltac elim_eq_term t1 t2 :=
-  pattern (eq_term t1 t2) in |- *; apply bool_eq_ind; intro Aux;
+  pattern (eq_term t1 t2); apply bool_eq_ind; intro Aux;
    [ generalize (eq_term_true t1 t2 Aux); clear Aux
    | generalize (eq_term_false t1 t2 Aux); clear Aux ].
 
 Ltac elim_beq t1 t2 :=
-  pattern (beq t1 t2) in |- *; apply bool_eq_ind; intro Aux;
+  pattern (beq t1 t2); apply bool_eq_ind; intro Aux;
    [ generalize (beq_true t1 t2 Aux); clear Aux
    | generalize (beq_false t1 t2 Aux); clear Aux ].
 
 Ltac elim_bgt t1 t2 :=
-  pattern (bgt t1 t2) in |- *; apply bool_eq_ind; intro Aux;
+  pattern (bgt t1 t2); apply bool_eq_ind; intro Aux;
   [ generalize (bgt_true t1 t2 Aux); clear Aux
   | generalize (bgt_false t1 t2 Aux); clear Aux ].
 
@@ -1209,15 +1160,15 @@ Theorem goal_to_hyps :
  (interp_hyps envp env l -> False) -> interp_goal envp env l.
 Proof.
  simple induction l;
- [ simpl in |- *; auto
- | simpl in |- *; intros a l1 H1 H2 H3; apply H1; intro H4; apply H2; auto ].
+ [ simpl; auto
+ | simpl; intros a l1 H1 H2 H3; apply H1; intro H4; apply H2; auto ].
 Qed.
 
 Theorem hyps_to_goal :
  forall (envp : list Prop) (env : list int) (l : hyps),
  interp_goal envp env l -> interp_hyps envp env l -> False.
 Proof.
- simple induction l; simpl in |- *; [ auto | intros; apply H; elim H1; auto ].
+ simple induction l; simpl; [ auto | intros; apply H; elim H1; auto ].
 Qed.
 
 (* \subsection{Manipulations sur les hypothèses} *)
@@ -1257,7 +1208,7 @@ Theorem valid_goal :
   forall (ep : list Prop) (env : list int) (l : hyps) (a : hyps -> hyps),
   valid_hyps a -> interp_goal ep env (a l) -> interp_goal ep env l.
 Proof.
- intros; simpl in |- *; apply goal_to_hyps; intro H1;
+ intros; simpl; apply goal_to_hyps; intro H1;
  apply (hyps_to_goal ep env (a l) H0); apply H; assumption.
 Qed.
 
@@ -1282,7 +1233,7 @@ Theorem list_goal_to_hyps :
  forall (envp : list Prop) (env : list int) (l : lhyps),
  (interp_list_hyps envp env l -> False) -> interp_list_goal envp env l.
 Proof.
- simple induction l; simpl in |- *;
+ simple induction l; simpl;
  [ auto
  | intros h1 l1 H H1; split;
     [ apply goal_to_hyps; intro H2; apply H1; auto
@@ -1293,7 +1244,7 @@ Theorem list_hyps_to_goal :
  forall (envp : list Prop) (env : list int) (l : lhyps),
  interp_list_goal envp env l -> interp_list_hyps envp env l -> False.
 Proof.
- simple induction l; simpl in |- *;
+ simple induction l; simpl;
  [ auto
  | intros h1 l1 H (H1, H2) H3; elim H3; intro H4;
     [ apply hyps_to_goal with (1 := H1); assumption | auto ] ].
@@ -1310,7 +1261,7 @@ Definition valid_list_goal (f : hyps -> lhyps) :=
 Theorem goal_valid :
  forall f : hyps -> lhyps, valid_list_hyps f -> valid_list_goal f.
 Proof.
- unfold valid_list_goal in |- *; intros f H ep e lp H1; apply goal_to_hyps;
+ unfold valid_list_goal; intros f H ep e lp H1; apply goal_to_hyps;
  intro H2; apply list_hyps_to_goal with (1 := H1);
  apply (H ep e lp); assumption.
 Qed.
@@ -1321,8 +1272,8 @@ Theorem append_valid :
  interp_list_hyps ep e (l1 ++ l2).
 Proof.
  intros ep e; simple induction l1;
- [ simpl in |- *; intros l2 [H| H]; [ contradiction | trivial ]
- | simpl in |- *; intros h1 t1 HR l2 [[H| H]| H];
+ [ simpl; intros l2 [H| H]; [ contradiction | trivial ]
+ | simpl; intros h1 t1 HR l2 [[H| H]| H];
     [ auto
     | right; apply (HR l2); left; trivial
     | right; apply (HR l2); right; trivial ] ].
@@ -1338,11 +1289,11 @@ Theorem nth_valid :
  forall (ep : list Prop) (e : list int) (i : nat) (l : hyps),
  interp_hyps ep e l -> interp_proposition ep e (nth_hyps i l).
 Proof.
- unfold nth_hyps in |- *; simple induction i;
- [ simple induction l; simpl in |- *; [ auto | intros; elim H0; auto ]
+ unfold nth_hyps; simple induction i;
+ [ simple induction l; simpl; [ auto | intros; elim H0; auto ]
  | intros n H; simple induction l;
-    [ simpl in |- *; trivial
-    | intros; simpl in |- *; apply H; elim H1; auto ] ].
+    [ simpl; trivial
+    | intros; simpl; apply H; elim H1; auto ] ].
 Qed.
 
 (* Appliquer une opération (valide) sur deux hypothèses extraites de
@@ -1355,7 +1306,7 @@ Theorem apply_oper_2_valid :
  forall (i j : nat) (f : proposition -> proposition -> proposition),
  valid2 f -> valid_hyps (apply_oper_2 i j f).
 Proof.
- intros i j f Hf; unfold apply_oper_2, valid_hyps in |- *; simpl in |- *;
+ intros i j f Hf; unfold apply_oper_2, valid_hyps; simpl;
  intros lp Hlp; split; [ apply Hf; apply nth_valid; assumption | assumption ].
 Qed.
 
@@ -1376,14 +1327,14 @@ Theorem apply_oper_1_valid :
  forall (i : nat) (f : proposition -> proposition),
  valid1 f -> valid_hyps (apply_oper_1 i f).
 Proof.
- unfold valid_hyps in |- *; intros i f Hf ep e; elim i;
+ unfold valid_hyps; intros i f Hf ep e; elim i;
  [ intro lp; case lp;
-    [ simpl in |- *; trivial
-    | simpl in |- *; intros p l' (H1, H2); split;
+    [ simpl; trivial
+    | simpl; intros p l' (H1, H2); split;
        [ apply Hf with (1 := H1) | assumption ] ]
  | intros n Hrec lp; case lp;
-    [ simpl in |- *; auto
-    | simpl in |- *; intros p l' (H1, H2); split;
+    [ simpl; auto
+    | simpl; intros p l' (H1, H2); split;
        [ assumption | apply Hrec; assumption ] ] ].
 Qed.
 
@@ -1421,14 +1372,14 @@ Definition apply_both (f g : term -> term) (t : term) :=
 Theorem apply_left_stable :
  forall f : term -> term, term_stable f -> term_stable (apply_left f).
 Proof.
- unfold term_stable in |- *; intros f H e t; case t; auto; simpl in |- *;
+ unfold term_stable; intros f H e t; case t; auto; simpl;
  intros; elim H; trivial.
 Qed.
 
 Theorem apply_right_stable :
  forall f : term -> term, term_stable f -> term_stable (apply_right f).
 Proof.
- unfold term_stable in |- *; intros f H e t; case t; auto; simpl in |- *;
+ unfold term_stable; intros f H e t; case t; auto; simpl;
  intros t0 t1; elim H; trivial.
 Qed.
 
@@ -1436,7 +1387,7 @@ Theorem apply_both_stable :
  forall f g : term -> term,
  term_stable f -> term_stable g -> term_stable (apply_both f g).
 Proof.
- unfold term_stable in |- *; intros f g H1 H2 e t; case t; auto; simpl in |- *;
+ unfold term_stable; intros f g H1 H2 e t; case t; auto; simpl;
  intros t0 t1; elim H1; elim H2; trivial.
 Qed.
 
@@ -1444,7 +1395,7 @@ Theorem compose_term_stable :
  forall f g : term -> term,
  term_stable f -> term_stable g -> term_stable (fun t : term => f (g t)).
 Proof.
- unfold term_stable in |- *; intros f g Hf Hg e t; elim Hf; apply Hg.
+ unfold term_stable; intros f g Hf Hg e t; elim Hf; apply Hg.
 Qed.
 
 (* \subsection{Les règles de réécriture} *)
@@ -1522,14 +1473,14 @@ Ltac loop t :=
   | (if beq ?X1 ?X2 then _ else _) =>
       let H := fresh "H" in
       elim_beq X1 X2; intro H; try (rewrite H in *; clear H);
-       simpl in |- *; auto; Simplify
+       simpl; auto; Simplify
   | (if bgt ?X1 ?X2 then _ else _) =>
       let H := fresh "H" in
-      elim_bgt X1 X2; intro H; simpl in |- *; auto; Simplify
+      elim_bgt X1 X2; intro H; simpl; auto; Simplify
   | (if eq_term ?X1 ?X2 then _ else _) =>
       let H := fresh "H" in
       elim_eq_term X1 X2; intro H; try (rewrite H in *; clear H);
-       simpl in |- *; auto; Simplify
+       simpl; auto; Simplify
   | (if _ && _ then _ else _) => rewrite andb_if; Simplify
   | (if negb _ then _ else _) => rewrite negb_if; Simplify
   | _ => fail
@@ -1543,7 +1494,7 @@ with Simplify := match goal with
 Ltac prove_stable x th :=
   match constr:x with
   | ?X1 =>
-      unfold term_stable, X1 in |- *; intros; Simplify; simpl in |- *;
+      unfold term_stable, X1; intros; Simplify; simpl;
        apply th
   end.
 
@@ -1663,7 +1614,7 @@ Definition T_OMEGA13 (t : term) :=
 
 Theorem T_OMEGA13_stable : term_stable T_OMEGA13.
 Proof.
- unfold term_stable, T_OMEGA13 in |- *; intros; Simplify; simpl in |- *;
+ unfold term_stable, T_OMEGA13; intros; Simplify; simpl;
  apply OMEGA13.
 Qed.
 
@@ -1910,16 +1861,16 @@ Fixpoint reduce (t : term) : term :=
 
 Theorem reduce_stable : term_stable reduce.
 Proof.
- unfold term_stable in |- *; intros e t; elim t; auto;
+ unfold term_stable; intros e t; elim t; auto;
  try
-  (intros t0 H0 t1 H1; simpl in |- *; rewrite H0; rewrite H1;
+  (intros t0 H0 t1 H1; simpl; rewrite H0; rewrite H1;
     (case (reduce t0);
       [ intro z0; case (reduce t1); intros; auto
       | intros; auto
       | intros; auto
       | intros; auto
       | intros; auto
-      | intros; auto ])); intros t0 H0; simpl in |- *;
+      | intros; auto ])); intros t0 H0; simpl;
  rewrite H0; case (reduce t0); intros; auto.
 Qed.
 
@@ -1942,14 +1893,14 @@ Fixpoint fusion (trace : list t_fusion) (t : term) {struct trace} : term :=
       end
   end.
 
-Theorem fusion_stable : forall t : list t_fusion, term_stable (fusion t).
+Theorem fusion_stable : forall trace : list t_fusion, term_stable (fusion trace).
 Proof.
- simple induction t; simpl in |- *;
+ simple induction trace; simpl;
  [ exact reduce_stable
  | intros stp l H; case stp;
     [ apply compose_term_stable;
        [ apply apply_right_stable; assumption | exact T_OMEGA10_stable ]
-    | unfold term_stable in |- *; intros e t1; rewrite T_OMEGA10_stable;
+    | unfold term_stable; intros e t1; rewrite T_OMEGA10_stable;
        rewrite Tred_factor5_stable; apply H
     | apply compose_term_stable;
        [ apply apply_right_stable; assumption | exact T_OMEGA11_stable ]
@@ -1982,7 +1933,7 @@ Fixpoint fusion_cancel (trace : nat) (t : term) {struct trace} : term :=
 
 Theorem fusion_cancel_stable : forall t : nat, term_stable (fusion_cancel t).
 Proof.
- unfold term_stable, fusion_cancel in |- *; intros trace e; elim trace;
+ unfold term_stable, fusion_cancel; intros trace e; elim trace;
  [ exact (reduce_stable e)
  | intros n H t; elim H; exact (T_OMEGA13_stable e t) ].
 Qed.
@@ -1999,7 +1950,7 @@ Fixpoint scalar_norm_add (trace : nat) (t : term) {struct trace} : term :=
 Theorem scalar_norm_add_stable :
  forall t : nat, term_stable (scalar_norm_add t).
 Proof.
- unfold term_stable, scalar_norm_add in |- *; intros trace; elim trace;
+ unfold term_stable, scalar_norm_add; intros trace; elim trace;
  [ exact reduce_stable
  | intros n H e t; elim apply_right_stable;
     [ exact (T_OMEGA11_stable e t) | exact H ] ].
@@ -2014,7 +1965,7 @@ Fixpoint scalar_norm (trace : nat) (t : term) {struct trace} : term :=
 
 Theorem scalar_norm_stable : forall t : nat, term_stable (scalar_norm t).
 Proof.
- unfold term_stable, scalar_norm in |- *; intros trace; elim trace;
+ unfold term_stable, scalar_norm; intros trace; elim trace;
  [ exact reduce_stable
  | intros n H e t; elim apply_right_stable;
     [ exact (T_OMEGA16_stable e t) | exact H ] ].
@@ -2029,7 +1980,7 @@ Fixpoint add_norm (trace : nat) (t : term) {struct trace} : term :=
 
 Theorem add_norm_stable : forall t : nat, term_stable (add_norm t).
 Proof.
- unfold term_stable, add_norm in |- *; intros trace; elim trace;
+ unfold term_stable, add_norm; intros trace; elim trace;
  [ exact reduce_stable
  | intros n H e t; elim apply_right_stable;
     [ exact (Tplus_assoc_r_stable e t) | exact H ] ].
@@ -2038,12 +1989,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,14 +2020,14 @@ 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 |- *;
+ simple induction s; simpl;
  [ intros; apply apply_both_stable; auto
  | intros; apply apply_left_stable; auto
  | intros; apply apply_right_stable; auto
- | unfold term_stable in |- *; intros; elim H0; apply H
- | unfold term_stable in |- *; auto
+ | unfold term_stable; intros; elim H0; apply H
+ | unfold term_stable; auto
  | exact Topp_plus_stable
  | exact Topp_opp_stable
  | exact Topp_mult_r_stable
@@ -2116,11 +2067,8 @@ Definition constant_not_nul (i : nat) (h : hyps) :=
 Theorem constant_not_nul_valid :
  forall i : nat, valid_hyps (constant_not_nul i).
 Proof.
- unfold valid_hyps, constant_not_nul in |- *; intros;
- generalize (nth_valid ep e i lp); Simplify; simpl in |- *.
-
- elim_beq i1 i0; auto; simpl in |- *; intros H1 H2;
- elim H1; symmetry  in |- *; auto.
+ unfold valid_hyps, constant_not_nul; intros i ep e lp H.
+ generalize (nth_valid ep e i lp H); Simplify.
 Qed.
 
 (* \paragraph{[O_CONSTANT_NEG]} *)
@@ -2134,8 +2082,8 @@ Definition constant_neg (i : nat) (h : hyps) :=
 
 Theorem constant_neg_valid : forall i : nat, valid_hyps (constant_neg i).
 Proof.
- unfold valid_hyps, constant_neg in |- *; intros;
- generalize (nth_valid ep e i lp); Simplify; simpl in |- *.
+ unfold valid_hyps, constant_neg; intros;
+ generalize (nth_valid ep e i lp); Simplify; simpl.
  rewrite gt_lt_iff in H0; rewrite le_lt_iff; intuition.
 Qed.
 
@@ -2154,12 +2102,12 @@ Definition not_exact_divide (k1 k2 : int) (body : term)
   end.
 
 Theorem not_exact_divide_valid :
- forall (k1 k2 : int) (body : term) (t i : nat),
- valid_hyps (not_exact_divide k1 k2 body t i).
+ forall (k1 k2 : int) (body : term) (t0 i : nat),
+ valid_hyps (not_exact_divide k1 k2 body t0 i).
 Proof.
- unfold valid_hyps, not_exact_divide in |- *; intros;
+ unfold valid_hyps, not_exact_divide; intros;
  generalize (nth_valid ep e i lp); Simplify.
- rewrite (scalar_norm_add_stable t e), <-H1.
+ rewrite (scalar_norm_add_stable t0 e), <-H1.
  do 2 rewrite <- scalar_norm_add_stable; simpl in *; intros.
  absurd (interp_term e body * k1 + k2 = 0);
  [ now apply OMEGA4 | symmetry; auto ].
@@ -2186,16 +2134,16 @@ Definition contradiction (t i j : nat) (l : hyps) :=
 Theorem contradiction_valid :
  forall t i j : nat, valid_hyps (contradiction t i j).
 Proof.
- unfold valid_hyps, contradiction in |- *; intros t i j ep e l H;
+ unfold valid_hyps, contradiction; intros t i j ep e l H;
  generalize (nth_valid _ _ i _ H); generalize (nth_valid _ _ j _ H);
  case (nth_hyps i l); auto; intros t1 t2; case t1;
  auto; case (nth_hyps j l);
  auto; intros t3 t4; case t3; auto;
- simpl in |- *; intros z z' H1 H2;
- generalize (refl_equal (interp_term e (fusion_cancel t (t2 + t4)%term)));
- pattern (fusion_cancel t (t2 + t4)%term) at 2 3 in |- *;
- case (fusion_cancel t (t2 + t4)%term); simpl in |- *;
- auto; intro k; elim (fusion_cancel_stable t); simpl in |- *.
+ simpl; intros z z' H1 H2;
+ generalize (eq_refl (interp_term e (fusion_cancel t (t2 + t4)%term)));
+ pattern (fusion_cancel t (t2 + t4)%term) at 2 3;
+ case (fusion_cancel t (t2 + t4)%term); simpl;
+ auto; intro k; elim (fusion_cancel_stable t); simpl.
  Simplify; intro H3.
  generalize (OMEGA2 _ _ H2 H1); rewrite H3.
  rewrite gt_lt_iff in H0; rewrite le_lt_iff; intuition.
@@ -2250,23 +2198,23 @@ Definition negate_contradict_inv (t i1 i2 : nat) (h : hyps) :=
 Theorem negate_contradict_valid :
  forall i j : nat, valid_hyps (negate_contradict i j).
 Proof.
- unfold valid_hyps, negate_contradict in |- *; intros i j ep e l H;
+ unfold valid_hyps, negate_contradict; intros i j ep e l H;
  generalize (nth_valid _ _ i _ H); generalize (nth_valid _ _ j _ H);
  case (nth_hyps i l); auto; intros t1 t2; case t1;
  auto; intros z; auto; case (nth_hyps j l);
  auto; intros t3 t4; case t3; auto; intros z';
- auto; simpl in |- *; intros H1 H2; Simplify.
+ auto; simpl; intros H1 H2; Simplify.
 Qed.
 
 Theorem negate_contradict_inv_valid :
  forall t i j : nat, valid_hyps (negate_contradict_inv t i j).
 Proof.
- unfold valid_hyps, negate_contradict_inv in |- *; intros t i j ep e l H;
+ unfold valid_hyps, negate_contradict_inv; intros t i j ep e l H;
  generalize (nth_valid _ _ i _ H); generalize (nth_valid _ _ j _ H);
  case (nth_hyps i l); auto; intros t1 t2; case t1;
  auto; intros z; auto; case (nth_hyps j l);
  auto; intros t3 t4; case t3; auto; intros z';
- auto; simpl in |- *; intros H1 H2; Simplify;
+ auto; simpl; intros H1 H2; Simplify;
  [
  rewrite <- scalar_norm_stable in H2; simpl in *;
  elim (mult_integral (interp_term e t4) (-(1))); intuition;
@@ -2333,9 +2281,9 @@ Definition sum (k1 k2 : int) (trace : list t_fusion)
 Theorem sum_valid :
  forall (k1 k2 : int) (t : list t_fusion), valid2 (sum k1 k2 t).
 Proof.
- unfold valid2 in |- *; intros k1 k2 t ep e p1 p2; unfold sum in |- *;
- Simplify; simpl in |- *; auto; try elim (fusion_stable t);
- simpl in |- *; intros;
+ unfold valid2; intros k1 k2 t ep e p1 p2; unfold sum;
+ Simplify; simpl; auto; try elim (fusion_stable t);
+ simpl; intros;
  [ apply sum1; assumption
  | apply sum2; try assumption; apply sum4; assumption
  | rewrite plus_comm; apply sum2; try assumption; apply sum4; assumption
@@ -2367,10 +2315,10 @@ Definition exact_divide (k : int) (body : term) (t : nat)
 Theorem exact_divide_valid :
  forall (k : int) (t : term) (n : nat), valid1 (exact_divide k t n).
 Proof.
- unfold valid1, exact_divide in |- *; intros k1 k2 t ep e p1;
+ unfold valid1, exact_divide; intros k1 k2 t ep e p1;
  Simplify; simpl; auto; subst;
  rewrite <- scalar_norm_stable; simpl; intros;
- [ destruct (mult_integral _ _ (sym_eq H0)); intuition
+ [ destruct (mult_integral _ _ (eq_sym H0)); intuition
  | contradict H0; rewrite <- H0, mult_0_l; auto
  ].
 Qed.
@@ -2397,9 +2345,9 @@ Theorem divide_and_approx_valid :
  forall (k1 k2 : int) (body : term) (t : nat),
  valid1 (divide_and_approx k1 k2 body t).
 Proof.
- unfold valid1, divide_and_approx in |- *; intros k1 k2 body t ep e p1;
+ unfold valid1, divide_and_approx; intros k1 k2 body t ep e p1;
  Simplify; simpl; auto; subst;
- elim (scalar_norm_add_stable t e); simpl in |- *.
+ elim (scalar_norm_add_stable t e); simpl.
  intro H2; apply mult_le_approx with (3 := H2); assumption.
 Qed.
 
@@ -2421,9 +2369,9 @@ Definition merge_eq (t : nat) (prop1 prop2 : proposition) :=
 
 Theorem merge_eq_valid : forall n : nat, valid2 (merge_eq n).
 Proof.
- unfold valid2, merge_eq in |- *; intros n ep e p1 p2; Simplify; simpl in |- *;
- auto; elim (scalar_norm_stable n e); simpl in |- *;
- intros; symmetry  in |- *; apply OMEGA8 with (2 := H0);
+ unfold valid2, merge_eq; intros n ep e p1 p2; Simplify; simpl;
+ auto; elim (scalar_norm_stable n e); simpl;
+ intros; symmetry ; apply OMEGA8 with (2 := H0);
  [ assumption | elim opp_eq_mult_neg_1; trivial ].
 Qed.
 
@@ -2440,8 +2388,8 @@ Definition constant_nul (i : nat) (h : hyps) :=
 
 Theorem constant_nul_valid : forall i : nat, valid_hyps (constant_nul i).
 Proof.
- unfold valid_hyps, constant_nul in |- *; intros;
- generalize (nth_valid ep e i lp); Simplify; simpl in |- *;
+ unfold valid_hyps, constant_nul; intros;
+ generalize (nth_valid ep e i lp); Simplify; simpl;
  intro H1; absurd (0 = 0); intuition.
 Qed.
 
@@ -2453,7 +2401,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
@@ -2462,8 +2410,8 @@ 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 |- *;
+ unfold valid2; intros m s ep e p1 p2; unfold state; Simplify;
+ simpl; auto; elim (t_rewrite_stable s e); simpl;
  intros H1 H2; elim H1.
  now rewrite H2, plus_opp_l, plus_0_l, mult_0_l.
 Qed.
@@ -2490,18 +2438,18 @@ Theorem split_ineq_valid :
  valid_list_hyps f1 ->
  valid_list_hyps f2 -> valid_list_hyps (split_ineq i t f1 f2).
 Proof.
- unfold valid_list_hyps, split_ineq in |- *; intros i t f1 f2 H1 H2 ep e lp H;
+ unfold valid_list_hyps, split_ineq; intros i t f1 f2 H1 H2 ep e lp H;
  generalize (nth_valid _ _ i _ H); case (nth_hyps i lp);
- simpl in |- *; auto; intros t1 t2; case t1; simpl in |- *;
- auto; intros z; simpl in |- *; auto; intro H3.
+ simpl; auto; intros t1 t2; case t1; simpl;
+ auto; intros z; simpl; auto; intro H3.
  Simplify.
  apply append_valid; elim (OMEGA19 (interp_term e t2));
- [ intro H4; left; apply H1; simpl in |- *; elim (add_norm_stable t);
-    simpl in |- *; auto
- | intro H4; right; apply H2; simpl in |- *; elim (scalar_norm_add_stable t);
-    simpl in |- *; auto
- | generalize H3; unfold not in |- *; intros E1 E2; apply E1;
-    symmetry  in |- *; trivial ].
+ [ intro H4; left; apply H1; simpl; elim (add_norm_stable t);
+    simpl; auto
+ | intro H4; right; apply H2; simpl; elim (scalar_norm_add_stable t);
+    simpl; auto
+ | generalize H3; unfold not; intros E1 E2; apply E1;
+    symmetry ; trivial ].
 Qed.
 
 
@@ -2532,49 +2480,49 @@ Fixpoint execute_omega (t : t_omega) (l : hyps) {struct t} : lhyps :=
       execute_omega cont (apply_oper_2 i1 i2 (state m s) l)
   end.
 
-Theorem omega_valid : forall t : t_omega, valid_list_hyps (execute_omega t).
+Theorem omega_valid : forall tr : t_omega, valid_list_hyps (execute_omega tr).
 Proof.
- simple induction t; simpl in |- *;
- [ unfold valid_list_hyps in |- *; simpl in |- *; intros; left;
+ simple induction tr; simpl;
+ [ unfold valid_list_hyps; simpl; intros; left;
     apply (constant_not_nul_valid n ep e lp H)
- | unfold valid_list_hyps in |- *; simpl in |- *; intros; left;
+ | unfold valid_list_hyps; simpl; intros; left;
     apply (constant_neg_valid n ep e lp H)
- | unfold valid_list_hyps, valid_hyps in |- *;
+ | unfold valid_list_hyps, valid_hyps;
     intros k1 k2 body n t' Ht' m ep e lp H; apply Ht';
     apply
      (apply_oper_1_valid m (divide_and_approx k1 k2 body n)
         (divide_and_approx_valid k1 k2 body n) ep e lp H)
- | unfold valid_list_hyps in |- *; simpl in |- *; intros; left;
-    apply (not_exact_divide_valid i i0 t0 n n0 ep e lp H)
- | unfold valid_list_hyps, valid_hyps in |- *;
+ | unfold valid_list_hyps; simpl; intros; left;
+    apply (not_exact_divide_valid _ _ _ _ _ ep e lp H)
+ | unfold valid_list_hyps, valid_hyps;
     intros k body n t' Ht' m ep e lp H; apply Ht';
     apply
      (apply_oper_1_valid m (exact_divide k body n)
         (exact_divide_valid k body n) ep e lp H)
- | unfold valid_list_hyps, valid_hyps in |- *;
+ | unfold valid_list_hyps, valid_hyps;
     intros k1 i1 k2 i2 trace t' Ht' ep e lp H; apply Ht';
     apply
      (apply_oper_2_valid i1 i2 (sum k1 k2 trace) (sum_valid k1 k2 trace) ep e
         lp H)
- | unfold valid_list_hyps in |- *; simpl in |- *; intros; left;
+ | unfold valid_list_hyps; simpl; intros; left;
     apply (contradiction_valid n n0 n1 ep e lp H)
- | unfold valid_list_hyps, valid_hyps in |- *;
+ | unfold valid_list_hyps, valid_hyps;
     intros trace i1 i2 t' Ht' ep e lp H; apply Ht';
     apply
      (apply_oper_2_valid i1 i2 (merge_eq trace) (merge_eq_valid trace) ep e
         lp H)
- | intros t' i k1 H1 k2 H2; unfold valid_list_hyps in |- *; simpl in |- *;
+ | intros t' i k1 H1 k2 H2; unfold valid_list_hyps; simpl;
     intros ep e lp H;
     apply
      (split_ineq_valid i t' (execute_omega k1) (execute_omega k2) H1 H2 ep e
         lp H)
- | unfold valid_list_hyps in |- *; simpl in |- *; intros i ep e lp H; left;
+ | unfold valid_list_hyps; simpl; intros i ep e lp H; left;
     apply (constant_nul_valid i ep e lp H)
- | unfold valid_list_hyps in |- *; simpl in |- *; intros i j ep e lp H; left;
+ | unfold valid_list_hyps; simpl; intros i j ep e lp H; left;
     apply (negate_contradict_valid i j ep e lp H)
- | unfold valid_list_hyps in |- *; simpl in |- *; intros n i j ep e lp H;
+ | unfold valid_list_hyps; simpl; intros n i j ep e lp H;
     left; apply (negate_contradict_inv_valid n i j ep e lp H)
- | unfold valid_list_hyps, valid_hyps in |- *;
+ | unfold valid_list_hyps, valid_hyps;
     intros m s i1 i2 t' Ht' ep e lp H; apply Ht';
     apply (apply_oper_2_valid i1 i2 (state m s) (state_valid m s) ep e lp H) ].
 Qed.
@@ -2585,20 +2533,20 @@ 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 |- *;
- [ symmetry  in |- *; apply egal_left; assumption
+ unfold valid1, move_right; intros s ep e p; Simplify; simpl;
+ elim (t_rewrite_stable s e); simpl;
+ [ symmetry ; 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
@@ -2611,7 +2559,7 @@ Definition do_normalize (i : nat) (s : step) := apply_oper_1 i (move_right s).
 Theorem do_normalize_valid :
  forall (i : nat) (s : step), valid_hyps (do_normalize i s).
 Proof.
- intros; unfold do_normalize in |- *; apply apply_oper_1_valid;
+ intros; unfold do_normalize; apply apply_oper_1_valid;
  apply move_right_valid.
 Qed.
 
@@ -2625,7 +2573,7 @@ Fixpoint do_normalize_list (l : list step) (i : nat)
 Theorem do_normalize_list_valid :
  forall (l : list step) (i : nat), valid_hyps (do_normalize_list l i).
 Proof.
- simple induction l; simpl in |- *; unfold valid_hyps in |- *;
+ simple induction l; simpl; unfold valid_hyps;
  [ auto
  | intros a l' Hl' i ep e lp H; unfold valid_hyps in Hl'; apply Hl';
     apply (do_normalize_valid i a ep e lp); assumption ].
@@ -2641,10 +2589,10 @@ Qed.
 (* \subsubsection{Exécution de la trace} *)
 
 Theorem execute_goal :
- forall (t : t_omega) (ep : list Prop) (env : list int) (l : hyps),
- interp_list_goal ep env (execute_omega t l) -> interp_goal ep env l.
+ forall (tr : t_omega) (ep : list Prop) (env : list int) (l : hyps),
+ interp_list_goal ep env (execute_omega tr l) -> interp_goal ep env l.
 Proof.
- intros; apply (goal_valid (execute_omega t) (omega_valid t) ep env l H).
+ intros; apply (goal_valid (execute_omega tr) (omega_valid tr) ep env l H).
 Qed.
 
 
@@ -2654,8 +2602,8 @@ Theorem append_goal :
  interp_list_goal ep e (l1 ++ l2).
 Proof.
  intros ep e; simple induction l1;
- [ simpl in |- *; intros l2 (H1, H2); assumption
- | simpl in |- *; intros h1 t1 HR l2 ((H1, H2), H3); split; auto ].
+ [ simpl; intros l2 (H1, H2); assumption
+ | simpl; intros h1 t1 HR l2 ((H1, H2), H3); split; auto ].
 Qed.
 
 (* A simple decidability checker : if the proposition belongs to the
@@ -2684,11 +2632,11 @@ Theorem decidable_correct :
  forall (ep : list Prop) (e : list int) (p : proposition),
  decidability p = true -> decidable (interp_proposition ep e p).
 Proof.
- simple induction p; simpl in |- *; intros;
+ simple induction p; simpl; intros;
  [ apply dec_eq
  | apply dec_le
  | left; auto
- | right; unfold not in |- *; auto
+ | right; unfold not; auto
  | apply dec_not; auto
  | apply dec_ge
  | apply dec_gt
@@ -2724,7 +2672,7 @@ Theorem interp_full_false :
  forall (ep : list Prop) (e : list int) (l : hyps) (c : proposition),
  (interp_hyps ep e l -> interp_proposition ep e c) -> interp_full ep e (l, c).
 Proof.
- simple induction l; unfold interp_full in |- *; simpl in |- *;
+ simple induction l; unfold interp_full; simpl;
  [ auto | intros a l1 H1 c H2 H3; apply H1; auto ].
 Qed.
 
@@ -2744,12 +2692,12 @@ Theorem to_contradict_valid :
  forall (ep : list Prop) (e : list int) (lc : hyps * proposition),
  interp_goal ep e (to_contradict lc) -> interp_full ep e lc.
 Proof.
- intros ep e lc; case lc; intros l c; simpl in |- *;
- pattern (decidability c) in |- *; apply bool_eq_ind;
- [ simpl in |- *; intros H H1; apply interp_full_false; intros H2;
+ intros ep e lc; case lc; intros l c; simpl;
+ pattern (decidability c); apply bool_eq_ind;
+ [ simpl; intros H H1; apply interp_full_false; intros H2;
     apply not_not;
     [ apply decidable_correct; assumption
-    | unfold not at 1 in |- *; intro H3; apply hyps_to_goal with (2 := H2);
+    | unfold not at 1; intro H3; apply hyps_to_goal with (2 := H2);
        auto ]
  | intros H1 H2; apply interp_full_false; intro H3;
     elim hyps_to_goal with (1 := H2); assumption ].
@@ -2813,7 +2761,7 @@ Theorem map_cons_val :
  interp_proposition ep e p ->
  interp_list_hyps ep e l -> interp_list_hyps ep e (map_cons _ p l).
 Proof.
- simple induction l; simpl in |- *; [ auto | intros; elim H1; intro H2; auto ].
+ simple induction l; simpl; [ auto | intros; elim H1; intro H2; auto ].
 Qed.
 
 Hint Resolve map_cons_val append_valid decidable_correct.
@@ -2822,43 +2770,43 @@ Theorem destructure_hyps_valid :
  forall n : nat, valid_list_hyps (destructure_hyps n).
 Proof.
  simple induction n;
- [ unfold valid_list_hyps in |- *; simpl in |- *; auto
- | unfold valid_list_hyps at 2 in |- *; intros n1 H ep e lp; case lp;
-    [ simpl in |- *; auto
+ [ unfold valid_list_hyps; simpl; auto
+ | unfold valid_list_hyps at 2; intros n1 H ep e lp; case lp;
+    [ simpl; auto
     | intros p l; case p;
        try
-        (simpl in |- *; intros; apply map_cons_val; simpl in |- *; elim H0;
+        (simpl; intros; apply map_cons_val; simpl; elim H0;
           auto);
        [ intro p'; case p';
           try
-           (simpl in |- *; intros; apply map_cons_val; simpl in |- *; elim H0;
+           (simpl; intros; apply map_cons_val; simpl; elim H0;
              auto);
-          [ simpl in |- *; intros p1 (H1, H2);
-             pattern (decidability p1) in |- *; apply bool_eq_ind;
+          [ simpl; intros p1 (H1, H2);
+             pattern (decidability p1); apply bool_eq_ind;
              intro H3;
-             [ apply H; simpl in |- *; split;
+             [ apply H; simpl; split;
                 [ apply not_not; auto | assumption ]
              | auto ]
-          | simpl in |- *; intros p1 p2 (H1, H2); apply H; simpl in |- *;
+          | simpl; intros p1 p2 (H1, H2); apply H; simpl;
              elim not_or with (1 := H1); auto
-          | simpl in |- *; intros p1 p2 (H1, H2);
-             pattern (decidability p1) in |- *; apply bool_eq_ind;
+          | simpl; intros p1 p2 (H1, H2);
+             pattern (decidability p1); apply bool_eq_ind;
              intro H3;
              [ apply append_valid; elim not_and with (2 := H1);
-                [ intro; left; apply H; simpl in |- *; auto
-                | intro; right; apply H; simpl in |- *; auto
+                [ intro; left; apply H; simpl; auto
+                | intro; right; apply H; simpl; auto
                 | auto ]
              | auto ] ]
-       | simpl in |- *; intros p1 p2 (H1, H2); apply append_valid;
-          (elim H1; intro H3; simpl in |- *; [ left | right ]);
-          apply H; simpl in |- *; auto
-       | simpl in |- *; intros; apply H; simpl in |- *; tauto
-       | simpl in |- *; intros p1 p2 (H1, H2);
-          pattern (decidability p1) in |- *; apply bool_eq_ind;
+       | simpl; intros p1 p2 (H1, H2); apply append_valid;
+          (elim H1; intro H3; simpl; [ left | right ]);
+          apply H; simpl; auto
+       | simpl; intros; apply H; simpl; tauto
+       | simpl; intros p1 p2 (H1, H2);
+          pattern (decidability p1); apply bool_eq_ind;
           intro H3;
           [ apply append_valid; elim imp_simp with (2 := H1);
-             [ intro H4; left; simpl in |- *; apply H; simpl in |- *; auto
-             | intro H4; right; simpl in |- *; apply H; simpl in |- *; auto
+             [ intro H4; left; simpl; apply H; simpl; auto
+             | intro H4; right; simpl; apply H; simpl; auto
              | auto ]
           | auto ] ] ] ].
 Qed.
@@ -2881,8 +2829,8 @@ Theorem p_apply_left_stable :
  forall f : proposition -> proposition,
  prop_stable f -> prop_stable (p_apply_left f).
 Proof.
- unfold prop_stable in |- *; intros f H ep e p; split;
- (case p; simpl in |- *; auto; intros p1; elim (H ep e p1); tauto).
+ unfold prop_stable; intros f H ep e p; split;
+ (case p; simpl; auto; intros p1; elim (H ep e p1); tauto).
 Qed.
 
 Definition p_apply_right (f : proposition -> proposition)
@@ -2899,8 +2847,8 @@ Theorem p_apply_right_stable :
  forall f : proposition -> proposition,
  prop_stable f -> prop_stable (p_apply_right f).
 Proof.
- unfold prop_stable in |- *; intros f H ep e p; split;
- (case p; simpl in |- *; auto;
+ unfold prop_stable; intros f H ep e p; split;
+ (case p; simpl; auto;
    [ intros p1; elim (H ep e p1); tauto
    | intros p1 p2; elim (H ep e p2); tauto
    | intros p1 p2; elim (H ep e p2); tauto
@@ -2923,53 +2871,53 @@ Theorem p_invert_stable :
  forall f : proposition -> proposition,
  prop_stable f -> prop_stable (p_invert f).
 Proof.
- unfold prop_stable in |- *; intros f H ep e p; split;
- (case p; simpl in |- *; auto;
-   [ intros t1 t2; elim (H ep e (NeqTerm t1 t2)); simpl in |- *;
+ unfold prop_stable; intros f H ep e p; split;
+ (case p; simpl; auto;
+   [ intros t1 t2; elim (H ep e (NeqTerm t1 t2)); simpl;
       generalize (dec_eq (interp_term e t1) (interp_term e t2));
-      unfold decidable in |- *; tauto
-   | intros t1 t2; elim (H ep e (GtTerm t1 t2)); simpl in |- *;
+      unfold decidable; tauto
+   | intros t1 t2; elim (H ep e (GtTerm t1 t2)); simpl;
       generalize (dec_gt (interp_term e t1) (interp_term e t2));
-      unfold decidable in |- *; rewrite le_lt_iff, <- gt_lt_iff; tauto
-   | intros t1 t2; elim (H ep e (LtTerm t1 t2)); simpl in |- *;
+      unfold decidable; rewrite le_lt_iff, <- gt_lt_iff; tauto
+   | intros t1 t2; elim (H ep e (LtTerm t1 t2)); simpl;
       generalize (dec_lt (interp_term e t1) (interp_term e t2));
-      unfold decidable in |- *; rewrite ge_le_iff, le_lt_iff; tauto
-   | intros t1 t2; elim (H ep e (LeqTerm t1 t2)); simpl in |- *;
+      unfold decidable; rewrite ge_le_iff, le_lt_iff; tauto
+   | intros t1 t2; elim (H ep e (LeqTerm t1 t2)); simpl;
       generalize (dec_gt (interp_term e t1) (interp_term e t2));
-      unfold decidable in |- *; repeat rewrite le_lt_iff;
+      unfold decidable; repeat rewrite le_lt_iff;
       repeat rewrite gt_lt_iff; tauto
-   | intros t1 t2; elim (H ep e (GeqTerm t1 t2)); simpl in |- *;
+   | intros t1 t2; elim (H ep e (GeqTerm t1 t2)); simpl;
       generalize (dec_lt (interp_term e t1) (interp_term e t2));
-      unfold decidable in |- *; repeat rewrite ge_le_iff;
+      unfold decidable; repeat rewrite ge_le_iff;
       repeat rewrite le_lt_iff; tauto
-   | intros t1 t2; elim (H ep e (EqTerm t1 t2)); simpl in |- *;
+   | intros t1 t2; elim (H ep e (EqTerm t1 t2)); simpl;
       generalize (dec_eq (interp_term e t1) (interp_term e t2));
       unfold decidable; tauto ]).
 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 |- *;
-    [ symmetry  in |- *; apply egal_left; assumption
+ unfold move_right, prop_stable; intros s ep e p; split;
+ [ Simplify; simpl; elim (t_rewrite_stable s e); simpl;
+    [ symmetry ; 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);
-    simpl in |- *; intro H1;
-    [ rewrite (plus_0_r_reverse (interp_term e t0)); rewrite H1;
+ | case p; simpl; intros; auto; generalize H; elim (t_rewrite_stable s);
+    simpl; intro H1;
+    [ rewrite (plus_0_r_reverse (interp_term e t1)); rewrite H1;
        rewrite plus_permute; rewrite plus_opp_r;
        rewrite plus_0_r; trivial
-    | apply (fun a b => plus_le_reg_r a b (- interp_term e t));
+    | apply (fun a b => plus_le_reg_r a b (- interp_term e t0));
        rewrite plus_opp_r; assumption
     | rewrite ge_le_iff;
-       apply (fun a b => plus_le_reg_r a b (- interp_term e t0));
+       apply (fun a b => plus_le_reg_r a b (- interp_term e t1));
        rewrite plus_opp_r; assumption
     | rewrite gt_lt_iff; apply lt_left_inv; assumption
     | apply lt_left_inv; assumption
-    | unfold not in |- *; intro H2; apply H1;
+    | unfold not; intro H2; apply H1;
        rewrite H2; rewrite plus_opp_r; trivial ] ].
 Qed.
 
@@ -2985,12 +2933,12 @@ Fixpoint p_rewrite (s : p_step) : proposition -> proposition :=
 
 Theorem p_rewrite_stable : forall s : p_step, prop_stable (p_rewrite s).
 Proof.
- simple induction s; simpl in |- *;
+ simple induction s; simpl;
  [ intros; apply p_apply_left_stable; trivial
  | intros; apply p_apply_right_stable; trivial
  | intros; apply p_invert_stable; apply move_right_stable
  | apply move_right_stable
- | unfold prop_stable in |- *; simpl in |- *; intros; split; auto ].
+ | unfold prop_stable; simpl; intros; split; auto ].
 Qed.
 
 Fixpoint normalize_hyps (l : list h_step) (lh : hyps) {struct l} : hyps :=
@@ -3002,11 +2950,11 @@ Fixpoint normalize_hyps (l : list h_step) (lh : hyps) {struct l} : hyps :=
 Theorem normalize_hyps_valid :
  forall l : list h_step, valid_hyps (normalize_hyps l).
 Proof.
- simple induction l; unfold valid_hyps in |- *; simpl in |- *;
+ simple induction l; unfold valid_hyps; simpl;
  [ auto
  | intros n_s r; case n_s; intros n s H ep e lp H1; apply H;
     apply apply_oper_1_valid;
-    [ unfold valid1 in |- *; intros ep1 e1 p1 H2;
+    [ unfold valid1; intros ep1 e1 p1 H2;
        elim (p_rewrite_stable s ep1 e1 p1); auto
     | assumption ] ].
 Qed.
@@ -3073,21 +3021,21 @@ Theorem extract_valid :
  forall s : list direction,
  valid1 (extract_hyp_pos s) /\ co_valid1 (extract_hyp_neg s).
 Proof.
- unfold valid1, co_valid1 in |- *; simple induction s;
+ unfold valid1, co_valid1; simple induction s;
  [ split;
-    [ simpl in |- *; auto
-    | intros ep e p1; case p1; simpl in |- *; auto; intro p;
-       pattern (decidability p) in |- *; apply bool_eq_ind;
+    [ simpl; auto
+    | intros ep e p1; case p1; simpl; auto; intro p;
+       pattern (decidability p); apply bool_eq_ind;
        [ intro H; generalize (decidable_correct ep e p H);
-          unfold decidable in |- *; tauto
-       | simpl in |- *; auto ] ]
+          unfold decidable; tauto
+       | simpl; auto ] ]
  | intros a s' (H1, H2); simpl in H2; split; intros ep e p; case a; auto;
-    case p; auto; simpl in |- *; intros;
+    case p; auto; simpl; intros;
     (apply H1; tauto) ||
       (apply H2; tauto) ||
-        (pattern (decidability p0) in |- *; apply bool_eq_ind;
+        (pattern (decidability p0); apply bool_eq_ind;
           [ intro H3; generalize (decidable_correct ep e p0 H3);
-             unfold decidable in |- *; intro H4; apply H1;
+             unfold decidable; intro H4; apply H1;
              tauto
           | intro; tauto ]) ].
 Qed.
@@ -3117,29 +3065,29 @@ Fixpoint decompose_solve (s : e_step) (h : hyps) {struct s} : lhyps :=
 Theorem decompose_solve_valid :
  forall s : e_step, valid_list_goal (decompose_solve s).
 Proof.
- intro s; apply goal_valid; unfold valid_list_hyps in |- *; elim s;
- simpl in |- *; intros;
+ intro s; apply goal_valid; unfold valid_list_hyps; elim s;
+ simpl; intros;
  [ cut (interp_proposition ep e1 (extract_hyp_pos l (nth_hyps n lp)));
-    [ case (extract_hyp_pos l (nth_hyps n lp)); simpl in |- *; auto;
-       [ intro p; case p; simpl in |- *; auto; intros p1 p2 H2;
-          pattern (decidability p1) in |- *; apply bool_eq_ind;
+    [ case (extract_hyp_pos l (nth_hyps n lp)); simpl; auto;
+       [ intro p; case p; simpl; auto; intros p1 p2 H2;
+          pattern (decidability p1); apply bool_eq_ind;
           [ intro H3; generalize (decidable_correct ep e1 p1 H3); intro H4;
              apply append_valid; elim H4; intro H5;
-             [ right; apply H0; simpl in |- *; tauto
-             | left; apply H; simpl in |- *; tauto ]
-          | simpl in |- *; auto ]
-       | intros p1 p2 H2; apply append_valid; simpl in |- *; elim H2;
-          [ intros H3; left; apply H; simpl in |- *; auto
-          | intros H3; right; apply H0; simpl in |- *; auto ]
+             [ right; apply H0; simpl; tauto
+             | left; apply H; simpl; tauto ]
+          | simpl; auto ]
+       | intros p1 p2 H2; apply append_valid; simpl; elim H2;
+          [ intros H3; left; apply H; simpl; auto
+          | intros H3; right; apply H0; simpl; auto ]
        | intros p1 p2 H2;
-         pattern (decidability p1) in |- *; apply bool_eq_ind;
+         pattern (decidability p1); apply bool_eq_ind;
           [ intro H3; generalize (decidable_correct ep e1 p1 H3); intro H4;
              apply append_valid; elim H4; intro H5;
-             [ right; apply H0; simpl in |- *; tauto
-             | left; apply H; simpl in |- *; tauto ]
-          | simpl in |- *; auto ] ]
+             [ right; apply H0; simpl; tauto
+             | left; apply H; simpl; tauto ]
+          | simpl; auto ] ]
     | elim (extract_valid l); intros H2 H3; apply H2; apply nth_valid; auto ]
- | intros; apply H; simpl in |- *; split;
+ | intros; apply H; simpl; split;
     [ elim (extract_valid l); intros H2 H3; apply H2; apply nth_valid; auto
     | auto ]
  | apply omega_valid with (1 := H) ].
@@ -3160,11 +3108,11 @@ Fixpoint reduce_lhyps (lp : lhyps) : lhyps :=
 
 Theorem reduce_lhyps_valid : valid_lhyps reduce_lhyps.
 Proof.
- unfold valid_lhyps in |- *; intros ep e lp; elim lp;
- [ simpl in |- *; auto
+ unfold valid_lhyps; intros ep e lp; elim lp;
+ [ simpl; auto
  | intros a l HR; elim a;
-    [ simpl in |- *; tauto
-    | intros a1 l1; case l1; case a1; simpl in |- *; try tauto ] ].
+    [ simpl; tauto
+    | intros a1 l1; case l1; case a1; simpl; try tauto ] ].
 Qed.
 
 Theorem do_reduce_lhyps :
@@ -3184,13 +3132,13 @@ Definition do_concl_to_hyp :
   interp_goal envp env (concl_to_hyp c :: l) ->
   interp_goal_concl c envp env l.
 Proof.
- simpl in |- *; intros envp env c l; induction l as [| a l Hrecl];
- [ simpl in |- *; unfold concl_to_hyp in |- *;
-    pattern (decidability c) in |- *; apply bool_eq_ind;
+ simpl; intros envp env c l; induction l as [| a l Hrecl];
+ [ simpl; unfold concl_to_hyp;
+    pattern (decidability c); apply bool_eq_ind;
     [ intro H; generalize (decidable_correct envp env c H);
-       unfold decidable in |- *; simpl in |- *; tauto
-    | simpl in |- *; intros H1 H2; elim H2; trivial ]
- | simpl in |- *; tauto ].
+       unfold decidable; simpl; tauto
+    | simpl; intros H1 H2; elim H2; trivial ]
+ | simpl; tauto ].
 Qed.
 
 Definition omega_tactic (t1 : e_step) (t2 : list h_step)
@@ -3203,7 +3151,7 @@ Theorem do_omega :
  interp_list_goal envp env (omega_tactic t1 t2 c l) ->
  interp_goal_concl c envp env l.
 Proof.
- unfold omega_tactic in |- *; intros; apply do_concl_to_hyp;
+ unfold omega_tactic; intros; apply do_concl_to_hyp;
  apply (normalize_hyps_goal t2); apply (decompose_solve_valid t1);
  apply do_reduce_lhyps; assumption.
 Qed.
diff --git a/plugins/romega/const_omega.ml b/plugins/romega/const_omega.ml
index f4368a1b..fb45e816 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,14 +328,14 @@ 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)
+	(try Tnum (recognize t) with e when Errors.noncritical e -> Tother)
     | _ -> Tother
   with e when Logic.catchable_exception e -> Tother
 
@@ -334,19 +344,19 @@ 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
+  try aux t with e when Errors.noncritical e -> false
 
 end
diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml
index 570bb187..e57230cb 100644
--- a/plugins/romega/refl_omega.ml
+++ b/plugins/romega/refl_omega.ml
@@ -219,23 +219,26 @@ 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
 
 let get_reified_atom env =
-  try List.nth env.terms with _ -> failwith "get_reified_atom"
+  try List.nth env.terms
+  with e when Errors.noncritical e -> failwith "get_reified_atom"
 
 (* \subsection{Gestion de l'environnement de proposition pour Omega} *)
 (* ajout d'une proposition *)
 let add_prop env t =
-  try list_index0 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
 
 (* accès a une proposition *)
-let get_prop v env = try List.nth v env with _ -> failwith "get_prop"
+let get_prop v env =
+  try List.nth v env
+  with e when Errors.noncritical e -> failwith "get_prop"
 
 (* \subsection{Gestion du nommage des équations} *)
 (* Ajout d'une equation dans l'environnement de reification *)
@@ -247,7 +250,8 @@ let add_equation env e =
 (* accès a une equation *)
 let get_equation env id =
   try Hashtbl.find env.equations id
-  with e -> Printf.printf "Omega Equation %d non trouvée\n" id; raise e
+  with Not_found as e ->
+    Printf.printf "Omega Equation %d non trouvée\n" id; raise e
 
 (* Affichage des termes réifiés *)
 let rec oprint ch = function
@@ -349,7 +353,8 @@ let rec reified_of_formula env = function
       app coq_t_minus [| reified_of_formula env t1; reified_of_formula env t2 |]
 
 let reified_of_formula env f =
-  begin try reified_of_formula env f with e -> oprint stderr f; raise e end
+  try reified_of_formula env f
+  with reraise -> oprint stderr f; raise reraise
 
 let rec reified_of_proposition env = function
     Pequa (_,{ e_comp=Eq; e_left=t1; e_right=t2 }) ->
@@ -380,8 +385,8 @@ let rec reified_of_proposition env = function
   | Pprop t -> app coq_p_prop [| mk_nat (add_prop env t) |]
 
 let reified_of_proposition env f =
-  begin try reified_of_proposition env f
-  with e -> pprint stderr f; raise e end
+  try reified_of_proposition env f
+  with reraise -> pprint stderr f; raise reraise
 
 (* \subsection{Omega vers COQ réifié} *)
 
@@ -397,11 +402,11 @@ let reified_of_omega env body constant =
   List.fold_right mk_coeff body coeff_constant
 
 let reified_of_omega env body c  =
-  begin try
+  try
     reified_of_omega env body c
-  with e ->
-    display_eq display_omega_var (body,c); raise e
-  end
+  with reraise ->
+    display_eq display_omega_var (body,c); raise reraise
+
 
 (* \section{Opérations sur les équations}
 Ces fonctions préparent les traces utilisées par la tactique réfléchie
@@ -1000,10 +1005,11 @@ let rec solve_with_constraints all_solutions path =
   let weighted = filter_compatible_systems path all_solutions in
   let (winner_sol,winner_deps) =
     try select_smaller weighted
-    with e ->
+    with reraise ->
       Printf.printf "%d - %d\n"
 	(List.length weighted) (List.length all_solutions);
-      List.iter display_depend path; raise e in
+      List.iter display_depend path; raise reraise
+  in
   build_tree winner_sol (List.rev path) winner_deps
 
 let find_path {o_hyp=id;o_path=p} env =
diff --git a/plugins/rtauto/Bintree.v b/plugins/rtauto/Bintree.v
index 39c29a3d..98dd257d 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-2012     *)
 (*   \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 ?= Pos.succ 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.
+       (Pos.succ 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.
@@ -299,7 +181,7 @@ mkStore  {index:positive;contents:Tree}.
 Definition empty := mkStore xH Tempty.
 
 Definition push a  S :=
-mkStore (Psucc (index S)) (Tadd (index S) a (contents S)).
+mkStore (Pos.succ (index S)) (Tadd (index S) a (contents S)).
 
 Definition get i S := Tget i (contents S).
 
@@ -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.
@@ -331,7 +214,7 @@ intros a S.
 rewrite Tget_Tadd.
 rewrite Psucc_Gt.
 intro W.
-change (get (Psucc (index S)) S =PNone).
+change (get (Pos.succ (index S)) S =PNone).
 apply get_Full_Gt; auto.
 apply Psucc_Gt.
 Qed.
@@ -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,9 +245,10 @@ 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.
-rewrite (Pcompare_Eq_eq _ _ test) in H.
+case_eq (i ?= index S);intro test.
+rewrite (Pos.compare_eq _ _ test) in H.
 rewrite (get_Full_Eq _ F) in H;congruence.
 rewrite <- H.
 rewrite (get_push_Full i a).
@@ -375,13 +260,13 @@ Qed.
 Lemma Full_index_one_empty : forall S, Full S -> index S = 1 -> S=empty.
 intros [ind cont] F one; inversion F.
 reflexivity.
-simpl index in one;assert (h:=Psucc_not_one (index S)).
+simpl index in one;assert (h:=Pos.succ_not_1 (index S)).
 congruence.
 Qed.
 
 Lemma push_not_empty: forall a S, (push a S) <> empty.
 intros a [ind cont];unfold push,empty.
-simpl;intro H;injection H; intros _ ; apply Psucc_not_one.
+simpl;intro H;injection H; intros _ ; apply Pos.succ_not_1.
 Qed.
 
 Fixpoint In (x:A) (S:Store) (F:Full S) {struct F}: Prop :=
@@ -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..3b596238 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-2012     *)
 (*   \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..96277e65 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-2012     *)
 (*   \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..c1e83004 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-2012     *)
 (*   \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);
@@ -510,8 +509,8 @@ let pp_gl gl= cut () ++
 
 let pp =
   function
-      Incomplete(gl,ctx) -> msgnl (pp_gl gl)
-    | _ -> msg (str "<complete>")
+      Incomplete(gl,ctx) -> pp_gl gl ++ fnl ()
+    | _ -> str "<complete>"
 
 let pp_info () =
   let count_info =
diff --git a/plugins/rtauto/proof_search.mli b/plugins/rtauto/proof_search.mli
index 4d77a057..2adda33f 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-2012     *)
 (*   \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
@@ -40,7 +38,7 @@ val branching: state -> state list
 
 val success: state -> bool
 
-val pp: state -> unit
+val pp: state -> Pp.std_ppcmds
 
 val pr_form : form -> unit
 
diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml
index 20b4c8f6..e8909f08 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-2012     *)
 (*   \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
@@ -35,11 +32,11 @@ let data_constant =
   Coqlib.gen_constant "refl_tauto" ["Init";"Datatypes"]
 
 let l_true_equals_true =
-  lazy (mkApp(logic_constant "refl_equal",
+  lazy (mkApp(logic_constant "eq_refl",
         [|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..e5fb646a 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-2012     *)
 (*   \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..ed35bb46 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -21,17 +21,17 @@ 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 N.to_nat.
 Proof.
   constructor;trivial.
-  exact nat_of_Nplus.
-  exact nat_of_Nmult.
-  intros x y H;rewrite (Neq_bool_ok _ _ H);trivial.
+  exact N2Nat.inj_add.
+  exact N2Nat.inj_mul.
+  intros x y H. apply N.eqb_eq in H. now subst.
 Qed.
 
 Ltac natcst t :=
   match isnatcst t with
-    true => constr:(N_of_nat t)
+    true => constr:(N.of_nat t)
   | _ => constr:InitialRing.NotConstant
   end.
 
diff --git a/plugins/setoid_ring/BinList.v b/plugins/setoid_ring/BinList.v
index 905625cc..b3c59457 100644
--- a/plugins/setoid_ring/BinList.v
+++ b/plugins/setoid_ring/BinList.v
@@ -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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-Set Implicit Arguments.
 Require Import BinPos.
 Require Export List.
-Require Export ListTactics.
-Open Local Scope positive_scope.
+Set Implicit Arguments.
+Local Open Scope positive_scope.
 
 Section MakeBinList.
  Variable A : Type.
@@ -18,76 +17,64 @@ Section MakeBinList.
 
  Fixpoint jump (p:positive) (l:list A) {struct p} : list A :=
   match p with
-  | xH => tail l
+  | xH => tl l
   | xO p => jump p (jump p l)
-  | xI p  => jump p (jump p (tail l))
+  | xI p  => jump p (jump p (tl l))
   end.
 
  Fixpoint nth (p:positive) (l:list A) {struct p} : A:=
   match p with
   | xH => hd default l
   | xO p => nth p (jump p l)
-  | xI p => nth p (jump p (tail l))
+  | xI p => nth p (jump p (tl l))
   end.
 
- Lemma jump_tl : forall j l, tail (jump j l) = jump j (tail l).
+ Lemma jump_tl : forall j l, tl (jump j l) = jump j (tl l).
  Proof.
-  induction j;simpl;intros.
-  repeat rewrite IHj;trivial.
-  repeat rewrite IHj;trivial.
-  trivial.
+  induction j;simpl;intros; now rewrite ?IHj.
  Qed.
 
- Lemma jump_Psucc : forall j l,
-  (jump (Psucc j) l) = (jump 1 (jump j l)).
+ Lemma jump_succ : forall j l,
+  jump (Pos.succ j) l = jump 1 (jump j l).
  Proof.
   induction j;simpl;intros.
-  repeat rewrite IHj;simpl;repeat rewrite jump_tl;trivial.
-  repeat rewrite jump_tl;trivial.
-  trivial.
+  - rewrite !IHj; simpl; now rewrite !jump_tl.
+  - now rewrite !jump_tl.
+  - trivial.
  Qed.
 
- Lemma jump_Pplus : forall i j l,
-  (jump (i + j) l) = (jump i (jump j l)).
+ Lemma jump_add : forall i j l,
+  jump (i + j) l = jump i (jump j l).
  Proof.
-  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 jump_Psucc;trivial.
-  rewrite <- Pplus_diag;repeat rewrite <- Pplus_assoc.
-  repeat rewrite IHi;trivial.
-  rewrite Pplus_comm;rewrite <- Pplus_one_succ_r;rewrite jump_Psucc;trivial.
+  induction i using Pos.peano_ind; intros.
+  - now rewrite Pos.add_1_l, jump_succ.
+  - now rewrite Pos.add_succ_l, !jump_succ, IHi.
  Qed.
 
- Lemma jump_Pdouble_minus_one : forall i l,
-  (jump (Pdouble_minus_one i) (tail l)) = (jump i (jump i l)).
+ Lemma jump_pred_double : forall i l,
+  jump (Pos.pred_double i) (tl l) = jump i (jump i l).
  Proof.
   induction i;intros;simpl.
-  repeat rewrite jump_tl;trivial.
-  rewrite IHi. do 2 rewrite <- jump_tl;rewrite IHi;trivial.
-  trivial.
+  - now rewrite !jump_tl.
+  - now rewrite IHi, <- 2 jump_tl, IHi.
+  - trivial.
  Qed.
 
-
- Lemma nth_jump : forall p l, nth p (tail l) = hd default (jump p l).
+ Lemma nth_jump : forall p l, nth p (tl l) = hd default (jump p l).
  Proof.
   induction p;simpl;intros.
-  rewrite <-jump_tl;rewrite IHp;trivial.
-  rewrite <-jump_tl;rewrite IHp;trivial.
-  trivial.
+  - now rewrite <-jump_tl, IHp.
+  - now rewrite <-jump_tl, IHp.
+  - trivial.
  Qed.
 
- Lemma nth_Pdouble_minus_one :
-  forall p l, nth (Pdouble_minus_one p) (tail l) = nth p (jump p l).
+ Lemma nth_pred_double :
+  forall p l, nth (Pos.pred_double p) (tl l) = nth p (jump p l).
  Proof.
   induction p;simpl;intros.
-  repeat rewrite jump_tl;trivial.
-  rewrite jump_Pdouble_minus_one.
-  repeat rewrite <- jump_tl;rewrite IHp;trivial.
-  trivial.
+  - now rewrite !jump_tl.
+  - now rewrite jump_pred_double, <- !jump_tl, IHp.
+  - trivial.
  Qed.
 
 End MakeBinList.
-
-
diff --git a/plugins/setoid_ring/Cring.v b/plugins/setoid_ring/Cring.v
new file mode 100644
index 00000000..02194d4f
--- /dev/null
+++ b/plugins/setoid_ring/Cring.v
@@ -0,0 +1,271 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+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 _+_ _*_ -_ _==_.
+Proof.
+intros. apply mk_reqe; solve_proper.
+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 Z.add Z.mul Z.sub Z.opp 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 Z.sub. 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 _==_ Z.add Z.mul 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 Z.add Z.mul Z.sub Z.opp 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 Z.mul_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 Z.add Z.mul Z.sub Z.opp 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 (eq_refl 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 Z.add Z.mul Z.sub Z.opp 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 (eq_refl 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..6d454ba8 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-2012     *)
 (*   \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..8ac952c0 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -447,7 +447,7 @@ Ltac prove_field_eqn ope FLD fv expr :=
   pose (res' := res);
   let lemma := get_L1 FLD in
   let lemma :=
-    constr:(lemma O fv List.nil expr' res' I List.nil (refl_equal _)) in
+    constr:(lemma O fv List.nil expr' res' I List.nil (eq_refl _)) in
   let ty := type of lemma in
   let lhs := match ty with
     forall _, ?lhs=_ -> _ => lhs
@@ -487,7 +487,7 @@ Ltac reduce_field_expr ope kont FLD fv expr :=
   kont c.
 
 (* Hack to let a Ltac return a term in the context of a primitive tactic *)
-Ltac return_term x := generalize (refl_equal x).
+Ltac return_term x := generalize (eq_refl x).
 Ltac get_term :=
   match goal with
   | |- ?x = _ -> _ => x
diff --git a/plugins/setoid_ring/Field_theory.v b/plugins/setoid_ring/Field_theory.v
index ccdec656..bc05c252 100644
--- a/plugins/setoid_ring/Field_theory.v
+++ b/plugins/setoid_ring/Field_theory.v
@@ -1,13 +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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
 Require Ring.
-Import Ring_polynom Ring_tac Ring_theory InitialRing Setoid List.
+Import Ring_polynom Ring_tac Ring_theory InitialRing Setoid List Morphisms.
 Require Import ZArith_base.
 (*Require Import Omega.*)
 Set Implicit Arguments.
@@ -27,7 +27,7 @@ Section MakeFieldPol.
  Notation "x == y" := (req x y) (at level 70, no associativity).
 
  (* Equality properties *)
- Variable Rsth : Setoid_Theory R req.
+ Variable Rsth : Equivalence req.
  Variable Reqe : ring_eq_ext radd rmul ropp req.
  Variable SRinv_ext : forall p q, p == q ->  / p == / q.
 
@@ -75,7 +75,6 @@ Qed.
 
 
  (* Useful tactics *)
-  Add Setoid R req Rsth as R_set1.
   Add Morphism radd : radd_ext.  exact (Radd_ext Reqe). Qed.
   Add Morphism rmul : rmul_ext.  exact (Rmul_ext Reqe). Qed.
   Add Morphism ropp : ropp_ext.  exact (Ropp_ext Reqe). Qed.
@@ -96,7 +95,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.
@@ -116,16 +115,17 @@ Notation NPphi_pow := (Pphi_pow rO rI radd rmul rsub ropp cO cI ceqb phi Cp_phi
 (* add abstract semi-ring to help with some proofs *)
 Add Ring Rring : (ARth_SRth ARth).
 
+Local Hint Extern 2 (_ == _) => f_equiv.
 
 (* additional ring properties *)
 
 Lemma rsub_0_l : forall r, 0 - r == - r.
-intros; rewrite (ARsub_def ARth) in |- *;ring.
+intros; rewrite (ARsub_def ARth);ring.
 Qed.
 
 Lemma rsub_0_r : forall r, r - 0 == r.
-intros; rewrite (ARsub_def ARth) in |- *.
-rewrite (ARopp_zero Rsth Reqe ARth) in |- *;  ring.
+intros; rewrite (ARsub_def ARth).
+rewrite (ARopp_zero Rsth Reqe ARth);  ring.
 Qed.
 
 (***************************************************************************
@@ -135,42 +135,40 @@ Qed.
   ***************************************************************************)
 
 Theorem rdiv_simpl: forall p q, ~ q == 0 ->  q * (p / q) == p.
+Proof.
 intros p q H.
-rewrite rdiv_def in |- *.
+rewrite rdiv_def.
 transitivity (/ q * q * p); [  ring | idtac ].
-rewrite rinv_l in |- *; auto.
+rewrite rinv_l; auto.
 Qed.
 Hint Resolve rdiv_simpl .
 
-Theorem SRdiv_ext:
- forall p1 p2, p1 == p2 -> forall q1 q2, q1 == q2 ->  p1 / q1 == p2 / q2.
-intros p1 p2 H q1 q2 H0.
+Instance SRdiv_ext: Proper (req ==> req ==> req) rdiv.
+Proof.
+intros p1 p2 Ep q1 q2 Eq.
 transitivity (p1 * / q1); auto.
 transitivity (p2 * / q2); auto.
 Qed.
-Hint Resolve SRdiv_ext .
-
- Add Morphism rdiv : rdiv_ext. exact SRdiv_ext. Qed.
+Hint Resolve SRdiv_ext.
 
 Lemma rmul_reg_l : forall p q1 q2,
   ~ p == 0 -> p * q1 == p * q2 -> q1 == q2.
-intros.
-rewrite <- (@rdiv_simpl q1 p) in |- *; trivial.
-rewrite <- (@rdiv_simpl q2 p) in |- *; trivial.
-repeat rewrite rdiv_def in |- *.
-repeat rewrite (ARmul_assoc ARth) in |- *.
-auto.
+Proof.
+intros p q1 q2 H EQ.
+rewrite <- (@rdiv_simpl q1 p) by trivial.
+rewrite <- (@rdiv_simpl q2 p) by trivial.
+rewrite !rdiv_def, !(ARmul_assoc ARth).
+now rewrite EQ.
 Qed.
 
 Theorem field_is_integral_domain : forall r1 r2,
   ~ r1 == 0 -> ~ r2 == 0 -> ~ r1 * r2 == 0.
 Proof.
-red in |- *; intros.
-apply H0.
+intros r1 r2 H1 H2. contradict H2.
 transitivity (1 * r2); auto.
 transitivity (/ r1 * r1 * r2); auto.
-rewrite <- (ARmul_assoc ARth) in |- *.
-rewrite H1 in |- *.
+rewrite <- (ARmul_assoc ARth).
+rewrite H2.
 apply ARmul_0_r with (1 := Rsth) (2 := ARth).
 Qed.
 
@@ -179,15 +177,15 @@ Theorem ropp_neq_0 : forall r,
 intros.
 setoid_replace (- r) with (- (1) * r).
  apply field_is_integral_domain; trivial.
- rewrite <- (ARopp_mul_l ARth) in |- *.
-   rewrite (ARmul_1_l ARth) in |- *.
+ rewrite <- (ARopp_mul_l ARth).
+   rewrite (ARmul_1_l ARth).
    reflexivity.
 Qed.
 
 Theorem rdiv_r_r : forall r, ~ r == 0 -> r / r == 1.
 intros.
-rewrite (AFdiv_def AFth) in |- *.
-rewrite (ARmul_comm ARth) in |- *.
+rewrite (AFdiv_def AFth).
+rewrite (ARmul_comm ARth).
 apply (AFinv_l AFth).
 trivial.
 Qed.
@@ -203,14 +201,14 @@ Theorem rdiv2:
  r1 / r2 + r3 / r4 == (r1 * r4 + r3 * r2) / (r2 * r4).
 Proof.
 intros r1 r2 r3 r4 H H0.
-assert (~ r2 * r4 == 0) by complete (apply field_is_integral_domain; trivial).
+assert (~ r2 * r4 == 0) by (apply field_is_integral_domain; trivial).
 apply rmul_reg_l with (r2 * r4); trivial.
-rewrite rdiv_simpl in |- *; trivial.
-rewrite (ARdistr_r Rsth Reqe ARth) in |- *.
+rewrite rdiv_simpl; trivial.
+rewrite (ARdistr_r Rsth Reqe ARth).
 apply (Radd_ext Reqe).
- transitivity (r2 * (r1 / r2) * r4); [  ring | auto ].
- transitivity (r2 * (r4 * (r3 / r4))); auto.
-   transitivity (r2 * r3); auto.
+- transitivity (r2 * (r1 / r2) * r4); [  ring | auto ].
+- transitivity (r2 * (r4 * (r3 / r4))); auto.
+  transitivity (r2 * r3); auto.
 Qed.
 
 
@@ -225,35 +223,36 @@ assert (HH1: ~ r2 == 0) by (intros HH; case H; rewrite HH; ring).
 assert (HH2: ~ r5 == 0) by (intros HH; case H; rewrite HH; ring).
 assert (HH3: ~ r4 == 0) by (intros HH; case H0; rewrite HH; ring).
 assert (HH4: ~ r2 * (r4 * r5) == 0)
-   by complete (repeat apply field_is_integral_domain; trivial).
+   by (repeat apply field_is_integral_domain; trivial).
 apply rmul_reg_l with (r2 * (r4 * r5)); trivial.
-rewrite rdiv_simpl in |- *; trivial.
-rewrite (ARdistr_r Rsth Reqe ARth) in |- *.
+rewrite rdiv_simpl; trivial.
+rewrite (ARdistr_r Rsth Reqe ARth).
 apply (Radd_ext Reqe).
  transitivity ((r2 * r5) * (r1 / (r2 * r5)) * r4); [  ring | auto ].
  transitivity ((r4 * r5) * (r3 / (r4 * r5)) * r2); [  ring | auto ].
 Qed.
 
 Theorem rdiv5: forall r1 r2,  - (r1 / r2) == - r1 / r2.
+Proof.
 intros r1 r2.
 transitivity (- (r1 * / r2)); auto.
 transitivity (- r1 * / r2); auto.
 Qed.
 Hint Resolve rdiv5 .
 
-Theorem rdiv3:
- forall r1 r2 r3 r4,
+Theorem rdiv3 r1 r2 r3 r4 :
  ~ r2 == 0 ->
  ~ r4 == 0 ->
  r1 / r2 - r3 / r4 == (r1 * r4 -  r3 * r2) / (r2 * r4).
-intros r1 r2 r3 r4 H H0.
+Proof.
+intros H2 H4.
 assert (~ r2 * r4 == 0) by (apply field_is_integral_domain; trivial).
 transitivity (r1 / r2 + - (r3 / r4)); auto.
 transitivity (r1 / r2 + - r3 / r4); auto.
-transitivity ((r1 * r4 + - r3 * r2) / (r2 * r4)); auto.
+transitivity ((r1 * r4 + - r3 * r2) / (r2 * r4)).
 apply rdiv2; auto.
-apply SRdiv_ext; auto.
-transitivity (r1 * r4 + - (r3 * r2)); symmetry; auto.
+f_equiv.
+transitivity (r1 * r4 + - (r3 * r2)); auto.
 Qed.
 
 
@@ -279,13 +278,13 @@ intros r1 r2 H H0.
 assert (~ r1 / r2 == 0) as Hk.
  intros H1; case H.
    transitivity (r2 * (r1 / r2)); auto.
-   rewrite H1 in |- *;  ring.
+   rewrite H1;  ring.
  apply rmul_reg_l with (r1 / r2); auto.
    transitivity (/ (r1 / r2) * (r1 / r2)); auto.
    transitivity 1; auto.
-   repeat rewrite rdiv_def in |- *.
+   repeat rewrite rdiv_def.
    transitivity (/ r1 * r1 * (/ r2 * r2)); [ idtac |  ring ].
-   repeat rewrite rinv_l in |- *; auto.
+   repeat rewrite rinv_l; auto.
 Qed.
 Hint Resolve rdiv6 .
 
@@ -296,11 +295,11 @@ Hint Resolve rdiv6 .
  (r1 / r2) * (r3 / r4) == (r1 * r3) / (r2 * r4).
 Proof.
 intros r1 r2 r3 r4 H H0.
-assert (~ r2 * r4 == 0) by complete (apply field_is_integral_domain; trivial).
+assert (~ r2 * r4 == 0) by (apply field_is_integral_domain; trivial).
 apply rmul_reg_l with (r2 * r4); trivial.
-rewrite rdiv_simpl in |- *; trivial.
+rewrite rdiv_simpl; trivial.
 transitivity (r2 * (r1 / r2) * (r4 * (r3 / r4))); [  ring | idtac ].
-repeat rewrite rdiv_simpl in |- *; trivial.
+repeat rewrite rdiv_simpl; trivial.
 Qed.
 
  Theorem rdiv4b:
@@ -334,8 +333,8 @@ Theorem rdiv7:
  (r1 / r2) / (r3 / r4) == (r1 * r4) / (r2 * r3).
 Proof.
 intros.
-rewrite (rdiv_def (r1 / r2)) in |- *.
-rewrite rdiv6 in |- *; trivial.
+rewrite (rdiv_def (r1 / r2)).
+rewrite rdiv6; trivial.
 apply rdiv4; trivial.
 Qed.
 
@@ -373,14 +372,14 @@ Theorem cross_product_eq : forall r1 r2 r3 r4,
   ~ r2 == 0 -> ~ r4 == 0 -> r1 * r4 == r3 * r2 -> r1 / r2 == r3 / r4.
 intros.
 transitivity (r1 / r2 * (r4 / r4)).
- rewrite rdiv_r_r in |- *; trivial.
-   symmetry  in |- *.
+ rewrite rdiv_r_r; trivial.
+   symmetry .
    apply (ARmul_1_r Rsth ARth).
- rewrite rdiv4 in |- *; trivial.
-   rewrite H1 in |- *.
-   rewrite (ARmul_comm ARth r2 r4) in |- *.
-   rewrite <- rdiv4 in |- *; trivial.
-   rewrite rdiv_r_r in |- * by trivial.
+ rewrite rdiv4; trivial.
+   rewrite H1.
+   rewrite (ARmul_comm ARth r2 r4).
+   rewrite <- rdiv4; trivial.
+   rewrite rdiv_r_r by trivial.
   apply (ARmul_1_r Rsth ARth).
 Qed.
 
@@ -390,52 +389,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.
 
@@ -446,22 +409,14 @@ Qed.
 Add Morphism (pow_N rI rmul) with signature req ==> eq ==> req as pow_N_morph.
 intros x y H [|p];simpl;auto. apply pow_morph;trivial.
 Qed.
-(*
-Lemma rpow_morph : forall x y n, x == y ->rpow x (Cp_phi n) == rpow y (Cp_phi n).
-Proof.
-  intros; repeat rewrite pow_th.(rpow_pow_N).
-  destruct n;simpl. apply eq_refl.
-  induction p;simpl;try rewrite IHp;try rewrite H; apply eq_refl.
-Qed.
-*)
+
 Theorem PExpr_eq_semi_correct:
  forall l e1 e2, PExpr_eq e1 e2 = true ->  NPEeval l e1 == NPEeval l e2.
 intros l e1; elim e1.
 intros c1; intros e2; elim e2; simpl; (try (intros; discriminate)).
 intros c2; apply (morph_eq CRmorph).
 intros p1; intros e2; elim e2; simpl; (try (intros; discriminate)).
-intros p2; 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 +433,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 *)
@@ -497,8 +451,8 @@ Theorem NPEadd_correct:
  forall l e1 e2, NPEeval l (NPEadd e1 e2) == NPEeval l (PEadd e1 e2).
 Proof.
 intros l e1 e2.
-destruct e1; destruct e2; simpl in |- *; try reflexivity; try apply ceqb_rect;
- try (intro eq_c; rewrite eq_c in |- *); simpl in |- *;try apply eq_refl;
+destruct e1; destruct e2; simpl; try reflexivity; try apply ceqb_rect;
+ try (intro eq_c; rewrite eq_c); simpl;try apply eq_refl;
  try (ring [(morph0 CRmorph)]).
  apply (morph_add CRmorph).
 Qed.
@@ -507,7 +461,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 +474,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 +493,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.
 
@@ -549,15 +503,15 @@ Qed.
 
 Theorem NPEmul_correct : forall l e1 e2,
   NPEeval l (NPEmul e1 e2) == NPEeval l (PEmul e1 e2).
-induction e1;destruct e2; simpl in |- *;try reflexivity;
+induction e1;destruct e2; simpl;try reflexivity;
  repeat apply ceqb_rect;
- try (intro eq_c; rewrite eq_c in |- *); simpl in |- *; try reflexivity;
+ try (intro eq_c; rewrite eq_c); simpl; 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.
@@ -575,9 +529,9 @@ Definition NPEsub e1 e2 :=
 Theorem NPEsub_correct:
  forall l e1 e2,  NPEeval l (NPEsub e1 e2) == NPEeval l (PEsub e1 e2).
 intros l e1 e2.
-destruct e1; destruct e2; simpl in |- *; try reflexivity; try apply ceqb_rect;
- try (intro eq_c; rewrite eq_c in |- *); simpl in |- *;
- try rewrite (morph0 CRmorph) in |- *; try reflexivity;
+destruct e1; destruct e2; simpl; try reflexivity; try apply ceqb_rect;
+ try (intro eq_c; rewrite eq_c); simpl;
+ try rewrite (morph0 CRmorph); try reflexivity;
  try (symmetry; apply rsub_0_l); try (symmetry; apply rsub_0_r).
 apply (morph_sub CRmorph).
 Qed.
@@ -697,8 +651,8 @@ destruct H; trivial.
 Qed.
 
 Theorem PCond_app_inv_l: forall l l1 l2, PCond l (l1 ++ l2) ->  PCond l l1.
-intros l l1 l2; elim l1; simpl app in |- *.
- simpl in |- *; auto.
+intros l l1 l2; elim l1; simpl app.
+ simpl; auto.
  destruct l0; simpl in *.
   destruct l2; firstorder.
   firstorder.
@@ -713,8 +667,8 @@ Qed.
 Definition absurd_PCond := cons (PEc cO) nil.
 
 Lemma absurd_PCond_bottom : forall l, ~ PCond l absurd_PCond.
-unfold absurd_PCond in |- *; simpl in |- *.
-red in |- *; intros.
+unfold absurd_PCond; simpl.
+red; intros.
 apply H.
 apply (morph0 CRmorph).
 Qed.
@@ -743,10 +697,10 @@ Fixpoint isIn (e1:PExpr C)  (p1:positive)
          end
        end
   | PEpow e3 N0 => None
-  | PEpow e3 (Npos p3) => isIn e1 p1 e3 (Pmult p3 p2)
+  | PEpow e3 (Npos p3) => isIn e1 p1 e3 (Pos.mul p3 p2)
   | _ =>
      if  PExpr_eq e1 e2 then
-         match Zminus (Zpos p1) (Zpos p2) with
+         match Z.pos_sub p1 p2 with
           | Zpos p => Some (Npos p, PEc cI)
           | Z0 => Some (N0, PEc cI)
           | Zneg p => Some (N0, NPEpow e2 (Npos p))
@@ -757,13 +711,19 @@ Fixpoint isIn (e1:PExpr C)  (p1:positive)
  Definition ZtoN z := match z with Zpos p => Npos p | _ => N0 end.
  Definition NtoZ n := match n with Npos p => Zpos p | _ => Z0 end.
 
- Notation pow_pos_plus :=  (Ring_theory.pow_pos_Pplus _ Rsth Reqe.(Rmul_ext)
-                        ARth.(ARmul_comm) ARth.(ARmul_assoc)).
+ Notation pow_pos_add :=
+   (Ring_theory.pow_pos_add Rsth Reqe.(Rmul_ext) ARth.(ARmul_assoc)).
+
+ Lemma Z_pos_sub_gt p q : (p > q)%positive ->
+  Z.pos_sub p q = Zpos (p - q).
+ Proof. intros; now apply Z.pos_sub_gt, Pos.gt_lt. Qed.
+
+ Ltac simpl_pos_sub := rewrite ?Z_pos_sub_gt in * by assumption.
 
  Lemma isIn_correct_aux : forall l e1 e2 p1 p2,
   match
       (if  PExpr_eq e1 e2 then
-         match Zminus (Zpos p1) (Zpos p2) with
+         match Z.sub (Zpos p1) (Zpos p2) with
           | Zpos p => Some (Npos p, PEc cI)
           | Z0 => Some (N0, PEc cI)
           | Zneg p => Some (N0, NPEpow e2 (Npos p))
@@ -779,37 +739,29 @@ 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.
-  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 (NPEpow e2 (Npos (p2 - p1))).
-  rewrite NPEpow_correct;simpl.
-  repeat rewrite pow_th.(rpow_pow_N);simpl.
-  rewrite H;trivial. split. 2:refine (refl_equal _).
-  rewrite <- pow_pos_plus; rewrite Pplus_minus;auto. apply ZC2;trivial.
-  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))).
-  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.
-  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.
+  rewrite Z.pos_sub_spec.
+  case Pos.compare_spec;intros;simpl.
+  - repeat rewrite pow_th.(rpow_pow_N);simpl. split. 2:reflexivity.
+    subst. rewrite H by trivial. ring [ (morph1 CRmorph)].
+  - fold (p2 - p1 =? 1)%positive.
+    fold (NPEpow e2 (Npos (p2 - p1))).
+    rewrite NPEpow_correct;simpl.
+    repeat rewrite pow_th.(rpow_pow_N);simpl.
+    rewrite H;trivial. split. 2:reflexivity.
+    rewrite <- pow_pos_add. now rewrite Pos.add_comm, Pos.sub_add.
+  - repeat rewrite pow_th.(rpow_pow_N);simpl.
+    rewrite H;trivial.
+    rewrite Z.pos_sub_gt by now apply Pos.sub_decr.
+    replace (p1 - (p1 - p2))%positive with p2;
+    [| rewrite Pos.sub_sub_distr, Pos.add_comm;
+       auto using Pos.add_sub, Pos.sub_decr ].
+    split.
+    simpl. ring [ (morph1 CRmorph)].
+    now apply Z.lt_gt, Pos.sub_decr.
 Qed.
 
 Lemma pow_pos_pow_pos : forall x p1 p2, pow_pos rmul (pow_pos rmul x p1) p2 == pow_pos rmul x (p1*p2).
-induction p1;simpl;intros;repeat rewrite pow_pos_mul;repeat rewrite pow_pos_plus;simpl.
+induction p1;simpl;intros;repeat rewrite pow_pos_mul;repeat rewrite pow_pos_add;simpl.
 ring [(IHp1 p2)]. ring [(IHp1 p2)]. auto.
 Qed.
 
@@ -835,39 +787,39 @@ 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) ==
         pow_pos rmul (NPEeval l e1) p4 * pow_pos rmul (NPEeval l e1) (p1 - p4) *
         NPEeval l p3 *NPEeval l p5) by ring. rewrite H;clear H.
-   rewrite <- pow_pos_plus. rewrite Pplus_minus.
-   split. symmetry;apply ARth.(ARmul_assoc). refine (refl_equal _). trivial.
+   rewrite <- pow_pos_add.
+   rewrite Pos.add_comm, Pos.sub_add by (now apply Z.gt_lt in H4).
+   split. symmetry;apply ARth.(ARmul_assoc). reflexivity.
    repeat rewrite pow_th.(rpow_pow_N);simpl.
    intros (H1,H2) (H3,H4).
-   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 *
                 (pow_pos rmul (NPEeval l e1) (p4 - p6) * NPEeval l p5) ==
              pow_pos rmul (NPEeval l e1) (p1 - p4) * pow_pos rmul (NPEeval l e1) (p4 - p6) *
                 NPEeval l p3 * NPEeval l p5) by ring. rewrite H0;clear H0.
-  rewrite <- pow_pos_plus.
+  rewrite <- pow_pos_add.
   replace (p1 - p4 + (p4 - p6))%positive with (p1 - p6)%positive.
  rewrite NPEmul_correct. simpl;ring.
   assert
      (Zpos p1 - Zpos p6 = Zpos p1 - Zpos p4 + (Zpos p4 - Zpos p6))%Z.
  change  ((Zpos p1 - Zpos p6)%Z = (Zpos p1 + (- Zpos p4) + (Zpos p4 +(- Zpos p6)))%Z).
- rewrite <- Zplus_assoc. rewrite (Zplus_assoc  (- Zpos p4)).
- simpl. rewrite Pcompare_refl. simpl. reflexivity.
- unfold Zminus, Zopp in H0. simpl in H0.
-  rewrite H2 in H0;rewrite H4 in H0;rewrite H in H0. inversion H0;trivial.
+ rewrite <- Z.add_assoc. rewrite (Z.add_assoc  (- Zpos p4)).
+ simpl. rewrite Z.pos_sub_diag. simpl. reflexivity.
+ unfold Z.sub, Z.opp in H0. simpl in H0.
+  simpl_pos_sub. inversion H0; trivial.
  simpl. repeat rewrite pow_th.(rpow_pow_N).
- intros H1 (H2,H3). 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 +830,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.
@@ -910,7 +861,7 @@ Fixpoint split_aux (e1: PExpr C) (p:positive) (e2:PExpr C) {struct e1}: rsplit :
                     (NPEmul (common r1) (common r2))
                     (right r2)
   | PEpow e3 N0 => mk_rsplit (PEc cI) (PEc cI) e2
-  | PEpow e3 (Npos p3) => split_aux e3 (Pmult p3 p) e2
+  | PEpow e3 (Npos p3) => split_aux e3 (Pos.mul p3 p) e2
   | _ =>
        match isIn e1 p e2 xH with
        | Some (N0,e3) => mk_rsplit (PEc cI) (NPEpow e1 (Npos p)) e3
@@ -937,9 +888,9 @@ 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].
-  rewrite <- pow_pos_plus. rewrite Pplus_minus. reflexivity. trivial.
+  intros (H, Hgt). simpl_pos_sub. simpl in H;split;try ring [H].
+  apply Z.gt_lt in Hgt.
+  now rewrite <- pow_pos_add, Pos.add_comm, Pos.sub_add.
   simpl;intros. repeat rewrite NPEmul_correct;simpl.
   rewrite NPEpow_correct;simpl. split;ring [CRmorph.(morph1)].
 Qed.
@@ -1061,13 +1012,13 @@ Theorem Pcond_Fnorm:
  forall l e,
  PCond l (condition (Fnorm e)) ->  ~ NPEeval l (denum (Fnorm e)) == 0.
 intros l e; elim e.
- simpl in |- *; intros _ _; rewrite (morph1 CRmorph) in |- *; exact rI_neq_rO.
- simpl in |- *; intros _ _; rewrite (morph1 CRmorph) in |- *; exact rI_neq_rO.
+ simpl; intros _ _; rewrite (morph1 CRmorph); exact rI_neq_rO.
+ simpl; intros _ _; rewrite (morph1 CRmorph); exact rI_neq_rO.
  intros e1 Hrec1 e2 Hrec2 Hcond.
    simpl condition in Hcond.
-   simpl denum in |- *.
-   rewrite NPEmul_correct in |- *.
-   simpl in |- *.
+   simpl denum.
+   rewrite NPEmul_correct.
+   simpl.
    apply field_is_integral_domain.
    intros HH; case Hrec1; auto.
      apply PCond_app_inv_l with (1 := Hcond).
@@ -1078,9 +1029,9 @@ intros l e; elim e.
    rewrite (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))); auto.
  intros e1 Hrec1 e2 Hrec2 Hcond.
    simpl condition in Hcond.
-   simpl denum in |- *.
-   rewrite NPEmul_correct in |- *.
-   simpl in |- *.
+   simpl denum.
+   rewrite NPEmul_correct.
+   simpl.
    apply field_is_integral_domain.
    intros HH; case Hrec1; auto.
      apply PCond_app_inv_l with (1 := Hcond).
@@ -1091,9 +1042,9 @@ intros l e; elim e.
    rewrite (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))); auto.
  intros e1 Hrec1 e2 Hrec2 Hcond.
    simpl condition in Hcond.
-   simpl denum in |- *.
-   rewrite NPEmul_correct in |- *.
-   simpl in |- *.
+   simpl denum.
+   rewrite NPEmul_correct.
+   simpl.
    apply field_is_integral_domain.
   intros HH; apply Hrec1.
     apply PCond_app_inv_l with (1 := Hcond).
@@ -1105,17 +1056,17 @@ intros l e; elim e.
     rewrite NPEmul_correct; simpl; rewrite HH; ring.
  intros e1 Hrec1 Hcond.
    simpl condition in Hcond.
-   simpl denum in |- *.
+   simpl denum.
    auto.
  intros e1 Hrec1 Hcond.
    simpl condition in Hcond.
-   simpl denum in |- *.
+   simpl denum.
    apply PCond_cons_inv_l with (1:=Hcond).
  intros e1 Hrec1 e2 Hrec2 Hcond.
    simpl condition in Hcond.
-   simpl denum in |- *.
-   rewrite NPEmul_correct in |- *.
-   simpl in |- *.
+   simpl denum.
+   rewrite NPEmul_correct.
+   simpl.
    apply field_is_integral_domain.
     intros HH; apply Hrec1.
     specialize PCond_cons_inv_r with (1:=Hcond); intro Hcond1.
@@ -1258,9 +1209,9 @@ Theorem Fnorm_crossproduct:
  PCond l (condition nfe1 ++ condition nfe2) ->
  FEeval l fe1 == FEeval l fe2.
 intros l fe1 fe2 nfe1 nfe2 Hcrossprod Hcond; subst nfe1 nfe2.
-rewrite Fnorm_FEeval_PEeval in |- * by
+rewrite Fnorm_FEeval_PEeval by
  apply PCond_app_inv_l with (1 := Hcond).
- rewrite Fnorm_FEeval_PEeval in |- * by
+ rewrite Fnorm_FEeval_PEeval by
   apply PCond_app_inv_r with (1 := Hcond).
   apply cross_product_eq; trivial.
    apply Pcond_Fnorm.
@@ -1355,9 +1306,9 @@ apply Fnorm_crossproduct; trivial.
 match goal with
  [ |- NPEeval l ?x == NPEeval l ?y] =>
     rewrite (ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec
-       O nil l I (refl_equal nil) x (refl_equal (Nnorm O nil x)));
+       O nil l I Logic.eq_refl x Logic.eq_refl);
     rewrite (ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec
-       O nil l I (refl_equal nil) y (refl_equal (Nnorm O nil y)))
+       O nil l I Logic.eq_refl y Logic.eq_refl)
  end.
 trivial.
 Qed.
@@ -1377,28 +1328,28 @@ Proof.
 intros n l lpe fe1 fe2 Hlpe lmp Hlmp nfe1 eq1 nfe2 eq2 den eq3 Hcrossprod Hcond;
   subst nfe1 nfe2 den lmp.
 apply Fnorm_crossproduct; trivial.
-simpl in |- *.
-rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))) in |- *.
-rewrite (split_correct_r l (denum (Fnorm fe1)) (denum (Fnorm fe2))) in |- *.
-rewrite NPEmul_correct in |- *.
-rewrite NPEmul_correct in |- *.
-simpl in |- *.
-repeat rewrite (ARmul_assoc ARth) in |- *.
+simpl.
+rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))).
+rewrite (split_correct_r l (denum (Fnorm fe1)) (denum (Fnorm fe2))).
+rewrite NPEmul_correct.
+rewrite NPEmul_correct.
+simpl.
+repeat rewrite (ARmul_assoc ARth).
 rewrite <-(
   let x := PEmul (num (Fnorm fe1))
                      (rsplit_right (split (denum (Fnorm fe1)) (denum (Fnorm fe2)))) in
 ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l
-        Hlpe (refl_equal (Nmk_monpol_list lpe))
-        x (refl_equal (Nnorm n (Nmk_monpol_list lpe) x))) in Hcrossprod.
+        Hlpe Logic.eq_refl
+        x Logic.eq_refl) in Hcrossprod.
 rewrite <-(
   let x := (PEmul (num (Fnorm fe2))
                      (rsplit_left
                         (split (denum (Fnorm fe1)) (denum (Fnorm fe2))))) in
     ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l
-        Hlpe (refl_equal (Nmk_monpol_list lpe))
-        x (refl_equal (Nnorm n (Nmk_monpol_list lpe) x))) in Hcrossprod.
+        Hlpe Logic.eq_refl
+        x Logic.eq_refl) in Hcrossprod.
 simpl in Hcrossprod.
-rewrite Hcrossprod in |- *.
+rewrite Hcrossprod.
 reflexivity.
 Qed.
 
@@ -1417,28 +1368,28 @@ Proof.
 intros n l lpe fe1 fe2 Hlpe lmp Hlmp nfe1 eq1 nfe2 eq2 den eq3 Hcrossprod Hcond;
   subst nfe1 nfe2 den lmp.
 apply Fnorm_crossproduct; trivial.
-simpl in |- *.
-rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))) in |- *.
-rewrite (split_correct_r l (denum (Fnorm fe1)) (denum (Fnorm fe2))) in |- *.
-rewrite NPEmul_correct in |- *.
-rewrite NPEmul_correct in |- *.
-simpl in |- *.
-repeat rewrite (ARmul_assoc ARth) in |- *.
+simpl.
+rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))).
+rewrite (split_correct_r l (denum (Fnorm fe1)) (denum (Fnorm fe2))).
+rewrite NPEmul_correct.
+rewrite NPEmul_correct.
+simpl.
+repeat rewrite (ARmul_assoc ARth).
 rewrite <-(
   let x := PEmul (num (Fnorm fe1))
                      (rsplit_right (split (denum (Fnorm fe1)) (denum (Fnorm fe2)))) in
 ring_rw_pow_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l
-        Hlpe (refl_equal (Nmk_monpol_list lpe))
-        x (refl_equal (Nnorm n (Nmk_monpol_list lpe) x))) in Hcrossprod.
+        Hlpe Logic.eq_refl
+        x Logic.eq_refl) in Hcrossprod.
 rewrite <-(
   let x := (PEmul (num (Fnorm fe2))
                      (rsplit_left
                         (split (denum (Fnorm fe1)) (denum (Fnorm fe2))))) in
     ring_rw_pow_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l
-        Hlpe (refl_equal (Nmk_monpol_list lpe))
-        x (refl_equal (Nnorm n (Nmk_monpol_list lpe) x))) in Hcrossprod.
+        Hlpe Logic.eq_refl
+        x Logic.eq_refl) in Hcrossprod.
 simpl in Hcrossprod.
-rewrite Hcrossprod in |- *.
+rewrite Hcrossprod.
 reflexivity.
 Qed.
 
@@ -1558,7 +1509,7 @@ Fixpoint Fapp (l m:list (PExpr C)) {struct l} : list (PExpr C) :=
 
 Lemma fcons_correct : forall l l1,
   PCond l (Fapp l1 nil) -> PCond l l1.
-induction l1; simpl in |- *; intros.
+induction l1; simpl; intros.
  trivial.
  elim PCond_fcons_inv with (1 := H); intros.
    destruct l1; auto.
@@ -1639,7 +1590,7 @@ intros l a; elim a; try (intros; apply PFcons0_fcons_inv; auto; fail).
    simpl in H1.
    case (H _ H1); intros H2 H3.
    case (H0 _ H3); intros H4 H5; split; auto.
-   simpl in |- *.
+   simpl.
    apply field_is_integral_domain; trivial.
    simpl;intros. rewrite pow_th.(rpow_pow_N).
    destruct (H _ H0);split;auto.
@@ -1667,7 +1618,7 @@ generalize (fun h => X (morph_eq CRmorph c1 c2 h)).
 generalize (@ceqb_complete c1 c2).
 case (c1 ?=! c2); auto; intros.
 apply X0.
-red in |- *; intro.
+red; intro.
 absurd (false = true); auto;  discriminate.
 Qed.
 
@@ -1683,18 +1634,18 @@ Fixpoint Fcons1 (e:PExpr C) (l:list (PExpr C)) {struct e} : list (PExpr C) :=
 Theorem PFcons1_fcons_inv:
   forall l a l1, PCond l (Fcons1 a l1) -> ~ NPEeval l a == 0 /\ PCond l l1.
 intros l a; elim a; try (intros; apply PFcons0_fcons_inv; auto; fail).
- simpl in |- *; intros c l1.
+ simpl; intros c l1.
    apply ceqb_rect_complete; intros.
   elim (@absurd_PCond_bottom l H0).
   split; trivial.
-    rewrite <- (morph0 CRmorph) in |- *; trivial.
+    rewrite <- (morph0 CRmorph); trivial.
  intros p H p0 H0 l1 H1.
    simpl in H1.
    case (H _ H1); intros H2 H3.
    case (H0 _ H3); intros H4 H5; split; auto.
-   simpl in |- *.
+   simpl.
    apply field_is_integral_domain; trivial.
- simpl in |- *; intros p H l1.
+ simpl; intros p H l1.
    apply ceqb_rect_complete; intros.
   elim (@absurd_PCond_bottom l H1).
   destruct (H _ H1).
@@ -1713,7 +1664,7 @@ Definition Fcons2 e l := Fcons1 (PExpr_simp e) l.
 
 Theorem PFcons2_fcons_inv:
  forall l a l1, PCond l (Fcons2 a l1) -> ~ NPEeval l a == 0 /\ PCond l l1.
-unfold Fcons2 in |- *; intros l a l1 H; split;
+unfold Fcons2; intros l a l1 H; split;
  case (PFcons1_fcons_inv l (PExpr_simp a) l1); auto.
 intros H1 H2 H3; case H1.
 transitivity (NPEeval l a); trivial.
@@ -1792,61 +1743,55 @@ Hypothesis gen_phiPOS_not_0 : forall p, ~ gen_phiPOS1 rI radd rmul p == 0.
 Lemma add_inj_r : forall p x y,
    gen_phiPOS1 rI radd rmul p + x == gen_phiPOS1 rI radd rmul p + y -> x==y.
 intros p x y.
-elim p using Pind; simpl in |- *; intros.
+elim p using Pos.peano_ind; simpl; intros.
  apply S_inj; trivial.
  apply H.
    apply S_inj.
-   repeat rewrite (ARadd_assoc ARth) in |- *.
-   rewrite <- (ARgen_phiPOS_Psucc Rsth Reqe ARth) in |- *; trivial.
+   repeat rewrite (ARadd_assoc ARth).
+   rewrite <- (ARgen_phiPOS_Psucc Rsth Reqe ARth); trivial.
 Qed.
 
 Lemma gen_phiPOS_inj : forall x y,
   gen_phiPOS rI radd rmul x == gen_phiPOS rI radd rmul y ->
   x = y.
 intros x y.
-repeat rewrite <- (same_gen Rsth Reqe ARth) in |- *.
-ElimPcompare x y; intro.
+repeat rewrite <- (same_gen Rsth Reqe ARth).
+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.
+   symmetry.
+   rewrite (ARadd_0_r Rsth ARth).
+   rewrite <- (ARgen_phiPOS_add Rsth Reqe ARth).
+   now rewrite Pos.add_comm, Pos.sub_add.
+ 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.
+   rewrite (ARadd_0_r Rsth ARth).
+   rewrite <- (ARgen_phiPOS_add Rsth Reqe ARth).
+   now rewrite Pos.add_comm, Pos.sub_add.
 Qed.
 
 
 Lemma gen_phiN_inj : forall x y,
   gen_phiN rO rI radd rmul x == gen_phiN rO rI radd rmul y ->
   x = y.
-destruct x; destruct y; simpl in |- *; intros; trivial.
+destruct x; destruct y; simpl; intros; trivial.
  elim gen_phiPOS_not_0 with p.
-   symmetry  in |- *.
-   rewrite (same_gen Rsth Reqe ARth) in |- *; trivial.
+   symmetry .
+   rewrite (same_gen Rsth Reqe ARth); trivial.
  elim gen_phiPOS_not_0 with p.
-   rewrite (same_gen Rsth Reqe ARth) in |- *; trivial.
- rewrite gen_phiPOS_inj with (1 := H) in |- *; trivial.
+   rewrite (same_gen Rsth Reqe ARth); trivial.
+ rewrite gen_phiPOS_inj with (1 := H); trivial.
 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.
@@ -1864,17 +1809,17 @@ Section Field.
 Lemma ring_S_inj : forall x y, 1+x==1+y -> x==y.
 intros.
 transitivity (x + (1 + - (1))).
- rewrite (Ropp_def Rth) in |- *.
-   symmetry  in |- *.
+ rewrite (Ropp_def Rth).
+   symmetry .
    apply (ARadd_0_r Rsth ARth).
  transitivity (y + (1 + - (1))).
-  repeat rewrite <- (ARplus_assoc ARth) in |- *.
-    repeat rewrite (ARadd_assoc ARth) in |- *.
+  repeat rewrite <- (ARplus_assoc ARth).
+    repeat rewrite (ARadd_assoc ARth).
     apply (Radd_ext Reqe).
-   repeat rewrite <- (ARadd_comm ARth 1) in |- *.
+   repeat rewrite <- (ARadd_comm ARth 1).
      trivial.
    reflexivity.
-  rewrite (Ropp_def Rth) in |- *.
+  rewrite (Ropp_def Rth).
     apply (ARadd_0_r Rsth ARth).
 Qed.
 
@@ -1886,14 +1831,14 @@ Let gen_phiPOS_inject :=
 
 Lemma gen_phiPOS_discr_sgn : forall x y,
   ~ gen_phiPOS rI radd rmul x == - gen_phiPOS rI radd rmul y.
-red in |- *; intros.
+red; intros.
 apply gen_phiPOS_not_0 with (y + x)%positive.
-rewrite (ARgen_phiPOS_add Rsth Reqe ARth) in |- *.
+rewrite (ARgen_phiPOS_add Rsth Reqe ARth).
 transitivity (gen_phiPOS1 1 radd rmul y + - gen_phiPOS1 1 radd rmul y).
  apply (Radd_ext Reqe); trivial.
   reflexivity.
-  rewrite (same_gen Rsth Reqe ARth) in |- *.
-    rewrite (same_gen Rsth Reqe ARth) in |- *.
+  rewrite (same_gen Rsth Reqe ARth).
+    rewrite (same_gen Rsth Reqe ARth).
     trivial.
  apply (Ropp_def Rth).
 Qed.
@@ -1901,33 +1846,33 @@ Qed.
 Lemma gen_phiZ_inj : forall x y,
   gen_phiZ rO rI radd rmul ropp x == gen_phiZ rO rI radd rmul ropp y ->
   x = y.
-destruct x; destruct y; simpl in |- *; intros.
+destruct x; destruct y; simpl; intros.
  trivial.
  elim gen_phiPOS_not_0 with p.
-   rewrite (same_gen Rsth Reqe ARth) in |- *.
-   symmetry  in |- *; trivial.
+   rewrite (same_gen Rsth Reqe ARth).
+   symmetry ; trivial.
  elim gen_phiPOS_not_0 with p.
-   rewrite (same_gen Rsth Reqe ARth) in |- *.
-   rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p)) in |- *.
-   rewrite <- H in |- *.
+   rewrite (same_gen Rsth Reqe ARth).
+   rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p)).
+   rewrite <- H.
    apply (ARopp_zero Rsth Reqe ARth).
  elim gen_phiPOS_not_0 with p.
-   rewrite (same_gen Rsth Reqe ARth) in |- *.
+   rewrite (same_gen Rsth Reqe ARth).
    trivial.
- rewrite gen_phiPOS_inject  with (1 := H) in |- *; trivial.
+ rewrite gen_phiPOS_inject  with (1 := H); trivial.
  elim gen_phiPOS_discr_sgn with (1 := H).
  elim gen_phiPOS_not_0 with p.
-   rewrite (same_gen Rsth Reqe ARth) in |- *.
-   rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p)) in |- *.
-   rewrite H in |- *.
+   rewrite (same_gen Rsth Reqe ARth).
+   rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p)).
+   rewrite H.
    apply (ARopp_zero Rsth Reqe ARth).
  elim gen_phiPOS_discr_sgn with p0 p.
-   symmetry  in |- *; trivial.
+   symmetry ; trivial.
  replace p0 with p; trivial.
    apply gen_phiPOS_inject.
-   rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p)) in |- *.
-   rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p0)) in |- *.
-   rewrite H in |- *; trivial.
+   rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p)).
+   rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p0)).
+   rewrite H; trivial.
    reflexivity.
 Qed.
 
@@ -1936,8 +1881,8 @@ Lemma gen_phiZ_complete : forall x y,
   Zeq_bool x y = true.
 intros.
  replace y with x.
- unfold Zeq_bool in |- *.
-   rewrite Zcompare_refl in |- *; trivial.
+ unfold Zeq_bool.
+   rewrite Z.compare_refl; trivial.
  apply gen_phiZ_inj; trivial.
 Qed.
 
diff --git a/plugins/setoid_ring/InitialRing.v b/plugins/setoid_ring/InitialRing.v
index 026e70c8..e805151c 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-2012     *)
 (*   \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.
@@ -28,14 +27,14 @@ Definition NotConstant := false.
 Lemma Zsth : Setoid_Theory Z (@eq Z).
 Proof (Eqsth Z).
 
-Lemma Zeqe : ring_eq_ext Zplus Zmult Zopp (@eq Z).
-Proof (Eq_ext Zplus Zmult Zopp).
+Lemma Zeqe : ring_eq_ext Z.add Z.mul Z.opp (@eq Z).
+Proof (Eq_ext Z.add Z.mul Z.opp).
 
-Lemma Zth : ring_theory Z0 (Zpos xH) Zplus Zmult Zminus Zopp (@eq Z).
+Lemma Zth : ring_theory Z0 (Zpos xH) Z.add Z.mul Z.sub Z.opp (@eq Z).
 Proof.
- constructor. exact Zplus_0_l. exact Zplus_comm. exact Zplus_assoc.
- exact Zmult_1_l. exact Zmult_comm. exact Zmult_assoc.
- exact Zmult_plus_distr_l. trivial. exact Zminus_diag.
+ constructor. exact Z.add_0_l. exact Z.add_comm. exact Z.add_assoc.
+ exact Z.mul_1_l. exact Z.mul_comm. exact Z.mul_assoc.
+ exact Z.mul_add_distr_r. trivial. exact Z.sub_diag.
 Qed.
 
 (** Two generic morphisms from Z to (abrbitrary) rings, *)
@@ -93,12 +92,12 @@ Section ZMORPHISM.
   | _ => None
   end.
 
- Lemma get_signZ_th : sign_theory Zopp Zeq_bool get_signZ.
+ Lemma get_signZ_th : sign_theory Z.opp Zeq_bool get_signZ.
  Proof.
   constructor.
   destruct c;intros;try discriminate.
   injection H;clear H;intros H1;subst c'.
-  simpl. unfold Zeq_bool. rewrite Zcompare_refl. trivial.
+  simpl. unfold Zeq_bool. rewrite Z.compare_refl. trivial.
  Qed.
 
 
@@ -117,7 +116,7 @@ Section ZMORPHISM.
  Qed.
 
  Lemma ARgen_phiPOS_Psucc : forall x,
-   gen_phiPOS1 (Psucc x) == 1 + (gen_phiPOS1 x).
+   gen_phiPOS1 (Pos.succ x) == 1 + (gen_phiPOS1 x).
  Proof.
   induction x;simpl;norm.
   rewrite IHx;norm.
@@ -128,7 +127,7 @@ Section ZMORPHISM.
    gen_phiPOS1 (x + y) == (gen_phiPOS1 x) + (gen_phiPOS1 y).
  Proof.
   induction x;destruct y;simpl;norm.
-  rewrite Pplus_carry_spec.
+  rewrite Pos.add_carry_spec.
   rewrite ARgen_phiPOS_Psucc.
   rewrite IHx;norm.
   add_push (gen_phiPOS1 y);add_push 1;rrefl.
@@ -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.
 
@@ -229,10 +208,10 @@ Section ZMORPHISM.
 (*proof that [.] satisfies morphism specifications*)
  Lemma gen_phiZ_morph :
   ring_morph 0 1 radd rmul rsub ropp req Z0 (Zpos xH)
-   Zplus Zmult Zminus Zopp Zeq_bool gen_phiZ.
+   Z.add Z.mul Z.sub Z.opp Zeq_bool gen_phiZ.
  Proof.
   assert ( SRmorph : semi_morph 0 1 radd rmul req Z0 (Zpos xH)
-                  Zplus Zmult Zeq_bool gen_phiZ).
+                  Z.add Z.mul Zeq_bool gen_phiZ).
    apply mkRmorph;simpl;try rrefl.
    apply gen_phiZ_add.  apply gen_phiZ_mul. apply gen_Zeqb_ok.
   apply  (Smorph_morph Rsth Reqe Rth Zth SRmorph gen_phiZ_ext).
@@ -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.
@@ -438,14 +396,14 @@ Section NWORDMORPHISM.
 
  Lemma gen_phiNword0_ok : forall w, Nw_is0 w = true -> gen_phiNword w == 0.
 Proof.
-induction w; simpl in |- *; intros; auto.
+induction w; simpl; intros; auto.
  reflexivity.
 
  destruct a.
   destruct w.
    reflexivity.
 
-   rewrite IHw in |- *; trivial.
+   rewrite IHw; trivial.
    apply (ARopp_zero Rsth Reqe ARth).
 
    discriminate.
@@ -454,7 +412,7 @@ Qed.
   Lemma gen_phiNword_cons : forall w n,
     gen_phiNword (n::w) == gen_phiN rO rI radd rmul n - gen_phiNword w.
 induction w.
- destruct n; simpl in |- *; norm.
+ destruct n; simpl; norm.
 
  intros.
  destruct n; norm.
@@ -465,31 +423,31 @@ Qed.
 destruct w; intros.
  destruct n; norm.
 
- unfold Nwcons in |- *.
- rewrite gen_phiNword_cons in |- *.
+ unfold Nwcons.
+ rewrite gen_phiNword_cons.
  reflexivity.
 Qed.
 
  Lemma gen_phiNword_ok : forall w1 w2,
    Nweq_bool w1 w2 = true -> gen_phiNword w1 == gen_phiNword w2.
 induction w1; intros.
- simpl in |- *.
- rewrite (gen_phiNword0_ok _ H) in |- *.
+ simpl.
+ rewrite (gen_phiNword0_ok _ H).
  reflexivity.
 
- rewrite gen_phiNword_cons in |- *.
+ rewrite gen_phiNword_cons.
  destruct w2.
   simpl in H.
   destruct a; try  discriminate.
-  rewrite (gen_phiNword0_ok _ H) in |- *.
+  rewrite (gen_phiNword0_ok _ H).
   norm.
 
   simpl in H.
-  rewrite gen_phiNword_cons in |- *.
-  case_eq (Neq_bool a n); intros.
+  rewrite gen_phiNword_cons.
+  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.
@@ -499,27 +457,27 @@ Qed.
 Lemma Nwadd_ok : forall x y,
    gen_phiNword (Nwadd x y) == gen_phiNword x + gen_phiNword y.
 induction x; intros.
- simpl in |- *.
+ simpl.
  norm.
 
  destruct y.
   simpl Nwadd; norm.
 
-  simpl Nwadd in |- *.
-  repeat rewrite gen_phiNword_cons in |- *.
-  rewrite (fun sreq => gen_phiN_add Rsth sreq (ARth_SRth ARth)) in |- * by
+  simpl Nwadd.
+  repeat rewrite gen_phiNword_cons.
+  rewrite (fun sreq => gen_phiN_add Rsth sreq (ARth_SRth ARth)) by
     (destruct Reqe; constructor; trivial).
 
-  rewrite IHx in |- *.
+  rewrite IHx.
   norm.
   add_push (- gen_phiNword x); reflexivity.
 Qed.
 
 Lemma Nwopp_ok : forall x, gen_phiNword (Nwopp x) == - gen_phiNword x.
-simpl in |- *.
-unfold Nwopp in |- *; simpl in |- *.
+simpl.
+unfold Nwopp; simpl.
 intros.
-rewrite gen_phiNword_Nwcons in |- *; norm.
+rewrite gen_phiNword_Nwcons; norm.
 Qed.
 
 Lemma Nwscal_ok : forall n x,
@@ -527,12 +485,12 @@ Lemma Nwscal_ok : forall n x,
 induction x; intros.
  norm.
 
- simpl Nwscal in |- *.
- repeat rewrite gen_phiNword_cons in |- *.
- rewrite (fun sreq => gen_phiN_mult Rsth sreq (ARth_SRth ARth)) in |- *
+ simpl Nwscal.
+ repeat rewrite gen_phiNword_cons.
+ rewrite (fun sreq => gen_phiN_mult Rsth sreq (ARth_SRth ARth))
    by (destruct Reqe; constructor; trivial).
 
-  rewrite IHx in |- *.
+  rewrite IHx.
   norm.
 Qed.
 
@@ -542,19 +500,19 @@ induction x; intros.
  norm.
 
  destruct a.
-  simpl Nwmul in |- *.
-  rewrite Nwopp_ok in |- *.
-  rewrite IHx in |- *.
-  rewrite gen_phiNword_cons in |- *.
+  simpl Nwmul.
+  rewrite Nwopp_ok.
+  rewrite IHx.
+  rewrite gen_phiNword_cons.
   norm.
 
-  simpl Nwmul in |- *.
-  unfold Nwsub in |- *.
-  rewrite Nwadd_ok in |- *.
-  rewrite Nwscal_ok in |- *.
-  rewrite Nwopp_ok in |- *.
-  rewrite IHx in |- *.
-  rewrite gen_phiNword_cons in |- *.
+  simpl Nwmul.
+  unfold Nwsub.
+  rewrite Nwadd_ok.
+  rewrite Nwscal_ok.
+  rewrite Nwopp_ok.
+  rewrite IHx.
+  rewrite gen_phiNword_cons.
   norm.
 Qed.
 
@@ -570,9 +528,9 @@ constructor.
  exact Nwadd_ok.
 
  intros.
- unfold Nwsub in |- *.
- rewrite Nwadd_ok in |- *.
- rewrite Nwopp_ok in |- *.
+ unfold Nwsub.
+ rewrite Nwadd_ok.
+ rewrite Nwopp_ok.
  norm.
 
  exact Nwmul_ok.
@@ -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.
@@ -783,10 +741,10 @@ Ltac gen_ring_sign morph sspec :=
 Ltac default_div_spec set reqe arth morph :=
  match type of morph with
  | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req
-               Z ?c0 ?c1 Zplus Zmult ?csub ?copp ?ceq_b ?phi =>
+               Z ?c0 ?c1 Z.add Z.mul ?csub ?copp ?ceq_b ?phi =>
       constr:(mkhypo (Ztriv_div_th set phi))
  | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req
-               N ?c0 ?c1 Nplus Nmult ?csub ?copp ?ceq_b ?phi =>
+               N ?c0 ?c1 N.add N.mul ?csub ?copp ?ceq_b ?phi =>
       constr:(mkhypo (Ntriv_div_th set phi))
  | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req
                ?C ?c0 ?c1 ?cadd ?cmul ?csub ?copp ?ceq_b ?phi =>
@@ -878,7 +836,7 @@ Ltac isPcst t :=
   | xO ?p => isPcst p
   | xH => constr:true
   (* nat -> positive *)
-  | P_of_succ_nat ?n => isnatcst n
+  | Pos.of_succ_nat ?n => isnatcst n
   | _ => constr:false
   end.
 
@@ -895,9 +853,9 @@ Ltac isZcst t :=
   | Zpos ?p => isPcst p
   | Zneg ?p => isPcst p
   (* injection nat -> Z *)
-  | Z_of_nat ?n => isnatcst n
+  | Z.of_nat ?n => isnatcst n
   (* injection N -> Z *)
-  | Z_of_N ?n => isNcst n
+  | Z.of_N ?n => isNcst n
   (* *)
   | _ => constr:false
   end.
diff --git a/plugins/setoid_ring/Integral_domain.v b/plugins/setoid_ring/Integral_domain.v
new file mode 100644
index 00000000..0c16fe1a
--- /dev/null
+++ b/plugins/setoid_ring/Integral_domain.v
@@ -0,0 +1,43 @@
+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_succ. cring. apply ring_setoid.
+apply ring_mult_comp.
+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..fae98d83 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-2012     *)
 (*   \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..7789ba3e
--- /dev/null
+++ b/plugins/setoid_ring/Ncring.v
@@ -0,0 +1,306 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* 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.
+Proof.
+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_succ : forall  x j, pow_pos x (Pos.succ 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_add : forall  x i j,
+  pow_pos x (i + j) == pow_pos x i * pow_pos x j.
+Proof.
+  intro x;induction i;intros.
+  rewrite Pos.xI_succ_xO;rewrite <- Pos.add_1_r.
+  rewrite <- Pos.add_diag;repeat rewrite <- Pos.add_assoc.
+  repeat rewrite IHi.
+  rewrite Pos.add_comm;rewrite Pos.add_1_r;
+  rewrite pow_pos_succ.
+  simpl;repeat rewrite ring_mul_assoc. reflexivity.
+  rewrite <- Pos.add_diag;repeat rewrite <- Pos.add_assoc.
+  repeat rewrite IHi. rewrite ring_mul_assoc. reflexivity.
+  rewrite Pos.add_comm;rewrite Pos.add_1_r;rewrite pow_pos_succ.
+   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..528ad4f1
--- /dev/null
+++ b/plugins/setoid_ring/Ncring_initial.v
@@ -0,0 +1,209 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+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 : Equivalence (@eq Z).
+Proof. exact Z.eq_equiv. Qed.
+
+Instance Zops:@Ring_ops Z 0%Z 1%Z Z.add Z.mul Z.sub Z.opp (@eq Z).
+
+Instance Zr: (@Ring _ _ _ _ _ _ _ _ Zops).
+Proof.
+constructor; try apply Zsth; try solve_proper.
+ exact Z.add_comm. exact Z.add_assoc.
+ exact Z.mul_1_l.  exact Z.mul_1_r. exact Z.mul_assoc.
+ exact Z.mul_add_distr_r.  intros; apply Z.mul_add_distr_l.  exact Z.sub_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 (Pos.succ 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 Pos.add_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.
+  generalize (Z.pos_sub_discr x y).
+  destruct (Z.pos_sub x y) as [|p|p]; intros; subst.
+  - now rewrite ring_opp_def.
+  - rewrite ARgen_phiPOS_add;simpl;norm.
+    add_push (gen_phiPOS1 p). rewrite ring_opp_def;norm.
+  - rewrite ARgen_phiPOS_add;simpl;norm.
+    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 (x-y)%Z with (x + (-y))%Z.
+now rewrite gen_phiZ_add, gen_phiZ_opp, ring_sub_def.
+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..8e4b613f
--- /dev/null
+++ b/plugins/setoid_ring/Ncring_polynom.v
@@ -0,0 +1,584 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*  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 Pos.compare i i', Pos.compare n n' 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 Pos.compare i i' 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 Pos.compare i i' with
+      | (* i > i' *)
+        Gt => mkPX P i n Q
+      | (* i < i' *)
+        Lt => mkPX P' i' n' (PaddX i n Q')
+      | (* i = i' *)
+        Eq => match Z.pos_sub 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 *)
+
+ Ltac destr_pos_sub H :=
+  match goal with |- context [Z.pos_sub ?x ?y] =>
+   assert (H := Z.pos_sub_discr x y); destruct (Z.pos_sub x y)
+  end.
+
+ Lemma Peq_ok : forall P P',
+    (P =? P') = true -> forall l, P@l == P'@ l.
+ Proof.
+ induction P;destruct P';simpl;intros ;try easy.
+ - now apply ring_morphism_eq, Ceqb_eq.
+ - specialize (IHP1 P'1). specialize (IHP2 P'2).
+   simpl in IHP1, IHP2.
+   destruct (Pos.compare_spec p p1); try discriminate;
+   destruct (Pos.compare_spec p0 p2); try discriminate.
+   destruct (Peq P2 P'1); try discriminate.
+   subst; now rewrite IHP1, IHP2.
+ 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.
+  destruct (Pos.compare_spec i p).
+  assert (Hh := @Peq_ok P3 P0). case_eq (P3=? P0). intro. simpl. 
+  rewrite Hh. 
+  rewrite Pphi0. rsimpl. rewrite Pos.add_comm. rewrite pow_pos_add;rsimpl.
+  subst;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 Pos.compare i i' 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 Z.pos_sub 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.
+ destruct (Pos.compare_spec k p) as [Hh|Hh|Hh].
+ destr_pos_sub H1h. Esimpl2.
+rewrite Hh; trivial. rewrite H1h. reflexivity.
+simpl. rewrite mkPX_ok. rewrite IHP1. Esimpl2.
+ rewrite Pos.add_comm in H1h.
+rewrite H1h. 
+rewrite pow_pos_add.  Esimpl2.
+rewrite Hh; trivial. reflexivity.
+rewrite mkPX_ok. rewrite PaddCl_ok. Esimpl2. rewrite Pos.add_comm in H1h.
+rewrite H1h.  Esimpl2. rewrite pow_pos_add. 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. 
+destruct (Pos.compare_spec k p1) as [H3h|H3h|H3h].
+destr_pos_sub H4h.
+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 Pos.add_comm in H4h.
+rewrite H4h. rewrite pow_pos_add. Esimpl2.
+rewrite mkPX_ok. simpl. rewrite H0. rewrite H1. 
+rewrite mkPX_ok.
+ Esimpl2. rewrite H3h;trivial.
+ rewrite Pos.add_comm in H4h.
+rewrite H4h. rewrite pow_pos_add. 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..44f8e7ff
--- /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-2012     *)
+(*   \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 (Pos.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 Z.add Z.mul Z.sub Z.opp (@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 (eq_refl 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 Z.add Z.mul Z.sub Z.opp (@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/RealField.v b/plugins/setoid_ring/RealField.v
index 56473adb..29372212 100644
--- a/plugins/setoid_ring/RealField.v
+++ b/plugins/setoid_ring/RealField.v
@@ -5,21 +5,21 @@ Require Import Rdefinitions.
 Require Import Rpow_def.
 Require Import Raxioms.
 
-Open Local Scope R_scope.
+Local Open Scope R_scope.
 
 Lemma RTheory : ring_theory 0 1 Rplus Rmult Rminus Ropp (eq (A:=R)).
 Proof.
 constructor.
  intro; apply Rplus_0_l.
  exact Rplus_comm.
- symmetry  in |- *; apply Rplus_assoc.
+ symmetry ; apply Rplus_assoc.
  intro; apply Rmult_1_l.
  exact Rmult_comm.
- symmetry  in |- *; apply Rmult_assoc.
+ symmetry ; apply Rmult_assoc.
  intros m n p.
-   rewrite Rmult_comm in |- *.
-   rewrite (Rmult_comm n p) in |- *.
-   rewrite (Rmult_comm m p) in |- *.
+   rewrite Rmult_comm.
+   rewrite (Rmult_comm n p).
+   rewrite (Rmult_comm m p).
    apply Rmult_plus_distr_l.
  reflexivity.
  exact Rplus_opp_r.
@@ -42,17 +42,17 @@ destruct H0.
  apply Rlt_trans with (IZR (up x)); trivial.
     replace (IZR (up x)) with (x + (IZR (up x) - x))%R.
   apply Rplus_lt_compat_l; trivial.
-  unfold Rminus in |- *.
-    rewrite (Rplus_comm (IZR (up x)) (- x)) in |- *.
-    rewrite <- Rplus_assoc in |- *.
-    rewrite Rplus_opp_r in |- *.
+  unfold Rminus.
+    rewrite (Rplus_comm (IZR (up x)) (- x)).
+    rewrite <- Rplus_assoc.
+    rewrite Rplus_opp_r.
     apply Rplus_0_l.
  elim H0.
-   unfold Rminus in |- *.
-   rewrite (Rplus_comm (IZR (up x)) (- x)) in |- *.
-   rewrite <- Rplus_assoc in |- *.
-   rewrite Rplus_opp_r in |- *.
-   rewrite Rplus_0_l in |- *; trivial.
+   unfold Rminus.
+   rewrite (Rplus_comm (IZR (up x)) (- x)).
+   rewrite <- Rplus_assoc.
+   rewrite Rplus_opp_r.
+   rewrite Rplus_0_l; trivial.
 Qed.
 
 Notation Rset := (Eqsth R).
@@ -61,7 +61,7 @@ Notation Rext := (Eq_ext Rplus Rmult Ropp).
 Lemma Rlt_0_2 : 0 < 2.
 apply Rlt_trans with (0 + 1).
  apply Rlt_n_Sn.
- rewrite Rplus_comm in |- *.
+ rewrite Rplus_comm.
    apply Rplus_lt_compat_l.
     replace 1 with (0 + 1).
   apply Rlt_n_Sn.
@@ -69,19 +69,19 @@ apply Rlt_trans with (0 + 1).
 Qed.
 
 Lemma Rgen_phiPOS : forall x, InitialRing.gen_phiPOS1 1 Rplus Rmult x > 0.
-unfold Rgt in |- *.
-induction x; simpl in |- *; intros.
+unfold Rgt.
+induction x; simpl; intros.
  apply Rlt_trans with (1 + 0).
-  rewrite Rplus_comm in |- *.
+  rewrite Rplus_comm.
     apply Rlt_n_Sn.
   apply Rplus_lt_compat_l.
-    rewrite <- (Rmul_0_l Rset Rext RTheory 2) in |- *.
-    rewrite Rmult_comm in |- *.
+    rewrite <- (Rmul_0_l Rset Rext RTheory 2).
+    rewrite Rmult_comm.
     apply Rmult_lt_compat_l.
    apply Rlt_0_2.
    trivial.
- rewrite <- (Rmul_0_l Rset Rext RTheory 2) in |- *.
-   rewrite Rmult_comm in |- *.
+ rewrite <- (Rmul_0_l Rset Rext RTheory 2).
+   rewrite Rmult_comm.
    apply Rmult_lt_compat_l.
   apply Rlt_0_2.
   trivial.
@@ -93,9 +93,9 @@ Qed.
 
 Lemma Rgen_phiPOS_not_0 :
   forall x, InitialRing.gen_phiPOS1 1 Rplus Rmult x <> 0.
-red in |- *; intros.
+red; intros.
 specialize (Rgen_phiPOS x).
-rewrite H in |- *; intro.
+rewrite H; intro.
 apply (Rlt_asym 0 0); trivial.
 Qed.
 
@@ -107,23 +107,23 @@ Proof gen_phiZ_complete Rset Rext Rfield Rgen_phiPOS_not_0.
 
 Lemma Rdef_pow_add : forall (x:R) (n m:nat), pow x  (n + m) = pow x n * pow 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 R_power_theory : power_theory 1%R Rmult (eq (A:=R))  nat_of_N pow.
+Lemma R_power_theory : power_theory 1%R Rmult (@eq R) N.to_nat pow.
 Proof.
  constructor. destruct n. reflexivity.
- simpl. induction p;simpl.
- rewrite ZL6. rewrite Rdef_pow_add;rewrite IHp. reflexivity.
- unfold nat_of_P;simpl;rewrite ZL6;rewrite Rdef_pow_add;rewrite IHp;trivial.
- rewrite Rmult_comm;apply Rmult_1_l.
+ simpl. induction p.
+ - rewrite Pos2Nat.inj_xI. simpl. now rewrite plus_0_r, Rdef_pow_add, IHp.
+ - rewrite Pos2Nat.inj_xO. simpl. now rewrite plus_0_r, Rdef_pow_add, IHp.
+ - simpl. rewrite Rmult_comm;apply Rmult_1_l.
 Qed.
 
 Ltac Rpow_tac t :=
   match isnatcst t with
   | false => constr:(InitialRing.NotConstant)
-  | _ => constr:(N_of_nat t)
+  | _ => constr:(N.of_nat t)
   end.
 
 Add Field RField : Rfield
diff --git a/plugins/setoid_ring/Ring.v b/plugins/setoid_ring/Ring.v
index 7b48f590..7c1bf981 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -14,7 +14,7 @@ Require Export Ring_tac.
 
 Lemma BoolTheory :
   ring_theory false true xorb andb xorb (fun b:bool => b) (eq(A:=bool)).
-split; simpl in |- *.
+split; simpl.
 destruct x; reflexivity.
 destruct x; destruct y; reflexivity.
 destruct x; destruct y; destruct z; reflexivity.
diff --git a/plugins/setoid_ring/Ring_base.v b/plugins/setoid_ring/Ring_base.v
index 9bc95a7f..dc5248b2 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-2012     *)
 (*   \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..b23ba352 100644
--- a/plugins/setoid_ring/Ring_polynom.v
+++ b/plugins/setoid_ring/Ring_polynom.v
@@ -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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
 Set Implicit Arguments.
-Require Import Setoid.
-Require Import BinList.
-Require Import BinPos.
-Require Import BinNat.
-Require Import BinInt.
+Require Import Setoid Morphisms BinList BinPos BinNat BinInt.
 Require Export Ring_theory.
 
-Open Local Scope positive_scope.
+Local Open Scope positive_scope.
 Import RingSyntax.
 
 Section MakeRingPol.
@@ -25,7 +21,7 @@ Section MakeRingPol.
  Variable req : R -> R -> Prop.
 
  (* Ring properties *)
- Variable Rsth : Setoid_Theory R req.
+ Variable Rsth : Equivalence req.
  Variable Reqe : ring_eq_ext radd rmul ropp req.
  Variable ARth : almost_ring_theory rO rI radd rmul rsub ropp req.
 
@@ -37,8 +33,8 @@ Section MakeRingPol.
  Variable CRmorph : ring_morph rO rI radd rmul rsub ropp req
                                 cO cI cadd cmul csub copp ceqb phi.
 
-  (* Power coefficients *)
- Variable Cpow : Set.
+ (* Power coefficients *)
+ Variable Cpow : Type.
  Variable Cp_phi : N -> Cpow.
  Variable rpow : R -> Cpow -> R.
  Variable pow_th : power_theory rI rmul req Cp_phi rpow.
@@ -50,26 +46,47 @@ Section MakeRingPol.
 
  (* R notations *)
  Notation "0" := rO. Notation "1" := rI.
- Notation "x + y" := (radd x y).  Notation "x * y " := (rmul x y).
- Notation "x - y " := (rsub x y). Notation "- x" := (ropp x).
- Notation "x == y" := (req x y).
+ Infix "+" := radd. Infix "*" := rmul.
+ Infix "-" := rsub. Notation "- x" := (ropp x).
+ Infix "==" := req.
+ Infix "^" := (pow_pos rmul).
 
  (* C notations *)
- Notation "x +! y" := (cadd x y). Notation "x *! y " := (cmul x y).
- Notation "x -! y " := (csub x y). Notation "-! x" := (copp x).
- Notation " x ?=! y" := (ceqb x y). Notation "[ x ]" := (phi x).
+ Infix "+!" := cadd. Infix "*!" := cmul.
+ Infix "-! " := csub. Notation "-! x" := (copp x).
+ Infix "?=!" := ceqb. Notation "[ x ]" := (phi x).
 
  (* Useful tactics *)
-  Add Setoid R req Rsth as R_set1.
- Ltac rrefl := gen_reflexivity Rsth.
-  Add Morphism radd : radd_ext.  exact (Radd_ext Reqe). Qed.
-  Add Morphism rmul : rmul_ext.  exact (Rmul_ext Reqe). Qed.
-  Add Morphism ropp : ropp_ext.  exact (Ropp_ext Reqe). Qed.
-  Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed.
+ Add Morphism radd : radd_ext. exact (Radd_ext Reqe). Qed.
+ Add Morphism rmul : rmul_ext. exact (Rmul_ext Reqe). Qed.
+ Add Morphism ropp : ropp_ext. exact (Ropp_ext Reqe). Qed.
+ Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed.
  Ltac rsimpl := gen_srewrite Rsth Reqe ARth.
+
  Ltac add_push := gen_add_push radd Rsth Reqe ARth.
  Ltac mul_push := gen_mul_push rmul Rsth Reqe ARth.
 
+ Ltac add_permut_rec t :=
+   match t with
+   | ?x + ?y => add_permut_rec y || add_permut_rec x
+   | _ => add_push t; apply (Radd_ext Reqe); [|reflexivity]
+   end.
+
+ Ltac add_permut :=
+  repeat (reflexivity ||
+    match goal with |- ?t == _ => add_permut_rec t end).
+
+ Ltac mul_permut_rec t :=
+   match t with
+   | ?x * ?y => mul_permut_rec y || mul_permut_rec x
+   | _ => mul_push t; apply (Rmul_ext Reqe); [|reflexivity]
+   end.
+
+ Ltac mul_permut :=
+  repeat (reflexivity ||
+    match goal with |- ?t == _ => mul_permut_rec t end).
+
+
  (* Definition of multivariable polynomials with coefficients in C :
     Type [Pol] represents [X1 ... Xn].
     The representation is Horner's where a [n] variable polynomial
@@ -104,31 +121,31 @@ 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
   | _, _ => false
   end.
 
- Notation " P ?== P' " := (Peq P P').
+ Infix "?==" := Peq.
 
  Definition mkPinj j P :=
   match P with
   | Pc _ => P
-  | Pinj j' Q => Pinj ((j + j'):positive) Q
+  | Pinj j' Q => Pinj (j + j') Q
   | _ => Pinj j P
   end.
 
  Definition mkPinj_pred j P:=
   match j with
   | xH => P
-  | xO j => Pinj (Pdouble_minus_one j) P
+  | xO j => Pinj (Pos.pred_double j) P
   | xI j => Pinj (xO j) P
   end.
 
@@ -156,14 +173,14 @@ Section MakeRingPol.
 
  (** Addition et subtraction *)
 
- Fixpoint PaddC (P:Pol) (c:C) {struct P} : Pol :=
+ Fixpoint PaddC (P:Pol) (c:C) : Pol :=
   match P with
   | Pc c1 => Pc (c1 +! c)
   | Pinj j Q => Pinj j (PaddC Q c)
   | PX P i Q => PX P i (PaddC Q c)
   end.
 
- Fixpoint PsubC (P:Pol) (c:C) {struct P} : Pol :=
+ Fixpoint PsubC (P:Pol) (c:C) : Pol :=
   match P with
   | Pc c1 => Pc (c1 -! c)
   | Pinj j Q => Pinj j (PsubC Q c)
@@ -175,11 +192,11 @@ Section MakeRingPol.
   Variable Pop : Pol -> Pol -> Pol.
   Variable Q : Pol.
 
-  Fixpoint PaddI (j:positive) (P:Pol){struct P} : Pol :=
+  Fixpoint PaddI (j:positive) (P:Pol) : Pol :=
    match P with
    | Pc c => mkPinj j (PaddC Q c)
    | Pinj j' Q' =>
-     match ZPminus j' j with
+     match Z.pos_sub j' j with
      | Zpos k =>  mkPinj j (Pop (Pinj k Q') Q)
      | Z0 => mkPinj j (Pop Q' Q)
      | Zneg k => mkPinj j' (PaddI k Q')
@@ -187,16 +204,16 @@ Section MakeRingPol.
    | PX P i Q' =>
      match j with
      | xH => PX P i (Pop Q' Q)
-     | xO j => PX P i (PaddI (Pdouble_minus_one j) Q')
+     | xO j => PX P i (PaddI (Pos.pred_double j) Q')
      | xI j => PX P i (PaddI (xO j) Q')
      end
    end.
 
-  Fixpoint PsubI (j:positive) (P:Pol){struct P} : Pol :=
+  Fixpoint PsubI (j:positive) (P:Pol) : Pol :=
    match P with
    | Pc c => mkPinj j (PaddC (--Q) c)
    | Pinj j' Q' =>
-     match ZPminus j' j with
+     match Z.pos_sub j' j with
      | Zpos k =>  mkPinj j (Pop (Pinj k Q') Q)
      | Z0 => mkPinj j (Pop Q' Q)
      | Zneg k => mkPinj j' (PsubI k Q')
@@ -204,41 +221,41 @@ Section MakeRingPol.
    | PX P i Q' =>
      match j with
      | xH => PX P i (Pop Q' Q)
-     | xO j => PX P i (PsubI (Pdouble_minus_one j) Q')
+     | xO j => PX P i (PsubI (Pos.pred_double j) Q')
      | xI j => PX P i (PsubI (xO j) Q')
      end
    end.
 
  Variable P' : Pol.
 
- Fixpoint PaddX (i':positive) (P:Pol) {struct P} : Pol :=
+ Fixpoint PaddX (i':positive) (P:Pol) : Pol :=
   match P with
   | Pc c => PX P' i' P
   | Pinj j Q' =>
     match j with
     | xH =>  PX P' i' Q'
-    | xO j => PX P' i' (Pinj (Pdouble_minus_one j) Q')
+    | xO j => PX P' i' (Pinj (Pos.pred_double j) Q')
     | xI j => PX P' i' (Pinj (xO j) Q')
     end
   | PX P i Q' =>
-    match ZPminus i i' with
+    match Z.pos_sub i i' with
     | Zpos k => mkPX (Pop (PX P k P0) P') i' Q'
     | Z0 => mkPX (Pop P P') i Q'
     | Zneg k => mkPX (PaddX k P) i Q'
     end
   end.
 
- Fixpoint PsubX (i':positive) (P:Pol) {struct P} : Pol :=
+ Fixpoint PsubX (i':positive) (P:Pol) : Pol :=
   match P with
   | Pc c => PX (--P') i' P
   | Pinj j Q' =>
     match j with
     | xH =>  PX (--P') i' Q'
-    | xO j => PX (--P') i' (Pinj (Pdouble_minus_one j) Q')
+    | xO j => PX (--P') i' (Pinj (Pos.pred_double j) Q')
     | xI j => PX (--P') i' (Pinj (xO j) Q')
     end
   | PX P i Q' =>
-    match ZPminus i i' with
+    match Z.pos_sub i i' with
     | Zpos k => mkPX (Pop (PX P k P0) P') i' Q'
     | Z0 => mkPX (Pop P P') i Q'
     | Zneg k => mkPX (PsubX k P) i Q'
@@ -258,18 +275,18 @@ Section MakeRingPol.
     | Pinj j Q =>
       match j with
       | xH => PX P' i' (Padd Q Q')
-      | xO j => PX P' i' (Padd (Pinj (Pdouble_minus_one j) Q) Q')
+      | xO j => PX P' i' (Padd (Pinj (Pos.pred_double j) Q) Q')
       | xI j => PX P' i' (Padd (Pinj (xO j) Q) Q')
       end
     | PX P i Q =>
-      match ZPminus i i' with
+      match Z.pos_sub i i' with
       | Zpos k => mkPX (Padd (PX P k P0) P') i' (Padd Q Q')
       | Z0 => mkPX (Padd P P') i (Padd Q Q')
       | Zneg k => mkPX (PaddX Padd P' k P) i (Padd Q Q')
       end
     end
   end.
- Notation "P ++ P'" := (Padd P P').
+ Infix "++" := Padd.
 
  Fixpoint Psub (P P': Pol) {struct P'} : Pol :=
   match P' with
@@ -281,22 +298,22 @@ Section MakeRingPol.
     | Pinj j Q =>
       match j with
       | xH => PX (--P') i' (Psub Q Q')
-      | xO j => PX (--P') i' (Psub (Pinj (Pdouble_minus_one j) Q) Q')
+      | xO j => PX (--P') i' (Psub (Pinj (Pos.pred_double j) Q) Q')
       | xI j => PX (--P') i' (Psub (Pinj (xO j) Q) Q')
       end
     | PX P i Q =>
-      match ZPminus i i' with
+      match Z.pos_sub i i' with
       | Zpos k => mkPX (Psub (PX P k P0) P') i' (Psub Q Q')
       | Z0 => mkPX (Psub P P') i (Psub Q Q')
       | Zneg k => mkPX (PsubX Psub P' k P) i (Psub Q Q')
       end
     end
   end.
- Notation "P -- P'" := (Psub P P').
+ Infix "--" := Psub.
 
  (** Multiplication *)
 
- Fixpoint PmulC_aux (P:Pol) (c:C) {struct P} : Pol :=
+ Fixpoint PmulC_aux (P:Pol) (c:C) : Pol :=
   match P with
   | Pc c' => Pc (c' *! c)
   | Pinj j Q => mkPinj j (PmulC_aux Q c)
@@ -310,11 +327,11 @@ Section MakeRingPol.
  Section PmulI.
   Variable Pmul : Pol -> Pol -> Pol.
   Variable Q : Pol.
-  Fixpoint PmulI (j:positive) (P:Pol) {struct P} : Pol :=
+  Fixpoint PmulI (j:positive) (P:Pol) : Pol :=
    match P with
    | Pc c => mkPinj j (PmulC Q c)
    | Pinj j' Q' =>
-     match ZPminus j' j with
+     match Z.pos_sub j' j with
      | Zpos k => mkPinj j (Pmul (Pinj k Q') Q)
      | Z0 => mkPinj j (Pmul Q' Q)
      | Zneg k => mkPinj j' (PmulI k Q')
@@ -322,13 +339,12 @@ Section MakeRingPol.
    | PX P' i' Q' =>
      match j with
      | xH => mkPX (PmulI xH P') i' (Pmul Q' Q)
-     | xO j' => mkPX (PmulI j P') i' (PmulI (Pdouble_minus_one j') Q')
+     | xO j' => mkPX (PmulI j P') i' (PmulI (Pos.pred_double j') Q')
      | xI j' => mkPX (PmulI j P') i' (PmulI (xO j') Q')
      end
    end.
 
  End PmulI.
-(* A symmetric version of the multiplication *)
 
  Fixpoint Pmul (P P'' : Pol) {struct P''} : Pol :=
    match P'' with
@@ -341,7 +357,7 @@ Section MakeRingPol.
        let QQ' :=
          match j with
          | xH => Pmul Q Q'
-         | xO j => Pmul (Pinj (Pdouble_minus_one j) Q) Q'
+         | xO j => Pmul (Pinj (Pos.pred_double j) Q) Q'
          | xI j => Pmul (Pinj (xO j) Q) Q'
          end in
        mkPX (Pmul P P') i' QQ'
@@ -354,25 +370,7 @@ Section MakeRingPol.
      end
   end.
 
-(* Non symmetric *)
-(*
- Fixpoint Pmul_aux (P P' : Pol) {struct P'} : Pol :=
-  match P' with
-  | Pc c' => PmulC P c'
-  | Pinj j' Q' => PmulI Pmul_aux Q' j' P
-  | PX P' i' Q' =>
-     (mkPX (Pmul_aux P P') i' P0) ++ (PmulI Pmul_aux Q' xH P)
-  end.
-
- Definition Pmul P P' :=
-  match P with
-  | Pc c => PmulC P' c
-  | Pinj j Q => PmulI Pmul_aux Q j P'
-  | PX P i Q =>
-    (mkPX (Pmul_aux P P') i P0) ++ (PmulI Pmul_aux Q xH P')
-  end.
-*)
- Notation "P ** P'" := (Pmul P P').
+ Infix "**" := Pmul.
 
  Fixpoint Psquare (P:Pol) : Pol :=
    match P with
@@ -387,26 +385,26 @@ Section MakeRingPol.
 
  (** Monomial **)
 
+ (** A monomial is X1^k1...Xi^ki. Its representation
+     is a simplified version of the polynomial representation:
+
+     - [mon0] correspond to the polynom [P1].
+     - [(zmon j M)] corresponds to [(Pinj j ...)],
+       i.e. skip j variable indices.
+     - [(vmon i M)] is X^i*M with X the current variable,
+       its corresponds to (PX P1 i ...)]
+ *)
+
   Inductive Mon: Set :=
-    mon0: Mon
+  | mon0: Mon
   | zmon: positive -> Mon -> Mon
   | vmon: positive -> Mon -> Mon.
 
- Fixpoint Mphi(l:list R) (M: Mon) {struct M} : R :=
-  match M with
-     mon0 => rI
-  | zmon j M1  => Mphi (jump j l) M1
-  | vmon i M1 =>
-     let x := hd 0 l in
-     let xi := pow_pos rmul x i in
-    (Mphi (tail l) M1) * xi
-  end.
-
  Definition mkZmon j M :=
    match M with mon0 => mon0 | _ => zmon j M end.
 
  Definition zmon_pred j M :=
-   match j with xH => M | _ => mkZmon (Ppred j) M end.
+   match j with xH => M | _ => mkZmon (Pos.pred j) M end.
 
  Definition mkVmon i M :=
    match M with
@@ -421,7 +419,7 @@ Section MakeRingPol.
    | Pinj j1 P1  =>
      let (R,S) := CFactor P1 c in
             (mkPinj j1 R, mkPinj j1 S)
-  | PX P1 i Q1 =>
+   | PX P1 i Q1 =>
      let (R1, S1) := CFactor P1 c in
      let (R2, S2) := CFactor Q1 c in
         (mkPX R1 i R2, mkPX S1 i S2)
@@ -429,13 +427,10 @@ Section MakeRingPol.
 
  Fixpoint MFactor (P: Pol) (c: C) (M: Mon) {struct P}: Pol * Pol :=
    match P, M with
-        _, mon0 =>
-            if (ceqb c cI) then (Pc cO, P) else
-(*            if (ceqb c (copp cI)) then (Pc cO, Popp P) else  Not in almost ring *)
-            CFactor P c
+        _, mon0 => if (ceqb c cI) then (Pc cO, P) else 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 +444,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
@@ -468,7 +463,7 @@ Section MakeRingPol.
     | _ => Some (Padd Q1 (Pmul P2 R1))
     end.
 
-  Fixpoint PNSubst1 (P1: Pol) (cM1: C * Mon) (P2: Pol) (n: nat) {struct n}: Pol :=
+  Fixpoint PNSubst1 (P1: Pol) (cM1: C * Mon) (P2: Pol) (n: nat) : Pol :=
     match POneSubst P1 cM1 P2 with
      Some P3 => match n with S n1 => PNSubst1 P3 cM1 P2 n1 | _ => P3 end
     | _ => P1
@@ -480,14 +475,13 @@ Section MakeRingPol.
     | _ => None
     end.
 
-  Fixpoint PSubstL1 (P1: Pol) (LM1: list ((C * Mon) * Pol)) (n: nat) {struct LM1}:
-     Pol :=
+  Fixpoint PSubstL1 (P1: Pol) (LM1: list ((C * Mon) * Pol)) (n: nat) : Pol :=
     match LM1 with
      cons (M1,P2) LM2 => PSubstL1 (PNSubst1 P1 M1 P2 n) LM2 n
     | _ => P1
     end.
 
-  Fixpoint PSubstL (P1: Pol) (LM1: list ((C * Mon) * Pol)) (n: nat) {struct LM1}: option Pol :=
+  Fixpoint PSubstL (P1: Pol) (LM1: list ((C * Mon) * Pol)) (n: nat) : option Pol :=
     match LM1 with
      cons (M1,P2) LM2 =>
       match PNSubst P1 M1 P2 n with
@@ -497,7 +491,7 @@ Section MakeRingPol.
     | _ => None
     end.
 
-  Fixpoint PNSubstL (P1: Pol) (LM1: list ((C * Mon) * Pol)) (m n: nat) {struct m}: Pol :=
+  Fixpoint PNSubstL (P1: Pol) (LM1: list ((C * Mon) * Pol)) (m n: nat) : Pol :=
     match PSubstL P1 LM1 n with
      Some P3 => match m with S m1 => PNSubstL P3 LM1 m1 n | _ => P3 end
     | _ => P1
@@ -505,658 +499,409 @@ Section MakeRingPol.
 
  (** Evaluation of a polynomial towards R *)
 
- Fixpoint Pphi(l:list R) (P:Pol) {struct P} : R :=
+ Local Notation hd := (List.hd 0).
+
+ Fixpoint Pphi(l:list R) (P:Pol) : R :=
   match P with
   | Pc c => [c]
   | Pinj j Q => Pphi (jump j l) Q
-  | PX P i Q =>
-     let x := hd 0 l in
-     let xi := pow_pos rmul x i in
-    (Pphi l P) * xi + (Pphi (tail l) Q)
+  | PX P i Q => Pphi l P * (hd l) ^ i + Pphi (tail l) Q
   end.
 
  Reserved Notation "P @ l " (at level 10, no associativity).
  Notation "P @ l " := (Pphi l P).
+
+ (** Evaluation of a monomial towards R *)
+
+ Fixpoint Mphi(l:list R) (M: Mon) : R :=
+  match M with
+  | mon0 => rI
+  | zmon j M1 => Mphi (jump j l) M1
+  | vmon i M1 => Mphi (tail l) M1 * (hd l) ^ i
+  end.
+
+ Notation "M @@ l" := (Mphi l M) (at level 10, no associativity).
+
  (** 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
+
+ Ltac destr_pos_sub :=
+  match goal with |- context [Z.pos_sub ?x ?y] =>
+   generalize (Z.pos_sub_discr x y); destruct (Z.pos_sub x y)
   end.
+
+ Lemma jump_add' i j (l:list R) : jump (i + j) l = jump j (jump i l).
+ Proof. rewrite Pos.add_comm. apply jump_add. Qed.
+
+ Lemma Peq_ok P P' : (P ?== P') = true -> forall l, P@l == P'@ l.
  Proof.
-  induction x;destruct y.
-  replace (ZPminus (xI x) (xI y)) with (Zdouble (ZPminus x y));trivial.
-  assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble;rewrite H;trivial.
-  replace (ZPminus (xI x) (xO y)) with (Zdouble_plus_one (ZPminus x y));trivial.
-  assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble_plus_one;rewrite H;trivial.
-  apply Pplus_xI_double_minus_one.
-  simpl;trivial.
-  replace (ZPminus (xO x) (xI y)) with (Zdouble_minus_one (ZPminus x y));trivial.
-  assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble_minus_one;rewrite H;trivial.
-  apply Pplus_xI_double_minus_one.
-  replace (ZPminus (xO x) (xO y)) with (Zdouble (ZPminus x y));trivial.
-  assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble;rewrite H;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.
+  revert P';induction P;destruct P';simpl; intros H l; try easy.
+  - now apply (morph_eq CRmorph).
+  - destruct (Pos.compare_spec p p0); [ subst | easy | easy ].
+    now rewrite IHP.
+  - specialize (IHP1 P'1); specialize (IHP2 P'2).
+    destruct (Pos.compare_spec p p0); [ subst | easy | easy ].
+    destruct (P2 ?== P'1); [|easy].
+    rewrite H in *.
+    now rewrite IHP1, IHP2.
  Qed.
 
- Lemma Peq_ok : forall P P',
-    (P ?== P') = true -> forall l, P@l == P'@ l.
+ Lemma Peq_spec P P' :
+   BoolSpec (forall l, P@l == P'@l) True (P ?== P').
  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);
-   try discriminate H.
-  rewrite (IHP P' H); rewrite H1;trivial;rrefl.
-  assert (H1 := Pcompare_Eq_eq p p0); destruct ((p ?= p0)%positive Eq);
-   try discriminate H.
-  rewrite H1;trivial. clear H1.
-  assert (H1 := IHP1 P'1);assert (H2 := IHP2 P'2);
-   destruct (P2 ?== P'1);[destruct (P3 ?== P'2); [idtac|discriminate H]
-                         |discriminate H].
-  rewrite (H1 H);rewrite (H2 H);rrefl.
+  generalize (Peq_ok P P'). destruct (P ?== P'); auto.
  Qed.
 
- Lemma Pphi0 : forall l, P0@l == 0.
+ Lemma Pphi0 l : P0@l == 0.
  Proof.
-  intros;simpl;apply (morph0 CRmorph).
+  simpl;apply (morph0 CRmorph).
  Qed.
 
- Lemma Pphi1 : forall l,  P1@l == 1.
+ Lemma Pphi1 l : P1@l == 1.
  Proof.
-  intros;simpl;apply (morph1 CRmorph).
+  simpl;apply (morph1 CRmorph).
  Qed.
 
- Lemma mkPinj_ok : forall j l P, (mkPinj j P)@l == P@(jump j l).
+ Lemma mkPinj_ok j l P : (mkPinj j P)@l == P@(jump j l).
  Proof.
-  intros j l p;destruct p;simpl;rsimpl.
-  rewrite <-jump_Pplus;rewrite Pplus_comm;rrefl.
+  destruct P;simpl;rsimpl.
+  now rewrite jump_add'.
  Qed.
 
- Let pow_pos_Pplus :=
-    pow_pos_Pplus rmul Rsth Reqe.(Rmul_ext) ARth.(ARmul_comm) ARth.(ARmul_assoc).
+ Lemma pow_pos_add x i j : x^(j + i) == x^i * x^j.
+ Proof.
+  rewrite Pos.add_comm.
+  apply (pow_pos_add Rsth Reqe.(Rmul_ext) ARth.(ARmul_assoc)).
+ Qed.
 
- Lemma mkPX_ok : forall l P i Q,
-  (mkPX P i Q)@l == P@l*(pow_pos rmul (hd 0 l) i) + Q@(tail l).
+ Lemma ceqb_spec c c' : BoolSpec ([c] == [c']) True (c ?=! c').
  Proof.
-  intros l P i Q;unfold mkPX.
-  destruct P;try (simpl;rrefl).
-  assert (H := morph_eq CRmorph c cO);destruct (c ?=! cO);simpl;try rrefl.
-  rewrite (H (refl_equal true));rewrite (morph0 CRmorph).
-  rewrite mkPinj_ok;rsimpl;simpl;rrefl.
-  assert (H := @Peq_ok P3 P0);destruct (P3 ?== P0);simpl;try rrefl.
-  rewrite (H (refl_equal true));trivial.
-  rewrite Pphi0.  rewrite pow_pos_Pplus;rsimpl.
+  generalize (morph_eq CRmorph c c').
+  destruct (c ?=! c'); auto.
  Qed.
 
- Ltac Esimpl :=
-  repeat (progress (
-   match goal with
-   | |- context [?P@?l] =>
-       match P with
-       | P0 => rewrite (Pphi0 l)
-       | P1 => rewrite (Pphi1 l)
-       | (mkPinj ?j ?P) => rewrite (mkPinj_ok j l P)
-       | (mkPX ?P ?i ?Q) => rewrite (mkPX_ok l P i Q)
-       end
-   | |- context [[?c]] =>
-       match c with
-       | cO => rewrite (morph0 CRmorph)
-       | cI => rewrite (morph1 CRmorph)
-       | ?x +! ?y => rewrite ((morph_add CRmorph) x y)
-       | ?x *! ?y => rewrite ((morph_mul CRmorph) x y)
-       | ?x -! ?y => rewrite ((morph_sub CRmorph) x y)
-       | -! ?x => rewrite ((morph_opp CRmorph) x)
-       end
-   end));
-  rsimpl; simpl.
-
- Lemma PaddC_ok : forall c P l, (PaddC P c)@l == P@l + [c].
+ Lemma mkPX_ok l P i Q :
+  (mkPX P i Q)@l == P@l * (hd l)^i + Q@(tail l).
  Proof.
-  induction P;simpl;intros;Esimpl;trivial.
-  rewrite IHP2;rsimpl.
+  unfold mkPX. destruct P.
+  - case ceqb_spec; intros H; simpl; try reflexivity.
+    rewrite H, (morph0 CRmorph), mkPinj_ok; rsimpl.
+  - reflexivity.
+  - case Peq_spec; intros H; simpl; try reflexivity.
+    rewrite H, Pphi0, Pos.add_comm, pow_pos_add; rsimpl.
  Qed.
 
- Lemma PsubC_ok : forall c P l, (PsubC P c)@l == P@l - [c].
+ Hint Rewrite
+  Pphi0
+  Pphi1
+  mkPinj_ok
+  mkPX_ok
+  (morph0 CRmorph)
+  (morph1 CRmorph)
+  (morph0 CRmorph)
+  (morph_add CRmorph)
+  (morph_mul CRmorph)
+  (morph_sub CRmorph)
+  (morph_opp CRmorph)
+  : Esimpl.
+
+ (* Quicker than autorewrite with Esimpl :-) *)
+ Ltac Esimpl := try rewrite_db Esimpl; rsimpl; simpl.
+
+ Lemma PaddC_ok c P l : (PaddC P c)@l == P@l + [c].
  Proof.
-  induction P;simpl;intros.
-  Esimpl.
-  rewrite IHP;rsimpl.
+  revert l;induction P;simpl;intros;Esimpl;trivial.
   rewrite IHP2;rsimpl.
  Qed.
 
- Lemma PmulC_aux_ok : forall c P l, (PmulC_aux P c)@l == P@l * [c].
+ Lemma PsubC_ok c P l : (PsubC P c)@l == P@l - [c].
  Proof.
-  induction P;simpl;intros;Esimpl;trivial.
-  rewrite IHP1;rewrite IHP2;rsimpl.
-  mul_push ([c]);rrefl.
+  revert l;induction P;simpl;intros.
+  - Esimpl.
+  - rewrite IHP;rsimpl.
+  - rewrite IHP2;rsimpl.
  Qed.
 
- Lemma PmulC_ok : forall c P l, (PmulC P c)@l == P@l * [c].
+ Lemma PmulC_aux_ok c P l : (PmulC_aux P c)@l == P@l * [c].
  Proof.
-  intros c P l; unfold PmulC.
-  assert (H:= morph_eq CRmorph c cO);destruct (c ?=! cO).
-  rewrite (H (refl_equal true));Esimpl.
-  assert (H1:= morph_eq CRmorph c cI);destruct (c ?=! cI).
-  rewrite (H1 (refl_equal true));Esimpl.
-  apply PmulC_aux_ok.
+  revert l;induction P;simpl;intros;Esimpl;trivial.
+  rewrite IHP1, IHP2;rsimpl. add_permut. mul_permut.
  Qed.
 
- Lemma Popp_ok : forall P l, (--P)@l == - P@l.
+ Lemma PmulC_ok c P l : (PmulC P c)@l == P@l * [c].
  Proof.
-  induction P;simpl;intros.
-  Esimpl.
-  apply IHP.
-  rewrite IHP1;rewrite IHP2;rsimpl.
+  unfold PmulC.
+  case ceqb_spec; intros H.
+  - rewrite H; Esimpl.
+  - case ceqb_spec; intros H'.
+    + rewrite H'; Esimpl.
+    + apply PmulC_aux_ok.
  Qed.
 
- Ltac Esimpl2 :=
-  Esimpl;
-  repeat (progress (
-   match goal with
-   | |- context [(PaddC ?P ?c)@?l] => rewrite (PaddC_ok c P l)
-   | |- context [(PsubC ?P ?c)@?l] => rewrite (PsubC_ok c P l)
-   | |- context [(PmulC ?P ?c)@?l] => rewrite (PmulC_ok c P l)
-   | |- context [(--?P)@?l] => rewrite (Popp_ok P l)
-   end)); Esimpl.
-
- Lemma Padd_ok : forall P' P l, (P ++ P')@l == P@l + P'@l.
+ Lemma Popp_ok P l : (--P)@l == - P@l.
  Proof.
-  induction P';simpl;intros;Esimpl2.
-  generalize P p l;clear P p l.
-  induction P;simpl;intros.
-  Esimpl2;apply (ARadd_comm ARth).
-  assert (H := ZPminus_spec p p0);destruct (ZPminus p p0).
-  rewrite H;Esimpl. rewrite IHP';rrefl.
-  rewrite H;Esimpl. rewrite IHP';Esimpl.
-  rewrite <- jump_Pplus;rewrite Pplus_comm;rrefl.
-  rewrite H;Esimpl. rewrite IHP.
-  rewrite <- jump_Pplus;rewrite Pplus_comm;rrefl.
-  destruct p0;simpl.
-  rewrite IHP2;simpl;rsimpl.
-  rewrite IHP2;simpl.
-  rewrite jump_Pdouble_minus_one;rsimpl.
-  rewrite IHP';rsimpl.
-  destruct P;simpl.
-  Esimpl2;add_push [c];rrefl.
-  destruct p0;simpl;Esimpl2.
-  rewrite IHP'2;simpl.
-  rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));rrefl.
-  rewrite IHP'2;simpl.
-  rewrite jump_Pdouble_minus_one;rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));rrefl.
-  rewrite IHP'2;rsimpl. add_push (P @ (tail l));rrefl.
-  assert (H := ZPminus_spec p0 p);destruct (ZPminus p0 p);Esimpl2.
-  rewrite IHP'1;rewrite IHP'2;rsimpl.
-  add_push (P3 @ (tail l));rewrite H;rrefl.
-  rewrite IHP'1;rewrite IHP'2;simpl;Esimpl.
-  rewrite H;rewrite Pplus_comm.
-  rewrite pow_pos_Pplus;rsimpl.
-  add_push (P3 @ (tail l));rrefl.
-  assert (forall P k l,
-           (PaddX Padd P'1 k P) @ l == P@l + P'1@l * pow_pos rmul (hd 0 l) k).
-   induction P;simpl;intros;try apply (ARadd_comm ARth).
-   destruct p2;simpl;try apply (ARadd_comm ARth).
-   rewrite jump_Pdouble_minus_one;apply (ARadd_comm ARth).
-    assert (H1 := ZPminus_spec p2 k);destruct (ZPminus p2 k);Esimpl2.
-    rewrite IHP'1;rsimpl; rewrite H1;add_push (P5 @ (tail l0));rrefl.
-    rewrite IHP'1;simpl;Esimpl.
-    rewrite H1;rewrite Pplus_comm.
-    rewrite pow_pos_Pplus;simpl;Esimpl.
-    add_push (P5 @ (tail l0));rrefl.
-    rewrite IHP1;rewrite H1;rewrite Pplus_comm.
-    rewrite pow_pos_Pplus;simpl;rsimpl.
-    add_push (P5 @ (tail l0));rrefl.
-  rewrite H0;rsimpl.
-  add_push (P3 @ (tail l)).
-  rewrite H;rewrite Pplus_comm.
-  rewrite IHP'2;rewrite pow_pos_Pplus;rsimpl.
-  add_push (P3 @ (tail l));rrefl.
+  revert l;induction P;simpl;intros.
+  - Esimpl.
+  - apply IHP.
+  - rewrite IHP1, IHP2;rsimpl.
  Qed.
 
- Lemma Psub_ok : forall P' P l, (P -- P')@l == P@l - P'@l.
+ Hint Rewrite PaddC_ok PsubC_ok PmulC_ok Popp_ok : Esimpl.
+
+ Lemma PaddX_ok P' P k l :
+  (forall P l, (P++P')@l == P@l + P'@l) ->
+  (PaddX Padd P' k P) @ l == P@l + P'@l * (hd l)^k.
  Proof.
-  induction P';simpl;intros;Esimpl2;trivial.
-  generalize P p l;clear P p l.
-  induction P;simpl;intros.
-  Esimpl2;apply (ARadd_comm ARth).
-  assert (H := ZPminus_spec p p0);destruct (ZPminus p p0).
-  rewrite H;Esimpl. rewrite IHP';rsimpl.
-  rewrite H;Esimpl. rewrite IHP';Esimpl.
-  rewrite <- jump_Pplus;rewrite Pplus_comm;rrefl.
-  rewrite H;Esimpl. rewrite IHP.
-  rewrite <- jump_Pplus;rewrite Pplus_comm;rrefl.
-  destruct p0;simpl.
-  rewrite IHP2;simpl;rsimpl.
-  rewrite IHP2;simpl.
-  rewrite jump_Pdouble_minus_one;rsimpl.
-  rewrite IHP';rsimpl.
-  destruct P;simpl.
-  repeat rewrite Popp_ok;Esimpl2;rsimpl;add_push [c];try rrefl.
-  destruct p0;simpl;Esimpl2.
-  rewrite IHP'2;simpl;rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));trivial.
-  add_push (P @ (jump p0 (jump p0 (tail l))));rrefl.
-  rewrite IHP'2;simpl;rewrite jump_Pdouble_minus_one;rsimpl.
-  add_push (- (P'1 @ l * pow_pos  rmul (hd 0 l) p));rrefl.
-  rewrite IHP'2;rsimpl;add_push (P @ (tail l));rrefl.
-  assert (H := ZPminus_spec p0 p);destruct (ZPminus p0 p);Esimpl2.
-  rewrite IHP'1; rewrite IHP'2;rsimpl.
-  add_push (P3 @ (tail l));rewrite H;rrefl.
-   rewrite IHP'1; rewrite IHP'2;rsimpl;simpl;Esimpl.
-  rewrite H;rewrite Pplus_comm.
-  rewrite pow_pos_Pplus;rsimpl.
-  add_push (P3 @ (tail l));rrefl.
-  assert (forall P k l,
-           (PsubX Psub P'1 k P) @ l == P@l + - P'1@l * pow_pos rmul (hd 0 l) k).
-   induction P;simpl;intros.
-   rewrite Popp_ok;rsimpl;apply (ARadd_comm ARth);trivial.
-   destruct p2;simpl;rewrite Popp_ok;rsimpl.
-   apply (ARadd_comm ARth);trivial.
-   rewrite jump_Pdouble_minus_one;apply (ARadd_comm ARth);trivial.
-   apply (ARadd_comm ARth);trivial.
-    assert (H1 := ZPminus_spec p2 k);destruct (ZPminus p2 k);Esimpl2;rsimpl.
-    rewrite IHP'1;rsimpl;add_push (P5 @ (tail l0));rewrite H1;rrefl.
-    rewrite IHP'1;rewrite H1;rewrite Pplus_comm.
-    rewrite pow_pos_Pplus;simpl;Esimpl.
-    add_push (P5 @ (tail l0));rrefl.
-    rewrite IHP1;rewrite H1;rewrite Pplus_comm.
-    rewrite pow_pos_Pplus;simpl;rsimpl.
-    add_push (P5 @ (tail l0));rrefl.
-  rewrite H0;rsimpl.
-  rewrite IHP'2;rsimpl;add_push (P3 @ (tail l)).
-  rewrite H;rewrite Pplus_comm.
-  rewrite pow_pos_Pplus;rsimpl.
+  intros IHP'.
+  revert k l. induction P;simpl;intros.
+  - add_permut.
+  - destruct p; simpl;
+    rewrite ?jump_pred_double; add_permut.
+  - destr_pos_sub; intros ->;Esimpl.
+    + rewrite IHP';rsimpl. add_permut.
+    + rewrite IHP', pow_pos_add;simpl;Esimpl. add_permut.
+    + rewrite IHP1, pow_pos_add;rsimpl. add_permut.
  Qed.
-(* Proof for the symmetriv version *)
 
- Lemma PmulI_ok :
-  forall P',
-   (forall (P : Pol) (l : list R), (Pmul P P') @ l == P @ l * P' @ l) ->
-   forall (P : Pol) (p : positive) (l : list R),
-    (PmulI Pmul P' p P) @ l == P @ l * P' @ (jump p l).
+ Lemma Padd_ok P' P l : (P ++ P')@l == P@l + P'@l.
  Proof.
-  induction P;simpl;intros.
-  Esimpl2;apply (ARmul_comm ARth).
-  assert (H1 := ZPminus_spec p p0);destruct (ZPminus p p0);Esimpl2.
-  rewrite H1; rewrite H;rrefl.
-  rewrite H1; rewrite H.
-  rewrite Pplus_comm.
-  rewrite jump_Pplus;simpl;rrefl.
-  rewrite H1;rewrite Pplus_comm.
-  rewrite jump_Pplus;rewrite IHP;rrefl.
-  destruct p0;Esimpl2.
-  rewrite IHP1;rewrite IHP2;simpl;rsimpl.
-  mul_push (pow_pos rmul (hd 0 l) p);rrefl.
-  rewrite IHP1;rewrite IHP2;simpl;rsimpl.
-  mul_push (pow_pos rmul (hd 0 l) p); rewrite jump_Pdouble_minus_one;rrefl.
-  rewrite IHP1;simpl;rsimpl.
-  mul_push (pow_pos rmul (hd 0 l) p).
-  rewrite H;rrefl.
+  revert P l; induction P';simpl;intros;Esimpl.
+  - revert p l; induction P;simpl;intros.
+    + Esimpl; add_permut.
+    + destr_pos_sub; intros ->;Esimpl.
+      * now rewrite IHP'.
+      * rewrite IHP';Esimpl. now rewrite jump_add'.
+      * rewrite IHP. now rewrite jump_add'.
+    + destruct p0;simpl.
+      * rewrite IHP2;simpl. rsimpl.
+      * rewrite IHP2;simpl. rewrite jump_pred_double. rsimpl.
+      * rewrite IHP'. rsimpl.
+  - destruct P;simpl.
+    + Esimpl. add_permut.
+    + destruct p0;simpl;Esimpl; rewrite IHP'2; simpl.
+      * rsimpl. add_permut.
+      * rewrite jump_pred_double. rsimpl. add_permut.
+      * rsimpl. add_permut.
+    + destr_pos_sub; intros ->; Esimpl.
+      * rewrite IHP'1, IHP'2;rsimpl. add_permut.
+      * rewrite IHP'1, IHP'2;simpl;Esimpl.
+        rewrite pow_pos_add;rsimpl. add_permut.
+      * rewrite PaddX_ok by trivial; rsimpl.
+        rewrite IHP'2, pow_pos_add; rsimpl. add_permut.
  Qed.
 
-(*
- Lemma PmulI_ok :
-  forall P',
-   (forall (P : Pol) (l : list R), (Pmul_aux P P') @ l == P @ l * P' @ l) ->
-   forall (P : Pol) (p : positive) (l : list R),
-    (PmulI Pmul_aux P' p P) @ l == P @ l * P' @ (jump p l).
+ Lemma PsubX_ok P' P k l :
+  (forall P l, (P--P')@l == P@l - P'@l) ->
+  (PsubX Psub P' k P) @ l == P@l - P'@l * (hd l)^k.
  Proof.
-  induction P;simpl;intros.
-  Esimpl2;apply (ARmul_comm ARth).
-  assert (H1 := ZPminus_spec p p0);destruct (ZPminus p p0);Esimpl2.
-  rewrite H1; rewrite H;rrefl.
-  rewrite H1; rewrite H.
-  rewrite Pplus_comm.
-  rewrite jump_Pplus;simpl;rrefl.
-  rewrite H1;rewrite Pplus_comm.
-  rewrite jump_Pplus;rewrite IHP;rrefl.
-  destruct p0;Esimpl2.
-  rewrite IHP1;rewrite IHP2;simpl;rsimpl.
-  mul_push (pow_pos rmul (hd 0 l) p);rrefl.
-  rewrite IHP1;rewrite IHP2;simpl;rsimpl.
-  mul_push (pow_pos rmul (hd 0 l) p); rewrite jump_Pdouble_minus_one;rrefl.
-  rewrite IHP1;simpl;rsimpl.
-  mul_push (pow_pos rmul (hd 0 l) p).
-  rewrite H;rrefl.
+  intros IHP'.
+  revert k l. induction P;simpl;intros.
+  - rewrite Popp_ok;rsimpl; add_permut.
+  - destruct p; simpl;
+    rewrite Popp_ok;rsimpl;
+    rewrite ?jump_pred_double; add_permut.
+  - destr_pos_sub; intros ->; Esimpl.
+    + rewrite IHP';rsimpl. add_permut.
+    + rewrite IHP', pow_pos_add;simpl;Esimpl. add_permut.
+    + rewrite IHP1, pow_pos_add;rsimpl. add_permut.
  Qed.
 
- Lemma Pmul_aux_ok : forall P' P l,(Pmul_aux P P')@l == P@l * P'@l.
+ Lemma Psub_ok P' P l : (P -- P')@l == P@l - P'@l.
  Proof.
-  induction P';simpl;intros.
-  Esimpl2;trivial.
-  apply PmulI_ok;trivial.
-  rewrite Padd_ok;Esimpl2.
-  rewrite (PmulI_ok P'2 IHP'2). rewrite IHP'1. rrefl.
+  revert P l; induction P';simpl;intros;Esimpl.
+  - revert p l; induction P;simpl;intros.
+    + Esimpl; add_permut.
+    + destr_pos_sub; intros ->;Esimpl.
+      * rewrite IHP';rsimpl.
+      * rewrite IHP';Esimpl. now rewrite jump_add'.
+      * rewrite IHP. now rewrite jump_add'.
+    + destruct p0;simpl.
+      * rewrite IHP2;simpl. rsimpl.
+      * rewrite IHP2;simpl. rewrite jump_pred_double. rsimpl.
+      * rewrite IHP'. rsimpl.
+  - destruct P;simpl.
+    + Esimpl; add_permut.
+    + destruct p0;simpl;Esimpl; rewrite IHP'2; simpl.
+      * rsimpl. add_permut.
+      * rewrite jump_pred_double. rsimpl. add_permut.
+      * rsimpl. add_permut.
+    + destr_pos_sub; intros ->; Esimpl.
+      * rewrite IHP'1, IHP'2;rsimpl. add_permut.
+      * rewrite IHP'1, IHP'2;simpl;Esimpl.
+        rewrite pow_pos_add;rsimpl. add_permut.
+      * rewrite PsubX_ok by trivial;rsimpl.
+        rewrite IHP'2, pow_pos_add;rsimpl. add_permut.
  Qed.
-*)
 
-(* Proof for the symmetric version *)
- Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
+ Lemma PmulI_ok P' :
+   (forall P l, (Pmul P P') @ l == P @ l * P' @ l) ->
+   forall P p l, (PmulI Pmul P' p P) @ l == P @ l * P' @ (jump p l).
  Proof.
-  intros P P';generalize P;clear P;induction P';simpl;intros.
-  apply PmulC_ok. apply PmulI_ok;trivial.
-  destruct P.
-  rewrite (ARmul_comm ARth);Esimpl2;Esimpl2.
-  Esimpl2. rewrite IHP'1;Esimpl2.
-   assert (match p0 with
-           | xI j => Pinj (xO j) P ** P'2
-           | xO j => Pinj (Pdouble_minus_one j) P ** P'2
-           | 1 => P ** P'2
-           end @ (tail l) == P @ (jump p0 l) * P'2 @ (tail l)).
-   destruct p0;simpl;rewrite IHP'2;Esimpl.
-   rewrite jump_Pdouble_minus_one;Esimpl.
-   rewrite H;Esimpl.
-   rewrite Padd_ok; Esimpl2. rewrite Padd_ok; Esimpl2.
-   repeat (rewrite IHP'1 || rewrite IHP'2);simpl.
-   rewrite PmulI_ok;trivial.
-   mul_push (P'1@l). simpl. mul_push (P'2 @ (tail l)). Esimpl.
+  intros IHP'.
+  induction P;simpl;intros.
+  - Esimpl; mul_permut.
+  - destr_pos_sub; intros ->;Esimpl.
+    + now rewrite IHP'.
+    + now rewrite IHP', jump_add'.
+    + now rewrite IHP, jump_add'.
+  - destruct p0;Esimpl; rewrite ?IHP1, ?IHP2; rsimpl.
+    + f_equiv. mul_permut.
+    + rewrite jump_pred_double. f_equiv. mul_permut.
+    + rewrite IHP'. f_equiv. mul_permut.
  Qed.
 
-(*
-Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
+ Lemma Pmul_ok P P' l : (P**P')@l == P@l * P'@l.
  Proof.
-  destruct P;simpl;intros.
-  Esimpl2;apply (ARmul_comm ARth).
-  rewrite (PmulI_ok P (Pmul_aux_ok P)).
-  apply (ARmul_comm ARth).
-  rewrite Padd_ok; Esimpl2.
-  rewrite (PmulI_ok P3 (Pmul_aux_ok P3));trivial.
-  rewrite Pmul_aux_ok;mul_push (P' @ l).
-  rewrite (ARmul_comm ARth (P' @ l));rrefl.
+  revert P l;induction P';simpl;intros.
+  - apply PmulC_ok.
+  - apply PmulI_ok;trivial.
+  - destruct P.
+    + rewrite (ARmul_comm ARth). Esimpl.
+    + Esimpl. f_equiv. rewrite IHP'1; Esimpl.
+      destruct p0;rewrite IHP'2;Esimpl.
+      rewrite jump_pred_double; Esimpl.
+    + rewrite Padd_ok, !mkPX_ok, Padd_ok, !mkPX_ok,
+       !IHP'1, !IHP'2, PmulI_ok; trivial. simpl. Esimpl.
+      add_permut; f_equiv; mul_permut.
  Qed.
-*)
 
- Lemma Psquare_ok : forall P l, (Psquare P)@l == P@l * P@l.
+ Lemma Psquare_ok P l : (Psquare P)@l == P@l * P@l.
  Proof.
-  induction P;simpl;intros;Esimpl2.
-  apply IHP. rewrite Padd_ok. rewrite Pmul_ok;Esimpl2.
-  rewrite IHP1;rewrite IHP2.
-  mul_push (pow_pos rmul (hd 0 l) p). mul_push (P2@l).
-  rrefl.
+  revert l;induction P;simpl;intros;Esimpl.
+  - apply IHP.
+  - rewrite Padd_ok, Pmul_ok;Esimpl.
+    rewrite IHP1, IHP2.
+    mul_push ((hd l)^p). now mul_push (P2@l).
  Qed.
 
-
- Lemma mkZmon_ok: forall M j l,
-   Mphi l (mkZmon j M) == Mphi l (zmon j M).
- intros M j l; case M; simpl; intros; rsimpl.
+ Lemma mkZmon_ok M j l :
+   (mkZmon j M) @@ l == (zmon j M) @@ l.
+ Proof.
+ destruct M; simpl; rsimpl.
  Qed.
 
- Lemma zmon_pred_ok : forall M j l,
-    Mphi (tail l) (zmon_pred j M) == Mphi l (zmon j M).
+ Lemma zmon_pred_ok M j l :
+   (zmon_pred j M) @@ (tail l) == (zmon j M) @@ l.
  Proof.
-   destruct j; simpl;intros auto; rsimpl.
-   rewrite mkZmon_ok;rsimpl.
-   rewrite mkZmon_ok;simpl. rewrite jump_Pdouble_minus_one; rsimpl.
+   destruct j; simpl; rewrite ?mkZmon_ok; simpl; rsimpl.
+   rewrite jump_pred_double; rsimpl.
  Qed.
 
- Lemma mkVmon_ok : forall M i l, Mphi l (mkVmon i M) == Mphi l M*pow_pos rmul (hd 0 l) i.
+ Lemma mkVmon_ok M i l :
+   (mkVmon i M)@@l == M@@l * (hd l)^i.
  Proof.
   destruct M;simpl;intros;rsimpl.
-   rewrite zmon_pred_ok;simpl;rsimpl.
-  rewrite Pplus_comm;rewrite pow_pos_Pplus;rsimpl.
+  - rewrite zmon_pred_ok;simpl;rsimpl.
+  - rewrite pow_pos_add;rsimpl.
  Qed.
 
- Lemma Mcphi_ok: forall P c l,
-    let (Q,R) := CFactor P c in
-      P@l == Q@l + (phi c) * (R@l).
+ Ltac destr_factor := match goal with
+  | H : context [CFactor ?P _] |- context [CFactor ?P ?c] =>
+    destruct (CFactor P c); destr_factor; rewrite H; clear H
+  | H : context [MFactor ?P _ _] |- context [MFactor ?P ?c ?M] =>
+    specialize (H M); destruct (MFactor P c M); destr_factor; rewrite H; clear H
+  | _ => idtac
+ end.
+
+ Lemma Mcphi_ok P c l :
+   let (Q,R) := CFactor P c in
+     P@l == Q@l + [c] * R@l.
  Proof.
- intros P; elim P; simpl; auto; clear P.
-   intros c c1 l; generalize (div_th.(div_eucl_th) c c1); case cdiv.
-   intros q r H; rewrite H.
-   Esimpl.
-   rewrite (ARadd_comm ARth); rsimpl.
- intros i P Hrec c l.
-  generalize (Hrec c (jump i l)); case CFactor.
-  intros R1 S1; Esimpl; auto.
- intros Q1 Qrec i R1 Rrec c l.
-   generalize (Qrec c l); case CFactor; intros S1 S2 HS.
-   generalize (Rrec c (tail l)); case CFactor; intros S3 S4 HS1.
-   rewrite HS; rewrite HS1; Esimpl.
-   apply (Radd_ext Reqe); rsimpl.
-   repeat rewrite <- (ARadd_assoc ARth).
-   apply (Radd_ext Reqe); rsimpl.
-   rewrite (ARadd_comm ARth); rsimpl.
+ revert l.
+ induction P as [c0 | j P IH | P1 IH1 i P2 IH2]; intros l; Esimpl.
+ - assert (H := div_th.(div_eucl_th) c0 c).
+   destruct cdiv as (q,r). rewrite H; Esimpl. add_permut.
+ - destr_factor. Esimpl.
+ - destr_factor. Esimpl. add_permut.
  Qed.
 
- Lemma Mphi_ok: forall P (cM: C * Mon) l,
-    let (c,M) := cM in
-    let (Q,R) := MFactor P c M in
-      P@l == Q@l + (phi c) * (Mphi l M) * (R@l).
+ Lemma Mphi_ok P (cM: C * Mon) l :
+   let (c,M) := cM in
+   let (Q,R) := MFactor P c M in
+     P@l == Q@l + [c] * M@@l * R@l.
  Proof.
- intros P; elim P; simpl; auto; clear P.
-   intros c (c1, M) l; case M; simpl; auto.
-   assert (H1:= morph_eq CRmorph c1 cI);destruct (c1 ?=! cI).
-   rewrite (H1 (refl_equal true));Esimpl.
-    try rewrite (morph0 CRmorph); rsimpl.
-   generalize (div_th.(div_eucl_th) c c1); case (cdiv c c1).
-   intros q r H; rewrite H; clear H H1.
-   Esimpl.
-   rewrite (ARadd_comm ARth); rsimpl.
-   intros p m; Esimpl.
-   intros p m; Esimpl.
-   intros i P Hrec (c,M) l; case M; simpl; clear M.
-     assert (H1:= morph_eq CRmorph c cI);destruct (c ?=! cI).
-     rewrite (H1 (refl_equal true));Esimpl.
-     Esimpl.
-   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).
-       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));
-       case (MFactor P c (zmon (j -i) M)); simpl.
-       intros P2 Q2 H; repeat rewrite mkPinj_ok; auto.
-       rewrite  <- (Pplus_minus _ _ (ZC2 _ _ He)).
-       rewrite Pplus_comm; rewrite jump_Pplus; auto.
-       rewrite (morph0 CRmorph); rsimpl.
-       intros P2 m; rewrite (morph0 CRmorph); rsimpl.
-
-   intros P2 Hrec1 i Q2 Hrec2 (c, M) l; case M; simpl; auto.
-     assert (H1:= morph_eq CRmorph c cI);destruct (c ?=! cI).
-     rewrite (H1 (refl_equal true));Esimpl.
-     Esimpl.
-    generalize (Mcphi_ok P2 c l); case CFactor.
-    intros S1 S2 HS.
-    generalize (Mcphi_ok Q2 c (tail l)); case CFactor.
-    intros S3 S4 HS1; Esimpl; rewrite HS; rewrite HS1.
-    rsimpl.
-    apply (Radd_ext Reqe); rsimpl.
-    repeat rewrite <- (ARadd_assoc ARth).
-    apply (Radd_ext Reqe); rsimpl.
-    rewrite (ARadd_comm ARth); rsimpl.
-   intros j M1.
-     generalize (Hrec1 (c,zmon j M1) l);
-     case (MFactor P2 c (zmon j M1)).
-     intros R1 S1 H1.
-     generalize (Hrec2 (c, zmon_pred j M1) (List.tail l));
-     case (MFactor Q2 c (zmon_pred j M1)); simpl.
-     intros R2 S2 H2; rewrite H1; rewrite H2.
-     repeat rewrite mkPX_ok; simpl.
-     rsimpl.
-     apply radd_ext; rsimpl.
-     rewrite (ARadd_comm ARth); rsimpl.
-     apply radd_ext; rsimpl.
-     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).
-       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.
-       repeat (rewrite <-(ARadd_assoc ARth)).
-       apply radd_ext; rsimpl.
-       rewrite (ARadd_comm ARth); rsimpl.
-       apply radd_ext; rsimpl.
-       repeat (rewrite <-(ARmul_assoc ARth)).
-       rewrite mkZmon_ok.
-       apply rmul_ext; rsimpl.
-       repeat (rewrite <-(ARmul_assoc ARth)).
-       apply rmul_ext; rsimpl.
-       rewrite (ARmul_comm ARth); rsimpl.
-       generalize (Hrec1 (c, vmon (j - i) M1) l);
-             case (MFactor P2 c (vmon (j - i) M1));
-        simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto.
-       rewrite H; rsimpl; repeat rewrite mkPinj_ok; auto.
-       rewrite mkPX_ok; rsimpl.
-       repeat (rewrite <-(ARadd_assoc ARth)).
-       apply radd_ext; rsimpl.
-       rewrite (ARadd_comm ARth); rsimpl.
-       apply radd_ext; rsimpl.
-       repeat (rewrite <-(ARmul_assoc ARth)).
-       apply rmul_ext; rsimpl.
-       rewrite (ARmul_comm ARth); rsimpl.
-       apply rmul_ext; rsimpl.
-       rewrite <- (ARmul_comm ARth (Mphi (tail l) M1)); rsimpl.
-       repeat (rewrite <-(ARmul_assoc ARth)).
-       apply rmul_ext; rsimpl.
-       rewrite <- pow_pos_Pplus.
-       rewrite (Pplus_minus _ _ (ZC2 _ _ He)); rsimpl.
-       generalize (Hrec1 (c, mkZmon 1 M1) l);
-             case (MFactor P2 c (mkZmon 1 M1));
-        simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto.
-       rewrite H; rsimpl.
-       rewrite mkPX_ok; rsimpl.
-       repeat (rewrite <-(ARadd_assoc ARth)).
-       apply radd_ext; rsimpl.
-       rewrite (ARadd_comm ARth); rsimpl.
-       apply radd_ext; rsimpl.
-       rewrite mkZmon_ok.
-       repeat (rewrite <-(ARmul_assoc ARth)).
-       apply rmul_ext; rsimpl.
-       rewrite (ARmul_comm ARth); rsimpl.
-       rewrite mkPX_ok; simpl; rsimpl.
-       rewrite (morph0 CRmorph); rsimpl.
-       repeat (rewrite <-(ARmul_assoc ARth)).
-       rewrite (ARmul_comm ARth (Q3@l)); rsimpl.
-       apply rmul_ext; rsimpl.
-       rewrite (ARmul_comm ARth); rsimpl.
-       repeat (rewrite <- (ARmul_assoc ARth)).
-       apply rmul_ext; rsimpl.
-       rewrite <- pow_pos_Pplus.
-       rewrite (Pplus_minus _ _ He); rsimpl.
+ destruct cM as (c,M). revert M l.
+ induction P; destruct M; intros l; simpl; auto;
+ try (case ceqb_spec; intro He);
+  try (case Pos.compare_spec; intros He); rewrite ?He;
+   destr_factor; simpl; Esimpl.
+ - assert (H := div_th.(div_eucl_th) c0 c).
+   destruct cdiv as (q,r). rewrite H; Esimpl. add_permut.
+ - assert (H := Mcphi_ok P c). destr_factor. Esimpl.
+ - now rewrite <- jump_add, Pos.sub_add.
+ - assert (H2 := Mcphi_ok P2 c). assert (H3 := Mcphi_ok P3 c).
+   destr_factor. Esimpl. add_permut.
+ - rewrite zmon_pred_ok. simpl. add_permut.
+ - rewrite mkZmon_ok. simpl. add_permut. mul_permut.
+ - add_permut. mul_permut.
+   rewrite <- pow_pos_add, Pos.add_comm, Pos.sub_add by trivial; rsimpl.
+ - rewrite mkZmon_ok. simpl. Esimpl. add_permut. mul_permut.
+   rewrite <- pow_pos_add, Pos.sub_add by trivial; rsimpl.
  Qed.
 
-(* Proof for the symmetric version *)
-
- Lemma POneSubst_ok: forall P1 M1 P2 P3 l,
-    POneSubst P1 M1 P2 = Some P3 -> phi (fst M1) * Mphi l (snd M1) == P2@l -> P1@l == P3@l.
+ Lemma POneSubst_ok P1 cM1 P2 P3 l :
+   POneSubst P1 cM1 P2 = Some P3 ->
+   [fst cM1] * (snd cM1)@@l == P2@l -> P1@l == P3@l.
  Proof.
- intros P2 (cc,M1) P3 P4 l; unfold POneSubst.
- generalize (Mphi_ok P2 (cc, M1) l); case (MFactor P2 cc M1); simpl; auto.
- intros Q1 R1; case R1.
-   intros c H; rewrite H.
-   generalize (morph_eq CRmorph c cO);
-        case (c ?=! cO); simpl; auto.
-   intros H1 H2; rewrite H1; auto; rsimpl.
-   discriminate.
-   intros _ H1 H2; injection H1; intros; subst.
-   rewrite H2; rsimpl.
- (* new version *)
-   rewrite Padd_ok; rewrite PmulC_ok; rsimpl.
- intros i P5 H; rewrite H.
-   intros HH H1; injection HH; intros; subst; rsimpl.
-   rewrite Padd_ok; rewrite PmulI_ok by (intros;apply Pmul_ok). rewrite H1; rsimpl.
- intros i P5 P6 H1 H2 H3; rewrite H1; rewrite H3.
-   assert (P4 = Q1 ++ P3 ** PX i P5 P6).
-   injection H2; intros; subst;trivial.
-  rewrite H;rewrite Padd_ok;rewrite Pmul_ok;rsimpl.
- Qed.
-(*
-  Lemma POneSubst_ok: forall P1 M1 P2 P3 l,
-    POneSubst P1 M1 P2 = Some P3 -> Mphi l M1 == P2@l -> P1@l == P3@l.
-Proof.
- intros P2 M1 P3 P4 l; unfold POneSubst.
- generalize (Mphi_ok P2 M1 l); case (MFactor P2 M1); simpl; auto.
- intros Q1 R1; case R1.
-   intros c H; rewrite H.
-   generalize (morph_eq CRmorph c cO);
-        case (c ?=! cO); simpl; auto.
-   intros H1 H2; rewrite H1; auto; rsimpl.
-   discriminate.
-   intros _ H1 H2; injection H1; intros; subst.
-   rewrite H2; rsimpl.
-  rewrite Padd_ok; rewrite Pmul_ok; rsimpl.
-  intros i P5 H; rewrite H.
-   intros HH H1; injection HH; intros; subst; rsimpl.
-   rewrite Padd_ok; rewrite Pmul_ok. rewrite H1; rsimpl.
-   intros i P5 P6 H1 H2 H3; rewrite H1; rewrite H3.
-   injection H2; intros; subst; rsimpl.
-   rewrite Padd_ok.
-   rewrite Pmul_ok; rsimpl.
+ destruct cM1 as (cc,M1).
+ unfold POneSubst.
+ assert (H := Mphi_ok P1 (cc, M1) l). simpl in H.
+ destruct MFactor as (R1,S1); simpl. rewrite H. clear H.
+ intros EQ EQ'. replace P3 with (R1 ++ P2 ** S1).
+ - rewrite EQ', Padd_ok, Pmul_ok; rsimpl.
+ - revert EQ. destruct S1; try now injection 1.
+   case ceqb_spec; now inversion 2.
  Qed.
-*)
- Lemma PNSubst1_ok: forall n P1 M1 P2 l,
-    [fst M1] * Mphi l (snd M1) == P2@l -> P1@l == (PNSubst1 P1 M1 P2 n)@l.
+
+ Lemma PNSubst1_ok n P1 cM1 P2 l :
+   [fst cM1] * (snd cM1)@@l == P2@l ->
+   P1@l == (PNSubst1 P1 cM1 P2 n)@l.
  Proof.
- intros n; elim n; simpl; auto.
-   intros P2 M1 P3 l H.
-   generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l);
-   case (POneSubst P2 M1 P3); [idtac | intros; rsimpl].
-   intros P4 Hrec; rewrite (Hrec P4); auto; rsimpl.
- intros n1 Hrec P2 M1 P3 l H.
-   generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l);
-   case (POneSubst P2 M1 P3); [idtac | intros; rsimpl].
-   intros P4 Hrec1; rewrite (Hrec1 P4); auto; rsimpl.
+ revert P1. induction n; simpl; intros P1;
+ generalize (POneSubst_ok P1 cM1 P2); destruct POneSubst;
+   intros; rewrite <- ?IHn; auto; reflexivity.
  Qed.
 
- Lemma PNSubst_ok: forall n P1 M1 P2 l P3,
-    PNSubst P1 M1 P2 n = Some P3 -> [fst M1] * Mphi l (snd M1) == P2@l -> P1@l == P3@l.
+ Lemma PNSubst_ok n P1 cM1 P2 l P3 :
+   PNSubst P1 cM1 P2 n = Some P3 ->
+   [fst cM1] * (snd cM1)@@l == P2@l -> P1@l == P3@l.
  Proof.
- intros n P2 (cc, M1) P3 l P4; unfold PNSubst.
- generalize (fun P4 => @POneSubst_ok P2 (cc,M1) P3 P4 l);
- case (POneSubst P2 (cc,M1) P3); [idtac | intros; discriminate].
- intros P5 H1; case n; try (intros; discriminate).
- intros n1 H2; injection H2; intros; subst.
- rewrite <- PNSubst1_ok; auto.
+ unfold PNSubst.
+ assert (H := POneSubst_ok P1 cM1 P2); destruct POneSubst; try discriminate.
+ destruct n; inversion_clear 1.
+ intros. rewrite <- PNSubst1_ok; auto.
  Qed.
 
- Fixpoint MPcond (LM1: list (C * Mon * Pol)) (l: list R) {struct LM1} : Prop :=
-    match LM1 with
-     cons (M1,P2) LM2 =>  ([fst M1] * Mphi l (snd M1) == P2@l) /\ (MPcond LM2 l)
-    | _ => True
-    end.
+ Fixpoint MPcond (LM1: list (C * Mon * Pol)) (l: list R) : Prop :=
+   match LM1 with
+   | (M1,P2) :: LM2 => ([fst M1] * (snd M1)@@l == P2@l) /\ MPcond LM2 l
+   | _ => True
+   end.
 
- Lemma PSubstL1_ok: forall n LM1 P1 l,
-    MPcond LM1 l ->  P1@l == (PSubstL1 P1 LM1 n)@l.
+ Lemma PSubstL1_ok n LM1 P1 l :
+   MPcond LM1 l -> P1@l == (PSubstL1 P1 LM1 n)@l.
  Proof.
- intros n LM1; elim LM1; simpl; auto.
-   intros; rsimpl.
- intros (M2,P2) LM2 Hrec P3 l [H H1].
- rewrite <- Hrec; auto.
- apply PNSubst1_ok; auto.
+ revert P1; induction LM1 as [|(M2,P2) LM2 IH]; simpl; intros.
+ - reflexivity.
+ - rewrite <- IH by intuition. now apply PNSubst1_ok.
  Qed.
 
- Lemma PSubstL_ok: forall n LM1 P1 P2 l,
-   PSubstL P1 LM1 n = Some P2 -> MPcond LM1 l ->  P1@l == P2@l.
+ Lemma PSubstL_ok n LM1 P1 P2 l :
+   PSubstL P1 LM1 n = Some P2 -> MPcond LM1 l -> P1@l == P2@l.
  Proof.
- intros n LM1; elim LM1; simpl; auto.
-   intros; discriminate.
- intros (M2,P2) LM2 Hrec P3 P4 l.
- generalize (PNSubst_ok n P3 M2 P2); case (PNSubst P3 M2 P2 n).
-   intros P5 H0 H1 [H2 H3]; injection H1; intros; subst.
-   rewrite <- PSubstL1_ok; auto.
- intros l1 H [H1 H2]; auto.
+ revert P1. induction LM1 as [|(M2,P2') LM2 IH]; simpl; intros.
+ - discriminate.
+ - assert (H':=PNSubst_ok n P3 M2 P2'). destruct PNSubst.
+   * injection H; intros <-. rewrite <- PSubstL1_ok; intuition.
+   * now apply IH.
  Qed.
 
- Lemma PNSubstL_ok: forall m n LM1 P1 l,
-    MPcond LM1 l ->  P1@l == (PNSubstL P1 LM1 m n)@l.
+ Lemma PNSubstL_ok m n LM1 P1 l :
+    MPcond LM1 l -> P1@l == (PNSubstL P1 LM1 m n)@l.
  Proof.
- intros m; elim m; simpl; auto.
-   intros n LM1 P2 l H; generalize (fun P3 => @PSubstL_ok n LM1 P2 P3 l);
-     case (PSubstL P2 LM1 n); intros; rsimpl; auto.
- intros m1 Hrec n LM1 P2 l H.
- generalize (fun P3 => @PSubstL_ok n LM1 P2 P3 l);
-     case (PSubstL P2 LM1 n); intros; rsimpl; auto.
- rewrite <- Hrec; auto.
+ revert LM1 P1. induction m; simpl; intros;
+ assert (H' := PSubstL_ok n LM1 P2); destruct PSubstL;
+ auto; try reflexivity.
+ rewrite <- IHm; auto.
  Qed.
 
  (** Definition of polynomial expressions *)
@@ -1190,58 +935,22 @@ Strategy expand [PEeval].
 
  (** Correctness proofs *)
 
- Lemma mkX_ok : forall p l, nth 0 p l == (mk_X p) @ l.
+ Lemma mkX_ok p l : nth 0 p l == (mk_X p) @ l.
  Proof.
   destruct p;simpl;intros;Esimpl;trivial.
-  rewrite <-jump_tl;rewrite nth_jump;rrefl.
-  rewrite <- nth_jump.
-  rewrite nth_Pdouble_minus_one;rrefl.
+  - now rewrite <-jump_tl, nth_jump.
+  - now rewrite <- nth_jump, nth_pred_double.
  Qed.
 
- Ltac Esimpl3 :=
-  repeat match goal with
-  | |- context [(?P1 ++ ?P2)@?l] => rewrite (Padd_ok P2 P1 l)
-  | |- context [(?P1 -- ?P2)@?l] => rewrite (Psub_ok P2 P1 l)
-  end;Esimpl2;try rrefl;try apply (ARadd_comm ARth).
-
-(* Power using the chinise algorithm *)
-(*Section POWER.
-  Variable subst_l : Pol -> Pol.
-  Fixpoint Ppow_pos (P:Pol) (p:positive){struct p} : Pol :=
-   match p with
-   | xH => P
-   | xO p => subst_l (Psquare (Ppow_pos P p))
-   | xI p => subst_l (Pmul P (Psquare (Ppow_pos P p)))
-   end.
-
-  Definition Ppow_N P n :=
-   match n with
-   | N0 => P1
-   | Npos p => Ppow_pos P p
-   end.
-
-  Lemma Ppow_pos_ok : forall l, (forall P, subst_l P@l == P@l) ->
-         forall P p, (Ppow_pos P p)@l == (pow_pos Pmul P p)@l.
-  Proof.
-   intros l subst_l_ok P.
-   induction p;simpl;intros;try rrefl;try rewrite subst_l_ok.
-   repeat rewrite Pmul_ok;rewrite Psquare_ok;rewrite IHp;rrefl.
-   repeat rewrite Pmul_ok;rewrite Psquare_ok;rewrite IHp;rrefl.
-  Qed.
-
-  Lemma Ppow_N_ok : forall l,  (forall P, subst_l P@l == P@l) ->
-         forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l.
-  Proof.  destruct n;simpl. rrefl. apply Ppow_pos_ok. trivial.  Qed.
-
- End POWER. *)
+ Hint Rewrite Padd_ok Psub_ok : Esimpl.
 
 Section POWER.
   Variable subst_l : Pol -> Pol.
-  Fixpoint Ppow_pos (res P:Pol) (p:positive){struct p} : Pol :=
+  Fixpoint Ppow_pos (res P:Pol) (p:positive) : Pol :=
    match p with
-   | xH => subst_l (Pmul res P)
+   | xH => subst_l (res ** P)
    | xO p => Ppow_pos (Ppow_pos res P p) P p
-   | xI p => subst_l (Pmul  (Ppow_pos (Ppow_pos res P p) P p) P)
+   | xI p => subst_l ((Ppow_pos (Ppow_pos res P p) P p) ** P)
    end.
 
   Definition Ppow_N P n :=
@@ -1250,17 +959,23 @@ Section POWER.
    | Npos p => Ppow_pos P1 P p
    end.
 
-  Lemma Ppow_pos_ok : forall l, (forall P, subst_l P@l == P@l) ->
-         forall res P p, (Ppow_pos res P p)@l == res@l * (pow_pos Pmul P p)@l.
+  Lemma Ppow_pos_ok l :
+    (forall P, subst_l P@l == P@l) ->
+    forall res P p, (Ppow_pos res P p)@l == res@l * (pow_pos Pmul P p)@l.
   Proof.
-   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. mul_push (P@l);rsimpl. rsimpl. rrefl.
+   intros subst_l_ok res P p. revert res.
+   induction p;simpl;intros; rewrite ?subst_l_ok, ?Pmul_ok, ?IHp;
+    mul_permut.
   Qed.
 
-  Lemma Ppow_N_ok : forall l,  (forall P, subst_l P@l == P@l) ->
-         forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l.
-  Proof.  destruct n;simpl. rrefl. rewrite Ppow_pos_ok by trivial. Esimpl.  Qed.
+  Lemma Ppow_N_ok l :
+    (forall P, subst_l P@l == P@l) ->
+    forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l.
+  Proof.
+  destruct n;simpl.
+  - reflexivity.
+  - rewrite Ppow_pos_ok by trivial. Esimpl.
+  Qed.
 
  End POWER.
 
@@ -1277,69 +992,66 @@ Section POWER.
    match pe with
    | PEc c => Pc c
    | PEX j => mk_X j
-   | PEadd (PEopp pe1) pe2 => Psub (norm_aux pe2) (norm_aux pe1)
-   | 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)
+   | PEadd (PEopp pe1) pe2 => (norm_aux pe2) -- (norm_aux pe1)
+   | PEadd pe1 (PEopp pe2) => (norm_aux pe1) -- (norm_aux pe2)
+   | PEadd pe1 pe2 => (norm_aux pe1) ++ (norm_aux pe2)
+   | PEsub pe1 pe2 => (norm_aux pe1) -- (norm_aux pe2)
+   | PEmul pe1 pe2 => (norm_aux pe1) ** (norm_aux pe2)
+   | PEopp pe1 => -- (norm_aux pe1)
    | PEpow pe1 n => Ppow_N (fun p => p) (norm_aux pe1) n
    end.
 
   Definition norm_subst pe := subst_l (norm_aux pe).
 
- (*
-  Fixpoint norm_subst (pe:PExpr) : Pol :=
+  (** Internally, [norm_aux] is expanded in a large number of cases.
+      To speed-up proofs, we use an alternative definition. *)
+
+  Definition get_PEopp pe :=
    match pe with
-   | PEc c => Pc c
-   | PEX j => subst_l (mk_X j)
-   | PEadd (PEopp pe1) pe2 => Psub (norm_subst pe2) (norm_subst pe1)
-   | PEadd pe1 (PEopp pe2) =>
-     Psub (norm_subst pe1) (norm_subst pe2)
-   | PEadd pe1 pe2 => Padd (norm_subst  pe1) (norm_subst pe2)
-   | PEsub pe1 pe2 => Psub (norm_subst pe1) (norm_subst pe2)
-   | PEmul pe1 pe2 => Pmul_subst (norm_subst pe1) (norm_subst pe2)
-   | PEopp pe1 => Popp (norm_subst pe1)
-   | PEpow pe1 n => Ppow_subst (norm_subst pe1) n
+   | PEopp pe' => Some pe'
+   | _ => None
    end.
 
-  Lemma norm_subst_spec :
-     forall l pe, MPcond lmp l ->
-       PEeval l pe == (norm_subst pe)@l.
+  Lemma norm_aux_PEadd pe1 pe2 :
+    norm_aux (PEadd pe1 pe2) =
+    match get_PEopp pe1, get_PEopp pe2 with
+    | Some pe1', _ => (norm_aux pe2) -- (norm_aux pe1')
+    | None, Some pe2' => (norm_aux pe1) -- (norm_aux pe2')
+    | None, None => (norm_aux pe1) ++ (norm_aux pe2)
+    end.
   Proof.
-   intros;assert (subst_l_ok:forall P, (subst_l P)@l == P@l).
-      unfold subst_l;intros.
-      rewrite <- PNSubstL_ok;trivial. rrefl.
-   assert (Pms_ok:forall P1 P2, (Pmul_subst P1 P2)@l == P1@l*P2@l).
-    intros;unfold Pmul_subst;rewrite subst_l_ok;rewrite Pmul_ok;rrefl.
-   induction pe;simpl;Esimpl3.
-   rewrite subst_l_ok;apply mkX_ok.
-   rewrite IHpe1;rewrite IHpe2;destruct pe1;destruct pe2;Esimpl3.
-   rewrite IHpe1;rewrite IHpe2;rrefl.
-   rewrite Pms_ok;rewrite IHpe1;rewrite IHpe2;rrefl.
-   rewrite IHpe;rrefl.
-   unfold Ppow_subst. rewrite Ppow_N_ok. trivial.
-   rewrite pow_th.(rpow_pow_N). destruct n0;Esimpl3.
-   induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok;
-      repeat rewrite Pmul_ok;rrefl.
+  simpl (norm_aux (PEadd _ _)).
+  destruct pe1; [ | | | | | reflexivity | ];
+   destruct pe2; simpl get_PEopp; reflexivity.
   Qed.
-*)
- Lemma norm_aux_spec :
-     forall l pe, MPcond lmp l ->
-       PEeval l pe == (norm_aux pe)@l.
+
+  Lemma norm_aux_PEopp pe :
+    match get_PEopp pe with
+    | Some pe' => norm_aux pe = -- (norm_aux pe')
+    | None => True
+    end.
+  Proof.
+  now destruct pe.
+  Qed.
+
+  Lemma norm_aux_spec l pe :
+    PEeval l pe == (norm_aux pe)@l.
   Proof.
    intros.
-   induction pe;simpl;Esimpl3.
-   apply mkX_ok.
-   rewrite IHpe1;rewrite IHpe2;destruct pe1;destruct pe2;Esimpl3.
-   rewrite IHpe1;rewrite IHpe2;rrefl.
-   rewrite IHpe1;rewrite IHpe2. rewrite Pmul_ok. rrefl.
-   rewrite IHpe;rrefl.
-   rewrite Ppow_N_ok by (intros;rrefl).
-   rewrite pow_th.(rpow_pow_N). destruct n0;Esimpl3.
-   induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok;
-      repeat rewrite Pmul_ok;rrefl.
+   induction pe.
+   - reflexivity.
+   - apply mkX_ok.
+   - simpl PEeval. rewrite IHpe1, IHpe2.
+     assert (H1 := norm_aux_PEopp pe1).
+     assert (H2 := norm_aux_PEopp pe2).
+     rewrite norm_aux_PEadd.
+     do 2 destruct get_PEopp; rewrite ?H1, ?H2; Esimpl; add_permut.
+   - simpl. rewrite IHpe1, IHpe2. Esimpl.
+   - simpl. rewrite IHpe1, IHpe2. now rewrite Pmul_ok.
+   - simpl. rewrite IHpe. Esimpl.
+   - simpl. rewrite Ppow_N_ok by reflexivity.
+     rewrite pow_th.(rpow_pow_N). destruct n0; simpl; Esimpl.
+     induction p;simpl; now rewrite ?IHp, ?IHpe, ?Pms_ok, ?Pmul_ok.
   Qed.
 
  Lemma norm_subst_spec :
@@ -1347,7 +1059,7 @@ Section POWER.
        PEeval l pe == (norm_subst pe)@l.
  Proof.
   intros;unfold norm_subst.
-  unfold subst_l;rewrite <- PNSubstL_ok;trivial. apply norm_aux_spec. trivial.
+  unfold subst_l;rewrite <- PNSubstL_ok;trivial. apply norm_aux_spec.
  Qed.
 
  End NORM_SUBST_REC.
@@ -1514,27 +1226,27 @@ Section POWER.
       (rP:R) (P:Pol) (fv:list R) (n:N) (lm:list (R*positive)) {struct P} : R :=
    match P with
    | Pc c =>
-     let lm := add_pow_list (hd 0 fv) n lm in
+     let lm := add_pow_list (hd fv) n lm in
      mkadd_mult rP c lm
    | Pinj j Q =>
-     add_mult_dev rP Q (jump j fv) N0 (add_pow_list (hd 0 fv) n lm)
+     add_mult_dev rP Q (jump j fv) N0 (add_pow_list (hd fv) n lm)
    | PX P i Q =>
-     let rP := add_mult_dev rP P fv (Nplus (Npos i) n) lm in
+     let rP := add_mult_dev rP P fv (N.add (Npos i) n) lm in
      if Q ?== P0 then rP
-     else add_mult_dev rP Q (tail fv) N0 (add_pow_list (hd 0 fv) n lm)
+     else add_mult_dev rP Q (tail fv) N0 (add_pow_list (hd fv) n lm)
    end.
 
   Fixpoint mult_dev (P:Pol) (fv : list R) (n:N)
                      (lm:list (R*positive)) {struct P} : R :=
   (* P@l * (hd 0 l)^n * lm *)
   match P with
-  | Pc c => mkmult_c c (add_pow_list (hd 0 fv) n lm)
-  | Pinj j Q => mult_dev Q (jump j fv) N0 (add_pow_list (hd 0 fv) n lm)
+  | Pc c => mkmult_c c (add_pow_list (hd fv) n lm)
+  | Pinj j Q => mult_dev Q (jump j fv) N0 (add_pow_list (hd fv) n lm)
   | PX P i Q =>
-     let rP := mult_dev P fv (Nplus (Npos i) n) lm in
+     let rP := mult_dev P fv (N.add (Npos i) n) lm in
      if Q ?== P0 then rP
      else
-       let lmq := add_pow_list (hd 0 fv) n lm in
+       let lmq := add_pow_list (hd fv) n lm in
        add_mult_dev rP Q (tail fv) N0 lmq
   end.
 
@@ -1575,7 +1287,7 @@ Section POWER.
     (forall l lr : list (R * positive), r_list_pow (rev_append l lr) == r_list_pow lr * r_list_pow l).
    induction l;intros;simpl;Esimpl.
    destruct a;rewrite IHl;Esimpl.
-   rewrite (ARmul_comm ARth (pow_pos rmul r p)). rrefl.
+   rewrite (ARmul_comm ARth (pow_pos rmul r p)). reflexivity.
   intros;unfold rev'. rewrite H;simpl;Esimpl.
   Qed.
 
@@ -1617,11 +1329,11 @@ Qed.
  Qed.
 
  Lemma add_mult_dev_ok : forall P rP fv n lm,
-    add_mult_dev rP P fv n lm == rP + P@fv*pow_N rI rmul (hd 0 fv) n * r_list_pow lm.
+    add_mult_dev rP P fv n lm == rP + P@fv*pow_N rI rmul (hd fv) n * r_list_pow lm.
   Proof.
     induction P;simpl;intros.
-    rewrite mkadd_mult_ok. rewrite  add_pow_list_ok; Esimpl.
-    rewrite IHP. simpl. rewrite  add_pow_list_ok; Esimpl.
+    rewrite mkadd_mult_ok. rewrite add_pow_list_ok; Esimpl.
+    rewrite IHP. simpl. rewrite add_pow_list_ok; Esimpl.
     change (match P3 with
        | Pc c => c ?=! cO
        | Pinj _ _ => false
@@ -1630,17 +1342,19 @@ Qed.
    change match n with
     | N0 => Npos p
     | Npos q => Npos (p + q)
-    end with (Nplus (Npos p) n);trivial.
+    end with (N.add (Npos p) n);trivial.
    assert (H := Peq_ok P3 P0).
     destruct (P3 ?== P0).
-    rewrite (H (refl_equal true)).
-   rewrite  IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_Pplus;Esimpl.
-   rewrite  IHP2.
-   rewrite IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_Pplus;Esimpl.
+    rewrite (H eq_refl).
+   rewrite IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_add;Esimpl.
+   add_permut. mul_permut.
+   rewrite IHP2.
+   rewrite IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_add;Esimpl.
+   add_permut. mul_permut.
  Qed.
 
  Lemma mult_dev_ok : forall P fv n lm,
-    mult_dev P fv n lm == P@fv * pow_N rI rmul (hd 0 fv) n * r_list_pow lm.
+    mult_dev P fv n lm == P@fv * pow_N rI rmul (hd fv) n * r_list_pow lm.
  Proof.
    induction P;simpl;intros;Esimpl.
    rewrite mkmult_c_ok;rewrite add_pow_list_ok;Esimpl.
@@ -1653,13 +1367,15 @@ Qed.
    change match n with
     | N0 => Npos p
     | Npos q => Npos (p + q)
-    end with (Nplus (Npos p) n);trivial.
+    end with (N.add (Npos p) n);trivial.
    assert (H := Peq_ok P3 P0).
     destruct (P3 ?== P0).
-    rewrite (H (refl_equal true)).
-   rewrite  IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_Pplus;Esimpl.
+    rewrite (H eq_refl).
+   rewrite  IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_add;Esimpl.
+   mul_permut.
    rewrite add_mult_dev_ok. rewrite IHP1; rewrite add_pow_list_ok.
-   destruct n;simpl;Esimpl;rewrite pow_pos_Pplus;Esimpl.
+   destruct n;simpl;Esimpl;rewrite pow_pos_add;Esimpl.
+   add_permut; mul_permut.
   Qed.
 
  Lemma Pphi_avoid_ok : forall P fv, Pphi_avoid fv P  == P@fv.
@@ -1676,18 +1392,18 @@ Qed.
    let mkmult_pow r x p := rmul r (mkpow x p) in
     Pphi_avoid mkpow mkopp_pow mkmult_pow.
 
- Lemma local_mkpow_ok :
-   forall (r : R) (p : positive),
+ Lemma local_mkpow_ok r p :
     match p with
     | xI _ => rpow r (Cp_phi (Npos p))
     | xO _ => rpow r (Cp_phi (Npos p))
     | 1 => r
     end == pow_pos rmul r p.
- Proof. intros r p;destruct p;try rewrite pow_th.(rpow_pow_N);reflexivity. Qed.
+ Proof. destruct p; now rewrite ?pow_th.(rpow_pow_N). Qed.
 
  Lemma Pphi_pow_ok : forall P fv, Pphi_pow fv P  == P@fv.
  Proof.
-  unfold Pphi_pow;intros;apply Pphi_avoid_ok;intros;try rewrite local_mkpow_ok;rrefl.
+  unfold Pphi_pow;intros;apply Pphi_avoid_ok;intros;
+   now rewrite ?local_mkpow_ok.
  Qed.
 
  Lemma ring_rw_pow_correct : forall n lH l,
@@ -1697,7 +1413,7 @@ Qed.
       PEeval l pe == Pphi_pow l npe.
  Proof.
   intros n lH l H1 lmp Heq1 pe npe Heq2.
-  rewrite Pphi_pow_ok. rewrite <- Heq2;rewrite <- Heq1.
+  rewrite Pphi_pow_ok, <- Heq2, <- Heq1.
   apply norm_subst_ok. trivial.
  Qed.
 
@@ -1711,58 +1427,48 @@ Qed.
   Definition mkpow x p :=
     match p with
     | xH => x
-    | xO p => mkmult_pow x x (Pdouble_minus_one p)
+    | xO p => mkmult_pow x x (Pos.pred_double p)
     | xI p => mkmult_pow x x (xO p)
     end.
 
   Definition mkopp_pow x p :=
     match p with
     | xH => -x
-    | xO p => mkmult_pow (-x) x (Pdouble_minus_one p)
+    | xO p => mkmult_pow (-x) x (Pos.pred_double p)
     | xI p => mkmult_pow (-x) x (xO p)
     end.
 
   Definition Pphi_dev := Pphi_avoid mkpow mkopp_pow mkmult_pow.
 
-  Lemma mkmult_pow_ok : forall p r x, mkmult_pow r x p == r*pow_pos rmul x p.
+  Lemma mkmult_pow_ok p r x : mkmult_pow r x p == r * x^p.
   Proof.
-    induction p;intros;simpl;Esimpl.
-    repeat rewrite IHp;Esimpl.
-    repeat rewrite IHp;Esimpl.
+    revert r; induction p;intros;simpl;Esimpl;rewrite !IHp;Esimpl.
   Qed.
 
- Lemma mkpow_ok : forall p x, mkpow x p == pow_pos rmul x p.
+ Lemma mkpow_ok p x : mkpow x p == x^p.
   Proof.
     destruct p;simpl;intros;Esimpl.
-    repeat rewrite mkmult_pow_ok;Esimpl.
-    rewrite mkmult_pow_ok;Esimpl.
-    pattern x at 1;replace x with (pow_pos rmul x 1).
-    rewrite <- pow_pos_Pplus.
-    rewrite <- Pplus_one_succ_l.
-    rewrite Psucc_o_double_minus_one_eq_xO.
-    simpl;Esimpl.
-    trivial.
+    - rewrite !mkmult_pow_ok;Esimpl.
+    - rewrite mkmult_pow_ok;Esimpl.
+      change x with (x^1) at 1.
+      now rewrite <- pow_pos_add, Pos.add_1_r, Pos.succ_pred_double.
   Qed.
 
-  Lemma mkopp_pow_ok : forall p x, mkopp_pow x p == - pow_pos rmul x p.
+  Lemma mkopp_pow_ok p x : mkopp_pow x p == - x^p.
   Proof.
     destruct p;simpl;intros;Esimpl.
-    repeat rewrite mkmult_pow_ok;Esimpl.
-    rewrite mkmult_pow_ok;Esimpl.
-    pattern x at 1;replace x with (pow_pos rmul x 1).
-    rewrite <- pow_pos_Pplus.
-    rewrite <- Pplus_one_succ_l.
-    rewrite Psucc_o_double_minus_one_eq_xO.
-    simpl;Esimpl.
-    trivial.
+    - rewrite !mkmult_pow_ok;Esimpl.
+    - rewrite mkmult_pow_ok;Esimpl.
+      change x with (x^1) at 1.
+      now rewrite <- pow_pos_add, Pos.add_1_r, Pos.succ_pred_double.
   Qed.
 
  Lemma Pphi_dev_ok : forall P fv, Pphi_dev fv P == P@fv.
   Proof.
    unfold Pphi_dev;intros;apply Pphi_avoid_ok.
-   intros;apply mkpow_ok.
-   intros;apply mkopp_pow_ok.
-   intros;apply mkmult_pow_ok.
+   - intros;apply mkpow_ok.
+   - intros;apply mkopp_pow_ok.
+   - intros;apply mkmult_pow_ok.
   Qed.
 
  Lemma ring_rw_correct : forall n lH l,
@@ -1776,6 +1482,4 @@ Qed.
   apply norm_subst_ok. trivial.
  Qed.
 
-
 End MakeRingPol.
-
diff --git a/plugins/setoid_ring/Ring_tac.v b/plugins/setoid_ring/Ring_tac.v
index d33e9a82..7a7ffcfd 100644
--- a/plugins/setoid_ring/Ring_tac.v
+++ b/plugins/setoid_ring/Ring_tac.v
@@ -3,6 +3,7 @@ Require Import Setoid.
 Require Import BinPos.
 Require Import Ring_polynom.
 Require Import BinList.
+Require Export ListTactics.
 Require Import InitialRing.
 Require Import Quote.
 Declare ML Module "newring_plugin".
@@ -14,7 +15,7 @@ Ltac compute_assertion eqn t' t :=
   let nft := eval vm_compute in t in
   pose (t' := nft);
   assert (eqn : t = t');
-  [vm_cast_no_check (refl_equal t')|idtac].
+  [vm_cast_no_check (eq_refl t')|idtac].
 
 Ltac relation_carrier req :=
   let ty := type of req in
@@ -340,7 +341,7 @@ Ltac Ring RNG lemma lH :=
         || idtac "can not automatically proof hypothesis :";
            idtac " maybe a left member of a hypothesis is not a monomial")
     | vm_compute;
-      (exact (refl_equal true) || fail "not a valid ring equation")]).
+      (exact (eq_refl true) || fail "not a valid ring equation")]).
 
 Ltac Ring_norm_gen f RNG lemma lH rl :=
   let mkFV := get_RingFV RNG in
@@ -385,7 +386,7 @@ Ltac Ring_simplify_gen f RNG lH rl :=
   let lemma := get_SimplifyLemma RNG in
   let l := fresh "to_rewrite" in
   pose (l:= rl);
-  generalize (refl_equal l);
+  generalize (eq_refl l);
   unfold l at 2;
   get_Pre RNG ();
   let rl :=
diff --git a/plugins/setoid_ring/Ring_theory.v b/plugins/setoid_ring/Ring_theory.v
index 4fbdcbaa..42ce4edc 100644
--- a/plugins/setoid_ring/Ring_theory.v
+++ b/plugins/setoid_ring/Ring_theory.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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-Require Import Setoid.
-Require Import BinPos.
-Require Import BinNat.
+Require Import Setoid Morphisms BinPos BinNat.
 
 Set Implicit Arguments.
 
@@ -35,48 +33,42 @@ Section Power.
  Variable rI : R.
  Variable rmul : R -> R -> R.
  Variable req : R -> R -> Prop.
- Variable Rsth : Setoid_Theory R req.
- Notation "x * y " := (rmul x y).
- Notation "x == y" := (req x y).
+ Variable Rsth : Equivalence req.
+ Infix "*" := rmul.
+ Infix "==" := req.
 
- Hypothesis mul_ext :
-   forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 * y1 == x2 * y2.
- Hypothesis mul_comm : forall x y, x * y == y * x.
+ Hypothesis mul_ext : Proper (req ==> req ==> req) rmul.
  Hypothesis mul_assoc  : forall x y z, x * (y * z) == (x * y) * z.
- Add Setoid R req Rsth as R_set_Power.
- Add Morphism rmul : rmul_ext_Power. exact mul_ext. Qed.
 
-
- Fixpoint pow_pos (x:R) (i:positive) {struct i}: R :=
+ Fixpoint pow_pos (x:R) (i:positive) : R :=
   match i with
   | xH => x
-  | xO i => let p := pow_pos x i in rmul p p
-  | xI i => let p := pow_pos x i in rmul x (rmul p p)
+  | xO i => let p := pow_pos x i in p * p
+  | xI i => let p := pow_pos x i in x * (p * p)
   end.
 
- Lemma pow_pos_Psucc : forall x j, pow_pos x (Psucc j) == x * pow_pos x j.
+ Lemma pow_pos_swap x j : pow_pos x j * x == x * pow_pos x j.
+ Proof.
+  induction j; simpl; rewrite <- ?mul_assoc.
+  - f_equiv. now do 2 (rewrite IHj, mul_assoc).
+  - now do 2 (rewrite IHj, mul_assoc).
+  - reflexivity.
+ Qed.
+
+ Lemma pow_pos_succ x j :
+   pow_pos x (Pos.succ j) == x * pow_pos x j.
  Proof.
-  induction j;simpl.
-  rewrite IHj.
-  rewrite (mul_comm x (pow_pos x j *pow_pos x j)).
-  setoid_rewrite (mul_comm x (pow_pos x j)) at 2.
-  repeat rewrite mul_assoc. apply (Seq_refl _ _ Rsth).
-  repeat rewrite mul_assoc. apply (Seq_refl _ _ Rsth).
-  apply (Seq_refl _ _ Rsth).
+  induction j; simpl; try reflexivity.
+  rewrite IHj, <- mul_assoc; f_equiv.
+  now rewrite mul_assoc, pow_pos_swap, mul_assoc.
  Qed.
 
- Lemma pow_pos_Pplus : forall x i j, pow_pos x (i + j) == pow_pos x i * pow_pos x j.
+ Lemma pow_pos_add 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 mul_assoc. apply (Seq_refl _ _ Rsth).
-  rewrite <- Pplus_diag;repeat rewrite <- Pplus_assoc.
-  repeat rewrite IHi;rewrite mul_assoc. apply (Seq_refl _ _ Rsth).
-  rewrite Pplus_comm;rewrite <- Pplus_one_succ_r;rewrite pow_pos_Psucc;
-   simpl. apply (Seq_refl _ _ Rsth).
+  induction i using Pos.peano_ind.
+  - now rewrite Pos.add_1_l, pow_pos_succ.
+  - now rewrite Pos.add_succ_l, !pow_pos_succ, IHi, mul_assoc.
  Qed.
 
  Definition pow_N (x:R) (p:N) :=
@@ -87,9 +79,9 @@ Section Power.
 
  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.
+ Lemma pow_N_pow_N x n : pow_N x (id_phi_N n) == pow_N x n.
  Proof.
-  intros; apply (Seq_refl _ _ Rsth).
+  reflexivity.
  Qed.
 
 End Power.
@@ -98,19 +90,18 @@ Section DEFINITIONS.
  Variable R : Type.
  Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R).
  Variable req : R -> R -> Prop.
-  Notation "0" := rO.  Notation "1" := rI.
-  Notation "x + y" := (radd x y).  Notation "x * y " := (rmul x y).
-  Notation "x - y " := (rsub x y).  Notation "- x" := (ropp x).
-  Notation "x == y" := (req x y).
+ Notation "0" := rO.  Notation "1" := rI.
+ Infix "==" := req. Infix "+" := radd. Infix "*" := rmul.
+ Infix "-" := rsub. Notation "- x" := (ropp x).
 
  (** Semi Ring *)
  Record semi_ring_theory : Prop := mk_srt {
     SRadd_0_l   : forall n, 0 + n == n;
-    SRadd_comm   : forall n m, n + m == m + n ;
+    SRadd_comm  : forall n m, n + m == m + n ;
     SRadd_assoc : forall n m p, n + (m + p) == (n + m) + p;
     SRmul_1_l   : forall n, 1*n == n;
     SRmul_0_l   : forall n, 0*n == 0;
-    SRmul_comm   : forall n m, n*m == m*n;
+    SRmul_comm  : forall n m, n*m == m*n;
     SRmul_assoc : forall n m p, n*(m*p) == (n*m)*p;
     SRdistr_l   : forall n m p, (n + m)*p == n*p + m*p
   }.
@@ -119,11 +110,11 @@ Section DEFINITIONS.
 (*Almost ring are no ring : Ropp_def is missing **)
  Record almost_ring_theory : Prop := mk_art {
     ARadd_0_l   : forall x, 0 + x == x;
-    ARadd_comm   : forall x y, x + y == y + x;
+    ARadd_comm  : forall x y, x + y == y + x;
     ARadd_assoc : forall x y z, x + (y + z) == (x + y) + z;
     ARmul_1_l   : forall x, 1 * x == x;
     ARmul_0_l   : forall x, 0 * x == 0;
-    ARmul_comm   : forall x y, x * y == y * x;
+    ARmul_comm  : forall x y, x * y == y * x;
     ARmul_assoc : forall x y z, x * (y * z) == (x * y) * z;
     ARdistr_l   : forall x y z, (x + y) * z == (x * z) + (y * z);
     ARopp_mul_l : forall x y, -(x * y) == -x * y;
@@ -134,10 +125,10 @@ Section DEFINITIONS.
  (** Ring *)
  Record ring_theory : Prop := mk_rt {
     Radd_0_l    : forall x, 0 + x == x;
-    Radd_comm    : forall x y, x + y == y + x;
+    Radd_comm   : forall x y, x + y == y + x;
     Radd_assoc  : forall x y z, x + (y + z) == (x + y) + z;
     Rmul_1_l    : forall x, 1 * x == x;
-    Rmul_comm    : forall x y, x * y == y * x;
+    Rmul_comm   : forall x y, x * y == y * x;
     Rmul_assoc  : forall x y z, x * (y * z) == (x * y) * z;
     Rdistr_l    : forall x y z, (x + y) * z == (x * z) + (y * z);
     Rsub_def    : forall x y, x - y == x + -y;
@@ -148,19 +139,15 @@ Section DEFINITIONS.
 
  Record sring_eq_ext : Prop := mk_seqe {
     (* SRing operators are compatible with equality *)
-    SRadd_ext :
-      forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 + y1 == x2 + y2;
-    SRmul_ext :
-      forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 * y1 == x2 * y2
+    SRadd_ext : Proper (req ==> req ==> req) radd;
+    SRmul_ext : Proper (req ==> req ==> req) rmul
   }.
 
  Record ring_eq_ext : Prop := mk_reqe {
     (* Ring operators are compatible with equality *)
-    Radd_ext :
-      forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 + y1 == x2 + y2;
-    Rmul_ext :
-      forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 * y1 == x2 * y2;
-    Ropp_ext : forall x1 x2, x1 == x2 ->  -x1 == -x2
+    Radd_ext : Proper (req ==> req ==> req) radd;
+    Rmul_ext : Proper (req ==> req ==> req) rmul;
+    Ropp_ext : Proper (req ==> req) ropp
   }.
 
  (** Interpretation morphisms definition*)
@@ -170,9 +157,9 @@ Section DEFINITIONS.
  Variable ceqb : C->C->bool.
  (* [phi] est un morphisme de [C] dans [R] *)
  Variable phi : C -> R.
- Notation "x +! y" := (cadd x y). Notation "x -! y " := (csub x y).
- Notation "x *! y " := (cmul x y). Notation "-! x" := (copp x).
- Notation "x ?=! y" := (ceqb x y). Notation "[ x ]" := (phi x).
+ Infix "+!" := cadd. Infix "-!" := csub.
+ Infix "*!" := cmul. Notation "-! x" := (copp x).
+ Infix "?=!" := ceqb. Notation "[ x ]" := (phi x).
 
 (*for semi rings*)
  Record semi_morph : Prop := mkRmorph {
@@ -216,20 +203,18 @@ Section DEFINITIONS.
  End MORPHISM.
 
  (** Identity is a morphism *)
- Variable Rsth : Setoid_Theory R req.
-   Add Setoid R req Rsth as R_setoid1.
+ Variable Rsth : Equivalence req.
  Variable reqb : R->R->bool.
  Hypothesis morph_req : forall x y, (reqb x y) = true -> x == y.
  Definition IDphi (x:R) := x.
  Lemma IDmorph : ring_morph rO rI radd rmul rsub ropp reqb IDphi.
  Proof.
-  apply (mkmorph rO rI radd rmul rsub ropp reqb IDphi);intros;unfold IDphi;
-  try apply (Seq_refl _ _ Rsth);auto.
+  now apply (mkmorph rO rI radd rmul rsub ropp reqb IDphi).
  Qed.
 
  (** Specification of the power function *)
  Section POWER.
-  Variable Cpow : Set.
+  Variable Cpow : Type.
   Variable Cp_phi : N -> Cpow.
   Variable rpow : R -> Cpow -> R.
 
@@ -239,35 +224,31 @@ Section DEFINITIONS.
 
  End POWER.
 
- Definition pow_N_th := mkpow_th id_phi_N (pow_N rI rmul) (pow_N_pow_N rI rmul Rsth).
+ Definition pow_N_th :=
+   mkpow_th id_phi_N (pow_N rI rmul) (pow_N_pow_N rI rmul Rsth).
 
 
 End DEFINITIONS.
 
-
-
 Section ALMOST_RING.
  Variable R : Type.
  Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R).
  Variable req : R -> R -> Prop.
-  Notation "0" := rO.  Notation "1" := rI.
-  Notation "x + y" := (radd x y).  Notation "x * y " := (rmul x y).
-  Notation "x - y " := (rsub x y).  Notation "- x" := (ropp x).
-  Notation "x == y" := (req x y).
+ Notation "0" := rO.  Notation "1" := rI.
+ Infix "==" := req. Infix "+" := radd.  Infix "* " := rmul.
+ Infix "-" := rsub. Notation "- x" := (ropp x).
 
  (** Leibniz equality leads to a setoid theory and is extensional*)
- Lemma Eqsth : Setoid_Theory R (@eq R).
- Proof.  constructor;red;intros;subst;trivial. Qed.
+ Lemma Eqsth : Equivalence (@eq R).
+ Proof. exact eq_equivalence. Qed.
 
  Lemma Eq_s_ext : sring_eq_ext radd rmul (@eq R).
- Proof. constructor;intros;subst;trivial. Qed.
+ Proof. constructor;solve_proper. Qed.
 
  Lemma Eq_ext : ring_eq_ext radd rmul ropp (@eq R).
- Proof. constructor;intros;subst;trivial. Qed.
+ Proof. constructor;solve_proper. Qed.
 
- Variable Rsth : Setoid_Theory R req.
-   Add Setoid R req Rsth as R_setoid2.
-   Ltac sreflexivity := apply (Seq_refl _ _ Rsth).
+ Variable Rsth : Equivalence req.
 
  Section SEMI_RING.
  Variable SReqe : sring_eq_ext radd rmul req.
@@ -282,23 +263,24 @@ Section ALMOST_RING.
  Definition SRsub x y := x + -y. Notation "x - y " := (SRsub x y).
 
  Lemma SRopp_ext : forall x y, x == y -> -x == -y.
- Proof. intros x y H;exact H. Qed.
+ Proof. intros x y H; exact H. Qed.
 
  Lemma SReqe_Reqe : ring_eq_ext radd rmul SRopp req.
  Proof.
-  constructor.  exact (SRadd_ext SReqe). exact (SRmul_ext SReqe).
-  exact SRopp_ext.
+  constructor.
+  - exact (SRadd_ext SReqe).
+  - exact (SRmul_ext SReqe).
+  - exact SRopp_ext.
  Qed.
 
  Lemma SRopp_mul_l : forall x y, -(x * y) == -x * y.
- Proof. intros;sreflexivity. Qed.
+ Proof. reflexivity. Qed.
 
  Lemma SRopp_add : forall x y, -(x + y) == -x + -y.
- Proof. intros;sreflexivity.  Qed.
-
+ Proof. reflexivity. Qed.
 
  Lemma SRsub_def   : forall x y, x - y == x + -y.
- Proof. intros;sreflexivity. Qed.
+ Proof. reflexivity. Qed.
 
  Lemma SRth_ARth : almost_ring_theory 0 1 radd rmul SRsub SRopp req.
  Proof (mk_art 0 1 radd rmul SRsub SRopp req
@@ -315,7 +297,7 @@ Section ALMOST_RING.
  Definition SRIDmorph : ring_morph 0 1 radd rmul SRsub SRopp req
                             0 1 radd rmul SRsub SRopp reqb (@IDphi R).
  Proof.
-  apply mkmorph;intros;try sreflexivity.  unfold IDphi;auto.
+  now apply mkmorph.
  Qed.
 
  (* a semi_morph can be extended to a ring_morph for the almost_ring derived
@@ -331,9 +313,7 @@ Section ALMOST_RING.
    ring_morph rO rI radd rmul SRsub SRopp req
               cO cI cadd cmul cadd (fun x => x) ceqb phi.
  Proof.
- case Smorph; intros; constructor; auto.
- unfold SRopp in |- *; intros.
-  setoid_reflexivity.
+ case Smorph; now constructor.
  Qed.
 
  End  SEMI_RING.
@@ -347,31 +327,28 @@ Section ALMOST_RING.
  Variable Rth : ring_theory 0 1 radd rmul rsub ropp req.
 
  (** Rings are almost rings*)
- Lemma Rmul_0_l : forall x, 0 * x == 0.
+ Lemma Rmul_0_l x : 0 * x == 0.
  Proof.
-  intro x; setoid_replace (0*x) with ((0+1)*x + -x).
-  rewrite (Radd_0_l Rth); rewrite (Rmul_1_l Rth).
-  rewrite (Ropp_def Rth);sreflexivity.
+  setoid_replace (0*x) with ((0+1)*x + -x).
+  now rewrite (Radd_0_l Rth), (Rmul_1_l Rth), (Ropp_def Rth).
 
-  rewrite (Rdistr_l Rth);rewrite (Rmul_1_l Rth).
-  rewrite <- (Radd_assoc Rth); rewrite (Ropp_def Rth).
-  rewrite (Radd_comm Rth); rewrite (Radd_0_l Rth);sreflexivity.
+  rewrite (Rdistr_l Rth), (Rmul_1_l Rth).
+  rewrite <- (Radd_assoc Rth), (Ropp_def Rth).
+  now rewrite (Radd_comm Rth), (Radd_0_l Rth).
  Qed.
 
- Lemma Ropp_mul_l : forall x y, -(x * y) == -x * y.
+ Lemma Ropp_mul_l x y : -(x * y) == -x * y.
  Proof.
-  intros x y;rewrite <-(Radd_0_l Rth (- x * y)).
-  rewrite (Radd_comm Rth).
-  rewrite <-(Ropp_def Rth (x*y)).
-  rewrite (Radd_assoc Rth).
-  rewrite <- (Rdistr_l Rth).
-  rewrite (Rth.(Radd_comm) (-x));rewrite (Ropp_def Rth).
-  rewrite Rmul_0_l;rewrite (Radd_0_l Rth);sreflexivity.
+  rewrite <-(Radd_0_l Rth (- x * y)).
+  rewrite (Radd_comm Rth), <-(Ropp_def Rth (x*y)).
+  rewrite (Radd_assoc Rth), <- (Rdistr_l Rth).
+  rewrite (Rth.(Radd_comm) (-x)), (Ropp_def Rth).
+  now rewrite Rmul_0_l, (Radd_0_l Rth).
  Qed.
 
- Lemma Ropp_add : forall x y, -(x + y) == -x + -y.
+ Lemma Ropp_add x y : -(x + y) == -x + -y.
  Proof.
-  intros x y;rewrite <- ((Radd_0_l Rth) (-(x+y))).
+  rewrite <- ((Radd_0_l Rth) (-(x+y))).
   rewrite <- ((Ropp_def Rth) x).
   rewrite <- ((Radd_0_l Rth) (x + - x + - (x + y))).
   rewrite <- ((Ropp_def Rth) y).
@@ -383,17 +360,17 @@ Section ALMOST_RING.
   rewrite ((Radd_comm Rth) y).
   rewrite <- ((Radd_assoc Rth)  (- x)).
   rewrite ((Radd_assoc Rth) y).
-  rewrite ((Radd_comm Rth) y);rewrite (Ropp_def Rth).
-  rewrite ((Radd_comm Rth) (-x) 0);rewrite (Radd_0_l Rth).
-  apply (Radd_comm Rth).
+  rewrite ((Radd_comm Rth) y), (Ropp_def Rth).
+  rewrite ((Radd_comm Rth) (-x) 0), (Radd_0_l Rth).
+  now apply (Radd_comm Rth).
  Qed.
 
- Lemma Ropp_opp : forall x, - -x == x.
+ Lemma Ropp_opp x : - -x == x.
  Proof.
-  intros x; rewrite <- (Radd_0_l Rth (- -x)).
+  rewrite <- (Radd_0_l Rth (- -x)).
   rewrite <- (Ropp_def Rth x).
-  rewrite <- (Radd_assoc Rth); rewrite (Ropp_def Rth).
-  rewrite ((Radd_comm Rth) x);apply (Radd_0_l Rth).
+  rewrite <- (Radd_assoc Rth), (Ropp_def Rth).
+  rewrite ((Radd_comm Rth) x); now apply (Radd_0_l Rth).
  Qed.
 
  Lemma  Rth_ARth : almost_ring_theory 0 1 radd rmul rsub ropp req.
@@ -407,10 +384,10 @@ Section ALMOST_RING.
  Variable (cO cI : C) (cadd cmul csub: C->C->C) (copp : C -> C).
  Variable (ceq : C -> C -> Prop) (ceqb : C -> C -> bool).
  Variable phi : C -> R.
-  Notation "x +! y" := (cadd x y).  Notation "x *! y " := (cmul x y).
-  Notation "x -! y " := (csub x y).  Notation "-! x" := (copp x).
-  Notation "x ?=! y" := (ceqb x y). Notation "[ x ]" := (phi x).
- Variable Csth : Setoid_Theory C ceq.
+  Infix "+!" := cadd. Infix "*!" := cmul.
+  Infix "-!" := csub. Notation "-! x" := (copp x).
+  Notation "?=!" := ceqb. Notation "[ x ]" := (phi x).
+ Variable Csth : Equivalence ceq.
  Variable Ceqe : ring_eq_ext cadd cmul copp ceq.
    Add Setoid C ceq Csth as C_setoid.
    Add Morphism cadd : cadd_ext.  exact (Radd_ext Ceqe). Qed.
@@ -420,9 +397,9 @@ Section ALMOST_RING.
  Variable Smorph : semi_morph 0 1 radd rmul req cO cI cadd cmul ceqb phi.
  Variable phi_ext : forall x y, ceq x y -> [x] == [y].
    Add Morphism phi : phi_ext1.  exact phi_ext. Qed.
- Lemma Smorph_opp : forall x, [-!x] == -[x].
+ Lemma Smorph_opp x : [-!x] == -[x].
  Proof.
-  intros x;rewrite <-  (Rth.(Radd_0_l) [-!x]).
+  rewrite <-  (Rth.(Radd_0_l) [-!x]).
   rewrite <- ((Ropp_def Rth) [x]).
   rewrite ((Radd_comm Rth) [x]).
   rewrite <- (Radd_assoc Rth).
@@ -430,17 +407,18 @@ Section ALMOST_RING.
   rewrite (Ropp_def Cth).
   rewrite (Smorph0 Smorph).
   rewrite (Radd_comm Rth (-[x])).
-  apply (Radd_0_l Rth);sreflexivity.
+  now apply (Radd_0_l Rth).
  Qed.
 
- Lemma Smorph_sub : forall x y, [x -! y] == [x] - [y].
+ Lemma Smorph_sub x y : [x -! y] == [x] - [y].
  Proof.
-  intros x y; rewrite (Rsub_def Cth);rewrite (Rsub_def Rth).
-  rewrite (Smorph_add Smorph);rewrite Smorph_opp;sreflexivity.
+  rewrite (Rsub_def Cth), (Rsub_def Rth).
+  now rewrite (Smorph_add Smorph), Smorph_opp.
  Qed.
 
- Lemma Smorph_morph : ring_morph 0 1 radd rmul rsub ropp req
-                                             cO cI cadd cmul csub copp ceqb phi.
+ Lemma Smorph_morph :
+   ring_morph 0 1 radd rmul rsub ropp req
+     cO cI cadd cmul csub copp ceqb phi.
  Proof
   (mkmorph 0 1 radd rmul rsub ropp req cO cI cadd cmul csub copp ceqb phi
         (Smorph0 Smorph) (Smorph1 Smorph)
@@ -458,17 +436,11 @@ elim ARth; intros.
 constructor; trivial.
 Qed.
 
- Lemma ARsub_ext :
-      forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 - y1 == x2 - y2.
+ Instance ARsub_ext : Proper (req ==> req ==> req) rsub.
  Proof.
-  intros.
-  setoid_replace (x1 - y1) with (x1 + -y1).
-  setoid_replace (x2 - y2) with (x2 + -y2).
-  rewrite H;rewrite H0;sreflexivity.
-  apply (ARsub_def ARth).
-  apply (ARsub_def ARth).
+  intros x1 x2 Ex y1 y2 Ey.
+  now rewrite !(ARsub_def ARth), Ex, Ey.
  Qed.
-   Add Morphism rsub : rsub_ext.  exact ARsub_ext. Qed.
 
  Ltac mrewrite :=
    repeat first
@@ -479,64 +451,56 @@ Qed.
      | rewrite (ARmul_0_l ARth)
      | rewrite <- ((ARmul_comm ARth) 0)
      | rewrite (ARdistr_l ARth)
-     | sreflexivity
+     | reflexivity
      | match goal with
        | |- context [?z * (?x + ?y)] => rewrite ((ARmul_comm ARth) z (x+y))
        end].
 
- Lemma ARadd_0_r : forall x, (x + 0) == x.
- Proof. intros; mrewrite. Qed.
+ Lemma ARadd_0_r x : x + 0 == x.
+ Proof. mrewrite. Qed.
 
- Lemma ARmul_1_r   : forall x, x * 1 == x.
- Proof. intros;mrewrite. Qed.
+ Lemma ARmul_1_r x : x * 1 == x.
+ Proof. mrewrite. Qed.
 
- Lemma ARmul_0_r : forall x, x * 0 == 0.
- Proof. intros;mrewrite. Qed.
+ Lemma ARmul_0_r x : x * 0 == 0.
+ Proof. mrewrite. Qed.
 
- Lemma ARdistr_r : forall x y z, z * (x + y) == z*x + z*y.
+ Lemma ARdistr_r x y z : z * (x + y) == z*x + z*y.
  Proof.
-  intros;mrewrite.
-  repeat rewrite (ARth.(ARmul_comm) z);sreflexivity.
+  mrewrite. now rewrite !(ARth.(ARmul_comm) z).
  Qed.
 
- Lemma ARadd_assoc1 : forall x y z, (x + y) + z == (y + z) + x.
+ Lemma ARadd_assoc1 x y z : (x + y) + z == (y + z) + x.
  Proof.
-  intros;rewrite <-(ARth.(ARadd_assoc) x).
-  rewrite (ARth.(ARadd_comm) x);sreflexivity.
+  now rewrite <-(ARth.(ARadd_assoc) x), (ARth.(ARadd_comm) x).
  Qed.
 
- Lemma ARadd_assoc2 : forall x y z, (y + x) + z == (y + z) + x.
+ Lemma ARadd_assoc2 x y z : (y + x) + z == (y + z) + x.
  Proof.
-  intros; repeat rewrite <- (ARadd_assoc ARth);
-   rewrite ((ARadd_comm ARth) x); sreflexivity.
+  now rewrite <- !(ARadd_assoc ARth), ((ARadd_comm ARth) x).
  Qed.
 
- Lemma ARmul_assoc1 : forall x y z, (x * y) * z == (y * z) * x.
+ Lemma ARmul_assoc1 x y z : (x * y) * z == (y * z) * x.
  Proof.
-  intros;rewrite <-((ARmul_assoc ARth) x).
-  rewrite ((ARmul_comm ARth) x);sreflexivity.
+  now rewrite <- ((ARmul_assoc ARth) x), ((ARmul_comm ARth) x).
  Qed.
 
- Lemma ARmul_assoc2 : forall x y z, (y * x) * z == (y * z) * x.
+ Lemma ARmul_assoc2 x y z : (y * x) * z == (y * z) * x.
  Proof.
-  intros; repeat rewrite <- (ARmul_assoc ARth);
-   rewrite ((ARmul_comm ARth) x); sreflexivity.
+  now rewrite <- !(ARmul_assoc ARth), ((ARmul_comm ARth) x).
  Qed.
 
- Lemma ARopp_mul_r : forall x y,  - (x * y) == x * -y.
+ Lemma ARopp_mul_r x y : - (x * y) == x * -y.
  Proof.
-  intros;rewrite ((ARmul_comm ARth) x y);
-   rewrite (ARopp_mul_l ARth); apply (ARmul_comm ARth).
+  rewrite ((ARmul_comm ARth) x y), (ARopp_mul_l ARth).
+  now apply (ARmul_comm ARth).
  Qed.
 
  Lemma ARopp_zero : -0 == 0.
  Proof.
-  rewrite <- (ARmul_0_r 0); rewrite (ARopp_mul_l ARth).
-  repeat rewrite ARmul_0_r; sreflexivity.
+  now rewrite <- (ARmul_0_r 0), (ARopp_mul_l ARth), !ARmul_0_r.
  Qed.
 
-
-
 End ALMOST_RING.
 
 
@@ -590,12 +554,29 @@ 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] =>
      progress rewrite (ARadd_assoc2 Rsth Reqe ARth x y z)
   | |- context [add (add x ?y) ?z] =>
      progress rewrite (ARadd_assoc1 Rsth ARth x y z)
+  | |- context [(add x ?y)] =>
+     progress rewrite (ARadd_comm ARth x y)
   end).
 
 Ltac gen_mul_push mul Rsth Reqe ARth x :=
@@ -604,5 +585,6 @@ Ltac gen_mul_push mul Rsth Reqe ARth x :=
      progress rewrite (ARmul_assoc2 Rsth Reqe ARth x y z)
   | |- context [mul (mul x ?y) ?z] =>
      progress rewrite (ARmul_assoc1 Rsth ARth x y z)
+  | |- context [(mul x ?y)] =>
+     progress rewrite (ARmul_comm ARth x y)
   end).
-
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..58a4d7ea
--- /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 Z.mul_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..3c4f6b86 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-2012     *)
 (*   \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
@@ -43,14 +39,14 @@ Ltac Zpower_neg :=
   repeat match goal with
   | [|- ?G] =>
     match G with
-    | context c [Zpower _ (Zneg _)] =>
+    | context c [Z.pow _ (Zneg _)] =>
       let t := context c [Z0] in
       change t
     end
   end.
 
 Add Ring Zr : Zth
-  (decidable Zeq_bool_eq, constants [Zcst], preprocess [Zpower_neg;unfold Zsucc],
+  (decidable Zeq_bool_eq, constants [Zcst], preprocess [Zpower_neg;unfold Z.succ],
    power_tac Zpower_theory [Zpow_tac],
     (* The two following option are not needed, it is the default chose when the set of
         coefficiant is usual ring Z *)
diff --git a/plugins/setoid_ring/newring.ml4 b/plugins/setoid_ring/newring.ml4
index 820246af..580e78f6 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-2012     *)
 (*   \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..f4d8b769 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. *)
 
@@ -129,18 +132,29 @@ let rec chop_product n t =
       | Prod (_, _, b) ->  if noccurn 1 b then chop_product (pred n) (Termops.pop b) else None
       | _ -> None
 
-let evar_dependencies evm ev =
+let evars_of_evar_info evi =
+  Intset.union (Evarutil.evars_of_term evi.evar_concl)
+    (Intset.union
+	(match evi.evar_body with
+	| Evar_empty -> Intset.empty
+	| Evar_defined b -> Evarutil.evars_of_term b)
+	(Evarutil.evars_of_named_context (evar_filtered_context evi)))
+
+let evar_dependencies evm oev =
   let one_step deps =
     Intset.fold (fun ev s ->
       let evi = Evd.find evm ev in
-	Intset.union (Evarutil.evars_of_evar_info evi) s)
+      let deps' = evars_of_evar_info evi in
+	if Intset.mem oev deps' then
+	  raise (Invalid_argument ("Ill-formed evar map: cycle detected for evar " ^ string_of_int oev))
+	else Intset.union deps' s)
       deps deps
   in
   let rec aux deps =
     let deps' = one_step deps in
       if Intset.equal deps deps' then deps
       else aux deps'
-  in aux (Intset.singleton ev)
+  in aux (Intset.singleton oev)
       
 let move_after (id, ev, deps as obl) l = 
   let rec aux restdeps = function
@@ -210,7 +224,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 +232,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 +245,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..a0b693de 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-2012     *)
 (*   \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..6e7a8d32 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-2012     *)
 (*   \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
@@ -79,14 +75,14 @@ type 'a gallina_loc_argtype = (Vernacexpr.vernac_expr located, 'a) Genarg.abstra
 let (wit_subtac_gallina_loc : Genarg.tlevel gallina_loc_argtype),
   (globwit_subtac_gallina_loc : Genarg.glevel gallina_loc_argtype),
   (rawwit_subtac_gallina_loc : Genarg.rlevel gallina_loc_argtype) =
-  Genarg.create_arg "subtac_gallina_loc"
+  Genarg.create_arg None "subtac_gallina_loc"
 
 type 'a withtac_argtype = (Tacexpr.raw_tactic_expr option, 'a) Genarg.abstract_argument_type
 
 let (wit_subtac_withtac : Genarg.tlevel withtac_argtype),
   (globwit_subtac_withtac : Genarg.glevel withtac_argtype),
   (rawwit_subtac_withtac : Genarg.rlevel withtac_argtype) =
-  Genarg.create_arg "subtac_withtac"
+  Genarg.create_arg None "subtac_withtac"
 
 VERNAC COMMAND EXTEND Subtac
 [ "Program" subtac_gallina_loc(g) ] -> [ Subtac.subtac g ]
@@ -94,7 +90,8 @@ VERNAC COMMAND EXTEND Subtac
 
 let try_catch_exn f e =
   try f e
-  with exn -> errorlabstrm "Program" (Cerrors.explain_exn exn)
+  with exn when Errors.noncritical exn ->
+    errorlabstrm "Program" (Errors.print exn)
 
 let subtac_obligation e = try_catch_exn Subtac_obligations.subtac_obligation e
 let next_obligation e = try_catch_exn Subtac_obligations.next_obligation e
diff --git a/plugins/subtac/subtac.ml b/plugins/subtac/subtac.ml
index 95cacc38..ad248bfb 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-2012     *)
 (*   \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
@@ -83,13 +82,11 @@ let start_proof_com env isevars sopt kind (bl,t) hook =
       Impargs.declare_manual_implicits (loc = Local) gr ~enriching:true [imps];
       hook loc gr)
 
-let print_subgoals () = Flags.if_verbose (fun () -> msg (Printer.pr_open_subgoals ())) ()
-
 let start_proof_and_print env isevars idopt k t hook =
   start_proof_com env isevars idopt k t hook;
-  print_subgoals ()
+  Vernacentries.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 +139,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 +169,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 +216,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
+  | reraise ->
+      (*       msg_warning (str "Uncaught exception: " ++ Errors.print e); *)
+      raise reraise
diff --git a/plugins/subtac/subtac_cases.ml b/plugins/subtac/subtac_cases.ml
index 25aec39c..0b1ed9bb 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-2012     *)
 (*   \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 *
@@ -345,7 +342,7 @@ let prepare_predicate_from_arsign_tycon loc env evm tomatchs arsign c =
       let pred = predicate 0 c in
       let env' = push_rel_context (context_of_arsign arsign) env in
 	ignore(Typing.sort_of env' evm pred); pred
-    with _ -> lift nar c
+    with e when Errors.noncritical e -> lift nar c
 
 module Cases_F(Coercion : Coercion.S) : S = struct
 
@@ -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 =
@@ -1468,7 +1465,8 @@ let extract_arity_signatures env0 tomatchl tmsign =
 	      | None -> list_tabulate (fun _ -> Anonymous) nrealargs in
 	  let arsign = fst (get_arity env0 indf) in
 	    (na,None,build_dependent_inductive env0 indf)
-	    ::(try List.map2 (fun x (_,c,t) ->(x,c,t)) realnal arsign with _ -> assert false) in
+	    ::(try List.map2 (fun x (_,c,t) ->(x,c,t)) realnal arsign
+              with e when Errors.noncritical e -> assert false) in
   let rec buildrec = function
     | [],[] -> []
     | (_,tm)::ltm, x::tmsign ->
@@ -1518,7 +1516,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 +1532,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 +1546,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 +1605,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 +1742,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 +1784,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,
@@ -1848,7 +1846,7 @@ let build_dependent_signature env evars avoid tomatchs arsign =
 			 refl_arg :: refl_args,
 			 pred slift,
 			 (Name id, b, t) :: argsign'))
-		   (env, 0, [], [], slift, []) args argsign
+		   (env, neqs, [], [], slift, []) args argsign
 	       in
 	       let eq = mk_JMeq
 		 (lift (nargeqs + slift) appt)
diff --git a/plugins/subtac/subtac_cases.mli b/plugins/subtac/subtac_cases.mli
index bc2b2bb7..91142067 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-2012     *)
 (*   \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..f11f611f 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-2012     *)
 (*   \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
@@ -51,7 +52,7 @@ let type_ctx_instance evars env ctx inst subst =
 	| None -> interp_casted_constr_evars evars env (List.hd l) t', List.tl l
 	| Some b -> substl subst b, l
       in
-       evars := resolve_typeclasses ~onlyargs:true ~fail:true env !evars;
+       evars := resolve_typeclasses ~filter:Subtac_utils.no_goals_or_obligations ~fail:true env !evars;
        let d = na, Some c', t' in
 	aux (c' :: subst, d :: instctx) l ctx
     | [] -> subst
@@ -106,18 +107,20 @@ let new_instance ?(global=false) ctx (instid, bk, cl) props ?(generalize=true) p
 	let i = Nameops.add_suffix (Classes.id_of_class k) "_instance_0" in
 	  Namegen.next_global_ident_away i (Termops.ids_of_context env)
   in
+  evars := resolve_typeclasses ~filter:Subtac_utils.no_goals_or_obligations ~fail:true env !evars;  
+  let ctx = Evarutil.nf_rel_context_evar !evars ctx 
+  and ctx' = Evarutil.nf_rel_context_evar !evars ctx' in
   let env' = push_rel_context ctx env in
-  evars := Evarutil.nf_evar_map !evars;
-  evars := resolve_typeclasses ~onlyargs:false ~fail:true env !evars;
   let sigma =  !evars in
   let subst = List.map (Evarutil.nf_evar sigma) subst in
   let props =
     match props with
-    | CRecord (loc, _, fs) ->
+    | 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 +141,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
@@ -151,6 +158,8 @@ let new_instance ?(global=false) ctx (instid, bk, cl) props ?(generalize=true) p
 	    Inl (type_ctx_instance evars (push_rel_context ctx' env') k.cl_props props subst)
   in	  
   evars := Evarutil.nf_evar_map !evars;
+  evars := resolve_typeclasses ~filter:Subtac_utils.no_goals_or_obligations ~fail:true env !evars;
+  evars := resolve_typeclasses ~filter:Typeclasses.no_goals ~fail:false env !evars;
   let term, termtype =
     match subst with
     | Inl subst ->
@@ -173,10 +182,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..2c9fbaf5 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-2012     *)
 (*   \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..0c03fb4c 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-2012     *)
 (*   \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
@@ -30,6 +27,9 @@ open Subtac_errors
 open Eterm
 open Pp
 
+let app_opt env evars f t =
+  whd_betaiota !evars (app_opt f t)
+
 let pair_of_array a = (a.(0), a.(1))
 let make_name s = Name (id_of_string s)
 
@@ -83,7 +83,8 @@ module Coercion = struct
       | Type _, Prop Null -> Prop Null
       | _, Type _ -> s2
 
-  let hnf env isevars c = whd_betadeltaiota env ( !isevars) c
+  let hnf env isevars c = whd_betadeltaiota env isevars c
+  let hnf_nodelta env evars c = whd_betaiota evars c
 
   let lift_args n sign =
     let rec liftrec k = function
@@ -93,15 +94,16 @@ module Coercion = struct
       liftrec (List.length sign) sign
 
   let rec mu env isevars t =
-    let isevars = ref isevars in
     let rec aux v =
-      let v = hnf env isevars v in
+      let v = hnf env !isevars v in
       match disc_subset v with
 	  Some (u, p) ->
 	    let f, ct = aux u in
+	    let p = hnf env !isevars p in
 	      (Some (fun x ->
-		       app_opt f (mkApp ((delayed_force sig_).proj1,
-					 [| u; p; x |]))),
+		     app_opt env isevars 
+		     f (mkApp ((delayed_force sig_).proj1,
+			       [| u; p; x |]))),
 	       ct)
 	| None -> (None, v)
     in aux t
@@ -109,9 +111,8 @@ module Coercion = struct
   and coerce loc env isevars (x : Term.constr) (y : Term.constr)
       : (Term.constr -> Term.constr) option
       =
-    let x = nf_evar ( !isevars) x and y = nf_evar ( !isevars) y in
     let rec coerce_unify env x y =
-      let x = hnf env isevars x and y = hnf env isevars y in
+      let x = hnf env !isevars x and y = hnf env !isevars y in
 	try
 	  isevars := the_conv_x_leq env x y !isevars;
 	  None
@@ -144,7 +145,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
@@ -170,7 +171,7 @@ module Coercion = struct
 	      let env' = push_rel (name', None, a') env in
 	      let c1 = coerce_unify env' (lift 1 a') (lift 1 a) in
 		(* env, x : a' |- c1 : lift 1 a' > lift 1 a *)
-	      let coec1 = app_opt c1 (mkRel 1) in
+	      let coec1 = app_opt env' isevars c1 (mkRel 1) in
 		(* env, x : a' |- c1[x] : lift 1 a *)
 	      let c2 = coerce_unify env' (subst1 coec1 (liftn 1 2 b)) b' in
 		(* env, x : a' |- c2 : b[c1[x]/x]] > b' *)
@@ -180,7 +181,7 @@ module Coercion = struct
 		    Some
 		      (fun f ->
 			mkLambda (name', a',
-				 app_opt c2
+				 app_opt env' isevars c2
 				   (mkApp (Term.lift 1 f, [| coec1 |])))))
 
 	  | App (c, l), App (c', l') ->
@@ -205,7 +206,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
@@ -223,9 +224,9 @@ module Coercion = struct
 				     Some
 				       (fun x ->
 					  let x, y =
-					    app_opt c1 (mkApp (existS.proj1,
+					    app_opt env' isevars c1 (mkApp (existS.proj1,
 							       [| a; pb; x |])),
-					    app_opt c2 (mkApp (existS.proj2,
+					    app_opt env' isevars c2 (mkApp (existS.proj2,
 							       [| a; pb; x |]))
 					  in
 					    mkApp (existS.intro, [| a'; pb'; x ; y |]))
@@ -243,9 +244,9 @@ module Coercion = struct
 				     Some
 				       (fun x ->
 					  let x, y =
-					    app_opt c1 (mkApp (prod.proj1,
+					    app_opt env isevars c1 (mkApp (prod.proj1,
 							       [| a; b; x |])),
-					    app_opt c2 (mkApp (prod.proj2,
+					    app_opt env isevars c2 (mkApp (prod.proj2,
 							       [| a; b; x |]))
 					  in
 					    mkApp (prod.intro, [| a'; b'; x ; y |]))
@@ -279,7 +280,7 @@ module Coercion = struct
 	  Some (u, p) ->
 	    let c = coerce_unify env u y in
 	    let f x =
-	      app_opt c (mkApp ((delayed_force sig_).proj1,
+	      app_opt env isevars c (mkApp ((delayed_force sig_).proj1,
 				[| u; p; x |]))
 	    in Some f
 	| None ->
@@ -288,7 +289,7 @@ module Coercion = struct
 		  let c = coerce_unify env x u in
 		    Some
 		      (fun x ->
-			 let cx = app_opt c x in
+			 let cx = app_opt env isevars c x in
 			 let evar = make_existential loc env isevars (mkApp (p, [| cx |]))
 			 in
 			   (mkApp
@@ -303,7 +304,8 @@ module Coercion = struct
   let coerce_itf loc env isevars v t c1 =
     let evars = ref isevars in
     let coercion = coerce loc env evars t c1 in
-      !evars, Option.map (app_opt coercion) v
+    let t = Option.map (app_opt env evars coercion) v in
+      !evars, t
 
   (* Taken from pretyping/coercion.ml *)
 
@@ -330,8 +332,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 *)
@@ -354,37 +356,39 @@ module Coercion = struct
 		     jres),
 		jres.uj_type)
              (hj,typ_cl) p)
-    with _ -> anomaly "apply_coercion"
+    with e when Errors.noncritical e -> anomaly "apply_coercion"
 
   let inh_app_fun env isevars j =
-    let t = whd_betadeltaiota env ( isevars) j.uj_type in
+    let isevars = ref isevars in
+    let t = hnf env !isevars j.uj_type in
       match kind_of_term t with
-	| Prod (_,_,_) -> (isevars,j)
-	| Evar ev when not (is_defined_evar isevars ev) ->
-	    let (isevars',t) = define_evar_as_product isevars ev in
+	| Prod (_,_,_) -> (!isevars,j)
+	| Evar ev when not (is_defined_evar !isevars ev) ->
+	    let (isevars',t) = define_evar_as_product !isevars ev in
 	      (isevars',{ uj_val = j.uj_val; uj_type = t })
 	| _ ->
        	    (try
       	       let t,p =
-		 lookup_path_to_fun_from env ( isevars) j.uj_type in
-		 (isevars,apply_coercion env ( isevars) p j t)
+		 lookup_path_to_fun_from env !isevars j.uj_type in
+		 (!isevars,apply_coercion env !isevars p j t)
 	     with Not_found ->
 	       try
 		 let coercef, t = mu env isevars t in
-		   (isevars, { uj_val = app_opt coercef j.uj_val; uj_type = t })
+		 let res = { uj_val = app_opt env isevars coercef j.uj_val; uj_type = t } in
+		   (!isevars, res)
 	       with NoSubtacCoercion | NoCoercion ->
-		 (isevars,j))
+		 (!isevars,j))
 
   let inh_tosort_force loc env isevars j =
     try
       let t,p = lookup_path_to_sort_from env ( isevars) j.uj_type in
       let j1 = apply_coercion env ( isevars) p j t in
-	(isevars,type_judgment env (j_nf_evar ( isevars) j1))
+	(isevars, type_judgment env (j_nf_evar ( isevars) j1))
     with Not_found ->
       error_not_a_type_loc loc env ( isevars) j
 
   let inh_coerce_to_sort loc env isevars j =
-    let typ = whd_betadeltaiota env ( isevars) j.uj_type in
+    let typ = hnf env isevars j.uj_type in
       match kind_of_term typ with
 	| Sort s -> (isevars,{ utj_val = j.uj_val; utj_type = s })
 	| Evar ev when not (is_defined_evar isevars ev) ->
@@ -394,15 +398,19 @@ module Coercion = struct
 	    inh_tosort_force loc env isevars j
 
   let inh_coerce_to_base loc env isevars j =
-    let typ = whd_betadeltaiota env ( isevars) j.uj_type in
+    let isevars = ref isevars in
+    let typ = hnf env !isevars j.uj_type in
     let ct, typ' = mu env isevars typ in
-      isevars, { uj_val = app_opt ct j.uj_val;
-		 uj_type = typ' }
+    let res =
+      { uj_val = app_opt env isevars ct j.uj_val;
+	uj_type = typ' }
+    in !isevars, res
 
   let inh_coerce_to_prod loc env isevars t =
-    let typ = whd_betadeltaiota env ( isevars) (snd t) in
+    let isevars = ref isevars in
+    let typ = hnf env !isevars (snd t) in
     let _, typ' = mu env isevars typ in
-      isevars, (fst t, typ')
+      !isevars, (fst t, typ')
 
   let inh_coerce_to_fail env evd rigidonly v t c1 =
     if rigidonly & not (Heads.is_rigid env c1 && Heads.is_rigid env t)
@@ -411,10 +419,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 +438,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. *)
@@ -455,23 +463,23 @@ module Coercion = struct
   (* Look for cj' obtained from cj by inserting coercions, s.t. cj'.typ = t *)
   let inh_conv_coerce_to_gen rigidonly loc env evd cj ((n, t) as _tycon) =
     match n with
-	None ->
-	  let (evd', val') =
-	    try
-	      inh_conv_coerce_to_fail loc env evd rigidonly
-		(Some (nf_evar evd cj.uj_val))
-		(nf_evar evd cj.uj_type) (nf_evar evd t)
-	    with NoCoercion ->
-	      let sigma =  evd in
-		try
-		  coerce_itf loc env evd (Some cj.uj_val) cj.uj_type t
-		with NoSubtacCoercion ->
-		  error_actual_type_loc loc env sigma cj t
-	  in
-	  let val' = match val' with Some v -> v | None -> assert(false) in
-	    (evd',{ uj_val = val'; uj_type = t })
-      | Some (init, cur) ->
-	  (evd, cj)
+    | None ->
+      let cj = { cj with uj_type = hnf_nodelta env evd cj.uj_type } 
+      and t = hnf_nodelta env evd t in
+      let (evd', val') =
+	try
+	  inh_conv_coerce_to_fail loc env evd rigidonly
+	  (Some cj.uj_val) cj.uj_type t
+	with NoCoercion ->
+	(try
+	   coerce_itf loc env evd (Some cj.uj_val) cj.uj_type t
+	 with NoSubtacCoercion ->
+	   error_actual_type_loc loc env evd cj t)
+      in
+      let val' = match val' with Some v -> v | None -> assert(false) in
+	(evd',{ uj_val = val'; uj_type = t })
+    | Some (init, cur) ->
+      (evd, cj)
 
   let inh_conv_coerce_to = inh_conv_coerce_to_gen false
   let inh_conv_coerce_rigid_to = inh_conv_coerce_to_gen true
@@ -498,5 +506,5 @@ module Coercion = struct
 	    with NoSubtacCoercion ->
 	      error_cannot_coerce env' isevars (t, t'))
 	else isevars
-      with _ -> isevars
+      with e when Errors.noncritical e -> isevars
 end
diff --git a/plugins/subtac/subtac_command.ml b/plugins/subtac/subtac_command.ml
index a83611a4..537a8301 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
@@ -248,7 +248,7 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation boxed =
 	  | [(_, None, t); (_, None, u)], Sort (Prop Null)
 	      when Reductionops.is_conv env !isevars t u -> t
 	  | _, _ -> error ()
-      with _ -> error ()
+      with e when Errors.noncritical e -> error ()
   in
   let measure = interp_casted_constr isevars binders_env measure relargty in
   let wf_rel, wf_rel_fun, measure_fn =
@@ -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
@@ -380,9 +380,16 @@ let rec unfold f b =
     | Some (x, b') -> x :: unfold f b'
     | None -> []
 
+
+let find_annot loc id ctx = 
+  try rel_index id ctx
+  with Not_found -> 
+  user_err_loc(loc,"",
+	       str "No parameter named " ++ Nameops.pr_id id ++ str".")
+
 let compute_possible_guardness_evidences (n,_) (_, fixctx) fixtype =
   match n with
-  | Some (loc, n) -> [rel_index n fixctx]
+  | Some (loc, id) -> [find_annot loc id fixctx]
   | None ->
       (* If recursive argument was not given by user, we try all args.
 	 An earlier approach was to look only for inductive arguments,
@@ -417,7 +424,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
@@ -433,7 +440,7 @@ let interp_recursive fixkind l boxed =
       let sort = Retyping.get_type_of env !evdref t in
       let fixprot =
 	try mkApp (delayed_force Subtac_utils.fix_proto, [|sort; t|])
-	with e -> t
+	with e when Errors.noncritical e -> t
       in
 	(id,None,fixprot) :: env')
       [] fixnames fixtypes
@@ -458,7 +465,7 @@ let interp_recursive fixkind l boxed =
   (* Instantiate evars and check all are resolved *)
   let evd = Evarconv.consider_remaining_unif_problems env_rec !evdref in
   let evd = Typeclasses.resolve_typeclasses
-    ~onlyargs:true ~split:true ~fail:false env_rec evd
+    ~filter:Typeclasses.no_goals ~split:true ~fail:false env_rec evd
   in
   let evd = Evarutil.nf_evar_map evd in
   let fixdefs = List.map (nf_evar evd) fixdefs in
@@ -506,7 +513,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 +521,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 80e712e5..d8f46098 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 e when Errors.noncritical e -> assert(false)
+       in (xobl.obl_name, (xobl.obl_type, oblb)) :: acc)
+    deps []
+
 let subst_deps expand obls deps t =
-  let subst =
-    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 (
@@ -384,12 +445,12 @@ let deps_remaining obls deps =
       else x :: acc)
     deps []
 
-let has_dependencies obls n =
-  let res = ref false in
+let dependencies obls n =
+  let res = ref Intset.empty in
     Array.iteri
       (fun i obl ->
 	if i <> n && Intset.mem n obl.obl_deps then
-	  res := true)
+	  res := Intset.add i !res)
       obls;
     !res
 
@@ -437,12 +498,14 @@ 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 when Errors.noncritical e ->
+                    pperror (Errors.print (Cerrors.process_vernac_interp_error e))
 		in
 		  match res with
 		  | Remain n when n > 0 ->
-		      if has_dependencies obls num then
-			ignore(auto_solve_obligations (Some prg.prg_name) None)
+		      let deps = dependencies obls num in
+			if deps <> Intset.empty then
+			  ignore(auto_solve_obligations (Some prg.prg_name) None ~oblset:deps)
 		  | _ -> ());
 	    trace (str "Started obligation " ++ int user_num ++ str "  proof: " ++
 		      Subtac_utils.my_print_constr (Global.env ()) obl.obl_type);
@@ -485,20 +548,25 @@ and solve_obligation_by_tac prg obls i tac =
 	      true
 	  else false
 	with
-	| Compat.Exc_located(_, Proof_type.LtacLocated (_, Refiner.FailError (_, s)))
-	| Compat.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)
-	| e -> false
+	    user_err_loc (fst obl.obl_location, "solve_obligation", Lazy.force s)
+	| Util.Anomaly _ as e -> raise e
+	| e when Errors.noncritical e -> false
 
-and solve_prg_obligations prg tac =
+and solve_prg_obligations prg ?oblset tac =
   let obls, rem = prg.prg_obligations in
   let rem = ref rem in
   let obls' = Array.copy obls in
+  let p = match oblset with
+    | None -> (fun _ -> true)
+    | Some s -> (fun i -> Intset.mem i s)
+  in
   let _ =
     Array.iteri (fun i x ->
-		   if solve_obligation_by_tac prg obls' i tac then
-		     decr rem)
+		 if p i && solve_obligation_by_tac prg obls' i tac then
+		   decr rem)
       obls'
   in
     update_obls prg obls' !rem
@@ -520,9 +588,9 @@ and try_solve_obligation n prg tac =
 and try_solve_obligations n tac =
   try ignore (solve_obligations n tac) with NoObligations _ -> ()
 
-and auto_solve_obligations n tac : progress =
+and auto_solve_obligations n ?oblset tac : progress =
   Flags.if_verbose msgnl (str "Solving obligations automatically...");
-  try solve_prg_obligations (get_prog_err n) tac with NoObligations _ -> Dependent
+  try solve_prg_obligations (get_prog_err n) ?oblset tac with NoObligations _ -> Dependent
 
 open Pp
 let show_obligations_of_prg ?(msg=true) prg =
@@ -556,7 +624,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 +636,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
@@ -599,13 +664,14 @@ let add_mutual_definitions l ?tactic ?(kind=Global,false,Definition) ?(reduce=re
 let admit_obligations n =
   let prg = get_prog_err n in
   let obls, rem = prg.prg_obligations in
+  let obls = Array.copy obls in
     Array.iteri 
       (fun i x ->
 	match x.obl_body with
 	| None ->
             let x = subst_deps_obl obls x in
-	    let kn = Declare.declare_constant x.obl_name (ParameterEntry (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..fac6b567 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-2012     *)
 (*   \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,20 +58,17 @@ 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
   let evd = consider_remaining_unif_problems env !isevars in
 (*   let unevd = undefined_evars evd in *)
-  let unevd' = Typeclasses.resolve_typeclasses ~onlyargs:true ~split:true ~fail:true env evd in
-  let unevd' = Typeclasses.resolve_typeclasses ~onlyargs:false ~split:true ~fail:false env unevd' in
+  let unevd' = Typeclasses.resolve_typeclasses ~filter:Subtac_utils.no_goals_or_obligations ~split:true ~fail:true env evd in
+  let unevd' = Typeclasses.resolve_typeclasses ~filter:Typeclasses.all_evars ~split:true ~fail:false env unevd' in
   let evm =  unevd' in
     isevars := unevd';
     nf_evar evm j.uj_val, nf_evar evm j.uj_type
@@ -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..f0579711 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-2012     *)
 (*   \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,20 +75,20 @@ 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 *)
   let inh_conv_coerce_to_tycon loc env evdref j = function
-    | None -> j_nf_evar !evdref j
+    | None -> j
     | Some t -> evd_comb2 (Coercion.inh_conv_coerce_to loc env) evdref j t
 
   let push_rels vars env = List.fold_right push_rel vars env
@@ -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,18 @@ 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 when Errors.noncritical e -> Loc.raise loc e);
 	      make_judge (mkCoFix cofix) ftys.(i) in
 	inh_conv_coerce_to_tycon loc env evdref fixj tycon
 
-    | 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 =
@@ -325,40 +324,41 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
  	    else tycon
 	  in
 	    match ty with
-	    | Some (_, t) when Subtac_coercion.disc_subset t = None -> ty
+	    | Some (_, t) ->
+	      if Subtac_coercion.disc_subset (whd_betadeltaiota env !evdref t) = None then ty
+	      else None
 	    | _ -> None
 	in
 	let fj = pretype ftycon env evdref lvar f in
- 	let floc = loc_of_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 :=
 			Coercion.inh_conv_coerces_to loc env !evdref resty ty) tycon;
 		      let evd, (_, _, tycon) = split_tycon loc env !evdref tycon in
 		      evdref := evd;
-		      let hj = pretype (mk_tycon (nf_evar !evdref c1)) env evdref lvar c in
+		      let hj = pretype (mk_tycon c1) env evdref lvar c in
 		      let value, typ = applist (j_val resj, [j_val hj]), subst1 hj.uj_val c2 in
-		      let typ' = nf_evar !evdref typ in
 			apply_rec env (n+1)
-			  { uj_val = nf_evar !evdref value;
-			    uj_type = nf_evar !evdref typ' }
-			  (Option.map (fun (abs, c) -> abs, nf_evar !evdref c) tycon) rest
+			{ uj_val = value;
+			  uj_type = typ }
+			  (Option.map (fun (abs, c) -> abs, c) tycon) rest
 
 		  | _ ->
 		      let hj = pretype empty_tycon env evdref lvar c in
 			error_cant_apply_not_functional_loc
-			  (join_loc floc argloc) env ( !evdref)
+			  (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 = apply_rec env 1 fj ftycon args in
 	let resj =
-	  match kind_of_term resj.uj_val with
+	  match kind_of_term (whd_evar !evdref resj.uj_val) with
 	  | App (f,args) when isInd f or isConst f ->
 	      let sigma =  !evdref in
 	      let c = mkApp (f,Array.map (whd_evar sigma) args) in
@@ -367,7 +367,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 +385,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 +434,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 +454,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 +469,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 +494,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,15 +505,14 @@ 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
-	 (*   msgnl (str "Pred is: " ++ Termops.print_constr_env env pred);*)
+	  let pred = nf_evar !evdref pred in
+	  let p = nf_evar !evdref p in
 	  let f cs b =
 	    let n = rel_context_length cs.cs_args in
-	    let pi = lift n pred in (* liftn n 2 pred ? *)
+	    let pi = lift n pred in
 	    let pi = beta_applist (pi, [build_dependent_constructor cs]) in
 	    let csgn =
 	      if not !allow_anonymous_refs then
@@ -527,7 +526,6 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
 		cs.cs_args
 	    in
 	    let env_c = push_rels csgn env in
-(* 	      msgnl (str "Pi is: " ++ Termops.print_constr_env env_c pi); *)
 	    let bj = pretype (mk_tycon pi) env_c evdref lvar b in
 	      it_mkLambda_or_LetIn bj.uj_val cs.cs_args in
 	  let b1 = f cstrs.(0) b1 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 ->
@@ -553,25 +551,14 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
 	    | CastConv (k,t) ->
 		let tj = pretype_type empty_valcon env evdref lvar t in
 		let cj = pretype (mk_tycon tj.utj_val) env evdref lvar c in
-		  (* User Casts are for helping pretyping, experimentally not to be kept*)
-		  (* ... except for Correctness *)
 		let v = mkCast (cj.uj_val, k, tj.utj_val) in
 		  { uj_val = v; uj_type = tj.utj_val }
 	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 +573,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 +586,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 +594,20 @@ 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 ~filter:Subtac_utils.no_goals_or_obligations
+	     ~split:true ~fail:true env !evdref;
+	   evdref := Typeclasses.resolve_typeclasses ~filter:Typeclasses.all_evars
+	     ~split:true ~fail:false env !evdref
+	 with e when Errors.noncritical e ->
+           if fail_evar then raise e else ());
+      evdref := consider_remaining_unif_problems env !evdref;
+      let c = if expand_evar then nf_evar !evdref c' else c' in
+      if fail_evar then check_evars env Evd.empty !evdref c;
+      c
 
   (* TODO: comment faire remonter l'information si le typage a resolu des
      variables du sigma original. il faudrait que la fonction de typage
@@ -654,8 +646,8 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
   let understand_type sigma env c =
     snd (ise_pretype_gen true false true sigma env ([],[]) IsType c)
 
-  let understand_ltac expand_evar sigma env lvar kind c =
-    ise_pretype_gen expand_evar false true sigma env lvar kind c
+  let understand_ltac ?(resolve_classes=false) expand_evar sigma env lvar kind c =
+    ise_pretype_gen expand_evar false resolve_classes sigma env lvar kind c
 
   let understand_tcc ?(resolve_classes=true) sigma env ?expected_type:exptyp c =
     ise_pretype_gen true false resolve_classes sigma env ([],[]) (OfType exptyp) c
diff --git a/plugins/subtac/subtac_utils.ml b/plugins/subtac/subtac_utils.ml
index 362c4ddc..e32bb9e0 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
 
@@ -172,12 +161,11 @@ let print_args env args =
   Array.fold_right (fun a acc -> my_print_constr env a ++ spc () ++ acc) args (str "")
 
 let make_existential loc ?(opaque = Define true) env isevars c =
-  let evar = Evarutil.e_new_evar isevars env ~src:(loc, QuestionMark opaque) c in
-  let (key, args) = destEvar evar in
-    (try trace (str "Constructed evar " ++ int key ++ str " applied to args: " ++
-		  print_args env args ++ str " for type: "++
-		  my_print_constr env c) with _ -> ());
-    evar
+  Evarutil.e_new_evar isevars env ~src:(loc, QuestionMark opaque) c
+
+let no_goals_or_obligations = function
+  | GoalEvar | QuestionMark _ -> false
+  | _ -> true
 
 let make_existential_expr loc env c =
   let key = Evarutil.new_untyped_evar () in
@@ -244,7 +232,7 @@ let build_dependent_sum l =
 	let hyptype = substl names t in
 	  trace (spc () ++ str ("treating evar " ^ string_of_id n));
 	  (try trace (str " assert: " ++ my_print_constr (Global.env ()) hyptype)
-	   with _ -> ());
+	   with e when Errors.noncritical e -> ());
 	let tac = assert_tac (Name n) hyptype in
 	let conttac =
 	  (fun cont ->
@@ -253,7 +241,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
@@ -343,7 +331,7 @@ let destruct_ex ext ex =
 	       Ind i when i = Term.destInd (delayed_force ex_ind) && Array.length args = 2 ->
 		 let (dom, rng) =
 		   try (args.(0), args.(1))
-		   with _ -> assert(false)
+		   with e when Errors.noncritical e -> assert(false)
 		 in
 		 let pi1 = (mk_ex_pi1 dom rng acc) in
 		 let rng_body =
@@ -356,7 +344,7 @@ let destruct_ex ext ex =
       | _ -> [acc]
   in aux ex ext
 
-open Rawterm
+open Glob_term
 
 let id_of_name = function
     Name n -> n
@@ -387,9 +375,9 @@ let solve_by_tac evi t =
       Inductiveops.control_only_guard (Global.env ())
 	const.Entries.const_entry_body;
       const.Entries.const_entry_body
-  with e ->
+  with reraise ->
     Pfedit.delete_current_proof();
-    raise e
+    raise reraise
 
 (* let apply_tac t goal = t goal *)
 
@@ -418,7 +406,6 @@ let string_of_intset d =
 open Printer
 open Ppconstr
 open Nameops
-open Termops
 open Evd
 
 let pr_meta_map evd =
@@ -430,11 +417,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 +432,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 +450,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 +473,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..112b1795 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
 
 
@@ -88,6 +82,7 @@ val app_opt : ('a -> 'a) option -> 'a -> 'a
 val print_args : env -> constr array -> std_ppcmds
 val make_existential : loc -> ?opaque:obligation_definition_status ->
   env -> evar_map ref -> types -> constr
+val no_goals_or_obligations : Typeclasses.evar_filter
 val make_existential_expr : loc -> 'a -> 'b -> constr_expr
 val string_of_hole_kind : hole_kind -> string
 val evars_of_term : evar_map -> evar_map -> constr -> evar_map
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..63b44008 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-2012     *)
 (*   \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
@@ -30,19 +28,21 @@ open Names
 (* Parsing via scopes *)
 (* For example, (nat_of_string "3") is <<(S (S (S O)))>> *)
 
+let threshold = of_int 5000
+
 let nat_of_int dloc n =
   if is_pos_or_zero n then begin
-      if less_than (of_string "5000") n then
+      if less_than threshold n then
 	Flags.if_warn msg_warning
 	  (strbrk "Stack overflow or segmentation fault happens when " ++
 	   strbrk "working with large numbers in nat (observed threshold " ++
 	   strbrk "may vary from 5000 to 70000 depending on your system " ++
 	   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 +58,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 +75,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..b8636a74 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-2012     *)
 (*   \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,30 +46,14 @@ 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) *)
-let n_inlined = of_string "7"
-let bigN_constructor =
- (* converts a bigint into an int the ugly way *)
-  let rec to_int i =
-    if equal i zero then
-      0
-    else
-      let (quo,rem) = div2_with_rest i in
-      if rem then
-	2*(to_int quo)+1
-      else
-	2*(to_int quo)
-  in
-  fun i ->
-  ConstructRef ((bigN_t,0),
-		if less_than i n_inlined then
-		  (to_int i)+1
-		else
-		  (to_int n_inlined)+1
-	       )
+let n_inlined = 7
+
+let bigN_constructor i =
+  ConstructRef ((bigN_t,0),(min i n_inlined)+1)
 
 (*bigZ stuff*)
 let bigZ_module = ["Coq"; "Numbers"; "Integer"; "BigZ"; "BigZ" ]
@@ -100,9 +82,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 +92,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 +109,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,62 +127,61 @@ 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)
 
 
 (*** Parsing for bigN in digital notation ***)
 (* the base for bigN (in Coq) that is 2^31 in our case *)
-let base = pow two (of_string "31")
+let base = pow two 31
 
-(* base of the bigN of height N : *)
-let rank n = pow base (pow two n)
+(* base of the bigN of height N : (2^31)^(2^n) *)
+let rank n =
+  let rec rk n pow2 =
+    if n <= 0 then pow2
+    else rk (n-1) (mult pow2 pow2)
+  in rk n base
 
 (* splits a number bi at height n, that is the rest needs 2^n int31 to be stored
    it is expected to be used only when the quotient would also need 2^n int31 to be
    stored *)
 let split_at n bi =
-  euclid bi (rank (sub_1 n))
+  euclid bi (rank (n-1))
 
 (* search the height of the Coq bigint needed to represent the integer bi *)
 let height bi =
-  let rec height_aux n =
-    if less_than bi (rank n) then
-      n
-    else
-      height_aux (add_1 n)
-  in
-  height_aux zero
-
+  let rec hght n pow2 =
+    if less_than bi pow2 then n
+    else hght (n+1) (mult pow2 pow2)
+  in hght 0 base
 
 (* 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
+    if hgt <= 0 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);
-			   decomp (sub_1 hgt) h;
-			   decomp (sub_1 hgt) l])
+      GApp (dloc, ref_WW, [GHole (dloc, Evd.InternalHole);
+			   decomp (hgt-1) h;
+			   decomp (hgt-1) l])
   in
   decomp hght n
 
 let bigN_of_pos_bigint dloc n =
-  let ref_constructor i = RRef (dloc, bigN_constructor i) in
-  let result h word = RApp (dloc, ref_constructor h, if less_than h n_inlined then
-				                       [word]
-			                             else
-				                      [Nat_syntax.nat_of_int dloc (sub h n_inlined);
-						       word])
+  let h = height n in
+  let ref_constructor = GRef (dloc, bigN_constructor h) in
+  let word = word_of_pos_bigint dloc h n in
+  let args =
+    if h < n_inlined then [word]
+    else [Nat_syntax.nat_of_int dloc (of_int (h-n_inlined));word]
   in
-  let hght = height n in
-  result hght (word_of_pos_bigint dloc hght n)
+  GApp (dloc, ref_constructor, args)
 
 let bigN_error_negative dloc =
   Util.user_err_loc (dloc, "interp_bigN", Pp.str "bigN are only non-negative numbers.")
@@ -217,23 +198,18 @@ 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 ->
-	                                  let hleft = get_height lft in
-					  let hright = get_height rght in
-					  add_1
-					    (if less_than hleft hright then
-						 hright
-					     else
-						 hleft)
-    | _ -> zero
+    | GApp (_,GRef(_,c), [_;lft;rght]) when c = zn2z_WW ->
+      1+max (get_height lft) (get_height rght)
+    | _ -> 0
   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
-	                                                add (mult (rank new_hght)
-                                                          (transform (new_hght) lft))
-	                                            (transform (new_hght) rght)
+    | GApp (_,GRef(_,c),_) when c = zn2z_W0-> zero
+    | GApp (_,GRef(_,c), [_;lft;rght]) when c=zn2z_WW->
+      let new_hght = hght-1 in
+      add (mult (rank new_hght)
+             (transform new_hght lft))
+	(transform new_hght rght)
     | _ -> bigint_of_int31 rc
   in
   fun rc ->
@@ -242,8 +218,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 =
@@ -258,12 +234,12 @@ 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))
+    if i < n_inlined+1 then
+      GRef (Util.dummy_loc, bigN_constructor i)::(build (i+1))
     else
       []
   in
-  build zero
+  build 0
 
 (* Actually declares the interpreter for bigN *)
 let _ = Notation.declare_numeral_interpreter bigN_scope
@@ -276,17 +252,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 +281,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 +302,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..401c23f7 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-2012     *)
 (*   \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..032e0036 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-2012     *)
 (*   \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..a14eda60 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                                    *)
@@ -349,7 +349,7 @@ let acic_of_cic_context' computeinnertypes seed ids_to_terms constr_to_ids
          if computeinnertypes then
 try
           Acic.CicHash.find terms_to_types tt
-with _ ->
+with e when e <> Sys.Break ->
 (*CSC: Warning: it really happens, for example in Ring_theory!!! *)
 Pp.ppnl (Pp.(++) (Pp.str "BUG: this subterm was not visited during the double-type-inference: ") (Printer.pr_lconstr tt)) ; assert false
          else
diff --git a/plugins/xml/doubleTypeInference.ml b/plugins/xml/doubleTypeInference.ml
index d67c114e..c22c16f0 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 ***)
@@ -147,7 +147,8 @@ let double_type_of env sigma cstr expectedty subterms_to_types =
 (*CSC: universes.                                                        *)
 (try
         Typeops.judge_of_type u
- with _ -> (* Successor of a non universe-variable universe anomaly *)
+ with e when e <> Sys.Break ->
+ (* Successor of a non universe-variable universe anomaly *)
  (Pp.ppnl (Pp.str "Warning: universe refresh performed!!!") ; flush stdout ) ;
   Typeops.judge_of_type (Termops.new_univ ())
 )
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..cbc52c5f 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-2012     *)
 (*   \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) =
@@ -109,17 +107,17 @@ let pr_context_xml env =
 
 let pr_subgoal_metas_xml metas env=
   let pr_one (meta, typ) =
-    fnl () ++ str "<meta index=\"" ++ int meta ++ str " type=\"" ++ xmlstream (pr_ltype_env_at_top env typ) ++
+    fnl () ++ str "<meta index=\"" ++ int meta ++ str " type=\"" ++ xmlstream (pr_goal_concl_style_env env typ) ++
       str "\"/>"
   in
   List.fold_left (++) (mt ()) (List.map pr_one metas)
 ;;
 
-let pr_goal_xml 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_goal_concl_style_env 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..867aac71 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                                    *)
@@ -143,7 +143,7 @@ let rec join_dirs cwd =
   | he::tail ->
       (try
         Unix.mkdir cwd 0o775
-       with _ -> () (* Let's ignore the errors on mkdir *)
+       with e when e <> Sys.Break -> () (* Let's ignore the errors on mkdir *)
       ) ;
      let newcwd = cwd ^ "/" ^ he in
       join_dirs newcwd tail
@@ -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..a145508a
--- /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-2012     *)
+(*   \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..a4121623
--- /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-2012     *)
+(*   \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 4205f517..38355cf1 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: cases.ml 15025 2012-03-09 14:27:07Z glondu $ *)
-
+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
 
@@ -99,8 +77,9 @@ let rec list_try_compile f = function
   | [] -> anomaly "try_find_f"
   | h::t ->
       try f h
-      with UserError _ | TypeError _ | PretypeError _
-	| Compat.Exc_located (_,(UserError _ | TypeError _ | PretypeError _)) ->
+      with UserError _ | TypeError _ | PretypeError _ | PatternMatchingError _
+	| Loc.Exc_located
+	    (_, (UserError _ | TypeError _ | PretypeError _ | PatternMatchingError _)) ->
 	    list_try_compile f t
 
 let force_name =
@@ -128,37 +107,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 +133,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 +168,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 +216,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 +290,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 +302,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 +336,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 +432,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 +515,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 +529,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 +540,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 +636,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 +668,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 +686,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 +707,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 +726,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 +767,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 +778,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 +795,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 +809,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 +837,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 +915,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 +931,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 +1084,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 +1097,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 +1116,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 +1210,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 +1219,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 +1231,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 +1245,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 +1363,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 +1376,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 +1417,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 +1459,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 +1548,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 +1570,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 +1634,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 +1667,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 +1687,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 +1741,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 +1750,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 (List.flatten 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 +1802,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..566c172d 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-2012     *)
 (*   \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..9429086c 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-2012     *)
 (*   \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..08e52ff7 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-2012     *)
 (*   \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..ddc99e0e 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-2012     *)
 (*   \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..675ccbbc 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-2012     *)
 (*   \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..86f96c7c 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-2012     *)
 (*   \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 *)
@@ -103,7 +110,7 @@ module Default = struct
 
   let saturate_evd env evd =
     Typeclasses.resolve_typeclasses
-      ~onlyargs:true ~split:true ~fail:false env evd
+      ~filter:Typeclasses.no_goals ~split:true ~fail:false env evd
 
   (* appliquer le chemin de coercions p à hj *)
   let apply_coercion env sigma p hj typ_cl =
@@ -119,7 +126,7 @@ module Default = struct
 		     jres),
 		jres.uj_type)
              (hj,typ_cl) p)
-    with _ -> anomaly "apply_coercion"
+    with e when Errors.noncritical e -> anomaly "apply_coercion"
 
   let inh_app_fun env evd j =
     let t = whd_betadeltaiota env evd j.uj_type in
@@ -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..4c4725b3 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-2012     *)
 (*   \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 fe4354b6..0166b64c 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: detyping.ml 15069 2012-03-20 14:06:07Z 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))
@@ -273,36 +272,36 @@ let is_nondep_branch c n =
   try
     let sign,ccl = decompose_lam_n_assum n c in
     noccur_between 1 (rel_context_length sign) ccl
-  with _ -> (* Not eta-expanded or not reduced *)
+  with e when Errors.noncritical e -> (* Not eta-expanded or not reduced *)
     false
 
 let extract_nondep_branches test c b n =
   let rec strip n r = if n=0 then r else
     match r with
-      | 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,45 @@ 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)
-	 with _ ->
-	  RVar (dl, id))
-    | Sort s -> RSort (dl,detype_sort s)
+	  let _ = Global.lookup_named id in GRef (dl, VarRef id)
+	 with e when Errors.noncritical e ->
+	  GVar (dl, id))
+    | Sort s -> GSort (dl,detype_sort s)
+    | Cast (c1,REVERTcast,c2) when not !Flags.raw_print ->
+        detype isgoal avoid env c1
     | 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 +429,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 +445,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)
@@ -491,7 +492,7 @@ and detype_eqns isgoal avoid env ci computable constructs consnargsl bl =
     let mat = build_tree Anonymous isgoal (avoid,env) ci bl in
     List.map (fun (pat,((avoid,env),c)) -> (dl,[],[pat],detype isgoal avoid env c))
       mat
-  with _ ->
+  with e when Errors.noncritical e ->
     Array.to_list
       (array_map3 (detype_eqn isgoal avoid env) constructs consnargsl bl)
 
@@ -539,9 +540,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
@@ -575,42 +576,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) ->
@@ -621,72 +622,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..cd017ba7 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-2012     *)
 (*   \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..0eed1949 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-2012     *)
 (*   \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_already_stuck = 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 ->
+    | 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]
+
+	| _, _ ->
 	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))
@@ -298,187 +324,217 @@ and evar_eqappr_x env evd pbty (term1,l1 as appr1) (term2,l2 as appr2) =
           (* heuristic: unfold second argument first, exception made
              if the first argument is a beta-redex (expand a constant
              only if necessary) or the second argument is potentially
-             usable as a canonical projection *)
-	  if isLambda flex1 or is_open_canonical_projection i appr2
-	  then
-	    match eval_flexible_term env flex1 with
+             usable as a canonical projection or canonical value *)
+          let rec is_unnamed (hd, args) = match kind_of_term hd with
+            | (Var _|Construct _|Ind _|Const _|Prod _|Sort _) -> false
+            | (Case _|Fix _|CoFix _|Meta _|Rel _)-> true
+            | Evar _ -> false (* immediate solution without Canon Struct *)
+            | Lambda _ -> assert(args = []); true
+            | LetIn (_,b,_,c) -> 
+                is_unnamed (evar_apprec ts env i args (subst1 b c))
+            | App _| Cast _ -> assert false in
+          let rhs_is_stuck_and_unnamed () =
+            match eval_flexible_term ts env flex2 with
+            | None -> false
+            | Some v2 -> is_unnamed (evar_apprec ts env i l2 v2) in
+          let rhs_is_already_stuck =
+            rhs_is_already_stuck || rhs_is_stuck_and_unnamed () in
+	  if isLambda flex1 || rhs_is_already_stuck then
+	    match eval_flexible_term ts env flex1 with
 	    | Some v1 ->
-		evar_eqappr_x env i pbty (evar_apprec env i l1 v1) appr2
+		evar_eqappr_x ~rhs_is_already_stuck 
+                  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)
+	     | e when Errors.noncritical e -> (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
+
+	| (LetIn _ | Cast _), _ -> assert false
+	| _, (LetIn _ | Cast _) -> assert false
 
-	| (Ind _ | Construct _ | Sort _ | Prod _), _ -> (evd,false)
-	| _, (Ind _ | Construct _ | Sort _ | Prod _) -> (evd,false)
+	| (Lambda _ | Rel _ | Var _ | Const _ | Evar _), _ -> assert false
+	| _, (Lambda _ | Rel _ | Var _ | Const _ | Evar _) -> assert false
+      end
 
-	| (App _ | Case _ | Fix _ | CoFix _),
-	  (App _ | Case _ | Fix _ | CoFix _) -> (evd,false)
+    | PseudoRigid _, Rigid _ ->  (evd,false)
 
-	| (Rel _ | Var _ | Const _ | Evar _), _ -> assert false
-	| _, (Rel _ | Var _ | Const _ | Evar _) -> assert false
+    | Rigid _, PseudoRigid _ ->  (evd,false)
 
-and conv_record env evd (c,bs,(params,params1),(us,us2),(ts,ts1),c1,(n,t2)) =
+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 +547,324 @@ 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_already_stuck *)
+let evar_eqappr_x ts env evd pbty appr1 appr2 =
+  evar_eqappr_x ts env evd pbty appr1 appr2
 
 (* We assume here |l1| <= |l2| *)
 
-let first_order_unification 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
-  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 subst' = List.filter (fun (id,c) -> eq_constr c term) subst in
+  if subst' = [] then evd, false else
+  Evd.define evk (mkVar (fst (List.hd subst'))) evd, true
+
+let 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 ty ctxt args =
+  let fv1 = free_rels c in
+  let fv2 = collect_vars c in
+  let tyvars = collect_vars ty in
+  List.map2 (fun (id,_,_) 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 ||
+    Idset.mem id tyvars)
+    ctxt args
+
+let initial_evar_data evi =
+  let ids = List.map pi1 (evar_context evi) in
+  (evar_filter evi, List.map mkVar ids)
+
+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 ty = Retyping.get_type_of env_rhs evd c in
+      let filter' = filter_possible_projections c ty ctxt args in
+      let filter = List.map2 (&&) filter filter' in
+      (id,t,c,ty,evs,filter,occs) :: make_subst (ctxt',l,occsl)
+  | [], [], [] -> []
+  | _ -> anomaly "Signature, instance and occurrences list do not match" in
+
+  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 ->
+      & List.for_all (fun a -> eq_constr a term2 or isEvar a)
+        (remove_instance_local_defs evd evk1 (Array.to_list args1)) ->
       (* The typical kind of constraint coming from pattern-matching return
          type inference *)
-      choose_less_dependent_instance evk1 evd term2 args1, true
+    choose_less_dependent_instance evk1 evd term2 args1
   | (Rel _|Var _), Evar (evk2,args2) when l1 = [] & l2 = []
-      & array_for_all (fun a -> a = term1 or isEvar a) args2 ->
+      & List.for_all (fun a -> eq_constr a term1 or isEvar a)
+        (remove_instance_local_defs evd evk2 (Array.to_list args2)) ->
       (* The typical kind of constraint coming from pattern-matching return
          type inference *)
-      choose_less_dependent_instance evk2 evd term1 args2, true
+    choose_less_dependent_instance evk2 evd term1 args2
+  | Evar (evk1,args1), Evar (evk2,args2) when evk1 = evk2 ->
+      let f env evd pbty x y = (evd,is_trans_fconv pbty ts env evd x y) in
+      solve_refl ~can_drop:true f env evd evk1 args1 args2, true
+  | Evar ev1, Evar ev2 ->
+      solve_evar_evar ~force:true
+        (evar_define (evar_conv_x ts)) (evar_conv_x ts) env evd ev1 ev2, true
   | Evar ev1,_ when List.length l1 <= List.length l2 ->
       (* 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
-
-let consider_remaining_unif_problems env evd =
+      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 max_undefined_with_candidates evd =
+  (* If evar were ordered with highest index first, fold_undefined
+     would be going decreasingly and we could use fold_undefined to
+     find the undefined evar of maximum index (alternatively,
+     max_bindings from ocaml 3.12 could be used); instead we traverse
+     the whole map *)
+  let l = Evd.fold_undefined
+    (fun evk ev_info evars ->
+        match ev_info.evar_candidates with
+        | None -> evars
+        | Some l -> (evk,ev_info,l)::evars) evd [] in
+  match l with
+  | [] -> None
+  | a::l -> Some (list_last (a::l))
+
+let rec solve_unconstrained_evars_with_canditates evd =
+  (* max_undefined is supposed to return the most recent, hence
+     possibly most dependent evar *)
+  match max_undefined_with_candidates evd with
+  | None -> evd
+  | Some (evk,ev_info,l) ->
+      let rec aux = function
+      | [] -> error "Unsolvable existential variables."
+      | a::l ->
+          try
+            let conv_algo = evar_conv_x full_transparent_state in
+            let evd = check_evar_instance evd evk a conv_algo in
+            let evd = Evd.define evk a evd in
+            let evd,b = reconsider_conv_pbs conv_algo evd in
+            if b then solve_unconstrained_evars_with_canditates evd
+            else aux l
+          with e when Pretype_errors.precatchable_exception e ->
+            aux l in
+      (* List.rev is there to favor most dependent solutions *)
+      (* and favor progress when used with the refine tactics *)
+      let evd = aux (List.rev l) in
+      solve_unconstrained_evars_with_canditates evd
+
+let solve_unconstrained_impossible_cases evd =
+  Evd.fold_undefined (fun evk ev_info evd' ->
+    match ev_info.evar_source with
+    | _,ImpossibleCase -> Evd.define evk (j_type (coq_unit_judge ())) evd'
+    | _ -> evd') evd evd
+
+
+let consider_remaining_unif_problems ?(ts=full_transparent_state) env evd =
+  let evd = solve_unconstrained_evars_with_canditates evd in
+  let rec aux evd pbs progress stuck =
+    match pbs with
+    | (pbty,env,t1,t2 as pb) :: pbs ->
+      let evd', b = apply_conversion_problem_heuristic ts env evd pbty t1 t2 in
+	if b then 
+	  let (evd', rest) = extract_all_conv_pbs evd' in
+	    if rest = [] then aux evd' pbs true stuck
+	    else (* Unification got actually stuck, postpone *)
+	      aux evd pbs progress (pb :: stuck)
+	else Pretype_errors.error_cannot_unify env evd (t1, t2)
+    | _ -> 
+	if progress then aux evd stuck false []
+	else 
+	  match stuck with
+	  | [] -> (* We're finished *) evd
+	  | (pbty,env,t1,t2) :: _ ->
+	      (* There remains stuck problems *)
+	      Pretype_errors.error_cannot_unify env evd (t1, t2)
+  in
   let (evd,pbs) = extract_all_conv_pbs evd in
-  List.fold_left
-    (fun evd (pbty,env,t1,t2) ->
-      let evd', b = apply_conversion_problem_heuristic env evd pbty t1 t2 in
-	if b then evd' else Pretype_errors.error_cannot_unify env evd (t1, t2))
-    evd pbs
+  let heuristic_solved_evd = aux evd pbs false [] in
+  check_problems_are_solved env heuristic_solved_evd;
+  solve_unconstrained_impossible_cases 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
-      (evd',true) -> evd := evd'; true
+let e_conv ?(ts=full_transparent_state) env evdref t1 t2 =
+  match evar_conv_x ts env !evdref CONV t1 t2 with
+      (evd',true) -> evdref := evd'; true
     | _ -> false
 
-let e_cumul env evd t1 t2 =
-  match evar_conv_x env !evd CUMUL t1 t2 with
-      (evd',true) -> evd := evd'; true
+let e_cumul ?(ts=full_transparent_state) env evdref t1 t2 =
+  match evar_conv_x ts env !evdref CUMUL t1 t2 with
+      (evd',true) -> evdref := evd'; true
     | _ -> false
diff --git a/pretyping/evarconv.mli b/pretyping/evarconv.mli
index 50228d4e..dd68f16f 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-2012     *)
 (*   \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..fc29ba6c 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-2012     *)
 (*   \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,11 +21,11 @@ open Reductionops
 open Pretype_errors
 open Retyping
 
-open Pretype_errors
-open Retyping
+(****************************************************)
+(* Expanding/testing/exposing existential variables *)
+(****************************************************)
 
-(* Expanding existential variables *)
-(* 1- flush_and_check_evars fails if an existential is undefined *)
+(* flush_and_check_evars fails if an existential is undefined *)
 
 exception Uninstantiated_evar of existential_key
 
@@ -63,11 +61,99 @@ 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
+
+(*-------------------*)
+(* Auxiliary functions for the conversion algorithms modulo evars
+ *)
+
+let has_undefined_evars_or_sorts evd t =
+  let rec has_ev t =
+    match kind_of_term t with
+    | Evar (ev,args) ->
+        (match evar_body (Evd.find evd ev) with
+        | Evar_defined c ->
+            has_ev c; Array.iter has_ev args
+        | Evar_empty ->
+	    raise NotInstantiatedEvar)
+    | Sort s when is_sort_variable evd s -> raise Not_found
+    | _ -> iter_constr has_ev t in
+  try let _ = has_ev t in false
+  with (Not_found | NotInstantiatedEvar) -> true
+
+let is_ground_term evd t =
+  not (has_undefined_evars_or_sorts evd t)
+
+let is_ground_env evd env =
+  let is_ground_decl = function
+      (_,Some b,_) -> is_ground_term evd b
+    | _ -> true in
+  List.for_all is_ground_decl (rel_context env) &&
+  List.for_all is_ground_decl (named_context env)
+(* Memoization is safe since evar_map and environ are applicative
+   structures *)
+let is_ground_env = memo1_2 is_ground_env
+
+(* Return the head evar if any *)
+
+exception NoHeadEvar
+
+let head_evar =
+  let rec hrec c = match kind_of_term c with
+    | Evar (evk,_)   -> evk
+    | Case (_,_,c,_) -> hrec c
+    | App (c,_)      -> hrec c
+    | Cast (c,_,_)   -> hrec c
+    | _              -> raise NoHeadEvar
+  in
+  hrec
+
+(* Expand head evar if any (currently consider only applications but I
+   guess it should consider Case too) *)
+
+let whd_head_evar_stack sigma c =
+  let rec whrec (c, l as s) =
+    match kind_of_term c with
+      | Evar (evk,args as ev) when Evd.is_defined sigma evk
+	  -> whrec (existential_value sigma ev, l)
+      | Cast (c,_,_) -> whrec (c, l)
+      | App (f,args) -> whrec (f, Array.fold_right (fun a l -> a::l) args l)
+      | _ -> s
+  in
+  whrec (c, [])
+
+let whd_head_evar sigma c = applist (whd_head_evar_stack sigma c)
+
+let noccur_evar env evd evk c =
+  let rec occur_rec k c = match kind_of_term c with
+  | Evar (evk',args' as ev') ->
+      (match safe_evar_value evd ev' with
+       | Some c -> occur_rec k c
+       | None ->
+           if evk = evk' then raise Occur else Array.iter (occur_rec k) args')
+  | Rel i when i > k ->
+      (match pi2 (Environ.lookup_rel (i-k) env) with
+       | None -> ()
+       | Some b -> occur_rec k (lift i b))
+  | _ -> iter_constr_with_binders succ occur_rec k c
+  in
+  try occur_rec 0 c; true with Occur -> false
+
+let normalize_evar evd ev =
+  match kind_of_term (whd_evar evd (mkEvar ev)) with
+  | Evar (evk,args) -> (evk,args)
+  | _ -> assert false
 
 (**********************)
 (* Creating new metas *)
@@ -76,6 +162,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 +174,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,9 +206,22 @@ 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
+  (* if an evar has been instantiated in [emap] (as part of typing [c])
+     then it is instantiated in [sigma]. *)
+  let repair_evars sigma emap =
+    fold_undefined begin fun ev _ sigma' ->
+      try
+	let info = find emap ev in
+	match evar_body info with
+	| Evar_empty -> sigma'
+	| Evar_defined body -> define ev body sigma'
+      with Not_found -> sigma'
+    end sigma sigma
+  in
+  let sigma' = repair_evars sigma' emap in
   let change_exist evar =
     let ty = nf_betaiota emap (existential_type emap evar) in
     let n = new_meta() in
@@ -129,15 +232,23 @@ 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
+
+(************************)
+(* Manipulating filters *)
+(************************)
+
+let apply_subfilter filter subfilter =
+  fst (List.fold_right (fun oldb (l,filter) ->
+    if oldb then List.hd filter::l,List.tl filter else (false::l,filter))
+         filter ([], List.rev subfilter))
+
+let extract_subfilter initial_filter refined_filter =
+  snd (list_filter2 (fun b1 b2 -> b1) (initial_filter,refined_filter))
 
 (**********************)
 (* Creating new evars *)
@@ -146,138 +257,16 @@ 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
-  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
-  (evd,mkEvar (newevk,Array.of_list instance))
-
-(* Expand rels and vars that are bound to other rels or vars so that
-   dependencies in variables are canonically associated to the most ancient
-   variable in its family of aliased variables *)
-
-let compute_aliases sign =
-  List.fold_right (fun (id,b,c) aliases ->
-    match b with
-    | Some t ->
-	(match kind_of_term t with
-	| Var id' ->
-	    let id'' = try Idmap.find id' aliases with Not_found -> id' in
-	    Idmap.add id id'' aliases
-	| _ -> aliases)
-    | None -> aliases) sign Idmap.empty
-
-let alias_of_var id aliases = try Idmap.find id aliases with Not_found -> id
-
-let make_alias_map env =
-  let var_aliases = compute_aliases (named_context env) in
-  let rels = rel_context env in
-  let rel_aliases = 
-    snd (List.fold_right (fun (_,b,t) (n,aliases) ->
-      (n-1,
-      match b with
-	| Some t when isRel t or isVar t -> Intmap.add n (lift n t) aliases
-	| _ -> aliases)) rels (List.length rels,Intmap.empty)) in
-  (var_aliases,rel_aliases)
-
-let expand_var_once aliases x = match kind_of_term x with
-  | Rel n -> Intmap.find n (snd aliases)
-  | Var id -> mkVar (Idmap.find id (fst aliases))
-  | _ -> raise Not_found
-
-let rec expand_var_at_least_once aliases x =
-  let t = expand_var_once aliases x in
-  try expand_var_at_least_once aliases t
-  with Not_found -> t
-
-let expand_var aliases x =
-  try expand_var_at_least_once aliases x with Not_found -> x
-
-let expand_var_opt aliases x =
-  try Some (expand_var_at_least_once aliases x) with Not_found -> None
-
-let extend_alias (_,b,_) (var_aliases,rel_aliases) =
-  let rel_aliases =
-    Intmap.fold (fun n c -> Intmap.add (n+1) (lift 1 c))
-      rel_aliases Intmap.empty in
-  let rel_aliases =
-    match b with
-    | Some t when isRel t or isVar t -> Intmap.add 1 (lift 1 t) rel_aliases
-    | _ -> rel_aliases in
-  (var_aliases, rel_aliases)
-
-let rec expand_vars_in_term_using aliases t = match kind_of_term t with
-  | Rel _ | Var _ ->
-      expand_var aliases t
-  | _ ->
-      map_constr_with_full_binders
-	extend_alias expand_vars_in_term_using aliases t
-
-let expand_vars_in_term env = expand_vars_in_term_using (make_alias_map env)
-
-let rec expansions_of_var aliases x =
-  try
-    let t = expand_var_once aliases x in
-    t :: expansions_of_var aliases t
-  with Not_found ->
-    [x]
-
-let expand_full_opt aliases y =
-  try Some (expand_var aliases y) with Not_found -> None
-
-(* Knowing that [Gamma |- ev : T] and that [ev] is applied to [args],
- * [make_projectable_subst ev args] builds the substitution [Gamma:=args].
- * If a variable and an alias of it are bound to the same instance, we skip
- * the alias (we just use eq_constr -- instead of conv --, since anyway,
- * only instances that are variables -- or evars -- are later considered;
- * morever, we can bet that similar instances came at some time from
- * the very same substitution. The removal of aliased duplicates is
- * useful to ensure the uniqueness of a projection.
-*)
-
-let make_projectable_subst aliases sigma evi args =
-  let sign = evar_filtered_context evi in
-  let evar_aliases = compute_aliases sign in
-  snd (List.fold_right
-    (fun (id,b,c) (args,l) ->
-      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)
-	| Some c, a::rest ->
-	    let a = whd_evar sigma a in
-	    (match kind_of_term c with
-	    | Var id' ->
-		let idc = alias_of_var id' evar_aliases in
-		let sub = try Idmap.find idc l with Not_found -> [] in
-		if List.exists (fun (c,_,_) -> eq_constr a c) sub then (rest,l)
-		else
-		  (rest,Idmap.add idc ((a,expand_full_opt aliases a,id)::sub) l)
-	    | _ ->
-		(rest,Idmap.add id [a,expand_full_opt aliases a,id] l))
-	| _ -> anomaly "Instance does not match its signature")
-    sign (array_rev_to_list args,Idmap.empty))
-
-let make_pure_subst evi args =
-  snd (List.fold_right
-    (fun (id,b,c) (args,l) ->
-      match args with
-	| a::rest -> (rest, (id,a)::l)
-	| _ -> anomaly "Instance does not match its signature")
-    (evar_filtered_context evi) (array_rev_to_list args,[]))
-
 (* [push_rel_context_to_named_context] builds the defining context and the
  * initial instance of an evar. If the evar is to be used in context
  *
@@ -322,137 +311,258 @@ 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)
+
+(*------------------------------------*
+ * Entry points to define new evars   *
+ *------------------------------------*)
+
+let default_source = (dummy_loc,InternalHole)
+
+let new_pure_evar evd sign ?(src=default_source) ?filter ?candidates typ =
+  let newevk = new_untyped_evar() in
+  let evd = evar_declare sign newevk typ ~src ?filter ?candidates evd in
+  (evd,newevk)
+
+let new_evar_instance sign evd typ ?src ?filter ?candidates instance =
+  assert (not !Flags.debug ||
+            list_distinct (ids_of_named_context (named_context_of_val sign)));
+  let evd,newevk = new_pure_evar evd sign ?src ?filter ?candidates typ in
+  (evd,mkEvar (newevk,Array.of_list instance))
 
 (* [new_evar] declares a new existential in an env env with type typ *)
 (* Converting the env into the sign of the evar to define *)
 
-let new_evar evd env ?(src=(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 ?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 -> list_filter_with filter instance in
+  new_evar_instance sign evd typ' ?src ?filter ?candidates instance
+
+let new_type_evar ?src ?filter evd env =
+  let evd', s = new_sort_variable evd in
+  new_evar evd' env ?src ?filter (mkSort s)
 
   (* 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
 
 (*------------------------------------*
- * operations on the evar constraints *
+ * Restricting existing evars         *
  *------------------------------------*)
 
-(* 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)
-*)
+let restrict_evar_key evd evk filter candidates =
+  if filter = None && candidates = None then
+    evd,evk
+  else
+    let evi = Evd.find_undefined evd evk in
+    let oldfilter = evar_filter evi in
+    if filter = Some oldfilter && candidates = None then
+      evd,evk
+    else
+    let filter =
+      match filter with
+      | None -> evar_filter evi
+      | Some filter -> filter in
+    let candidates =
+      match candidates with None -> evi.evar_candidates | _ -> candidates in
+    let ccl = evi.evar_concl in
+    let sign = evar_hyps evi in
+    let src = evi.evar_source in
+    let evd,newevk = new_pure_evar evd sign ccl ~src ~filter ?candidates in
+    let ctxt = snd (list_filter2 (fun b c -> b) (filter,evar_context evi)) in
+    let id_inst = Array.of_list (List.map (fun (id,_,_) -> mkVar id) ctxt) in
+    Evd.define evk (mkEvar(newevk,id_inst)) evd,newevk
+
+(* Restrict an applied evar and returns its restriction in the same context *)
+let restrict_applied_evar evd (evk,argsv) filter candidates =
+  let evd,newevk = restrict_evar_key evd evk filter candidates in
+  let newargsv = match filter with
+  | None -> (* optim *) argsv
+  | Some filter ->
+      let evi = Evd.find evd evk in
+      let subfilter = extract_subfilter (evar_filter evi) filter in
+      array_filter_with subfilter argsv in
+  evd,(newevk,newargsv)
+
+(* Restrict an evar in the current evar_map *)
+let restrict_evar evd evk filter candidates =
+  fst (restrict_evar_key evd evk filter candidates)
+
+(* Restrict an evar in the current evar_map *)
+let restrict_instance evd evk filter argsv =
+  match filter with None -> argsv | Some filter ->
+  let evi = Evd.find evd evk in
+  array_filter_with (extract_subfilter (evar_filter evi) filter) argsv
+
+(* 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
+
+(***************************************)
+(* Managing chains of local definitons *)
+(***************************************)
 
+(* Expand rels and vars that are bound to other rels or vars so that
+   dependencies in variables are canonically associated to the most ancient
+   variable in its family of aliased variables *)
 
-(* We have x1..xq |- ?e1 and had to solve something like
- * Σ; Γ |- ?e1[u1..uq] = (...\y1 ... \yk ... c), where c is typically some
- * ?e2[v1..vn], hence flexible. We had to go through k binders and now
- * virtually have x1..xq, y1..yk | ?e1' and the equation
- * Γ, y1..yk |- ?e1'[u1..uq y1..yk] = c.
- * What we do is to formally introduce ?e1' in context x1..xq, Γ, y1..yk,
- * but forbidding it to use the variables of Γ (otherwise said,
- * Γ is here only for ensuring the correct typing of ?e1').
- *
- * 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.
- *)
+let compute_var_aliases sign =
+  List.fold_right (fun (id,b,c) aliases ->
+    match b with
+    | Some t ->
+        (match kind_of_term t with
+        | Var id' ->
+            let aliases_of_id =
+              try Idmap.find id' aliases with Not_found -> [] in
+            Idmap.add id (aliases_of_id@[t]) aliases
+	| _ ->
+            Idmap.add id [t] aliases)
+    | None -> aliases)
+    sign Idmap.empty
+
+let compute_rel_aliases var_aliases rels =
+  snd (List.fold_right (fun (_,b,t) (n,aliases) ->
+    (n-1,
+     match b with
+     | Some t ->
+         (match kind_of_term t with
+         | Var id' ->
+             let aliases_of_n =
+               try Idmap.find id' var_aliases with Not_found -> [] in
+             Intmap.add n (aliases_of_n@[t]) aliases
+         | Rel p ->
+             let aliases_of_n =
+               try Intmap.find (p+n) aliases with Not_found -> [] in
+             Intmap.add n (aliases_of_n@[mkRel (p+n)]) aliases
+         | _ ->
+             Intmap.add n [lift n t] aliases)
+     | None -> aliases))
+         rels (List.length rels,Intmap.empty))
 
-let 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
-  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 filter = evar_filter evi in
-  let newfilter,newargs = subfilter p filter 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 = Evd.define evk newev evd in
-    evd,fst (destEvar newev),newargs
-  else
-    evd,evk,args
+let make_alias_map env =
+  (* We compute the chain of aliases for each var and rel *)
+  let var_aliases = compute_var_aliases (named_context env) in
+  let rel_aliases = compute_rel_aliases var_aliases (rel_context env) in
+  (var_aliases,rel_aliases)
 
-let collect_vars c =
-  let rec collrec acc c =
+let lift_aliases n (var_aliases,rel_aliases as aliases) =
+  if n = 0 then aliases else
+  (var_aliases,
+   Intmap.fold (fun p l -> Intmap.add (p+n) (List.map (lift n) l))
+     rel_aliases Intmap.empty)
+
+let get_alias_chain_of aliases x = match kind_of_term x with
+  | Rel n -> (try Intmap.find n (snd aliases) with Not_found -> [])
+  | Var id -> (try Idmap.find id (fst aliases) with Not_found -> [])
+  | _ -> []
+
+let normalize_alias_opt aliases x =
+  match get_alias_chain_of aliases x with
+  | []  -> None
+  | a::_ when isRel a or isVar a -> Some a
+  | [_] -> None
+  | _::a::_ -> Some a
+
+let normalize_alias aliases x =
+  match normalize_alias_opt aliases x with
+  | Some a -> a
+  | None -> x
+
+let normalize_alias_var var_aliases id =
+  destVar (normalize_alias (var_aliases,Intmap.empty) (mkVar id))
+
+let extend_alias (_,b,_) (var_aliases,rel_aliases) =
+  let rel_aliases =
+    Intmap.fold (fun n l -> Intmap.add (n+1) (List.map (lift 1) l))
+      rel_aliases Intmap.empty in
+  let rel_aliases =
+    match b with
+    | Some t ->
+        (match kind_of_term t with
+        | Var id' ->
+            let aliases_of_binder =
+              try Idmap.find id' var_aliases with Not_found -> [] in
+	    Intmap.add 1 (aliases_of_binder@[t]) rel_aliases
+        | Rel p ->
+            let aliases_of_binder =
+              try Intmap.find (p+1) rel_aliases with Not_found -> [] in
+	    Intmap.add 1 (aliases_of_binder@[mkRel (p+1)]) rel_aliases
+        | _ ->
+            Intmap.add 1 [lift 1 t] rel_aliases)
+    | None -> rel_aliases in
+  (var_aliases, rel_aliases)
+
+let expand_alias_once aliases x =
+  match get_alias_chain_of aliases x with
+  | []  -> None
+  | l -> Some (list_last l)
+
+let rec expansions_of_var aliases x =
+  match get_alias_chain_of aliases x with
+  | [] -> [x]
+  | a::_ as l when isRel a || isVar a -> x :: List.rev l
+  | _::l -> x :: List.rev l
+
+let expansion_of_var aliases x =
+  match get_alias_chain_of aliases x with
+  | [] -> x
+  | a::_ -> a
+
+let rec expand_vars_in_term_using aliases t = match kind_of_term t with
+  | Rel _ | Var _ ->
+      normalize_alias aliases t
+  | _ ->
+      map_constr_with_full_binders
+	extend_alias expand_vars_in_term_using aliases t
+
+let expand_vars_in_term env = expand_vars_in_term_using (make_alias_map env)
+
+let free_vars_and_rels_up_alias_expansion aliases c =
+  let acc1 = ref Intset.empty and acc2 = ref Idset.empty in
+  let cache_rel = ref Intset.empty and cache_var = ref Idset.empty in
+  let is_in_cache depth = function
+    | Rel n -> Intset.mem (n-depth) !cache_rel
+    | Var s -> Idset.mem s !cache_var
+    | _ -> false in
+  let put_in_cache depth = function
+    | Rel n -> cache_rel := Intset.add (n-depth) !cache_rel
+    | Var s -> cache_var := Idset.add s !cache_var
+    | _ -> () in
+  let rec frec (aliases,depth) c =
     match kind_of_term c with
-    | Var id -> list_add_set id acc
-    | _      -> fold_constr collrec acc c
+    | Rel _ | Var _ as ck ->
+      if is_in_cache depth ck then () else begin
+      put_in_cache depth ck;
+      let c = expansion_of_var aliases c in
+        match kind_of_term c with
+        | Var id -> acc2 := Idset.add id !acc2
+        | Rel n -> if n >= depth+1 then acc1 := Intset.add (n-depth) !acc1
+        | _ -> frec (aliases,depth) c end
+    | Const _ | Ind _ | Construct _ ->
+        acc2 := List.fold_right Idset.add (vars_of_global (Global.env()) c) !acc2
+    | _ ->
+        iter_constr_with_full_binders
+          (fun d (aliases,depth) -> (extend_alias d aliases,depth+1))
+          frec (aliases,depth) c
   in
-  collrec [] c
+  frec (aliases,0) c;
+  (!acc1,!acc2)
+
+(************************************)
+(* Removing a dependency in an evar *)
+(************************************)
 
 type clear_dependency_error =
 | OccurHypInSimpleClause of identifier option
@@ -460,6 +570,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 +591,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 +601,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
@@ -495,7 +609,7 @@ let rec check_and_clear_in_constr evdref err ids c =
 		  (* Check if some id to clear occurs in the instance
 		     a of rid in ev and remember the dependency *)
 		  match
-		    List.filter (fun id -> List.mem id ids) (collect_vars a)
+		    List.filter (fun id -> List.mem id ids) (Idset.elements (collect_vars a))
 		  with
 		  | id :: _ -> (hy,ar,(rid,id)::ri)
 		  | _ ->
@@ -521,6 +635,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 +674,270 @@ let clear_hyps_in_evi evdref hyps concl ids =
   in
   (nhyps,nconcl)
 
+(********************************)
+(* Managing pattern-unification *)
+(********************************)
+
+let rec expand_and_check_vars aliases = function
+  | [] -> []
+  | a::l when isRel a or isVar a ->
+      let a = expansion_of_var aliases a in
+      if isRel a or isVar a then a :: expand_and_check_vars aliases l
+      else raise Exit
+  | _ ->
+      raise Exit
+
+module Constrhash = Hashtbl.Make
+  (struct type t = constr
+	  let equal = eq_constr
+	  let hash = hash_constr
+   end)
+
+let rec constr_list_distinct l =
+  let visited = Constrhash.create 23 in
+  let rec loop = function
+    | h::t ->
+	if Constrhash.mem visited h then false
+	else (Constrhash.add visited h h; loop t)
+    | [] -> true
+  in loop l
+
+let get_actual_deps aliases l t =
+  if occur_meta_or_existential t then
+    (* Probably no restrictions on allowed vars in presence of evars *)
+    l
+  else
+    (* Probably strong restrictions coming from t being evar-closed *)
+    let (fv_rels,fv_ids) = free_vars_and_rels_up_alias_expansion aliases t in
+    List.filter (fun c ->
+      match kind_of_term c with
+      | Var id -> Idset.mem id fv_ids
+      | Rel n -> Intset.mem n fv_rels
+      | _ -> assert false) l
+
+let remove_instance_local_defs evd evk args =
+  let evi = Evd.find evd evk in
+  let rec aux = function
+  | (_,Some _,_)::sign, a::args -> aux (sign,args)
+  | (_,None,_)::sign, a::args -> a::aux (sign,args)
+  | [], [] -> []
+  | _ -> assert false in
+  aux (evar_filtered_context evi, args)
+
+(* Check if an applied evar "?X[args] l" is a Miller's pattern *)
+
+let find_unification_pattern_args env l t =
+  if List.for_all (fun x -> isRel x || isVar x) l (* common failure case *) then
+    let aliases = make_alias_map env in
+    match (try Some (expand_and_check_vars aliases l) with Exit -> None) with
+    | Some l as x when constr_list_distinct (get_actual_deps aliases l t) -> x
+    | _ -> None
+  else
+    None
+
+let is_unification_pattern_meta env nb m l t =
+  (* Variables from context and rels > nb are implicitly all there *)
+  (* so we need to be a rel <= nb *)
+  if List.for_all (fun x -> isRel x && destRel x <= nb) l then
+    match find_unification_pattern_args env l t with
+    | Some _ as x when not (dependent (mkMeta m) t) -> x
+    | _ -> None
+  else
+    None
+
+let is_unification_pattern_evar env evd (evk,args) l t =
+  if List.for_all (fun x -> isRel x || isVar x) l & noccur_evar env evd evk t
+  then
+    let args = remove_instance_local_defs evd evk (Array.to_list args) in
+    let n = List.length args in
+    match find_unification_pattern_args env (args @ l) t with
+    | Some l -> Some (list_skipn n l)
+    | _ -> None
+  else
+    None
+
+let is_unification_pattern_pure_evar env evd (evk,args) t =
+  is_unification_pattern_evar env evd (evk,args) [] t <> None
+
+let is_unification_pattern (env,nb) evd f l t =
+  match kind_of_term f with
+  | Meta m -> is_unification_pattern_meta env nb m l t
+  | Evar ev -> is_unification_pattern_evar env evd ev l t
+  | _ -> None
+
+(* From a unification problem "?X l = c", build "\x1...xn.(term1 l2)"
+   (pattern unification). It is assumed that l is made of rel's that
+   are distinct and not bound to aliases. *)
+(* It is also assumed that c does not contain metas because metas
+   *implicitly* depend on Vars but lambda abstraction will not reflect this
+   dependency: ?X x = ?1 (?1 is a meta) will return \_.?1 while it should
+   return \y. ?1{x\y} (non constant function if ?1 depends on x) (BB) *)
+let solve_pattern_eqn env l c =
+  let c' = List.fold_right (fun a c ->
+    let c' = subst_term (lift 1 a) (lift 1 c) in
+    match kind_of_term a with
+      (* Rem: if [a] links to a let-in, do as if it were an assumption *)
+      | Rel n ->
+          let d = map_rel_declaration (lift n) (lookup_rel n env) in
+          mkLambda_or_LetIn d c'
+      | Var id ->
+          let d = lookup_named id env in mkNamedLambda_or_LetIn d c'
+      | _ -> assert false)
+    l c in
+  (* Warning: we may miss some opportunity to eta-reduce more since c'
+     is not in normal form *)
+  whd_eta c'
+
+(*****************************************)
+(* Refining/solving unification problems *)
+(*****************************************)
+
+(* Knowing that [Gamma |- ev : T] and that [ev] is applied to [args],
+ * [make_projectable_subst ev args] builds the substitution [Gamma:=args].
+ * If a variable and an alias of it are bound to the same instance, we skip
+ * the alias (we just use eq_constr -- instead of conv --, since anyway,
+ * only instances that are variables -- or evars -- are later considered;
+ * morever, we can bet that similar instances came at some time from
+ * the very same substitution. The removal of aliased duplicates is
+ * useful to ensure the uniqueness of a projection.
+*)
+
+let make_projectable_subst aliases sigma evi args =
+  let sign = evar_filtered_context evi in
+  let evar_aliases = compute_var_aliases sign in
+  let (_,full_subst,cstr_subst) =
+    List.fold_right
+      (fun (id,b,c) (args,all,cstrs) ->
+        match b,args with
+	| None, a::rest ->
+	    let a = whd_evar sigma a in
+	    let cstrs =
+	      let a',args = decompose_app_vect a in
+	      match kind_of_term a' with
+	      | Construct cstr ->
+		  let l = try Constrmap.find cstr cstrs with Not_found -> [] in
+		  Constrmap.add cstr ((args,id)::l) cstrs
+	      | _ -> cstrs in
+	    (rest,Idmap.add id [a,normalize_alias_opt aliases a,id] all,cstrs)
+	| Some c, a::rest ->
+	    let a = whd_evar sigma a in
+	    (match kind_of_term c with
+	    | Var id' ->
+		let idc = normalize_alias_var evar_aliases id' in
+		let sub = try Idmap.find idc all with Not_found -> [] in
+		if List.exists (fun (c,_,_) -> eq_constr a c) sub then
+		  (rest,all,cstrs)
+		else
+		  (rest,
+		   Idmap.add idc ((a,normalize_alias_opt aliases a,id)::sub) all,
+		   cstrs)
+	    | _ ->
+		(rest,Idmap.add id [a,normalize_alias_opt aliases a,id] all,cstrs))
+	| _ -> anomaly "Instance does not match its signature")
+      sign (array_rev_to_list args,Idmap.empty,Constrmap.empty) in
+  (full_subst,cstr_subst)
+
+let make_pure_subst evi args =
+  snd (List.fold_right
+    (fun (id,b,c) (args,l) ->
+      match args with
+	| a::rest -> (rest, (id,a)::l)
+	| _ -> anomaly "Instance does not match its signature")
+    (evar_filtered_context evi) (array_rev_to_list args,[]))
+
+(*------------------------------------*
+ * operations on the evar constraints *
+ *------------------------------------*)
+
+(* We have a unification problem Σ; Γ |- ?e[u1..uq] = t : s where ?e is not yet
+ * declared in Σ but yet known to be declarable in some context x1:T1..xq:Tq.
+ * [define_evar_from_virtual_equation ... Γ Σ t (x1:T1..xq:Tq) .. (u1..uq) (x1..xq)]
+ * declares x1:T1..xq:Tq |- ?e : s such that ?e[u1..uq] = t holds.
+ *)
+
+let define_evar_from_virtual_equation define_fun env evd t_in_env sign filter inst_in_env =
+  let ty_t_in_env = Retyping.get_type_of env evd t_in_env in
+  let evd,evar_in_env = new_evar_instance sign evd ty_t_in_env ~filter inst_in_env in
+  let t_in_env = whd_evar evd t_in_env in
+  let evd = define_fun env evd (destEvar evar_in_env) t_in_env in
+  let ids = List.map pi1 (named_context_of_val sign) in
+  let inst_in_sign = List.map mkVar (list_filter_with filter ids) in
+  let evar_in_sign = mkEvar (fst (destEvar evar_in_env), Array.of_list inst_in_sign) in
+  (evd,whd_evar evd evar_in_sign)
+
+(* We have x1..xq |- ?e1 : Ï„ and had to solve something like
+ * Σ; Γ |- ?e1[u1..uq] = (...\y1 ... \yk ... c), where c is typically some
+ * ?e2[v1..vn], hence flexible. We had to go through k binders and now
+ * virtually have x1..xq, y1'..yk' | ?e1' : Ï„' and the equation
+ * Γ, y1..yk |- ?e1'[u1..uq y1..yk] = c.
+ * [materialize_evar Γ evd k (?e1[u1..uq]) τ'] extends Σ with the declaration
+ * of ?e1' and returns both its instance ?e1'[x1..xq y1..yk] in an extension
+ * of the context of e1 so that e1 can be instantiated by
+ * (...\y1' ... \yk' ... ?e1'[x1..xq y1'..yk']),
+ * and the instance ?e1'[u1..uq y1..yk] so that the remaining equation
+ * ?e1'[u1..uq y1..yk] = c can be registered
+ *
+ * Note that, because invert_definition does not check types, we need to
+ * guess the types of y1'..yn' by inverting the types of y1..yn along the
+ * substitution u1..uq.
+ *)
+
+let materialize_evar define_fun env evd k (evk1,args1) ty_in_env =
+  let evi1 = Evd.find_undefined evd evk1 in
+  let env1,rel_sign = env_rel_context_chop k env in
+  let sign1 = evar_hyps evi1 in
+  let filter1 = evar_filter evi1 in
+  let ids1 = List.map pi1 (named_context_of_val sign1) in
+  let inst_in_sign = List.map mkVar (list_filter_with filter1 ids1) in
+  let (sign2,filter2,inst2_in_env,inst2_in_sign,_,evd,_) =
+    List.fold_right (fun (na,b,t_in_env as d) (sign,filter,inst_in_env,inst_in_sign,env,evd,avoid) ->
+      let id = next_name_away na avoid in
+      let evd,t_in_sign =
+        define_evar_from_virtual_equation define_fun env evd t_in_env
+          sign filter inst_in_env in
+      let evd,b_in_sign = match b with
+      | None -> evd,None
+      | Some b ->
+          let evd,b = define_evar_from_virtual_equation define_fun env evd b
+            sign filter inst_in_env in
+          evd,Some b in
+      (push_named_context_val (id,b_in_sign,t_in_sign) sign,true::filter,
+       (mkRel 1)::(List.map (lift 1) inst_in_env),
+       (mkRel 1)::(List.map (lift 1) inst_in_sign),
+       push_rel d env,evd,id::avoid))
+      rel_sign
+      (sign1,filter1,Array.to_list args1,inst_in_sign,env1,evd,ids1)
+  in
+  let evd,ev2ty_in_sign =
+    define_evar_from_virtual_equation define_fun env evd ty_in_env
+      sign2 filter2 inst2_in_env in
+  let evd,ev2_in_sign =
+    new_evar_instance sign2 evd ev2ty_in_sign ~filter:filter2 inst2_in_sign in
+  let ev2_in_env = (fst (destEvar ev2_in_sign), Array.of_list inst2_in_env) in
+  (evd, ev2_in_sign, ev2_in_env)
+
+let restrict_upon_filter evd evk p args =
+  let newfilter = List.map p args in
+  if List.for_all (fun id -> id) newfilter then
+    None
+  else
+    let oldfullfilter = evar_filter (Evd.find_undefined evd evk) in
+    Some (apply_subfilter oldfullfilter newfilter)
+
+(* Inverting constructors in instances (common when inferring type of match) *)
+
+let find_projectable_constructor env evd cstr k args cstr_subst =
+  try
+    let l = Constrmap.find cstr cstr_subst in
+    let args = Array.map (lift (-k)) args in
+    let l =
+      List.filter (fun (args',id) ->
+	(* is_conv is maybe too strong (and source of useless computation) *)
+	(* (at least expansion of aliases is needed) *)
+	array_for_all2 (is_conv env evd) args args') l in
+    List.map snd l
+  with Not_found ->
+    []
 
 (* [find_projectable_vars env sigma y subst] finds all vars of [subst]
  * that project on [y]. It is able to find solutions to the following
@@ -586,28 +971,28 @@ let clear_hyps_in_evi evdref hyps concl ids =
  * [make_projectable_subst])
  *)
 
-exception NotUnique
-exception NotUniqueInType of types
-
 type evar_projection =
 | ProjectVar
 | ProjectEvar of existential * evar_info * identifier * evar_projection
 
+exception NotUnique
+exception NotUniqueInType of (identifier * evar_projection) list
+
 let rec assoc_up_to_alias sigma aliases y yc = function
   | [] -> raise Not_found
   | (c,cc,id)::l ->
       let c' = whd_evar sigma c in
-      if 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 +1008,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 +1065,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
 
@@ -712,47 +1097,75 @@ type projectibility_status =
   | CannotInvert
   | Invertible of projectibility_kind
 
-let invert_arg_from_subst aliases k sigma subst_in_env c_in_env_extended_with_k_binders =
+let invert_arg_from_subst evd aliases k0 subst_in_env_extended_with_k_binders c_in_env_extended_with_k_binders =
   let effects = ref [] in
   let rec aux k t =
-    let t = whd_evar sigma t in
+    let t = whd_evar evd t in
     match kind_of_term t with
-    | Rel i when i>k ->
-	project_with_effects aliases sigma effects (mkRel (i-k)) subst_in_env
-    | Var id ->
-	project_with_effects aliases sigma effects t subst_in_env
-    | _ ->
-	map_constr_with_binders succ aux k t in
+    | Rel i when i>k0+k -> aux' k (mkRel (i-k))
+    | Var id -> aux' k t
+    | _ -> map_constr_with_binders succ aux k t
+  and aux' k t =
+    try project_with_effects aliases evd effects t subst_in_env_extended_with_k_binders
+    with Not_found ->
+      match expand_alias_once aliases t with
+      | None -> raise Not_found
+      | Some c -> aux k c in
   try
-    let c = aux k c_in_env_extended_with_k_binders in
+    let c = aux 0 c_in_env_extended_with_k_binders in
     Invertible (UniqueProjection (c,!effects))
   with
     | Not_found -> CannotInvert
     | NotUnique -> Invertible NoUniqueProjection
 
-let invert_arg aliases k sigma evk subst_in_env c_in_env_extended_with_k_binders =
-  let res = invert_arg_from_subst aliases k sigma subst_in_env c_in_env_extended_with_k_binders in
+let invert_arg fullenv evd aliases k evk subst_in_env_extended_with_k_binders c_in_env_extended_with_k_binders =
+  let res = invert_arg_from_subst evd aliases k subst_in_env_extended_with_k_binders c_in_env_extended_with_k_binders in
   match res with
-  | Invertible (UniqueProjection (c,_)) when occur_evar evk c -> CannotInvert
-  | _ -> res
-
+  | Invertible (UniqueProjection (c,_)) when not (noccur_evar fullenv evd evk c)
+      ->
+      CannotInvert
+  | _ ->
+      res
 
 let effective_projections =
   map_succeed (function Invertible c -> c | _ -> failwith"")
 
 let instance_of_projection f env t evd projs =
-  let ty = lazy (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) ->
       (List.fold_left (do_projection_effects f env ty) evd effects, c)
 
-let filter_of_projection = function CannotInvert -> false | _ -> true
+exception NotEnoughInformationToInvert
 
-let filter_along f projs v =
-  let l = Array.to_list v in
-  let _,l = list_filter2 (fun b c -> f b) (projs,l) in
-  Array.of_list l
+let extract_unique_projections projs =
+  List.map (function
+    | Invertible (UniqueProjection (c,_)) -> c
+    | _ ->
+        (* For instance, there are evars with non-invertible arguments and *)
+        (* we cannot arbitrarily restrict these evars before knowing if there *)
+        (* will really be used; it can also be due to some argument *)
+        (* (typically a rel) that is not inversible and that cannot be *)
+        (* inverted either because it is needed for typing the conclusion *)
+        (* of the evar to project *)
+      raise NotEnoughInformationToInvert) projs
+
+let extract_candidates sols =
+  try
+    Some
+      (List.map (function (id,ProjectVar) -> mkVar id | _ -> raise Exit) sols)
+  with Exit ->
+    None
+
+let filter_of_projection = function Invertible _ -> true | _ -> false
+
+let invert_invertible_arg fullenv evd aliases k (evk,argsv) args' =
+  let evi = Evd.find_undefined evd evk in
+  let subst,_ = make_projectable_subst aliases evd evi argsv in
+  let projs =
+    array_map_to_list (invert_arg fullenv evd aliases k evk subst) args' in
+  Array.of_list (extract_unique_projections projs)
 
 (* Redefines an evar with a smaller context (i.e. it may depend on less
  * variables) such that c becomes closed.
@@ -767,7 +1180,26 @@ let filter_along f projs v =
  * such that "hyps' |- ?e : T"
  *)
 
-let restrict_hyps evd evk filter =
+let filter_candidates evd evk filter candidates =
+  let evi = Evd.find_undefined evd evk in
+  let candidates = match candidates with
+  | None -> evi.evar_candidates
+  | Some _ -> candidates in
+  match candidates,filter with
+  | None,_ | _, None -> candidates
+  | Some l, Some filter ->
+      let ids = List.map pi1 (list_filter_with filter (evar_context evi)) in
+      Some (List.filter (fun a ->
+        list_subset (Idset.elements (collect_vars a)) ids) l)
+
+let closure_of_filter evd evk filter =
+  let evi = Evd.find_undefined evd evk in
+  let vars = collect_vars (nf_evar evd (evar_concl evi)) in
+  let test (id,c,_) b = b || Idset.mem id vars || c <> None in
+  let newfilter = List.map2 test (evar_context evi) filter in
+  if newfilter = evar_filter evi then None else Some newfilter
+
+let restrict_hyps evd evk filter candidates =
     (* What to do with dependencies?
        Assume we have x:A, y:B(x), z:C(x,y) |- ?e:T(x,y,z) and restrict on y.
        - If y is in a non-erasable position in C(x,y) (i.e. it is not below an
@@ -778,61 +1210,75 @@ let restrict_hyps evd evk filter =
        interest for this early detection in practice is not obvious. We let
        it for future work. In any case, thanks to the use of filters, the whole
        (unrestricted) context remains consistent. *)
-    let evi = Evd.find evd evk in
-    let env = evar_unfiltered_env evi in
-    let oldfilter = evar_filter evi in
-    let filter,_ = List.fold_right (fun oldb (l,filter) ->
-      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)
-
-let do_restrict_hyps evd evk projs =
-  let filter = List.map filter_of_projection projs in
-  if List.for_all (fun x -> x) filter then
-    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'
-
-(* [postpone_evar_term] postpones an equation of the form ?e[σ] = c *)
-
-let postpone_evar_term env evd (evk,argsv) rhs =
+    let candidates = filter_candidates evd evk (Some filter) candidates in
+    let typablefilter = closure_of_filter evd evk filter in
+    (typablefilter,candidates)
+
+exception EvarSolvedWhileRestricting of evar_map * constr
+
+let do_restrict_hyps evd (evk,args as ev) filter candidates =
+  let filter,candidates = match filter with
+  | None -> None,candidates
+  | Some filter -> restrict_hyps evd evk filter candidates in
+  match candidates,filter with
+  | Some [], _ -> error "Not solvable."
+  | Some [nc],_ ->
+      let evd = Evd.define evk nc evd in
+      raise (EvarSolvedWhileRestricting (evd,whd_evar evd (mkEvar ev)))
+  | None, None -> evd,ev
+  | _ -> restrict_applied_evar evd ev filter candidates
+
+(* [postpone_non_unique_projection] postpones equation of the form ?e[?] = c *)
+(* ?e is assumed to have no candidates *)
+
+let postpone_non_unique_projection env evd (evk,argsv as ev) sols rhs =
   let rhs = expand_vars_in_term env rhs in
-  let evi = Evd.find evd evk in
-  let evd,evk,args =
-    restrict_upon_filter evd evi evk
-      (* Keep only variables that depends in rhs *)
+  let filter =
+    restrict_upon_filter evd evk
+      (* Keep only variables that occur in rhs *)
       (* This is not safe: is the variable is a local def, its body *)
       (* may contain references to variables that are removed, leading to *)
       (* a ill-formed context. We would actually need a notion of filter *)
       (* that says that the body is hidden. Note that expand_vars_in_term *)
       (* expands only rels and vars aliases, not rels or vars bound to an *)
       (* arbitrary complex term *)
-      (fun a -> not (isRel a || isVar a) || dependent a rhs)
+      (fun a -> not (isRel a || isVar a)
+                || dependent a rhs || List.exists (fun (id,_) -> isVarId id a) sols)
       (Array.to_list argsv) in
-  let args = Array.of_list args in
-  let pb = (Reduction.CONV,env,mkEvar(evk,args),rhs) in
-  Evd.add_conv_pb pb evd
+  let filter = match filter with
+  | None -> None
+  | Some filter -> closure_of_filter evd evk filter in
+  let candidates = extract_candidates sols in
+  if candidates <> None then
+    restrict_evar evd evk filter candidates
+  else
+    (* We made an approximation by not expanding a local definition *)
+    let evd,ev = restrict_applied_evar evd ev filter None in
+    let pb = (Reduction.CONV,env,mkEvar ev,rhs) in
+    Evd.add_conv_pb pb evd
 
-(* [postpone_evar_evar] postpones an equation of the form ?e1[σ1] = ?e2[σ2] *)
+(* [postpone_evar_evar] postpones an equation of the form ?e1[?1] = ?e2[?2] *)
 
-let postpone_evar_evar env evd projs1 (evk1,args1) projs2 (evk2,args2) =
+let postpone_evar_evar f env evd filter1 ev1 filter2 ev2 =
   (* Leave an equation between (restrictions of) ev1 andv ev2 *)
-  let args1' = filter_along filter_of_projection projs1 args1 in
-  let evd,evk1' = do_restrict_hyps evd evk1 projs1 in
-  let args2' = filter_along filter_of_projection projs2 args2 in
-  let evd,evk2' = do_restrict_hyps evd evk2 projs2 in
-  let pb = (Reduction.CONV,env,mkEvar(evk1',args1'),mkEvar (evk2',args2')) in
-  add_conv_pb pb evd
+  try
+    let evd,ev1' = do_restrict_hyps evd ev1 filter1 None in
+    try
+      let evd,ev2' = do_restrict_hyps evd ev2 filter2 None in
+      add_conv_pb (Reduction.CONV,env,mkEvar ev1',mkEvar ev2') evd
+    with EvarSolvedWhileRestricting (evd,ev2) ->
+      (* ev2 solved on the fly *)
+      f env evd ev1' ev2
+  with EvarSolvedWhileRestricting (evd,ev1) ->
+    (* ev1 solved on the fly *)
+    f env evd ev2 ev1
 
 (* [solve_evar_evar f Γ Σ ?e1[u1..un] ?e2[v1..vp]] applies an heuristic
  * to solve the equation Σ; Γ ⊢ ?e1[u1..un] = ?e2[v1..vp]:
  * - if there are at most one φj for each vj s.t. vj = φj(u1..un),
- *   we first restrict ?2 to the subset v_k1..v_kq of the vj that are
- *   inversible and we set ?1[x1..xn] := ?2[φk1(x1..xn)..φkp(x1..xn)]
+ *   we first restrict ?e2 to the subset v_k1..v_kq of the vj that are
+ *   inversible and we set ?e1[x1..xn] := ?e2[φk1(x1..xn)..φkp(x1..xn)]
+ *   (this is a case of pattern-unification)
  * - symmetrically if there are at most one ψj for each uj s.t.
  *   uj = ψj(v1..vp),
  * - otherwise, each position i s.t. ui does not occur in v1..vp has to
@@ -850,63 +1296,214 @@ 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 && isVarId id args1.(n) && isVarId id 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))
+	  (isRelN (n1-n) args1.(n) && isRelN (n1-n) args2.(n) && aux2 (n+1))
 	in aux2 n
     | _ -> false in
   n1 = n2 & aux 0 (named_context env)
 
-exception CannotProject of projectibility_status list
+let filter_compatible_candidates conv_algo env evd evi args rhs c =
+  let c' = instantiate_evar (evar_filtered_context evi) c args in
+  let evd, b = conv_algo env evd Reduction.CONV rhs c' in
+  if b then Some (c,evd) else None
+
+exception DoesNotPreserveCandidateRestriction
+
+let restrict_candidates conv_algo env evd filter1 (evk1,argsv1) (evk2,argsv2) =
+  let evi1 = Evd.find evd evk1 in
+  let evi2 = Evd.find evd evk2 in
+  let cand1 = filter_candidates evd evk1 filter1 None in
+  let cand2 = evi2.evar_candidates in
+  match cand1, cand2 with
+  | _, None -> cand1
+  | None, Some _ -> raise DoesNotPreserveCandidateRestriction
+  | Some l1, Some l2 ->
+      let args1 = Array.to_list argsv1 in
+      let args2 = Array.to_list argsv2 in
+      let l1' = List.filter (fun c1 ->
+        let c1' = instantiate_evar (evar_filtered_context evi1) c1 args1 in
+        List.filter (fun c2 ->
+          (filter_compatible_candidates conv_algo env evd evi2 args2 c1' c2
+           <> None)) l2 <> []) l1 in
+      if List.length l1 = List.length l1' then None else Some l1'
+
+exception CannotProject of bool list option
+
+(* Assume that FV(?n[x1:=t1..xn:=tn]) belongs to some set U.
+   Can ?n be instantiated by a term u depending essentially on xi such that the
+   FV(u[x1:=t1..xn:=tn]) are in the set U?
+   - If ti is a variable, it has to be in U.
+   - If ti is a constructor, its parameters cannot be erased even if u
+     matches on it, so we have to discard ti if the parameters
+     contain variables not in U.
+   - If ti is rigid, we have to discard it if it contains variables in U.
+
+  Note: when restricting as part of an equation ?n[x1:=t1..xn:=tn] = ?m[...]
+  then, occurrences of ?m in the ti can be seen, like variables, as occurrences
+  of subterms to eventually discard so as to be allowed to keep ti.
+*)
 
-let 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 rec is_constrainable_in k (ev,(fv_rels,fv_ids) as g) t =
+  let f,args = decompose_app_vect t in
+  match kind_of_term f with
+  | Construct (ind,_) ->
+      let nparams =
+        (fst (Global.lookup_inductive ind)).Declarations.mind_nparams
+      in
+      if nparams > Array.length args
+      then true (* We don't try to be more clever *)
+      else
+        let params,_ = array_chop nparams args in
+        array_for_all (is_constrainable_in k g) params
+  | Ind _ -> array_for_all (is_constrainable_in k g) args
+  | Prod (_,t1,t2) -> is_constrainable_in k g t1 && is_constrainable_in k g t2
+  | Evar (ev',_) -> ev' <> ev (*If ev' needed, one may also try to restrict it*)
+  | Var id -> Idset.mem id fv_ids
+  | Rel n -> n <= k || Intset.mem n fv_rels
+  | Sort _ -> true
+  | _ -> (* We don't try to be more clever *) true
+
+let has_constrainable_free_vars evd aliases k ev (fv_rels,fv_ids as fvs) t =
+  let t = expansion_of_var aliases t in
+  match kind_of_term t with
+  | Var id -> Idset.mem id fv_ids
+  | Rel n -> n <= k || Intset.mem n fv_rels
+  | _ -> is_constrainable_in k (ev,fvs) t
+
+let ensure_evar_independent g env evd (evk1,argsv1 as ev1) (evk2,argsv2 as ev2)=
+  let filter1 =
+    restrict_upon_filter evd evk1 (noccur_evar env evd evk2)
+      (Array.to_list argsv1)
+  in
+  let candidates1 = restrict_candidates g env evd filter1 ev1 ev2 in
+  let evd,(evk1,_ as ev1) = do_restrict_hyps evd ev1 filter1 candidates1 in
+  let filter2 =
+    restrict_upon_filter evd evk2 (noccur_evar env evd evk1)
+      (Array.to_list argsv2)
+  in
+  let candidates2 = restrict_candidates g env evd filter2 ev2 ev1 in
+  let evd,ev2 = do_restrict_hyps evd ev2 filter2 candidates2 in
+  evd,ev1,ev2
+
+exception EvarSolvedOnTheFly of evar_map * constr
+
+let project_evar_on_evar g env evd aliases k2 (evk1,argsv1 as ev1) (evk2,argsv2 as ev2) =
+  (* Apply filtering on ev1 so that fvs(ev1) are in fvs(ev2). *)
+  let fvs2 = free_vars_and_rels_up_alias_expansion aliases (mkEvar ev2) in
+  let filter1 = restrict_upon_filter evd evk1
+    (has_constrainable_free_vars evd aliases k2 evk2 fvs2)
+    (Array.to_list argsv1) in
+  (* Only try pruning on variable substitutions, postpone otherwise. *)
+  (* Rules out non-linear instances. *)
+  if is_unification_pattern_pure_evar env evd ev2 (mkEvar ev1) then
+    try
+      let candidates1 = restrict_candidates g env evd filter1 ev1 ev2 in
+      let evd,(evk1',args1) = do_restrict_hyps evd ev1 filter1 candidates1 in
+      evd,mkEvar (evk1',invert_invertible_arg env evd aliases k2 ev2 args1)
+    with
+    | EvarSolvedWhileRestricting (evd,ev1) ->
+        raise (EvarSolvedOnTheFly (evd,ev1))
+    | DoesNotPreserveCandidateRestriction | NotEnoughInformationToInvert ->
+        raise (CannotProject filter1)
+  else
+    raise (CannotProject filter1)
+
+let solve_evar_evar_l2r f g env evd aliases ev1 (evk2,_ as ev2) =
+  try
+    let evd,body = project_evar_on_evar g env evd aliases 0 ev1 ev2 in
+    Evd.define evk2 body evd
+  with EvarSolvedOnTheFly (evd,c) ->
+    f env evd ev2 c
+
+let solve_evar_evar ?(force=false) f g env evd (evk1,args1 as ev1) (evk2,args2 as ev2) =
   if are_canonical_instances args1 args2 env then
     (* If instances are canonical, we solve the problem in linear time *)
     let sign = evar_filtered_context (Evd.find evd evk2) in
-    let subst = List.map (fun (id,_,_) -> mkVar id) sign in
-    Evd.define evk2 (mkEvar(evk1,Array.of_list subst)) evd
+    let id_inst = list_map_to_array (fun (id,_,_) -> mkVar id) sign in
+    Evd.define evk2 (mkEvar(evk1,id_inst)) 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)
-
-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
-
-(* Solve pbs (?i x1..xn) = (?i y1..yn) which arises often in fixpoint
- * definitions. We try to unify the xi with the yi pairwise. The pairs
- * that don't unify are discarded (i.e. ?i is redefined so that it does not
+    let evd,ev1,ev2 =
+      (* If an evar occurs in the instance of the other evar and the
+         use of an heuristic is forced, we restrict *)
+      if force then ensure_evar_independent g env evd ev1 ev2 else (evd,ev1,ev2) in
+    let aliases = make_alias_map env in
+    try solve_evar_evar_l2r f g env evd aliases ev1 ev2
+    with CannotProject filter1 ->
+    try solve_evar_evar_l2r f g env evd aliases ev2 ev1
+    with CannotProject filter2 ->
+    postpone_evar_evar f env evd filter1 ev1 filter2 ev2
+
+type conv_fun =
+  env ->  evar_map -> conv_pb -> constr -> constr -> evar_map * bool
+
+let check_evar_instance evd evk1 body conv_algo =
+  let evi = Evd.find evd evk1 in
+  let evenv = evar_unfiltered_env evi in
+  (* FIXME: The body might be ill-typed when this is called from w_merge *)
+  let ty =
+    try Retyping.get_type_of evenv evd body
+    with e when Errors.noncritical e -> error "Ill-typed evar instance"
+  in
+  let evd,b = conv_algo evenv evd Reduction.CUMUL ty evi.evar_concl in
+  if b then evd else
+    user_err_loc (fst (evar_source evk1 evd),"",
+		  str "Unable to find a well-typed instantiation")
+
+(* Solve pbs ?e[t1..tn] = ?e[u1..un] which arise often in fixpoint
+ * definitions. We try to unify the ti with the ui pairwise. The pairs
+ * that don't unify are discarded (i.e. ?e is redefined so that it does not
  * depend on these args). *)
 
-let solve_refl conv_algo env evd evk argsv1 argsv2 =
-  if argsv1 = argsv2 then evd else
-  let evi = Evd.find evd evk in
+let solve_refl ?(can_drop=false) conv_algo env evd evk argsv1 argsv2 =
+  if array_equal eq_constr argsv1 argsv2 then evd else
   (* Filter and restrict if needed *)
-  let evd,evk,args =
-    restrict_upon_filter evd evi evk
+  let untypedfilter =
+    restrict_upon_filter evd evk
       (fun (a1,a2) -> snd (conv_algo env evd Reduction.CONV a1 a2))
       (List.combine (Array.to_list argsv1) (Array.to_list argsv2)) in
+  let candidates = filter_candidates evd evk untypedfilter None in
+  let filter = match untypedfilter with
+    | None -> None
+    | Some filter -> closure_of_filter evd evk filter in
+  let evd,ev1 = restrict_applied_evar evd (evk,argsv1) filter candidates in
+  if fst ev1 = evk & can_drop then (* No refinement *) evd else
+    (* either progress, or not allowed to drop, e.g. to preserve possibly *)
+    (* informative equations such as ?e[x:=?y]=?e[x:=?y'] where we don't know *)
+    (* if e can depend on x until ?y is not resolved, or, conversely, we *)
+    (* don't know if ?y has to be unified with ?y, until e is resolved *)
+  let argsv2 = restrict_instance evd evk filter argsv2 in
+  let ev2 = (fst ev1,argsv2) in
   (* Leave a unification problem *)
-  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 (Reduction.CONV,env,mkEvar ev1,mkEvar ev2) evd
+
+(* If the evar can be instantiated by a finite set of candidates known
+   in advance, we check which of them apply *)
+
+exception NoCandidates
+
+let solve_candidates conv_algo env evd (evk,argsv as ev) rhs =
+  let evi = Evd.find evd evk in
+  let args = Array.to_list argsv in
+  match evi.evar_candidates with
+  | None -> raise NoCandidates
+  | Some l ->
+      let l' =
+        list_map_filter
+          (filter_compatible_candidates conv_algo env evd evi args rhs) l in
+      match l' with
+      | [] -> error_cannot_unify env evd (mkEvar ev, rhs)
+      | [c,evd] ->
+          (* solve_candidates might have been called recursively in the mean *)
+          (* time and the evar been solved by the filtering process *)
+          if Evd.is_undefined evd evk then Evd.define evk c evd else evd
+      | l when List.length l < List.length l' ->
+          let candidates = List.map fst l in
+          restrict_evar evd evk None (Some candidates)
+      | l -> evd
 
 (* We try to instantiate the evar assuming the body won't depend
  * on arguments that are not Rels or Vars, or appearing several times
@@ -925,22 +1522,22 @@ 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)
  *)
 
 exception NotInvertibleUsingOurAlgorithm of constr
-exception NotEnoughInformationToProgress
+exception NotEnoughInformationToProgress of (identifier * evar_projection) list
 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 =
@@ -951,67 +1548,120 @@ let rec invert_definition choose env evd (evk,argsv as ev) rhs =
 	| [] -> raise Not_found
 	| [id,p] -> (mkVar id, p)
 	| (id,p)::_::_ ->
-	    if choose then (mkVar id, p)
-	    else raise (NotUniqueInType(find_solution_type (evar_env evi) sols))
+	    if choose then (mkVar id, p) else raise (NotUniqueInType sols)
       in
       let ty = lazy (Retyping.get_type_of env !evdref t) in
-      let evd = do_projection_effects evar_define env ty !evdref p in
+      let evd = do_projection_effects (evar_define conv_algo) env ty !evdref p in
       evdref := evd;
       c
     with
       | Not_found -> raise (NotInvertibleUsingOurAlgorithm t)
-      | NotUniqueInType ty ->
-	  if not !progress then raise NotEnoughInformationToProgress;
+      | NotUniqueInType sols ->
+	  if not !progress then
+            raise (NotEnoughInformationToProgress sols);
 	  (* No unique projection but still restrict to where it is possible *)
+          (* materializing is necessary, but is restricting useful? *)
+          let ty = find_solution_type (evar_env evi) sols in
+          let sign = evar_filtered_context evi in
+          let ty' = instantiate_evar sign ty (Array.to_list argsv) in
+	  let (evd,evar,(evk',argsv' as ev')) =
+            materialize_evar (evar_define conv_algo) env !evdref 0 ev ty' in
 	  let ts = expansions_of_var aliases t in
 	  let test c = isEvar c or List.mem c ts in
-	  let filter = array_map_to_list test argsv in
-	  let 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
-	  evdref := Evd.add_conv_pb pb evd;
+	  let filter = array_map_to_list test argsv' in
+          let filter = apply_subfilter (evar_filter (Evd.find_undefined evd evk)) filter in
+
+          let filter = closure_of_filter evd evk' filter in
+          let candidates = extract_candidates sols in
+          let evd =
+            if candidates <> None then restrict_evar evd evk' filter candidates
+            else
+              let evd,ev'' = restrict_applied_evar evd ev' filter None in
+              Evd.add_conv_pb (Reduction.CONV,env,mkEvar ev'',t) evd in
+          evdref := evd;
 	  evar in
 
   let rec imitate (env',k as envk) t =
     let t = whd_evar !evdref t in
     match kind_of_term t with
-    | Rel i when i>k -> project_variable (mkRel (i-k))
-    | Var id -> project_variable t
+    | Rel i when i>k ->
+        (match pi2 (Environ.lookup_rel (i-k) env') with
+        | None -> project_variable (mkRel (i-k))
+        | Some b ->
+          try project_variable (mkRel (i-k))
+          with NotInvertibleUsingOurAlgorithm _ -> imitate envk (lift i b))
+    | Var id ->
+        (match pi2 (Environ.lookup_named id env') with
+        | None -> project_variable t
+        | Some b ->
+          try project_variable t
+          with NotInvertibleUsingOurAlgorithm _ -> imitate envk b)
     | Evar (evk',args' as ev') ->
         if evk = evk' then raise (OccurCheckIn (evd,rhs));
 	(* Evar/Evar problem (but left evar is virtual) *)
-	let projs' =
-	  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
+        let aliases = lift_aliases k aliases in
+        (try
+          let ev = (evk,Array.map (lift k) argsv) in
+          let evd,body = project_evar_on_evar conv_algo env' !evdref aliases k ev'  ev in
 	  evdref := evd;
-	  mkEvar (evk',Array.of_list args')
-	with NotUnique ->
+          body
+        with
+        | EvarSolvedOnTheFly (evd,t) -> evdref:=evd; imitate envk t
+        | CannotProject filter' ->
 	  assert !progress;
 	  (* Make the virtual left evar real *)
-	  let (evar'',ev'') = extend_evar env' evdref k ev t in
+	  let ty = get_type_of env' !evdref t in
+	  let (evd,evar'',ev'') =
+             materialize_evar (evar_define conv_algo) env' !evdref k ev ty in
+          (* materialize_evar may instantiate ev' by another evar; adjust it *)
+          let (evk',args' as ev') = normalize_evar evd ev' in
 	  let evd =
-	    (* Try to project (a restriction of) the left evar ... *)
-	    try 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
+	     (* Try to project (a restriction of) the left evar ... *)
+	    try
+              let evd,body = project_evar_on_evar conv_algo env' evd aliases 0 ev'' ev' in
+              Evd.define evk' body evd
+	    with
+            | EvarSolvedOnTheFly _ -> assert false (* ev has no candidates *)
+            | CannotProject filter'' ->
+	      (* ... or postpone the problem *)
+	      postpone_evar_evar (evar_define conv_algo) env' evd filter'' ev'' filter' ev' in
 	  evdref := evd;
 	  evar'')
     | _ ->
-	progress := true;
-	(* 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
+        progress := true;
+	match
+	  let c,args = decompose_app_vect t in
+	  match kind_of_term c with
+	  | Construct cstr when noccur_between 1 k t ->
+	    (* This is common case when inferring the return clause of match *)
+	    (* (currently rudimentary: we do not treat the case of multiple *)
+            (*  possible inversions; we do not treat overlap with a possible *)
+            (*  alternative inversion of the subterms of the constructor, etc)*)
+	    (match find_projectable_constructor env evd cstr k args cstr_subst with
+	     | _::_ as l -> Some (List.map mkVar l)
+	     | _ -> None)
+	  | _ -> None
+	with
+	| Some l ->
+            let ty = get_type_of env' !evdref t in
+            let candidates =
+              try
+                let t =
+                  map_constr_with_full_binders (fun d (env,k) -> push_rel d env, k+1)
+	            imitate envk t in
+                t::l
+              with e when Errors.noncritical e -> l in
+            (match candidates with
+            | [x] -> x
+            | _ ->
+	      let (evd,evar'',ev'') =
+                materialize_evar (evar_define conv_algo) env' !evdref k ev ty in
+              evdref := restrict_evar evd (fst ev'') None (Some candidates);
+              evar'')
+	| None ->
+	  (* Evar/Rigid problem (or assimilated if not normal): we "imitate" *)
+	    map_constr_with_full_binders (fun d (env,k) -> push_rel d env, k+1)
+	      imitate envk t in
 
   let rhs = whd_beta evd rhs (* heuristic *) in
   let body = imitate (env,0) rhs in
@@ -1024,15 +1674,19 @@ 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 ~can_drop:choose conv_algo env evd evk argsv argsv2
+      else
+        solve_evar_evar ~force:choose
+          (evar_define conv_algo) conv_algo env evd ev ev2
+  | _ ->
+  try solve_candidates conv_algo env evd ev rhs
+  with NoCandidates ->
   try
-    let (evd',body) = invert_definition 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,10 +1709,11 @@ 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
+    | NotEnoughInformationToProgress sols ->
+	postpone_non_unique_projection env evd ev sols rhs
     | NotInvertibleUsingOurAlgorithm t ->
 	error_not_clean env evd evk t (evar_source evk evd)
     | OccurCheckIn (evd,rhs) ->
@@ -1072,138 +1727,6 @@ and evar_define ?(choose=false) env (evk,argsv as ev) rhs evd =
 	| _ ->
 	    error_occur_check env evd evk rhs
 
-(*-------------------*)
-(* Auxiliary functions for the conversion algorithms modulo evars
- *)
-
-let has_undefined_evars_or_sorts evd t =
-  let rec has_ev t =
-    match kind_of_term t with
-    | Evar (ev,args) ->
-        (match evar_body (Evd.find evd ev) with
-        | Evar_defined c ->
-            has_ev c; Array.iter has_ev args
-        | Evar_empty ->
-	    raise NotInstantiatedEvar)
-    | Sort s when is_sort_variable evd s -> raise Not_found
-    | _ -> iter_constr has_ev t in
-  try let _ = has_ev t in false
-  with (Not_found | NotInstantiatedEvar) -> true
-
-let is_ground_term evd t =
-  not (has_undefined_evars_or_sorts evd t)
-
-let is_ground_env evd env =
-  let is_ground_decl = function
-      (_,Some b,_) -> is_ground_term evd b
-    | _ -> true in
-  List.for_all is_ground_decl (rel_context env) &&
-  List.for_all is_ground_decl (named_context env)
-(* Memoization is safe since evar_map and environ are applicative
-   structures *)
-let is_ground_env = memo1_2 is_ground_env
-
-(* Return the head evar if any *)
-
-exception NoHeadEvar
-
-let head_evar =
-  let rec hrec c = match kind_of_term c with
-    | Evar (evk,_)   -> evk
-    | Case (_,_,c,_) -> hrec c
-    | App (c,_)      -> hrec c
-    | Cast (c,_,_)   -> hrec c
-    | _              -> raise NoHeadEvar
-  in
-  hrec
-
-(* Expand head evar if any (currently consider only applications but I
-   guess it should consider Case too) *)
-
-let whd_head_evar_stack sigma c =
-  let rec whrec (c, l as s) =
-    match kind_of_term c with
-      | Evar (evk,args as ev) when Evd.is_defined sigma evk
-	  -> whrec (existential_value sigma ev, l)
-      | Cast (c,_,_) -> whrec (c, l)
-      | App (f,args) -> whrec (f, Array.fold_right (fun a l -> a::l) args l)
-      | _ -> s
-  in
-  whrec (c, [])
-
-let whd_head_evar sigma c = applist (whd_head_evar_stack sigma c)
-
-(* Check if an applied evar "?X[args] l" is a Miller's pattern; note
-   that we don't care whether args itself contains Rel's or even Rel's
-   distinct from the ones in l *)
-
-let rec expand_and_check_vars env = 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
-
-let is_unification_pattern_evar env (_,args) l t =
-  List.for_all (fun x -> isRel x || isVar x) l (* common failure case *)
-  &&
-    let aliases = make_alias_map env in
-    let l' = Array.to_list args @ l in
-    let l'' = try Some (expand_and_check_vars 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
-
-(* From a unification problem "?X l1 = term1 l2" such that l1 is made
-   of distinct rel's, build "\x1...xn.(term1 l2)" (patterns unification) *)
-(* NB: does not work when (term1 l2) contains metas because metas
-   *implicitly* depend on Vars but lambda abstraction will not reflect this
-   dependency: ?X x = ?1 (?1 is a meta) will return \_.?1 while it should
-   return \y. ?1{x\y} (non constant function if ?1 depends on x) (BB) *)
-let solve_pattern_eqn env l1 c =
-  let l1 = List.map (expand_var (make_alias_map env)) l1 in
-  let c' = List.fold_right (fun a c ->
-    let c' = subst_term (lift 1 a) (lift 1 c) in
-    match kind_of_term a with
-      (* Rem: if [a] links to a let-in, do as if it were an assumption *)
-      | Rel n -> let (na,_,t) = lookup_rel n env in mkLambda (na,lift n t,c')
-      | Var id -> let (id,_,t) = lookup_named id env in mkNamedLambda id t c'
-      | _ -> assert false)
-    l1 c in
-  (* Warning: we may miss some opportunity to eta-reduce more since c'
-     is not in normal form *)
-  whd_eta c'
-
 (* This code (i.e. solve_pb, etc.) takes a unification
  * problem, and tries to solve it. If it solves it, then it removes
  * all the conversion problems, and re-runs conversion on each one, in
@@ -1234,23 +1757,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 +1773,75 @@ 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 evars on which goals depend. *)
+let queue_set q is_dependent set =
+  Intset.iter (fun a -> Queue.push (is_dependent,a) q) set
+let queue_term q is_dependent c =
+  queue_set q is_dependent (evars_of_term c)
+
+let process_dependent_evar q acc evm is_dependent e =
+  let evi = Evd.find evm e in
+  (* Queues evars appearing in the types of the goal (conclusion, then
+     hypotheses), they are all dependent. *)
+  queue_term q true evi.evar_concl;
+  List.iter begin fun (_,b,t) ->
+    queue_term q true t;
+    match b with
+    | None -> ()
+    | Some b -> queue_term q true b
+  end (Environ.named_context_of_val evi.evar_hyps);
+  match evi.evar_body with
+  | Evar_empty ->
+      if is_dependent then Intmap.add e None acc else acc
+  | Evar_defined b ->
+      let subevars = evars_of_term b in
+      (* evars appearing in the definition of an evar [e] are marked
+         as dependent when [e] is dependent itself: if [e] is a
+         non-dependent goal, then, unless they are reach from another
+         path, these evars are just other non-dependent goals. *)
+      queue_set q is_dependent subevars;
+      if is_dependent then Intmap.add e (Some subevars) acc else acc
+
+let gather_dependent_evars q evm =
+  let acc = ref Intmap.empty in
+  while not (Queue.is_empty q) do
+    let (is_dependent,e) = Queue.pop q in
+    (* checks if [e] has already been added to [!acc] *)
+    begin if not (Intmap.mem e !acc) then
+        acc := process_dependent_evar q !acc evm is_dependent e  
+    end
+  done;
+  !acc
+
+let gather_dependent_evars evm l =
+  let q = Queue.create () in
+  List.iter (fun a -> Queue.add (false,a) q) l;
+  gather_dependent_evars q evm
+
+(* /spiwack *)
 
 let evars_of_named_context nc =
   List.fold_right (fun (_, b, t) s ->
@@ -1322,36 +1858,64 @@ 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 *)
+(****************************************)
 
 type type_constraint_type = (int * int) option * constr
 type type_constraint = type_constraint_type option
@@ -1390,44 +1954,92 @@ 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 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 +2055,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..591a008c 100644
--- a/pretyping/evarutil.mli
+++ b/pretyping/evarutil.mli
@@ -1,117 +1,150 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*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 : ?can_drop:bool -> conv_fun -> env ->  evar_map ->
+  existential_key -> constr array -> constr array -> evar_map
+val solve_evar_evar : ?force:bool ->
+  (env -> evar_map -> existential -> constr -> evar_map) -> conv_fun ->
+  env ->  evar_map -> existential -> existential -> evar_map
+
+val solve_simple_eqn : conv_fun -> ?choose:bool -> env ->  evar_map ->
+  bool option * existential * constr -> evar_map * bool
+val reconsider_conv_pbs : conv_fun -> evar_map -> evar_map * bool
+
+(** [check_evars env initial_sigma extended_sigma c] fails if some
    new unresolved evar remains in [c] *)
 val check_evars : env -> evar_map -> evar_map -> constr -> unit
 
-val 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
+
 val evars_of_named_context : named_context -> Intset.t
 val evars_of_evar_info : evar_info -> Intset.t
 
-(***********************************************************)
-(* Value/Type constraints *)
+(** [gather_dependent_evars evm seeds] classifies the evars in [evm]
+    as dependent_evars and goals (these may overlap). A goal is an
+    evar in [seeds] or an evar appearing in the (partial) definition
+    of a goal. A dependent evar is an evar appearing in the type
+    (hypotheses and conclusion) of a goal, or in the type or (partial)
+    definition of a dependent evar.  The value return is a map
+    associating to each dependent evar [None] if it has no (partial)
+    definition or [Some s] if [s] is the list of evars appearing in
+    its (partial) definition. *)
+val gather_dependent_evars : evar_map -> evar list -> (Intset.t option) Intmap.t
+
+(** 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 +172,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 +184,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 +215,19 @@ 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
+
+val remove_instance_local_defs : evar_map -> existential_key -> constr list -> constr list
diff --git a/pretyping/evd.ml b/pretyping/evd.ml
index 2db77837..4d9eb897 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-2012     *)
 (*   \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
@@ -67,9 +67,12 @@ let evar_hyps evi = evi.evar_hyps
 let evar_context evi = named_context_of_val evi.evar_hyps
 let evar_body evi = evi.evar_body
 let evar_filter evi = evi.evar_filter
-let evar_unfiltered_env evi = Global.env_of_context evi.evar_hyps
 let evar_filtered_context evi =
   snd (list_filter2 (fun b c -> b) (evar_filter evi,evar_context evi))
+let evar_filtered_hyps evi =
+  List.fold_right push_named_context_val (evar_filtered_context evi)
+    empty_named_context_val
+let evar_unfiltered_env evi = Global.env_of_context evi.evar_hyps
 let evar_env evi =
   List.fold_right push_named (evar_filtered_context evi)
     (reset_context (Global.env()))
@@ -81,10 +84,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 +96,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, ExistentialMap.empty
+
+  let is_empty (d,u) = ExistentialMap.is_empty d && ExistentialMap.is_empty u
 
-  let empty = ExistentialMap.empty
+  let has_undefined (_,u) = not (ExistentialMap.is_empty u)
 
-  let to_list evc = (* Workaround for change in Map.fold behavior *)
+  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 +210,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 +276,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 +344,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 +351,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 +393,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 +416,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 +434,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 +444,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 +460,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 +493,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 +668,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 +679,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 +692,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 +721,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 +753,134 @@ 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 candidates =
+    match evi.evar_body, evi.evar_candidates with
+      | Evar_empty, Some l ->
+           spc () ++ str "{" ++
+           prlist_with_sep (fun () -> str "|") print_constr l ++ str "}"
+      | _ ->
+          mt ()
+  in
+  let src = str "(" ++ pr_evar_source (snd evi.evar_source) ++ str ")" in
+  hov 2
+    (str"["  ++ phyps ++ spc () ++ str"|- "  ++ pty ++ pb ++ str"]" ++
+       candidates ++ 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..dbaf803b 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-2012     *)
 (*   \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
 
@@ -131,6 +127,7 @@ val evar_concl : evar_info -> constr
 val evar_context : evar_info -> named_context
 val evar_filtered_context : evar_info -> named_context
 val evar_hyps : evar_info -> named_context_val
+val evar_filtered_hyps : evar_info -> named_context_val
 val evar_body : evar_info -> evar_body
 val evar_filter : evar_info -> bool list
 val evar_unfiltered_env :  evar_info -> env
@@ -139,33 +136,42 @@ 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
 
+(** [add sigma ev info] adds [ev] with evar info [info] in sigma.
+    Precondition: ev must not preexist in [sigma]. *)
 val add : evar_map -> evar -> evar_info -> evar_map
 
-val 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 +179,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 +192,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 +240,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 +252,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 +276,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..8e4b211f 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-2012     *)
 (*   \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,87 @@ 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_glob_constr na = function
+  | GVar (loc,id) when na<>Anonymous ->
+      (* Unable to manage the presence of both an alias and a variable *)
+      raise Not_found
+  | GVar (loc,id) -> PatVar (loc,Name id)
+  | GHole (loc,_) -> PatVar (loc,na)
+  | GRef (loc,ConstructRef cstr) ->
+      PatCstr (loc,cstr,[],na)
+  | GApp (loc,GRef (_,ConstructRef (ind,_ as cstr)),args) ->
+      let mib,_ = Global.lookup_inductive ind in
+      let nparams = mib.Declarations.mind_nparams in
+      if nparams > List.length args then
+        user_err_loc (loc,"",Pp.str "Invalid notation for pattern.");
+      let params,args = list_chop nparams args in
+      List.iter (function GHole _ -> ()
+	| _ -> user_err_loc (loc,"",Pp.str"Invalid notation for pattern."))
+        params;
+      let args = List.map (cases_pattern_of_glob_constr Anonymous) args in
+      PatCstr (loc,cstr,args,na)
+  | _ -> raise Not_found
 
-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 (ind,_ as cstr)),args) ->
+      let mib,_ = Global.lookup_inductive ind in
+      let nparams = mib.Declarations.mind_nparams in
+      if nparams > List.length args then
+        user_err_loc (loc,"",Pp.str "Invalid notation for pattern.");
+      let params,args = list_chop nparams args in
+      List.iter (function GHole _ -> ()
+	| _ -> user_err_loc (loc,"",Pp.str"Invalid notation for pattern."))
+        params;
+      let args = List.map (cases_pattern_of_glob_constr Anonymous) args in
+      PatCstr (loc,cstr,args,na)
   | _ -> raise Not_found
 
-(* Turn a closed cases pattern into a 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 +424,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..798a960f
--- /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-2012     *)
+(*   \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..18d30bfd 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-2012     *)
 (*   \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..1bf5fd90 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-2012     *)
 (*   \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 fe90941d..bdccc57b 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: inductiveops.ml 15019 2012-03-02 17:27:18Z letouzey $ *)
-
 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 =
@@ -301,6 +290,7 @@ let find_rectype env sigma c =
   match kind_of_term t with
     | Ind ind ->
         let (mib,mip) = Inductive.lookup_mind_specif env ind in
+        if mib.mind_nparams > List.length l then raise Not_found;
         let (par,rargs) = list_chop mib.mind_nparams l in
         IndType((ind, par),rargs)
     | _ -> raise Not_found
diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli
index e5759864..91662fd9 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-2012     *)
 (*   \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..89ca95cb 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-2012     *)
 (*   \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..9b412692 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-2012     *)
 (*   \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 f133d842..e5dd75c0 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: namegen.ml 15069 2012-03-20 14:06:07Z herbelin $ *)
-
 (* Created from contents that was formerly in termops.ml and
    nameops.ml, Nov 2009 *)
 
@@ -55,7 +53,7 @@ let is_global id =
 let is_constructor id =
   try
     match locate (qualid_of_ident id) with
-      | ConstructRef _ as ref -> not (is_imported_ref ref)
+      | ConstructRef _ -> true
       | _ -> false
   with Not_found ->
     false
@@ -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 464efcf8..e23c6dad 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: namegen.mli 15069 2012-03-20 14:06:07Z 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 (name list * constr)
 
 val make_all_name_different : env -> env
diff --git a/pretyping/pattern.ml b/pretyping/pattern.ml
index 83bfe9ea..7e486956 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-2012     *)
 (*   \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..f6d55bc6 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-2012     *)
 (*   \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 a9b2a18b..672debfa 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: pretype_errors.ml 15025 2012-03-09 14:27:07Z glondu $ *)
-
+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 _
-  | Compat.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..68ea67f7 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-2012     *)
 (*   \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..1dd71fab 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-2012     *)
 (*   \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 *)
@@ -54,8 +69,9 @@ let search_guard loc env possible_indexes fixdefs =
   if List.for_all (fun l->1=List.length l) possible_indexes then
     let indexes = Array.of_list (List.map List.hd possible_indexes) in
     let fix = ((indexes, 0),fixdefs) in
-    (try check_fix env fix with
-       | e -> if loc = dummy_loc then raise e else Stdpp.raise_with_loc loc e);
+    (try check_fix env fix
+     with e when Errors.noncritical e ->
+       if loc = dummy_loc then raise e else Loc.raise loc e);
     indexes
   else
     (* we now search recursively amoungst all combinations *)
@@ -72,20 +88,54 @@ 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 ~filter:Typeclasses.no_goals
+		 ~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 when Errors.noncritical e ->
+               if fail_evar then raise e else !evdref)
+
+let solve_remaining_evars fail_evar use_classes hook env initial_sigma (evd,c) =
+  let evdref = ref evd in
+  resolve_evars env evdref fail_evar use_classes;
+  let rec proc_rec c =
+    let c = Reductionops.whd_evar !evdref c in
+    match kind_of_term c with
+    | Evar (evk,args as ev) when not (Evd.mem initial_sigma evk) ->
+        let sigma = !evdref in
+	(try
+	   let c = hook env sigma ev in
+	   evdref := Evd.define evk c !evdref;
+	   c
+	 with Exit ->
+           if fail_evar then
+	     let evi = Evd.find_undefined sigma evk in
+             let (loc,src) = evar_source evk !evdref in
+	     Pretype_errors.error_unsolvable_implicit loc env sigma evi src None
+           else
+             c)
+    | _ -> map_constr proc_rec c in
+  let c = proc_rec c in
+  (* Side-effect *)
+  !evdref,c
 
 module type S =
 sig
@@ -95,54 +145,55 @@ 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],
 
+     resolve_classes : launch typeclass resolution after typechecking.
      expand_evars : expand inferred evars by their value if any
      sigma : initial set of existential variables (typically dependent subgoals)
      ltac_env : partial substitution of variables (used for the tactic language)
      constraint : tell if interpreted as a possibly constrained term or a type
   *)
 
-  val understand_ltac :
+  val understand_ltac : ?resolve_classes:bool ->
     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 +201,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 +258,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 +285,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)
 
@@ -289,28 +321,43 @@ module Pretyping_F (Coercion : Coercion.S) = struct
   let pretype_ref evdref env ref =
     let c = constr_of_global ref in
       make_judge c (Retyping.get_type_of env Evd.empty c)
-
-  let pretype_sort = function
-    | RProp c -> judge_of_prop_contents c
-    | RType _ -> judge_of_new_Type ()
+  let pretype_ref loc evdref env = function
+    | VarRef id ->
+        (* Section variable *)
+        (try let (_,_,ty) = lookup_named id env in make_judge (mkVar id) ty
+         with Not_found ->
+           (* This may happen if env is a goal env and section variables have
+              been cleared - section variables should be different from goal
+              variables *)
+           Pretype_errors.error_var_not_found_loc loc id)
+    | ref ->
+        let c = constr_of_global ref in
+        make_judge c (Retyping.get_type_of env Evd.empty c)
+
+  let pretype_sort evdref = function
+    | GProp c -> judge_of_prop_contents c
+    | GType _ -> evd_comb0 judge_of_new_Type evdref
 
   exception Found of fixpoint
 
+  let new_type_evar evdref env loc =
+    evd_comb0 (fun evd -> Evarutil.new_type_evar evd env ~src:(loc,InternalHole)) evdref
+
   (* [pretype tycon env evdref lvar lmeta cstr] attempts to type [cstr] *)
   (* in environment [env], with existential variables [evdref] and *)
   (* the type constraint tycon *)
   let rec pretype (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)
+	  (pretype_ref loc 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 +368,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 +425,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 +441,24 @@ 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 when Errors.noncritical e -> Loc.raise loc e);
 	      make_judge (mkCoFix cofix) ftys.(i) in
 	inh_conv_coerce_to_tycon loc env evdref fixj tycon
 
-    | 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 +492,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 +500,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 +513,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 +531,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 +572,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 +592,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 +626,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 +656,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 +680,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 +712,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 +725,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 +733,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 +746,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
 
@@ -744,8 +778,8 @@ module Pretyping_F (Coercion : Coercion.S) = struct
   let understand_type sigma env c =
     snd (ise_pretype_gen true true true sigma env ([],[]) IsType c)
 
-  let understand_ltac expand_evar sigma env lvar kind c =
-    ise_pretype_gen expand_evar false false sigma env lvar kind c
+  let understand_ltac ?(resolve_classes=false) expand_evar sigma env lvar kind c =
+    ise_pretype_gen expand_evar false resolve_classes sigma env lvar kind c
 
   let understand_tcc ?(resolve_classes=true) sigma env ?expected_type:exptyp c =
     ise_pretype_gen true false resolve_classes sigma env ([],[]) (OfType exptyp) c
diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli
index b94f9789..761e1641 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-2012     *)
 (*   \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,91 +30,96 @@ 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],
 
+     resolve_classes : launch typeclass resolution after typechecking.
      expand_evars : expand inferred evars by their value if any
      sigma : initial set of existential variables (typically dependent subgoals)
      ltac_env : partial substitution of variables (used for the tactic language)
      constraint : tell if interpreted as a possibly constrained term or a type
   *)
 
-  val understand_ltac :
+  val understand_ltac : ?resolve_classes:bool ->
     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..434fe80c 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-2012     *)
 (*   \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);
@@ -197,16 +207,16 @@ let cs_pattern_of_constr t =
   match kind_of_term t with
       App (f,vargs) ->
 	begin
-	  try  Const_cs (global_of_constr f) , -1, Array.to_list vargs with
-	      _ -> raise Not_found
+	  try  Const_cs (global_of_constr f) , -1, Array.to_list vargs
+          with e when Errors.noncritical e -> raise Not_found
 	end
     | Rel n -> Default_cs, pred n, []
-    | Prod (_,a,b) when not (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
-	  try  Const_cs (global_of_constr t) , -1, [] with
-	      _ -> raise Not_found
+	  try  Const_cs (global_of_constr t) , -1, []
+          with e when Errors.noncritical e -> raise Not_found
 	end
 
 (* Intended to always succeed *)
@@ -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..1c19ef6c 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-2012     *)
 (*   \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..993ad46b 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-2012     *)
 (*   \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 ->
@@ -947,7 +924,10 @@ let meta_reducible_instance evd b =
     let u = whd_betaiota Evd.empty u in
     match kind_of_term u with
     | Case (ci,p,c,bl) when isMeta c or isCast c & isMeta (pi1 (destCast c)) ->
-	let m = try destMeta c with _ -> destMeta (pi1 (destCast c)) in
+	let m =
+          try destMeta c
+          with e when Errors.noncritical e -> destMeta (pi1 (destCast c))
+        in
 	(match
 	  try
 	    let g,s = List.assoc m metas in
@@ -957,7 +937,10 @@ let meta_reducible_instance evd b =
 	    | Some g -> irec (mkCase (ci,p,g,bl))
 	    | None -> mkCase (ci,irec p,c,Array.map irec bl))
     | App (f,l) when isMeta f or isCast f & isMeta (pi1 (destCast f)) ->
-	let m = try destMeta f with _ -> destMeta (pi1 (destCast f)) in
+        let m =
+          try destMeta f
+          with e when Errors.noncritical e -> destMeta (pi1 (destCast f))
+        in
 	(match
 	  try
 	    let g,s = List.assoc m metas in
diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli
index 95032bde..6f7f9de3 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-2012     *)
 (*   \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..3b679fce 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-2012     *)
 (*   \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
@@ -32,12 +30,12 @@ let rec subst_type env sigma typ = function
 (* et sinon on substitue *)
 
 let sort_of_atomic_type env sigma ft args =
-  let rec concl_of_arity env ar =
-    match kind_of_term (whd_betadeltaiota env sigma ar) with
-    | Prod (na, t, b) -> concl_of_arity (push_rel (na,None,t) env) b
-    | Sort s -> s
-    | _ -> decomp_sort env sigma (subst_type env sigma ft (Array.to_list args))
-  in concl_of_arity env ft
+  let rec concl_of_arity env ar args =
+    match kind_of_term (whd_betadeltaiota env sigma ar), args with
+    | Prod (na, t, b), h::l -> concl_of_arity (push_rel (na,Some h,t) env) b l
+    | Sort s, [] -> s
+    | _ -> anomaly "Not a sort"
+  in concl_of_arity env ft (Array.to_list args)
 
 let type_of_var env id =
   try let (_,_,ty) = lookup_named id env in ty
@@ -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..62bda6ef 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-2012     *)
 (*   \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..78b239c0 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-2012     *)
 (*   \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
 
@@ -126,12 +125,12 @@ type constant_evaluation =
 
 (* We use a cache registered as a global table *)
 
-let eval_table = ref Cmap.empty
+let eval_table = ref Cmap_env.empty
 
-type frozen = (int * constant_evaluation) Cmap.t
+type frozen = (int * constant_evaluation) Cmap_env.t
 
 let init () =
-  eval_table := Cmap.empty
+  eval_table := Cmap_env.empty
 
 let freeze () =
   !eval_table
@@ -292,25 +291,14 @@ let compute_consteval sigma env ref =
 let reference_eval sigma env = function
   | EvalConst cst as ref ->
       (try
-	 Cmap.find cst !eval_table
+	 Cmap_env.find cst !eval_table
        with Not_found -> begin
 	 let v = compute_consteval sigma env ref in
-	 eval_table := Cmap.add cst v !eval_table;
+	 eval_table := Cmap_env.add cst v !eval_table;
 	 v
        end)
   | ref -> compute_consteval sigma env ref
 
-let rev_firstn_liftn fn ln =
-  let rec rfprec p res l =
-    if p = 0 then
-      res
-    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,128 @@ 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 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, unfold_nonelim =
+    match recargs ref with
+    | None -> largs, false, false
+    | Some (_,n) when nargs < n -> raise Redelimination
+    | Some (x::l,_) when nargs <= List.fold_left max x l -> raise Redelimination
+    | Some (l,n) ->
+        List.fold_left (fun stack i ->
+          let arg = stack_nth stack i in
+          let rarg = whd_construct_state env sigma (arg, empty_stack) in
+          match kind_of_term (fst rarg) with
+          | Construct _ -> stack_assign stack i (app_stack rarg)
+          | _ -> raise Redelimination)
+        largs l, n >= 0 && l =  [] && nargs >= n, 
+                 n >= 0 && l <> [] && nargs >= n in
+  try match reference_eval sigma env ref with
+    | 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
@@ -563,7 +652,13 @@ let rec red_elim_const env sigma ref largs =
 	(match reduce_fix_use_function env sigma f whfun (destFix d) lrest with
 	   | NotReducible -> raise Redelimination
 	   | Reduced (c,rest) -> (nf_beta sigma c, rest))
+    | NotAnElimination when unfold_nonelim -> 
+         let c = reference_value sigma env ref in
+         whd_betaiotazeta sigma (app_stack (c, largs)), empty_stack
     | _ -> 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 +686,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 +800,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 +810,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 +818,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 +882,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 +969,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 +1007,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 +1038,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 +1078,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..f2a4c303 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-2012     *)
 (*   \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..3340dbe2 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-2012     *)
 (*   \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..bf4557fc 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-2012     *)
 (*   \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..0e31ee2d 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-2012     *)
 (*   \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..0e384829 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-2012     *)
 (*   \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..0344ebcc 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-2012     *)
 (*   \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
@@ -108,7 +118,7 @@ let _ =
 
 let class_info c =
   try Gmap.find c !classes
-  with _ -> not_a_class (Global.env()) (constr_of_global c)
+  with Not_found -> not_a_class (Global.env()) (constr_of_global c)
 
 let global_class_of_constr env c =
   try class_info (global_of_constr c)
@@ -118,7 +128,13 @@ 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 e when Errors.noncritical e -> None
 
 let rec is_class_type evd c =
   match kind_of_term c with
@@ -148,7 +164,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 +196,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 +211,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 e when Errors.noncritical e -> 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 +233,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 e when Errors.noncritical e -> false
+
+let build_subclasses ~check env sigma glob pri =
+  let rec aux pri c =
+    let ty = Evarutil.nf_evar sigma (Retyping.get_type_of env sigma c) in
+      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 rebuild_instance (action, inst) =
+  if action = AddInstance then add_instance true inst;
+  (action, inst)
 
-let (instance_input,instance_output) =
+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 +390,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 +423,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 =
@@ -344,47 +452,53 @@ let is_instance = function
       is_class (IndRef ind)
   | _ -> false
 
-let is_implicit_arg k =
-  match k with
-      ImplicitArg (ref, (n, id), b) -> true
-    | InternalHole -> true
-    | _ -> false
 
 (* To embed a boolean for resolvability status.
    This is essentially a hack to mark which evars correspond to
    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_resolvability_undef b evi =
+  let t = resolvable.set b evi.evar_extra in
+  { evi with evar_extra = t }
 
-let mark_unresolvable evi =
-  { evi with evar_extra = Some bool_false }
+let mark_resolvability b evi =
+  assert (evi.evar_body = Evar_empty);
+  mark_resolvability_undef b evi
 
-let mark_unresolvables sigma =
-  Evd.fold (fun ev evi evs ->
-    Evd.add evs ev (mark_unresolvable evi))
-    sigma Evd.empty
+let mark_unresolvable evi = mark_resolvability false evi
+let mark_resolvable evi = mark_resolvability true evi
+
+let mark_resolvability b sigma =
+  Evd.fold_undefined (fun ev evi evs ->
+    Evd.add evs ev (mark_resolvability_undef b evi))
+    sigma (Evd.defined_evars sigma)
+
+let mark_unresolvables sigma = mark_resolvability false 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_resolvable evi && is_class_evar evd 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
+type evar_filter = hole_kind -> bool
 
-let resolve_one_typeclass env evm t =
-  !solve_instanciation_problem env evm t
+let no_goals = function GoalEvar -> false | _ -> true
+let all_evars _ = true
+
+let resolve_typeclasses ?(filter=no_goals) ?(split=true) ?(fail=true) env evd =
+  if not (has_typeclasses evd) then evd
+  else !solve_instanciations_problem env evd filter split fail
diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli
index 83ae84a5..c458e5d5 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-2012     *)
 (*   \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,46 +55,65 @@ 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
 
 val is_class : global_reference -> bool
 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
+val mark_resolvable : evar_info -> evar_info
 val mark_unresolvables : evar_map -> evar_map
 val is_class_evar : evar_map -> evar_info -> bool
 
-val resolve_typeclasses : ?onlyargs:bool -> ?split:bool -> ?fail:bool ->
+(** Filter which evars to consider for resolution. *)
+type evar_filter = hole_kind -> bool
+val no_goals : evar_filter
+val all_evars : evar_filter
+
+val resolve_typeclasses : ?filter:evar_filter -> ?split:bool -> ?fail:bool ->
   env -> evar_map -> evar_map
 val resolve_one_typeclass : env -> evar_map -> types -> open_constr
 
-val 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_classes_transparent_state : (unit -> transparent_state) -> unit
+val classes_transparent_state : unit -> transparent_state
 
-val register_add_instance_hint : (global_reference -> int option -> unit) -> unit
-val add_instance_hint : global_reference -> int option -> unit
+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_instanciations_problem : (env -> evar_map -> evar_filter -> 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 7b09f957..19e18489 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: typeclasses_errors.ml 15025 2012-03-09 14:27:07Z glondu $ 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 (Compat.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
-  | Compat.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..cb67c73d 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-2012     *)
 (*   \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..22aacb29 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-2012     *)
 (*   \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,19 @@ 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_assumption_of_judgment env evdref j =
+  try (e_type_judgment env evdref j).utj_val
+  with TypeError _ ->
+    error_assumption env j
+
 let e_judge_of_apply env evdref funj argjv =
   let rec apply_rec n typ = function
   | [] ->
@@ -47,29 +59,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
@@ -90,7 +155,7 @@ let rec execute env evdref cstr =
     | Evar ev ->
 	let ty = Evd.existential_type !evdref ev in
 	let jty = execute env evdref (whd_evar !evdref ty) in
-	let jty = assumption_of_judgment env jty in
+	let jty = e_assumption_of_judgment env evdref jty in
 	{ uj_val = cstr; uj_type = jty }
 
     | Rel n ->
@@ -100,13 +165,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 +218,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,12 +243,12 @@ 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) =
   let larj = execute_array env evdref lar in
-  let lara = Array.map (assumption_of_judgment env) larj in
+  let lara = Array.map (e_assumption_of_judgment env evdref) larj in
   let env1 = push_rec_types (names,lara,vdef) env in
   let vdefj = execute_array env1 evdref vdef in
   let vdefv = Array.map j_val vdefj in
@@ -192,8 +257,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 +274,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..88dc895e 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-2012     *)
 (*   \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..df5eff6a 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-2012     *)
 (*   \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
@@ -40,6 +37,15 @@ let occur_meta_or_undefined_evar evd c =
     | _ -> iter_constr occrec c
   in try occrec c; false with Occur | Not_found -> true
 
+let occur_meta_evd sigma mv c =
+  let rec occrec c =
+    (* Note: evars are not instantiated by terms with metas *)
+    let c = whd_evar sigma (whd_meta sigma c) in
+    match kind_of_term c with
+    | Meta mv' when mv = mv' -> raise Occur
+    | _ -> iter_constr occrec c
+  in try occrec c; false with Occur -> true
+
 (* if lname_typ is [xn,An;..;x1,A1] and l is a list of terms,
    gives [x1:A1]..[xn:An]c' such that c converts to ([x1:A1]..[xn:An]c' l) *)
 
@@ -51,7 +57,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 +72,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 +92,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 +122,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 +133,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 +173,158 @@ 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 constants are unfoldable; this is on for apply *)
+    (* (but not simple apply) since Feb 2008 for 8.2 *)
+
+  modulo_delta_types : Names.transparent_state;
+
+  modulo_delta_in_merge : Names.transparent_state option;
+    (* This controls whether unfoldability is different when trying to unify *)
+    (* several instances of the same metavariable *)
+    (* Typical situation is when we give a pattern to be matched *)
+    (* syntactically against a subterm but we want the metas of the *)
+    (* pattern to be modulo convertibility *)
+
+  check_applied_meta_types : bool;
+    (* This controls whether meta's applied to arguments have their *)
+    (* type unified with the type of their instance *)
+
   resolve_evars : bool;
-  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 (no flag should be modified anymore) *)
 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;
+  modulo_delta_in_merge = None;
+  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 *)
 }
 
-let default_no_delta_unify_flags = {
-  modulo_conv_on_closed_terms = Some full_transparent_state;
-  use_metas_eagerly = true;
+let set_merge_flags flags =
+  match flags.modulo_delta_in_merge with
+  | None -> flags
+  | Some ts ->
+    { flags with modulo_delta = ts; modulo_conv_on_closed_terms = Some ts }
+
+(* 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 = { default_unify_flags with
   modulo_delta = empty_transparent_state;
-  resolve_evars = false;
-  use_evars_pattern_unification = false;
+  check_applied_meta_types = false;
+  use_pattern_unification = false;
+  use_meta_bound_pattern_unification = true;
+  modulo_betaiota = false;
+}
+
+(* Default flags for looking for subterms in elimination tactics *)
+(* Not used in practice at the current date, to the exception of *)
+(* allow_K) because only closed terms are involved in *)
+(* induction/destruct/case/elim and w_unify_to_subterm_list does not *)
+(* call w_unify for induction/destruct/case/elim  (13/6/2011) *)
+let elim_flags = { default_unify_flags with
+  restrict_conv_on_strict_subterms = false; (* ? *)
+  modulo_betaiota = false;
+  allow_K_in_toplevel_higher_order_unification = true
 }
 
+let elim_no_delta_flags = { elim_flags with
+  modulo_delta = empty_transparent_state;
+  check_applied_meta_types = false;
+  use_pattern_unification = false;
+}
+
+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 +343,52 @@ 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) ->
+	| Meta k, _
+            when not (dependent cM cN) (* helps early trying alternatives *) ->
+            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
@@ -241,7 +397,12 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag
 	      (k,lift (-nb) cN,snd (extract_instance_status pb))::metasubst,
               evarsubst)
 	    else error_cannot_unify_local curenv sigma (m,n,cN)
-	| _, Meta k when not (dependent cN cM) ->
+	| _, Meta k
+            when not (dependent cN cM) (* helps early trying alternatives *) ->
+            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 +411,124 @@ 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 e when Errors.noncritical e ->
+               error_cannot_unify curenv sigma (m,n))
+
 	| Lambda (na,t1,c1), Lambda (_,t2,c2) ->
-	    unirec_rec (push (na,t1) curenvnb) 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 +543,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 +563,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 +632,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 +653,69 @@ 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 e when Errors.noncritical e ->
+       (right, IsSubType, unify_0 env sigma CUMUL flags c1 c2))
   | (IsSubType,IsSuperType) ->
-      (try (left, IsSuperType, unify_0 env sigma Cumul flags c1 c2)
-       with _ -> (right, IsSuperType, unify_0 env sigma Cumul flags c2 c1))
-
+    (try (left, IsSuperType, unify_0 env sigma CUMUL flags c1 c2)
+     with e when Errors.noncritical e ->
+       (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 (set_merge_flags 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')) =
@@ -691,24 +904,36 @@ let w_merge env with_types flags (evd,metas,evars) =
 	    in
               w_merge_rec evd' (metas'@metas@metas'') (evars'@evars'') eqns
     	  else
-	    let evd' = meta_assign mv (c,(status,TypeProcessed)) evd in
-	      w_merge_rec evd' (metas@metas'') evars'' eqns
+            let evd' =
+              if occur_meta_evd evd mv c then
+                if isMetaOf mv (whd_betadeltaiota env evd c) then evd
+                else error_cannot_unify env evd (mkMeta mv,c)
+              else
+	        meta_assign mv (c,(status,TypeProcessed)) evd in
+	    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 when Errors.noncritical 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 (set_merge_flags 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 +958,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 ~filter:Typeclasses.no_goals ~split:false
+	  ~fail:true env evd
+    with e when Typeclasses_errors.unsatisfiable_exception e ->
+      error_cannot_unify env evd (m, n)
+  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 +1016,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 +1071,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 +1101,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 +1133,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 +1214,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 +1222,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..1ec5c1a2 100644
--- a/pretyping/unification.mli
+++ b/pretyping/unification.mli
@@ -1,54 +1,79 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*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;
+  modulo_delta_in_merge : Names.transparent_state option;
+  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 57b183d5..3966146d 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: vnorm.ml 15029 2012-03-13 14:47:00Z herbelin $ i*)
-
 open Names
 open Declarations
 open Term
@@ -46,7 +44,7 @@ let invert_tag cst tag reloc_tbl =
 let find_rectype_a env c =
   let (t, l) =
     let t = whd_betadeltaiota env c in
-    try destApp t with _ -> (t,[||]) in
+    try destApp t with e when Errors.noncritical e -> (t,[||]) in
   match kind_of_term t with
   | Ind ind -> (ind, l)
   | _ -> raise Not_found
@@ -178,7 +176,10 @@ and nf_stk env c t stk  =
       nf_stk env (mkApp(c,args)) t stk
   | Zfix (f,vargs) :: stk ->
       let fa, typ = nf_fix_app env f vargs in
-      let _,_,codom = try decompose_prod env typ with _ -> exit 120 in
+      let _,_,codom =
+        try decompose_prod env typ
+        with e when Errors.noncritical e -> exit 120
+      in
       nf_stk env (mkApp(fa,[|c|])) (subst1 c codom) stk
   | Zswitch sw :: stk ->
       let (mind,_ as ind),allargs = find_rectype_a env t in
@@ -208,7 +209,10 @@ and nf_predicate env ind mip params v pT =
   | Vfun f, Prod _ ->
       let k = nb_rel env in
       let vb = body_of_vfun k f in
-      let name,dom,codom = try decompose_prod env pT with _ -> exit 121 in
+      let name,dom,codom =
+        try decompose_prod env pT
+        with e when Errors.noncritical e -> exit 121
+      in
       let dep,body =
 	nf_predicate (push_rel (name,None,dom) env) ind mip params vb codom in
       dep, mkLambda(name,dom,body)
@@ -230,7 +234,10 @@ and nf_args env vargs t =
   let args =
     Array.init len
       (fun i ->
-	let _,dom,codom = try decompose_prod env !t with _ -> exit 123 in
+	let _,dom,codom =
+          try decompose_prod env !t
+          with e when Errors.noncritical e -> exit 123
+        in
 	let c = nf_val env (arg vargs i) dom in
 	t := subst1 c codom; c) in
   !t,args
@@ -241,7 +248,10 @@ and nf_bargs env b t =
   let args =
     Array.init len
       (fun i ->
-	let _,dom,codom = try decompose_prod env !t with _ -> exit 124 in
+	let _,dom,codom =
+          try decompose_prod env !t
+          with e when Errors.noncritical e -> exit 124
+        in
 	let c = nf_val env (bfield b i) dom in
 	t := subst1 c codom; c) in
   args
@@ -251,7 +261,7 @@ and nf_fun env f typ =
   let vb = body_of_vfun k f in
   let name,dom,codom =
     try decompose_prod env typ
-    with _ ->
+    with e when Errors.noncritical e ->
       raise (Type_errors.TypeError(env,Type_errors.ReferenceVariables typ))
   in
   let body = nf_val (push_rel (name,None,dom) env) vb codom in
diff --git a/pretyping/vnorm.mli b/pretyping/vnorm.mli
index 4cf99842..ca370b55 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-2012     *)
 (*   \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 c2dd9f03..6af908ee 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: clenv.ml 15069 2012-03-20 14:06:07Z 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,7 +138,7 @@ 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
 
@@ -187,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"
@@ -196,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)
+
+   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)
 
-(* [clenv_metavars clenv mv]
- * returns a list of the metavars which appear in the type of
- * the metavar mv.  The list is unordered. *)
+   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,
@@ -301,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']
  *
@@ -328,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;
@@ -337,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
@@ -361,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 =
@@ -403,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
 
@@ -411,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
@@ -436,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
@@ -476,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..7722544a 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-2012     *)
 (*   \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..d18ee73f 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-2012     *)
 (*   \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)));
@@ -74,8 +71,8 @@ let clenv_refine with_evars ?(with_classes=true) clenv gls =
   let clenv = clenv_pose_dependent_evars with_evars clenv in
   let evd' =
     if with_classes then
-      Typeclasses.resolve_typeclasses ~fail:(not with_evars)
-	clenv.env clenv.evd
+      Typeclasses.resolve_typeclasses ~filter:Typeclasses.all_evars
+        ~fail:(not with_evars) clenv.env clenv.evd
     else clenv.evd
   in
   let clenv = { clenv with evd = evd' } in
@@ -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,28 @@ 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;
+  modulo_delta_in_merge = None;
+  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..b4cd77c2 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-2012     *)
 (*   \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..f271a6bd 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-2012     *)
 (*   \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."
@@ -43,10 +40,10 @@ let w_refine (evk,evi) (ltac_var,rawc) sigma =
     error "Instantiate called on already-defined evar";
   let env = Evd.evar_env evi in
   let sigma',typed_c =
-    try Pretyping.Default.understand_ltac true sigma env ltac_var
+    try Pretyping.Default.understand_ltac ~resolve_classes:true true sigma env ltac_var
 	  (Pretyping.OfType (Some evi.evar_concl)) rawc
-    with _ ->
-      let loc = Rawterm.loc_of_rawconstr rawc in
+    with e when Errors.noncritical e ->
+      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..6cdd46e0 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-2012     *)
 (*   \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..37ebce67
--- /dev/null
+++ b/proofs/goal.ml
@@ -0,0 +1,594 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+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 ?filter ?split ?(fail=false) () env rdefs _ _ =
+    rdefs:=Typeclasses.resolve_typeclasses ?filter ?split ~fail env !rdefs;
+    ()
+
+
+
+  (* a pessimistic (i.e : there won't be many positive answers) filter
+     over evar_maps, acting only on undefined evars *)
+  let evar_map_filter_undefined f evm =
+    Evd.fold_undefined
+      (fun ev evi r -> if f ev evi then Evd.add r ev evi else r)
+      evm
+      Evd.empty
+
+  (* Union, sorted in decreasing order, of two lists of evars in decreasing order. *)
+  let rec fusion l1 l2 = match l1 , l2 with
+    | [] , _ -> l2
+    | _ , [] -> l1
+    | a::l1 , b::_ when a>b -> a::(fusion l1 l2)
+    | a::l1 , b::l2 when a=b -> a::(fusion l1 l2)
+    | _ , b::l2 -> b::(fusion l1 l2)
+
+  let update_handle handle init_defs post_defs =
+    (* [delta_evars] holds the evars that have been introduced by this
+       refinement (but not immediatly solved) *)
+    (* spiwack: this is the hackish part, don't know how to do any better though. *)
+    let delta_evars = evar_map_filter_undefined
+      (fun ev _ -> not (Evd.mem init_defs ev))
+      post_defs
+    in
+    (* [delta_evars] in the shape of a list of [evar]-s*)
+    let delta_list = List.map fst (Evd.to_list delta_evars) in
+    (* The variables in [myevars] are supposed to be stored
+       in decreasing order. Breaking this invariant might cause
+       many things to go wrong. *)
+    handle := fusion delta_list !handle;
+    delta_evars
+
+  (* [constr_of_raw] is a pretyping function. The [check_type] argument
+      asks whether the term should have the same type as the conclusion.
+      [resolve_classes] is a flag on pretyping functions which, if set to true,
+      calls the typeclass resolver.
+      The principal argument is a [glob_constr] which is then pretyped in the
+      context of a term, the remaining evars are registered to the handle.
+      It is the main component of the toplevel refine tactic.*)
+  (* spiwack: it is not entirely satisfactory to have this function here. Plus it is
+      a bit hackish. However it does not seem possible to move it out until
+      pretyping is defined as some proof procedure. *)
+  let constr_of_raw handle check_type resolve_classes rawc env rdefs gl info =
+    (* We need to keep trace of what [rdefs] was originally*)
+    let init_defs = !rdefs in
+    (* if [check_type] is true, then creates a type constraint for the 
+       proof-to-be *)
+    let tycon = Pretyping.OfType (Option.init check_type (Evd.evar_concl info)) in
+    (* call to [understand_tcc_evars] returns a constr with undefined evars
+       these evars will be our new goals *)
+    let open_constr = 
+      Pretyping.Default.understand_tcc_evars ~resolve_classes rdefs env tycon rawc
+    in
+      ignore(update_handle handle init_defs !rdefs);
+      open_constr 
+  
+  let constr_of_open_constr handle check_type (evars, c) env rdefs gl info =
+    let delta = update_handle handle !rdefs evars in
+      rdefs := Evd.fold (fun ev evi evd -> Evd.add evd ev evi) delta !rdefs;
+      if check_type then with_type c (Evd.evar_concl (content !rdefs gl)) env rdefs gl info
+      else c
+ 
+end
+
+(* [refine t] takes a refinable term and use it as a partial proof for current
+    goal. *)
+let refine step env rdefs gl info =
+  (* subgoals to return *)
+  (* The evars in [my_evars] are stored in reverse order.
+     It is expectingly better however to display the goal
+     in increasing order. *)
+  rdefs := Evarconv.consider_remaining_unif_problems env !rdefs ;
+  let subgoals = List.map (descendent gl) (List.rev step.my_evars) in
+  (* creates the new [evar_map] by defining the evar of the current goal
+     as being [refine_step]. *)
+  let new_defs = Evd.define gl.content (step.me) !rdefs in
+  rdefs := new_defs;   
+  (* Filtering the [subgoals] for uninstanciated (=unsolved) goals. *)
+  let subgoals = 
+    Option.List.flatten (List.map (advance !rdefs) subgoals) 
+  in
+  { subgoals = subgoals }
+
+
+(*** Cleaning  goals ***)
+
+let clear ids env rdefs gl info =
+  let hyps = Evd.evar_hyps info in
+  let concl = Evd.evar_concl info in
+  let (hyps,concl) = Evarutil.clear_hyps_in_evi rdefs hyps concl ids in
+  let cleared_env = Environ.reset_with_named_context hyps env in
+  let cleared_concl = Evarutil.e_new_evar rdefs cleared_env concl in
+  let (cleared_evar,_) = Term.destEvar cleared_concl in
+  let cleared_goal = descendent gl cleared_evar in
+  rdefs := Evd.define gl.content cleared_concl !rdefs;
+  { subgoals = [cleared_goal] }
+
+let wrap_apply_to_hyp_and_dependent_on sign id f g =
+  try Environ.apply_to_hyp_and_dependent_on sign id f g 
+  with Environ.Hyp_not_found -> 
+    Util.error "No such assumption" 
+
+let check_typability env sigma c =
+  let _ = Typing.type_of env sigma c in () 
+
+let recheck_typability (what,id) env sigma t =
+  try check_typability env sigma t
+  with e when Errors.noncritical e ->
+    let s = match what with
+      | None -> "the conclusion"
+      | Some id -> "hypothesis "^(Names.string_of_id id) in
+    Util.error
+      ("The correctness of "^s^" relies on the body of "^(Names.string_of_id id))
+
+let remove_hyp_body env sigma id =
+  let sign =
+    wrap_apply_to_hyp_and_dependent_on (Environ.named_context_val env) id
+      (fun (_,c,t) _ ->
+	match c with
+	| None -> Util.error ((Names.string_of_id id)^" is not a local definition")
+	| Some c ->(id,None,t))
+      (fun (id',c,t as d) sign ->
+	(
+	  begin 
+	    let env = Environ.reset_with_named_context sign env in
+	    match c with
+	    | None ->  recheck_typability (Some id',id) env sigma t
+	    | Some b ->
+		let b' = mkCast (b,DEFAULTcast, t) in
+		recheck_typability (Some id',id) env sigma b'
+	  end;d))
+  in
+  Environ.reset_with_named_context sign env 
+
+
+let clear_body idents env rdefs gl info =
+  let info = content !rdefs gl in
+  let full_env = Environ.reset_with_named_context (Evd.evar_hyps info) env in
+  let aux env id = 
+     let env' = remove_hyp_body env !rdefs id in
+       recheck_typability (None,id) env' !rdefs (Evd.evar_concl info);
+       env'
+  in
+  let new_env = 
+    List.fold_left aux full_env idents
+  in
+  let concl = Evd.evar_concl info in
+  let (defs',new_constr) = Evarutil.new_evar !rdefs new_env concl in
+  let (new_evar,_) = destEvar new_constr in
+  let new_goal = descendent gl new_evar in
+  rdefs := Evd.define gl.content new_constr defs';
+  { subgoals = [new_goal] }
+
+
+(*** Sensitive primitives ***)
+
+(* [concl] is the conclusion of the current goal *)
+let concl _ _ _ info =
+  Evd.evar_concl info
+
+(* [hyps] is the [named_context_val] representing the hypotheses
+   of the current goal *)
+let hyps _ _ _ info =
+  Evd.evar_hyps info
+
+(* [env] is the current [Environ.env] containing both the 
+   environment in which the proof is ran, and the goal hypotheses *)
+let env env _ _ _ = env
+
+(* [defs] is the [Evd.evar_map] at the current evaluation point *)
+let defs _ rdefs _ _ =
+  !rdefs
+
+(* Cf mli for more detailed comment.
+    [null], [plus], [here] and [here_list] use internal exception [UndefinedHere]
+    to communicate whether or not the value is defined in the particular context. *)
+exception UndefinedHere
+(* no handler: this should never be allowed to reach toplevel *)
+let null _ _ _ _ = raise UndefinedHere
+
+let plus s1 s2 env rdefs goal info =
+  try s1 env rdefs goal info
+  with UndefinedHere -> s2 env rdefs goal info
+
+(* Equality of two goals *)
+let equal { content = e1 } { content = e2 } = e1 = e2
+
+let here goal value _ _ goal' _ =
+  if equal goal goal' then
+    value
+  else 
+    raise UndefinedHere
+
+(* arnaud: voir à la passer dans Util ? *)
+let rec list_mem_with eq x = function
+  | y::_ when eq x y -> true
+  | _::l -> list_mem_with eq x l
+  | [] -> false
+
+let here_list goals value _ _ goal' _ =
+  if list_mem_with equal goal' goals then
+    value
+  else
+    raise UndefinedHere
+
+
+(*** Conversion in goals ***)
+
+let convert_hyp check (id,b,bt as d) env rdefs gl info =
+  let sigma = !rdefs in
+  (* This function substitutes the new type and body definitions
+     in the appropriate variable when used with {!Environ.apply_hyps}. *)
+  let replace_function =
+    (fun _ (_,c,ct) _ ->
+       if check && not (Reductionops.is_conv env sigma bt ct) then
+	 Util.error ("Incorrect change of the type of "^(Names.string_of_id id));
+       if check && not (Option.Misc.compare (Reductionops.is_conv env sigma) b c) then
+	 Util.error ("Incorrect change of the body of "^(Names.string_of_id id));
+       d)
+  in
+  (* Modified named context. *)
+  let new_hyps = 
+    Environ.apply_to_hyp (hyps env rdefs gl info) id replace_function
+  in  
+  let new_env = Environ.reset_with_named_context new_hyps env in
+  let new_constr = 
+    Evarutil.e_new_evar rdefs new_env (concl env rdefs gl info)
+  in
+  let (new_evar,_) = Term.destEvar new_constr in
+  let new_goal = descendent gl new_evar in
+  rdefs := Evd.define gl.content new_constr !rdefs;
+  { subgoals = [new_goal] }
+  
+let convert_concl check cl' env rdefs gl info =
+  let sigma = !rdefs in
+  let cl = concl env rdefs gl info in
+  check_typability env sigma cl';
+  if (not check) || Reductionops.is_conv_leq env sigma cl' cl then
+    let new_constr = 
+      Evarutil.e_new_evar rdefs env cl' 
+    in
+    let (new_evar,_) = Term.destEvar new_constr in
+    let new_goal = descendent gl new_evar in
+    rdefs := Evd.define gl.content new_constr !rdefs;
+    { subgoals = [new_goal] }
+  else
+    Util.error "convert-concl rule passed non-converting term"
+
+
+(*** Bureaucracy in hypotheses ***)  
+
+(* Renames a hypothesis. *)
+let rename_hyp_sign id1 id2 sign =
+  Environ.apply_to_hyp_and_dependent_on sign id1
+    (fun (_,b,t) _ -> (id2,b,t))
+    (fun d _ -> map_named_declaration (replace_vars [id1,mkVar id2]) d)
+let rename_hyp id1 id2 env rdefs gl info = 
+  let hyps = hyps env rdefs gl info in
+  if id1 <> id2 &&
+    List.mem id2 (Termops.ids_of_named_context (Environ.named_context_of_val hyps)) then
+       Util.error ((Names.string_of_id id2)^" is already used.");
+  let new_hyps = rename_hyp_sign id1 id2 hyps in
+  let new_env = Environ.reset_with_named_context new_hyps env in
+  let new_concl = Term.replace_vars [id1,mkVar id2] (concl env rdefs gl info) in
+  let new_subproof = Evarutil.e_new_evar rdefs new_env new_concl in
+  let new_subproof = Term.replace_vars [id2,mkVar id1] new_subproof in
+  let (new_evar,_) = Term.destEvar new_subproof in
+  let new_goal = descendent gl new_evar in
+  rdefs := Evd.define gl.content new_subproof !rdefs;
+  { subgoals = [new_goal] }
+
+(*** Additional functions ***)
+
+(* emulates List.map for functions of type 
+   [Evd.evar_map -> 'a -> 'b * Evd.evar_map] on lists of type 'a, by propagating
+   new evar_map to next definition. *)
+(*This sort of construction actually works with any monad (here the State monade
+   in Haskell). There is a generic construction in Haskell called mapM.
+*)
+let rec list_map f l s = 
+  match l with
+  | [] -> ([],s)
+  | a::l -> let (a,s) = f s a in
+               let (l,s) = list_map f l s in
+	       (a::l,s)
+
+
+(* Layer to implement v8.2 tactic engine ontop of the new architecture. 
+   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
+    Evd.evar_filtered_hyps evi
+
+  (* 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 and change *)
+  let new_goal_with sigma gl extra_hyps =
+    let evi = content sigma gl in
+    let hyps = evi.Evd.evar_hyps in
+    let new_hyps =
+      List.fold_right Environ.push_named_context_val extra_hyps hyps in
+    let extra_filter = List.map (fun _ -> true) extra_hyps in
+    let new_filter = extra_filter @ evi.Evd.evar_filter in
+    let new_evi =
+      { evi with Evd.evar_hyps = new_hyps; Evd.evar_filter = new_filter } in
+    let new_evi = Typeclasses.mark_unresolvable new_evi in
+    let evk = Evarutil.new_untyped_evar () in
+    let new_sigma = Evd.add Evd.empty evk new_evi in
+    { Evd.it = build evk ; sigma = new_sigma }
+
+  (* Used by the compatibility layer and 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..c0a094d3
--- /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-2012     *)
+(*   \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 : ?filter:(Evd.hole_kind -> bool) -> ?split:bool -> ?fail:bool -> unit -> unit sensitive
+
+
+  (* [constr_of_raw h check_type resolve_classes] is a pretyping function.
+      The [check_type] argument asks whether the term should have the same
+      type as the conclusion. [resolve_classes] is a flag on pretyping functions
+      which, if set to true, calls the typeclass resolver.
+      The principal argument is a [glob_constr] which is then pretyped in the
+      context of a term, the remaining evars are registered to the handle.
+      It is the main component of the toplevel refine tactic.*)
+  val constr_of_raw : 
+    handle -> bool -> bool -> Glob_term.glob_constr -> Term.constr sensitive
+
+  (* [constr_of_open_constr h check_type] transforms an open constr into a 
+     goal-sensitive constr, adding the undefined variables to the set of subgoals.
+     If [check_type] is true, the term is coerced to the conclusion of the goal.
+     It allows to do refinement with already-built terms with holes.
+  *)
+  val constr_of_open_constr : handle -> bool -> Evd.open_constr -> Term.constr sensitive
+
+end
+
+(* [refine t] takes a refinable term and use it as a partial proof for current
+    goal. *)
+val refine : refinable -> subgoals sensitive
+
+
+(*** Cleaning  goals ***)
+
+(* Implements the [clear] tactic *)
+val clear : Names.identifier list -> subgoals sensitive
+
+(* Implements the [clearbody] tactic *)
+val clear_body : Names.identifier list -> subgoals sensitive
+
+
+(*** Conversion in goals ***)
+
+(* Changes an hypothesis of the goal with a convertible type and body.
+   Checks convertibility if the boolean argument is true. *)
+val convert_hyp : bool -> Term.named_declaration -> subgoals sensitive
+
+(* Changes the conclusion of the goal with a convertible type and body.
+   Checks convertibility if the boolean argument is true. *)
+val convert_concl : bool -> Term.constr -> subgoals sensitive
+
+(*** Bureaucracy in hypotheses ***)
+
+(* Renames a hypothesis. *)
+val rename_hyp : Names.identifier -> Names.identifier -> subgoals sensitive
+
+(*** Sensitive primitives ***)
+
+(* [concl] is the conclusion of the current goal *)
+val concl : Term.constr sensitive
+
+(* [hyps] is the [named_context_val] representing the hypotheses
+   of the current goal *)
+val hyps : Environ.named_context_val sensitive
+
+(* [env] is the current [Environ.env] containing both the 
+   environment in which the proof is ran, and the goal hypotheses *)
+val env : Environ.env sensitive
+
+(* [defs] is the [Evd.evar_map] at the current evaluation point *)
+val defs : Evd.evar_map sensitive
+
+(* These four functions serve as foundation for the goal sensitive part
+    of the tactic monad (see Proofview).
+    [here] is a special sort of [return]: [here g a] is the value [a], but
+    does not have any value (it raises an exception) if evaluated in
+    any other goal than [g].
+    [here_list] is the same, except with a list of goals rather than a single one.
+    [plus a b] is the same as [a] if [a] is defined in the current goal, otherwise
+    it is [b]. Effectively it's defined in the goals where [a] and [b] are defined.
+    [null] is defined in no goal. (it is a neutral element for [plus]). *)
+(* spiwack: these primitives are a bit hackish, but I couldn't find another way
+    to pass information between goals, like for an intro tactic which gives to
+    each goal the name of the variable it introduce.
+    In pratice, in my experience, the primitives given in Proofview (in terms of
+    [here] and [plus]) are sufficient to define any tactics, hence these might
+    be another example of communication primitives between Goal and Proofview.
+    Still, I can't see a way to prevent using the Proofview primitive to read
+    a goal sensitive value out of its valid context. *)
+val null : 'a sensitive
+
+val plus : 'a sensitive -> 'a sensitive -> 'a sensitive 
+
+val here : goal -> 'a -> 'a sensitive 
+
+val here_list : goal list -> 'a -> 'a sensitive 
+
+(*** Additional functions ***)
+
+(* emulates List.map for functions of type 
+   [Evd.evar_map -> 'a -> 'b * Evd.evar_map] on lists of type 'a, by propagating
+   new evar_map to next definition *)
+val list_map : (Evd.evar_map -> 'a -> 'b * Evd.evar_map) -> 
+                        'a list -> 
+                        Evd.evar_map -> 
+                        'b list *Evd.evar_map
+
+(* Layer to implement v8.2 tactic engine ontop of the new architecture. 
+   Types are different from what they used to be due to a change of the
+   internal types. *)
+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 -> Sign.named_context -> goal Evd.sigma
+
+  (* Used by the compatibility layer and 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 90514992..497ab1fa 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: logic.ml 15025 2012-03-09 14:27:07Z glondu $ *)
-
+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
-  | Compat.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
@@ -107,7 +105,7 @@ let clear_hyps sigma ids sign cl =
 
 let recheck_typability (what,id) env sigma t =
   try check_typability env sigma t
-  with _ ->
+  with e when Errors.noncritical e ->
     let s = match what with
       | None -> "the conclusion"
       | Some id -> "hypothesis "^(string_of_id id) in
@@ -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,15 @@ 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)
+	(* Normalises evars in goals. Used by instantiate. *)
+        let (goal,sigma) = Goal.V82.nf_evar sigma goal in
+	([goal],sigma)
 
 (************************************************************************)
 (************************************************************************)
@@ -644,27 +699,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 +706,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..696115a8 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-2012     *)
 (*   \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..7bac87d2 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-2012     *)
 (*   \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,137 @@ 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 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_topstate ()    = snd(get_state())
-let get_pftreestate () = fst(get_state())
-
-let get_end_tac () = let ts = get_topstate () in ts.top_end_tac
-
-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 get_current_goal_context () = get_goal_context 1
+let refining = Proof_global.there_are_pending_proofs
+let check_no_pending_proofs = Proof_global.check_no_pending_proof
 
-let set_current_proof = Edit.focus proof_edits
+let get_current_proof_name = Proof_global.get_current_proof_name
+let get_all_proof_names = Proof_global.get_all_proof_names
 
-let resume_proof (loc,id) =
-  try
-    Edit.focus proof_edits id
-  with Invalid_argument "Edit.focus" ->
-    user_err_loc(loc,"Pfedit.set_proof",str"No such proof" ++ msg_proofs false)
+type lemma_possible_guards = Proof_global.lemma_possible_guards
 
-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 =
-  try
-    Edit.mutate proof_edits (fun _ pfs -> f pfs)
-  with Invalid_argument "Edit.mutate" ->
-    errorlabstrm "Pfedit.mutate"
-      (str"No focused proof" ++ msg_proofs true)
-
-let start (na,ts) =
-  let pfs = mk_pftreestate ts.top_goal in
-  let pfs = Option.fold_right solve_pftreestate ts.top_init_tac pfs in
-  add_proof(na,pfs,ts)
-
-let restart_proof () =
-  match Edit.read proof_edits with
-    | None ->
-	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 delete_proof = Proof_global.discard
+let delete_current_proof = Proof_global.discard_current
+let delete_all_proofs = Proof_global.discard_all
 
 let undo n =
+  let p = Proof_global.give_me_the_proof () in
+  let d = Proof.V82.depth p in
+  if n >= d then raise Proof.EmptyUndoStack;
+  for i = 1 to n do
+    Proof.undo p
+  done
+
+let current_proof_depth () =
   try
-    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)
+    let p = Proof_global.give_me_the_proof () in
+    Proof.V82.depth p
+  with Proof_global.NoCurrentProof -> -1
 
-(* 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() =
+(* [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.depth proof_edits
-  with (Invalid_argument "Edit.depth") -> -1
-
-(*********************************************************************)
-(*                  Proof cooking                                    *)
-(*********************************************************************)
-
-let xml_cook_proof = ref (fun _ -> ())
-let set_xml_cook_proof f = xml_cook_proof := f
+    undo ((current_proof_depth ()) - n )
+  with Proof_global.NoCurrentProof  when n=0 -> ()
 
-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 set_undo _ = ()
+let get_undo _ = None
 
-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 refining () = [] <> (Edit.dom proof_edits)
-
-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 delete_current_proof () = delete_proof_gen (get_current_proof_name ())
-
-let delete_all_proofs () = Edit.clear proof_edits
-
-(*********************************************************************)
-(*   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}
+let start_proof id str hyps c ?init_tac ?compute_guard hook = 
+  let goals = [ (Global.env_of_context hyps , c) ] in
+  Proof_global.start_proof id str goals ?compute_guard hook;
+  let tac = match init_tac with
+   | Some tac -> Proofview.V82.tactic tac
+   | None -> Proofview.tclUNIT ()
   in
-  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"
+  try Proof_global.run_tactic tac
+  with reraise -> Proof_global.discard_current (); raise reraise
 
-let by tac = mutate (solve_pftreestate tac)
+let restart_proof () = undo_todepth 1
 
-let instantiate_nth_evar_com n c =
-  mutate (Evar_refiner.instantiate_pf_com n c)
+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 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)
+let xml_cook_proof = ref (fun _ -> ())
+let set_xml_cook_proof f = xml_cook_proof := f
 
-(* traverse the proof tree until it reach the nth subgoal *)
-let traverse_nth_goal n = mutate (nth_unproven n)
+let get_pftreestate () =
+  Proof_global.give_me_the_proof ()
 
-let traverse_prev_unproven () = mutate prev_unproven
+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 traverse_next_unproven () = mutate next_unproven
+let get_goal_context i =
+  try get_goal_context_gen i
+  with NoSuchGoal -> Util.error "No such goal."
 
-(* 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 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 reset_top_of_tree () =
-  mutate top_of_tree
+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
 
-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 *)
@@ -351,11 +164,30 @@ let build_constant_by_tactic id sign typ tac =
     let _,(const,_,_,_) = cook_proof (fun _ -> ()) in
     delete_current_proof ();
     const
-  with e ->
+  with reraise ->
     delete_current_proof ();
-    raise e
+    raise reraise
 
-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..89e12c01 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-2012     *)
 (*   \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,163 @@ 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
-   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] *)
-
-val resume_proof : identifier located -> unit
-
-(* [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
-
-(* [get_end_tac ()] returns the current tactic to apply to all new subgoal *)
-
-val get_end_tac : unit -> tactic option
+val get_pftreestate : unit -> Proof.proof
 
-(* [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.
+    The first name is the current proof, the other names may come in
+    any order. *)
 
 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
-
-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
-
+(** [build_by_tactic typ tac] returns a term of type [typ] by calling [tac] *)
 
-(* 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..012a4dc1
--- /dev/null
+++ b/proofs/proof.ml
@@ -0,0 +1,482 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* 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 of exn
+  | Loose
+  | Strict
+type _focus_condition = 
+    (_focus_kind -> Proofview.proofview -> unfocusable) *
+    (_focus_kind -> bool)
+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. *)
+let check kind1 kind2 = kind1=kind2
+
+(* To be authorized to unfocus one must meet the condition prescribed by
+    the action which focused.*)
+(* spiwack: we could consider having a list of authorized focus_kind instead
+    of just one, if anyone needs it *)
+(* [no_cond] only checks that the unfocusing command uses the right
+    [focus_kind]. *)
+
+module Cond = struct
+  (* first attempt at an algebra of condition *)
+  (* semantics:
+     - [Cannot] means that the condition is not met
+     - [Strict] that the condition is met
+     - [Loose] that the condition is not quite met
+       but authorises to unfocus provided a condition
+       of a previous focus on the stack is (strictly)
+       met. [Loose] focuses are those, like bullets,
+       which do not have a closing command and
+       are hence closed by unfocusing actions unrelated
+       to their focus_kind.
+  *)
+  let bool e b =
+    if b then fun _ _ -> Strict
+    else fun _ _ -> Cannot e
+  let loose c k p = match c k p with
+    | Cannot _ -> Loose
+    | c -> c
+  let cloose l c =
+    if l then loose c
+    else c
+  let (&&&) c1 c2 k p=
+    match c1 k p , c2 k p with
+    | Cannot e , _ 
+    | _ , Cannot e -> Cannot e
+    | Strict, Strict -> Strict
+    | _ , _ -> Loose
+  let kind e k0 k p = bool e (k0=k) k p 
+  let pdone e k p = bool e (Proofview.finished p) k p
+end
+
+
+(* Unfocus command.
+   Fails if the proof is not focused. *)
+exception CannotUnfocusThisWay
+let _ = Errors.register_handler begin function
+  | CannotUnfocusThisWay ->
+    Util.error "This proof is focused, but cannot be unfocused this way"
+  | _ -> raise Errors.Unhandled
+end
+
+open Cond
+let no_cond_gen e ~loose_end k0 =
+  cloose loose_end (kind e k0)
+let no_cond_gen e ?(loose_end=false) k = no_cond_gen e ~loose_end k , check k
+let no_cond ?loose_end = no_cond_gen CannotUnfocusThisWay ?loose_end
+(* [done_cond] checks that the unfocusing command uses the right [focus_kind]
+    and that the focused proofview is complete. *)
+let done_cond_gen e ~loose_end k0 =
+  (cloose loose_end (kind e k0)) &&& pdone e
+let done_cond_gen e ?(loose_end=false) k = done_cond_gen e ~loose_end k , check k
+let done_cond ?loose_end = done_cond_gen CannotUnfocusThisWay ?loose_end
+
+
+(* 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 proof { state = p } =
+  let (goals,sigma) = Proofview.proofview p.proofview in
+  (* spiwack: beware, the bottom of the stack is used by [Proof]
+     internally, and should not be exposed. *)
+  let rec map_minus_one f = function
+    | [] -> assert false
+    | [_] -> []
+    | a::l -> f a :: (map_minus_one f l)
+  in
+  let stack =
+    map_minus_one (fun (_,_,c) -> Proofview.focus_context c) p.focus_stack
+  in
+  (goals,stack,sigma)
+
+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 reraise -> rollback pr; raise reraise
+
+
+(* 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
+
+let rec unfocus kind pr () =
+  let starting_point = save_state pr in
+  let cond = cond_of_focus pr in
+  match fst cond kind pr.state.proofview with
+  | Cannot e -> raise e
+  | Strict -> 
+    (_unfocus pr;
+     push_undo starting_point pr)
+  | 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)
+
+exception NoSuchFocus
+(* no handler: should not be allowed to reach toplevel. *)
+let rec get_in_focus_stack kind stack =
+  match stack with
+  | ((_,check),inf,_)::stack ->
+      if check kind then inf
+      else get_in_focus_stack kind stack
+  | [] -> raise NoSuchFocus
+let get_at_focus kind pr =
+  Obj.magic (get_in_focus_stack kind pr.state.focus_stack)
+
+let is_last_focus kind pr =
+  let ((_,check),_,_) = List.hd pr.state.focus_stack in
+  check kind
+
+let no_focused_goal p =
+  Proofview.finished p.state.proofview
+
+(*** Proof Creation/Termination ***)
+
+(* [end_of_stack] is unfocused by return to close every loose focus. *)
+let end_of_stack_kind = new_focus_kind ()
+let end_of_stack = done_cond_gen FullyUnfocused end_of_stack_kind
+
+let unfocused = is_last_focus end_of_stack_kind
+
+let start goals =
+  let pr =
+    { state = { proofview = Proofview.init goals ;
+	        focus_stack = [] ;
+	        intel = Store.empty} ;
+      undo_stack = [] ;
+      transactions = [] ;
+      info = { endline_tactic = Proofview.tclUNIT ();
+               initial_conclusions = List.map snd goals;
+               section_vars = None }
+    }
+  in
+  _focus end_of_stack (Obj.repr ()) 1 (List.length goals) pr;
+  pr
+
+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 reraise ->
+    restore_state starting_point pr;
+    raise reraise
+
+(*** 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 grab_evars p =
+    if not (is_done p) then
+      raise UnfinishedProof
+    else
+      save p;
+      p.state <- { p.state with proofview = Proofview.V82.grab p.state.proofview }
+    
+
+    let instantiate_evar n com pr =
+      let starting_point = save_state pr in
+      let sp = pr.state.proofview in
+      try
+	let new_proofview = Proofview.V82.instantiate_evar n com sp in
+	pr.state <- { pr.state with proofview = new_proofview };
+	push_undo starting_point pr
+      with reraise ->
+	restore_state starting_point pr;
+	raise reraise
+end
diff --git a/proofs/proof.mli b/proofs/proof.mli
new file mode 100644
index 00000000..2e7c7a5a
--- /dev/null
+++ b/proofs/proof.mli
@@ -0,0 +1,200 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* 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
+
+(* Returns a stylised view of a proof for use by, for instance,
+   ide-s. *)
+(* spiwack: the type of [proof] will change as we push more refined
+   functions to ide-s. This would be better than spawning a new nearly
+   identical function everytime. Hence the generic name. *)
+(* In this version: returns the focused goals, a representation of the
+   focus stack (the number of goals at each level) and the underlying
+   evar_map *)
+val proof : proof -> Goal.goal list * (Goal.goal list * Goal.goal list) list * Evd.evar_map
+
+(*** 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
+
+(* [unfocused p] returns [true] when [p] is fully unfocused. *)
+val unfocused : proof -> bool
+
+(* [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
+
+(* [is_last_focus k] check if the most recent focus is of kind [k] *)
+val is_last_focus : 'a focus_kind -> proof -> bool
+
+(* returns [true] if there is no goal under focus. *)
+val no_focused_goal : proof -> bool
+
+(*** Function manipulation proof extra informations ***)
+
+val get_proof_info : proof -> Store.t
+
+(* Sets the section variables assumed by the proof *)
+val set_used_variables : Sign.section_context -> proof -> unit
+val get_used_variables : proof -> Sign.section_context option
+
+(*** Endline tactic ***)
+
+(* Sets the tactic to be used when a tactic line is closed with [...] *)
+val set_endline_tactic : unit Proofview.tactic -> proof -> unit
+
+val with_end_tac : proof -> unit Proofview.tactic -> unit Proofview.tactic
+
+(*** Tactics ***)
+
+val run_tactic : Environ.env -> unit Proofview.tactic -> proof -> unit
+
+
+(*** Transactions ***)
+
+(* A transaction chains several commands into a single one. For instance,
+   a focusing command and a tactic. Transactions are such that if
+   any of the atomic action fails, the whole transaction fails.
+
+   During a transaction, the visible undo stack is constituted only
+   of the actions performed done during the transaction.
+
+   [transaction p f] can be called on an [f] using, itself, [transaction p].*)
+val transaction : proof -> (unit -> unit) -> unit
+
+
+(*** 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
+
+  (* Turns the unresolved evars into goals.
+     Raises [UnfinishedProof] if there are still unsolved goals. *)
+  val grab_evars : proof -> unit
+
+  (* 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..6cc5f9dc
--- /dev/null
+++ b/proofs/proof_global.ml
@@ -0,0 +1,417 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(***********************************************************************)
+(*                                                                     *)
+(*      This 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: the domain of proof_info is current_proof.*)
+(* The head of [!current_proof] is the actual current proof, the other ones are
+   to be resumed when the current proof is closed or aborted. *)
+let current_proof = ref ([]:nproof list)
+let proof_info = ref (Idmap.empty : proof_info Idmap.t)
+
+(* 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 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
+
+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 () =
+  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 ".")
+
+let there_is_a_proof () = !current_proof <> []
+let there_are_pending_proofs () = there_is_a_proof ()
+let check_no_pending_proof () =
+  if not (there_are_pending_proofs ()) then
+    ()
+  else begin
+    Util.error (Pp.string_of_ppcmds
+      (str"Proof editing in progress" ++ msg_proofs () ++ fnl() ++
+       str"Use \"Abort All\" first or complete proof(s)."))
+  end
+
+let discard_gen id =
+  ignore (extract id current_proof);
+  remove id proof_info
+
+let discard (loc,id) = 
+  try
+    discard_gen id
+  with NoSuchProof ->
+    Util.user_err_loc
+      (loc,"Pfedit.delete_proof",str"No such proof" ++ msg_proofs ())
+
+let discard_current () =
+  let (id,_) = extract_top current_proof in
+  remove id proof_info
+ 
+let discard_all () =
+  current_proof := [];
+  proof_info := Idmap.empty
+
+(* [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
+
+exception AlreadyExists
+let _ = Errors.register_handler begin function
+  | AlreadyExists -> Util.error "Already editing something of that name."
+  | _ -> raise Errors.Unhandled
+end
+(* [start_proof s str env t hook tac] starts a proof of name [s] and
+    conclusion [t]; [hook] is optionally a function to be applied at
+    proof end (e.g. to declare the built constructions as a coercion
+    or a setoid morphism); init_tac is possibly a tactic to
+    systematically apply at initialization time (e.g. to start the
+    proof of mutually dependent theorems).
+    It raises exception [ProofInProgress] if there is a proof being
+    currently edited. *)
+let start_proof  id str goals ?(compute_guard=[]) hook =
+  begin
+    List.iter begin fun (id_ex,_) ->
+      if Names.id_ord id id_ex = 0 then raise AlreadyExists
+    end !current_proof
+  end;
+  let p = Proof.start goals in
+  add id { strength=str ; 
+	        compute_guard=compute_guard ; 
+		hook=hook ;
+	        mode = ! default_proof_mode } proof_info ;
+  push (id,p) current_proof
+
+(* arnaud: à enlever *)
+let run_tactic tac = 
+  let p = give_me_the_proof () in
+  let env = Global.env () in
+  Proof.run_tactic env tac p
+
+(* Sets the tactic to be used when a tactic line is closed with [...] *)
+let set_endline_tactic tac =
+  let p = give_me_the_proof () in
+  Proof.set_endline_tactic tac p
+
+let set_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
+
+    (* spiwack: as it is bullets are reset (locally) by *any* non-bullet focusing command
+       experience will tell if this is the right discipline of if we want to be finer and
+       reset them only for a choice of bullets. *)
+    let get_bullets pr =
+      if Proof.is_last_focus bullet_kind pr then
+	Proof.get_at_focus bullet_kind pr
+      else
+	[]
+
+    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..cf97955e
--- /dev/null
+++ b/proofs/proof_global.mli
@@ -0,0 +1,131 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** This 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
+
+(** 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..468effeb 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-2012     *)
 (*   \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..262f183b 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-2012     *)
 (*   \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..d299a520
--- /dev/null
+++ b/proofs/proofview.ml
@@ -0,0 +1,525 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+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
+     }
+
+let proofview p =
+  p.comb , p.solution
+
+(* Initialises a proofview, the argument is a list of environement, 
+   conclusion types, and optional names, creating that many initial goals. *)
+let init = 
+  let 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
+
+let focus_context f = f
+
+(* This (internal) function extracts a sublist between two indices, and
+   returns this sublist together with its context:
+   if it returns [(a,(b,c))] then [a] is the sublist and (rev b)@a@c is the
+   original list.
+   The focused list has lenght [j-i-1] and contains the goals from
+   number [i] to number [j] (both included) the first goal of the list
+   being numbered [1].
+   [focus_sublist i j l] raises [IndexOutOfRange] if
+   [i > length l], or [j > length l] or [ j < i ].  *)
+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 when Errors.noncritical e -> sk (Util.Inr e) fk step
+    }
+  in
+  tclBIND t' begin function
+    | Util.Inl x -> tclUNIT x
+    | Util.Inr e -> tclZERO e
+  end
+let tclDISPATCHGEN null join tacs = purify (tclDISPATCHGEN null join tacs)
+
+let unitK () () = ()
+let tclDISPATCH = tclDISPATCHGEN () unitK
+
+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
+
+  (* Main function in the implementation of Grab Existential Variables.*)
+  let grab pv =
+    let goals =
+      List.map begin fun (e,_) ->
+	Goal.build e
+      end (Evd.undefined_list pv.solution)
+    in
+    { pv with comb = goals }
+      
+    
+
+  (* Returns the open goals of the proofview together with the evar_map to 
+     interprete them. *)
+  let goals { comb = comb ; solution = solution } = 
+    { Evd.it = comb ; sigma = solution}
+
+  let 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..fb215c52
--- /dev/null
+++ b/proofs/proofview.mli
@@ -0,0 +1,236 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* 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 
+
+
+(* Returns a stylised view of a proofview for use by, for instance,
+   ide-s. *)
+(* spiwack: the type of [proofview] will change as we push more
+   refined functions to ide-s. This would be better than spawning a
+   new nearly identical function everytime. Hence the generic name. *)
+(* In this version: returns the list of focused goals together with
+   the [evar_map] context. *)
+val proofview : proofview -> Goal.goal list * Evd.evar_map
+
+(* Initialises a proofview, the argument is a list of environement, 
+   conclusion types, creating that many initial goals. *)
+val init : (Environ.env * Term.types) list -> proofview
+
+(* Returns whether this proofview is finished or not.That is,
+   if it has empty subgoals in the comb. There could still be unsolved
+   subgoaled, but they would then be out of the view, focused out. *)
+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
+
+(* Returns a stylised view of a focus_context for use by, for
+   instance, ide-s. *)
+(* spiwack: the type of [focus_context] will change as we push more
+   refined functions to ide-s. This would be better than spawning a
+   new nearly identical function everytime. Hence the generic name. *)
+(* In this version: returns the number of goals that are held *)
+val focus_context : focus_context -> Goal.goal list * Goal.goal list
+
+(* [focus i j] focuses a proofview on the goals from index [i] to index [j] 
+   (inclusive). (i.e. goals number [i] to [j] become the only goals of the
+   returned proofview).
+   It returns the focus proof, and a context for the focus trace. *)
+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
+
+  (* Main function in the implementation of Grab Existential Variables.
+     Resets the proofview's goals so that it contains all unresolved evars
+     (in chronological order of insertion). *)
+  val grab : proofview -> proofview
+
+  (* 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..d5750cfa 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-2012     *)
 (*   \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..fec9840d 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-2012     *)
 (*   \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 87e7f4ce..21b43212 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: refiner.ml 15025 2012-03-09 14:27:07Z glondu $ *)
-
+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,_) | Compat.Exc_located(_, FailError (0,_))
-  | Compat.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))
-  | Compat.Exc_located(s,FailError (lvl,s')) ->
-      raise (Compat.Exc_located(s,FailError (lvl - 1, s')))
-  | Compat.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
-       (Compat.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 *)
@@ -510,7 +255,7 @@ let tclORELSE0 t1 t2 g =
   try
     t1 g
   with (* Breakpoint *)
-    | e -> catch_failerror e; t2 g
+    | e when Errors.noncritical e -> catch_failerror e; t2 g
 
 (* ORELSE t1 t2 tries to apply t1 and if it fails or does not progress,
    then applies t2 *)
@@ -522,12 +267,12 @@ let tclORELSE t1 t2 = tclORELSE0 (tclPROGRESS t1) t2
 let tclORELSE_THEN t1 t2then t2else gls =
   match
     try Some(tclPROGRESS t1 gls)
-    with e -> catch_failerror e; None
+    with e when Errors.noncritical 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)
@@ -553,7 +298,7 @@ let ite_gen tcal tac_if continue tac_else gl=
     try
       tcal tac_if0 continue gl
     with (* Breakpoint *)
-      | e -> catch_failerror e; tac_else0 e gl
+      | e when Errors.noncritical e -> catch_failerror e; tac_else0 e gl
 
 (* Try the first tactic and, if it succeeds, continue with
    the second one, and if it fails, use the third one *)
@@ -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!")
+    | reraise -> restore_timeout (); raise reraise
 
 (* 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}
@@ -917,43 +415,21 @@ let tclEVARS sigma gls = tclIDTAC {gls with sigma=sigma}
 let pp_info = ref (fun _ _ _ -> assert false)
 let set_info_printer f = pp_info := f
 
-let tclINFO (tac : tactic) gls =
-  let (sgl,v) as res = tac gls in
-  begin try
-    let 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
-
 (* 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 +438,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..4e30c9c0 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-2012     *)
 (*   \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,27 @@ 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 +163,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..1be0669c 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-2012     *)
 (*   \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,9 @@ 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 debug = Debug | Info | Off (* for trivial / auto / eauto ... *)
+
+type glob_red_flag =
   | FBeta
   | FIota
   | FZeta
@@ -107,20 +107,15 @@ 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))
+    'constr with_bindings induction_arg *
+    (intro_pattern_expr located option (* eqn:... *)
+    * intro_pattern_expr located option) (* as ... *)
 
 type ('constr,'id) induction_clause_list =
-    'constr induction_clause list * 'id gclause option
+    'constr induction_clause list
+    * 'constr with_bindings option (* using ... *)
+    * 'id gclause option (* in ... *)
 
 type multi =
   | Precisely of int
@@ -168,7 +163,8 @@ type ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_atomic_tactic_expr =
   | TacAssert of 'tac option * intro_pattern_expr located option * 'constr
   | TacGeneralize of ('constr with_occurrences * name) list
   | TacGeneralizeDep of 'constr
-  | TacLetTac of name * 'constr * 'id gclause * letin_flag
+  | TacLetTac of name * 'constr * 'id gclause * letin_flag *
+      intro_pattern_expr located option
 
   (* Derived basic tactics *)
   | TacSimpleInductionDestruct of rec_flag * quantified_hypothesis
@@ -181,13 +177,8 @@ type ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_atomic_tactic_expr =
   | TacLApply of 'constr
 
   (* Automation tactics *)
-  | TacTrivial of 'constr list * string list option
-  | TacAuto of int or_var option * 'constr list * string list option
-  | TacAutoTDB of int option
-  | TacDestructHyp of (bool * identifier located)
-  | TacDestructConcl
-  | TacSuperAuto of (int option * reference list * bool * bool)
-  | TacDAuto of int or_var option * int option * 'constr list
+  | TacTrivial of debug * 'constr list * string list option
+  | TacAuto of debug * int or_var option * 'constr list * string list option
 
   (* Context management *)
   | TacClear of bool * 'id list
@@ -201,7 +192,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 +230,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 +241,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 +264,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 +309,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 +319,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 +331,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..b2a853d7 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-2012     *)
 (*   \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
@@ -76,14 +72,6 @@ let pf_get_new_ids ids gls =
     (fun id acc -> (next_ident_away id (acc@avoid))::acc)
     ids []
 
-let pf_interp_constr gls c =
-  let evc = project gls in
-  Constrintern.interp_constr evc (pf_env gls) c
-
-let pf_interp_type gls c =
-  let evc = project gls in
-  Constrintern.interp_type evc (pf_env gls) c
-
 let pf_global gls id = Constrintern.construct_reference (pf_hyps gls) id
 
 let pf_parse_const gls = compose (pf_global gls) id_of_string
@@ -123,11 +111,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 +126,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 +194,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..ef4c7957 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-2012     *)
 (*   \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
@@ -54,9 +48,6 @@ val pf_type_of            : goal sigma -> constr -> types
 val pf_check_type         : goal sigma -> constr -> types -> unit
 val pf_hnf_type_of        : goal sigma -> constr -> types
 
-val pf_interp_constr      : goal sigma -> Topconstr.constr_expr -> constr
-val pf_interp_type        : goal sigma -> Topconstr.constr_expr -> types
-
 val pf_get_hyp            : goal sigma -> identifier -> named_declaration
 val pf_get_hyp_typ        : goal sigma -> identifier -> types
 
@@ -90,40 +81,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 +101,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 +114,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 +128,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..27ab990c 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-2012     *)
 (*   \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,16 +34,27 @@ 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 =
-  msgnl (str "Goal:" ++ fnl () ++ Proof_trees.db_pr_goal (Refiner.sig_it 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 () ++ db_pr_goal g)
+
 
 (* Prints the commands *)
 let help () =
-  msgnl (str "Commands: <Enter>=Continue" ++ fnl() ++
-         str "          h/?=Help" ++ fnl() ++
-         str "          r<num>=Run <num> times" ++ fnl() ++
-         str "          s=Skip" ++ fnl() ++
-         str "          x=Exit")
+  msgnl (str "Commands: <Enter> = Continue" ++ fnl() ++
+         str "          h/? = Help" ++ fnl() ++
+         str "          r <num> = Run <num> times" ++ fnl() ++
+         str "          r <string> = Run up to next idtac <string>" ++ fnl() ++
+         str "          s = Skip" ++ fnl() ++
+         str "          x = Exit")
 
 (* Prints the goal and the command to be executed *)
 let goal_com g tac =
@@ -54,37 +63,62 @@ let goal_com g tac =
     msg (str "Going to execute:" ++ fnl () ++ !prtac tac ++ fnl ())
   end
 
-(* Gives the number of a run command *)
+let skipped = ref 0
+let skip = ref 0
+let breakpoint = ref None
+
+let rec drop_spaces inst i =
+  if String.length inst > i && inst.[i] = ' ' then drop_spaces inst (i+1)
+  else i
+
+let possibly_unquote s =
+  if String.length s >= 2 & s.[0] = '"' & s.[String.length s - 1] = '"' then
+    String.sub s 1 (String.length s - 2)
+  else
+    s
+
+(* (Re-)initialize debugger *)
+let db_initialize () =
+  skip:=0;skipped:=0;breakpoint:=None
+
+(* Gives the number of steps or next breakpoint of a run command *)
 let run_com inst =
   if (String.get inst 0)='r' then
-    let num = int_of_string (String.sub inst 1 ((String.length inst)-1)) in
-    if num>0 then num
-    else raise (Invalid_argument "run_com")
+    let i = drop_spaces inst 1 in
+    if String.length inst > i then
+      let s = String.sub inst i (String.length inst - i) in
+      if inst.[0] >= '0' && inst.[0] <= '9' then
+        let num = int_of_string s in
+        if num<0 then raise (Invalid_argument "run_com");
+        skip:=num;skipped:=0
+      else
+        breakpoint:=Some (possibly_unquote s)
+    else
+      raise (Invalid_argument "run_com")
   else
     raise (Invalid_argument "run_com")
 
-let allskip = ref 0
-let skip = ref 0
-
 (* Prints the run counter *)
 let run ini =
   if not ini then
+  begin
     for i=1 to 2 do
       print_char (Char.chr 8);print_char (Char.chr 13)
     done;
-  msg (str "Executed expressions: " ++ int (!allskip - !skip) ++
-       fnl() ++ fnl())
+    msg (str "Executed expressions: " ++ int !skipped ++ fnl() ++ fnl())
+  end;
+  incr skipped
 
 (* Prints the prompt *)
 let rec prompt level =
   begin
     msg (fnl () ++ str "TcDebug (" ++ int level ++ str ") > ");
     flush stdout;
-    let exit () = skip:=0;allskip:=0;raise Sys.Break in
+    let exit () = skip:=0;skipped:=0;raise Sys.Break in
     let inst = try read_line () with End_of_file -> exit () in
     match inst with
-    | ""  -> true
-    | "s" -> false
+    | ""  -> DebugOn (level+1)
+    | "s" -> DebugOff
     | "x" -> print_char (Char.chr 8); exit ()
     | "h"| "?" ->
       begin
@@ -92,32 +126,34 @@ let rec prompt level =
         prompt level
       end
     | _ ->
-      (try let ctr=run_com inst in skip:=ctr;allskip:=ctr;run true;true
+      (try run_com inst;run true;DebugOn (level+1)
        with Failure _ | Invalid_argument _ -> prompt level)
   end
 
 (* Prints the state and waits for an instruction *)
 let debug_prompt lev g tac f =
   (* What to print and to do next *)
-  let continue =
-    if !skip = 0 then (goal_com g tac; prompt lev)
-    else (decr skip; run false; if !skip=0 then allskip:=0; true) in
+  let newlevel =
+    if !skip = 0 then
+      if !breakpoint = None then (goal_com g tac; prompt lev)
+      else (run false; DebugOn (lev+1))
+    else (decr skip; run false; if !skip=0 then skipped:=0; DebugOn (lev+1)) in
   (* What to execute *)
-  try f (if continue then DebugOn (lev+1) else DebugOff)
-  with e ->
-    skip:=0; allskip:=0;
-    if Logic.catchable_exception e then
-      ppnl (str "Level " ++ int lev ++ str ": " ++ !explain_logic_error e);
-    raise e
+  try f newlevel
+  with reraise ->
+    skip:=0; skipped:=0;
+    if Logic.catchable_exception reraise then
+      ppnl (str "Level " ++ int lev ++ str ": " ++ !explain_logic_error reraise);
+    raise reraise
 
 (* Prints a constr *)
 let db_constr debug env c =
-  if debug <> DebugOff & !skip = 0 then
+  if debug <> DebugOff & !skip = 0 & !breakpoint = None then
     msgnl (str "Evaluated term: " ++ print_constr_env env c)
 
 (* Prints the pattern rule *)
 let db_pattern_rule debug num r =
-  if debug <> DebugOff & !skip = 0 then
+  if debug <> DebugOff & !skip = 0 & !breakpoint = None then
   begin
     msgnl (str "Pattern rule " ++ int num ++ str ":");
     msgnl (str "|" ++ spc () ++ !prmatchrl r)
@@ -130,43 +166,38 @@ let hyp_bound = function
 
 (* Prints a matched hypothesis *)
 let db_matched_hyp debug env (id,_,c) ido =
-  if debug <> DebugOff & !skip = 0 then
+  if debug <> DebugOff & !skip = 0 & !breakpoint = None then
     msgnl (str "Hypothesis " ++
            str ((Names.string_of_id id)^(hyp_bound ido)^
                 " has been matched: ") ++ print_constr_env env c)
 
 (* Prints the matched conclusion *)
 let db_matched_concl debug env c =
-  if debug <> DebugOff & !skip = 0 then
+  if debug <> DebugOff & !skip = 0 & !breakpoint = None then
     msgnl (str "Conclusion has been matched: " ++ print_constr_env env c)
 
 (* Prints a success message when the goal has been matched *)
 let db_mc_pattern_success debug =
-  if debug <> DebugOff & !skip = 0 then
+  if debug <> DebugOff & !skip = 0 & !breakpoint = None then
     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
+  if debug <> DebugOff & !skip = 0 & !breakpoint = None then
     msgnl (str ("The pattern hypothesis"^(hyp_bound na)^
                 " cannot match: ") ++
            !prmatchpatt env hyp)
 
 (* Prints a matching failure message for a rule *)
 let db_matching_failure debug =
-  if debug <> DebugOff & !skip = 0 then
+  if debug <> DebugOff & !skip = 0 & !breakpoint = None then
     msgnl (str "This rule has failed due to matching errors!" ++ fnl() ++
            str "Let us try the next one...")
 
 (* Prints an evaluation failure message for a rule *)
 let db_eval_failure debug s =
-  if debug <> DebugOff & !skip = 0 then
+  if debug <> DebugOff & !skip = 0 & !breakpoint = None then
     let s = str "message \"" ++ s ++ str "\"" in
     msgnl
       (str "This rule has failed due to \"Fail\" tactic (" ++
@@ -174,9 +205,20 @@ let db_eval_failure debug s =
 
 (* Prints a logic failure message for a rule *)
 let db_logic_failure debug err =
-  if debug <> DebugOff & !skip = 0 then
+  if debug <> DebugOff & !skip = 0 & !breakpoint = None then
   begin
     msgnl (!explain_logic_error err);
     msgnl (str "This rule has failed due to a logic error!" ++ fnl() ++
            str "Let us try the next one...")
   end
+
+let is_breakpoint brkname s = match brkname, s with
+  | Some s, MsgString s'::_ -> s = s'
+  | _ -> false
+
+let db_breakpoint debug s =
+  match debug with
+  | DebugOn lev when s <> [] & is_breakpoint !breakpoint s ->
+      breakpoint:=None
+  | _ ->
+      ()
diff --git a/proofs/tactic_debug.mli b/proofs/tactic_debug.mli
index e2606a06..04b3cedf 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-2012     *)
 (*   \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,60 @@ 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 *)
+(** Initializes debugger *)
+val db_initialize : unit -> unit
+
+(** 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
+
+(** Prints a logic failure message for a rule *)
+val db_breakpoint : debug_info ->
+  identifier Util.located message_token list -> 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..dbd73bbb 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-2012     *)
 (*   \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.
 
@@ -30,8 +28,6 @@ let image = ref ""
 
 (* coqc options *)
 
-let specification = ref false
-let keep = ref false
 let verbose = ref false
 
 (* Verifies that a string starts by a letter and do not contain
@@ -106,34 +102,27 @@ let parse_args () =
   let rec parse (cfiles,args) = function
     | [] ->
 	List.rev cfiles, List.rev args
-    | "-i" :: rem ->
-	specification := true ; parse (cfiles,args) rem
-    | "-t" :: rem ->
-	keep := true ; parse (cfiles,args) rem
     | ("-verbose" | "--verbose") :: rem ->
 	verbose := true ; parse (cfiles,args) rem
-    | "-boot" :: rem ->
-	Flags.boot := true;
-	parse (cfiles, "-boot"::args) rem
-    | "-byte" :: rem ->
-	binary := "coqtop.byte"; parse (cfiles,args) rem
-    | "-opt" :: rem ->
-	binary := "coqtop.opt"; parse (cfiles,args) rem
     | "-image" :: f :: rem ->
 	image := f; parse (cfiles,args) rem
     | "-image" :: [] ->
 	usage ()
+    | "-byte" :: rem ->
+       binary := "coqtop.byte"; parse (cfiles,args) rem
+    | "-opt" :: rem ->
+       binary := "coqtop.opt"; parse (cfiles,args) rem
     | "-libdir" :: _ :: rem ->
-        print_string "Warning: option -libdir deprecated\n"; flush stdout;
+        print_string "Warning: option -libdir deprecated and ignored\n"; flush stdout;
         parse (cfiles,args) rem
     | ("-db"|"-debugger") :: rem ->
-        print_string "Warning: option -db/-debugger deprecated\n";flush stdout;
+        print_string "Warning: option -db/-debugger deprecated and ignored\n";flush stdout;
         parse (cfiles,args) rem
 
     | ("-?"|"-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
@@ -152,13 +141,12 @@ let parse_args () =
     | "-R" :: s :: "-as" :: [] -> usage ()
     | "-R" :: s :: t :: rem -> parse (cfiles,t::s::"-R"::args) rem
 
-    | ("-notactics"|"-debug"|"-nolib"
-      |"-debugVM"|"-alltransp"|"-VMno"
+    | ("-notactics"|"-debug"|"-nolib"|"-boot"
       |"-batch"|"-nois"|"-noglob"|"-no-glob"
       |"-q"|"-full"|"-profile"|"-just-parsing"|"-echo" |"-unsafe"|"-quiet"
       |"-silent"|"-m"|"-xml"|"-v7"|"-v8"|"-beautify"|"-strict-implicit"
-      |"-dont-load-proofs"|"-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 +157,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 +183,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..b75984e3 100644
--- a/scripts/coqmktop.ml
+++ b/scripts/coqmktop.ml
@@ -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-2012     *)
 (*   \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). *)
 
 open Unix
 
+(* In Win32 outside cygwin, Sys.command calls cmd.exe. When it executes
+   a command that may contains many double-quote, we should double-quote
+   the whole ! *)
+
+let safe_sys_command =
+  if Sys.os_type = "Win32" then
+    fun cmd -> Sys.command ("\""^cmd^"\"")
+  else Sys.command
+
 (* Objects to link *)
 
 (* 1. Core objects *)
 let ocamlobjs = ["str.cma";"unix.cma";"nums.cma"]
 let dynobjs = ["dynlink.cma"]
-let camlp4objs = ["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 +36,16 @@ 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" ]
 let topobjs = camlp4topobjs
 
 let gramobjs = []
@@ -47,23 +57,24 @@ 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 is_ocaml4 = Coq_config.caml_version.[0] <> '3'
+
+(* Since the .cma are given with their relative paths (e.g. "lib/clib.cma"),
+   we only need to include directories mentionned in the temp main ml file
+   below (for accessing the corresponding .cmi). *)
 
-let src_dirs () =
-  [ []; ["kernel";"byterun"]; [ "config" ]; [ "toplevel" ] ] @
-  if !coqide then [[ "ide" ]] else []
+let src_dirs =
+  [ []; ["lib"]; ["toplevel"]; ["kernel";"byterun"]; ]
 
 let includes () =
-  let coqlib = Envars.coqlib () in
-  let camlp4lib = Envars.camlp4lib () in
-    List.fold_right
-      (fun d l -> "-I" :: ("\"" ^ List.fold_left Filename.concat coqlib d ^ "\"") :: l)
-      (src_dirs ())
-      (["-I"; "\"" ^ camlp4lib ^ "\""] @
-	 ["-I"; "\"" ^ coqlib ^ "\""] @
-	 (if !coqide then ["-thread"; "-I"; "+lablgtk2"] else []))
+  let coqlib = if !Flags.boot then "." else Envars.coqlib () in
+  let mkdir d = "\"" ^ List.fold_left Filename.concat coqlib d ^ "\"" in
+  (List.fold_right (fun d l -> "-I" :: mkdir d :: l) src_dirs [])
+  @ ["-I"; "\"" ^ Envars.camlp4lib () ^ "\""]
+  @ (if is_ocaml4 then ["-I"; "+compiler-libs"] else [])
 
 (* Transform bytecode object file names in native object file names *)
 let native_suffix f =
@@ -89,18 +100,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 +135,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 +167,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 +184,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,28 +222,28 @@ 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 =
-  let main_name = Filename.temp_file "coqmain" ".ml" in
-  let oc = open_out main_name in
+  let main_name,oc = Filename.open_temp_file "coqmain" ".ml" in
   try
     (* Add the pre-linked modules *)
     output_string oc "List.iter Mltop.add_known_module [\"";
@@ -249,17 +251,13 @@ 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 ->
-    clean main_name; raise e
+  with reraise ->
+    clean main_name; raise reraise
 
 (* main part *)
 let main () =
@@ -270,12 +268,14 @@ let main () =
     if !opt then begin
       (* native code *)
       if !top then failwith "no custom toplevel in native code !";
-      let ocamloptexec = Filename.concat camlbin "ocamlopt" in
+      let ocamloptexec = Filename.quote (Filename.concat camlbin "ocamlopt") in
         ocamloptexec^" -linkall"
     end else
       (* bytecode (we shunt ocamlmktop script which fails on win32) *)
-      let ocamlmktoplib = " toplevellib.cma" in
-      let ocamlcexec = Filename.concat camlbin "ocamlc" in
+      let ocamlmktoplib = if is_ocaml4
+	then " ocamlcommon.cma ocamlbytecomp.cma ocamltoplevel.cma"
+	else " toplevellib.cma" in
+      let ocamlcexec = Filename.quote (Filename.concat camlbin "ocamlc") in
       let ocamlccustom = Printf.sprintf "%s %s -linkall "
         ocamlcexec Coq_config.coqrunbyteflags in
       (if !top then ocamlccustom^ocamlmktoplib else ocamlccustom)
@@ -292,8 +292,8 @@ let main () =
   (* the list of the loaded modules *)
   let main_file = create_tmp_main_file modules in
   try
-    let args =
-      options @ (includes ()) @ copts @ tolink @ dynlink @ [ main_file ] in
+    let args = options @ includes () @ copts @ tolink @ dynlink in
+    let args = args @ [ Filename.quote main_file ] in
       (* add topstart.cmo explicitly because we shunted ocamlmktop wrapper *)
     let args = if !top then args @ [ "topstart.cmo" ] else args in
       (* Now, with the .cma, we MUST use the -linkall option *)
@@ -306,14 +306,14 @@ let main () =
 	       (string_of_int (String.length command)) ^ " characters)");
 	  flush Pervasives.stdout
 	end;
-      let retcode = Sys.command command in
+      let retcode = safe_sys_command command in
 	clean main_file;
 	(* command gives the exit code in HSB, and signal in LSB !!! *)
 	if retcode > 255 then retcode lsr 8 else retcode
-  with e ->
-    clean main_file; raise e
+  with reraise ->
+    clean main_file; raise reraise
 
 let retcode =
-  try Printexc.print main () with _ -> 1
+  try Printexc.print main () with any -> 1
 
 let _ = exit retcode
diff --git a/states/MakeInitial.v b/states/MakeInitial.v
index 1787c840..109e0c30 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-2012     *)
 (*   \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..44fea151 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-2012     *)
 (*   \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
+
+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 {pri=pri1} {pri=pri2} = pri1 <= pri2
+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,144 @@ 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 subst_path_atom subst p =
+  match p with
+  | PathAny -> p
+  | PathHints grs ->
+    let gr' gr = fst (subst_global subst gr) in
+    let grs' = list_smartmap gr' grs in
+      if grs' == grs then p else PathHints grs'
+
+let rec subst_hints_path subst hp =
+  match hp with
+  | PathAtom p ->
+    let p' = subst_path_atom subst p in
+      if p' == p then hp else PathAtom p'
+  | PathStar p -> let p' = subst_hints_path subst p in
+      if p' == p then hp else PathStar p'
+  | PathSeq (p, q) ->
+    let p' = subst_hints_path subst p in
+    let q' = subst_hints_path subst q in
+      if p' == p && q' == q then hp else PathSeq (p', q')
+  | PathOr (p, q) ->
+    let p' = subst_hints_path subst p in
+    let q' = subst_hints_path subst q in
+      if p' == p && q' == q then hp else PathOr (p', q')
+  | _ -> hp
+
 module Hint_db = struct
 
   type t = {
     hintdb_state : Names.transparent_state;
+    hintdb_cut : hints_path;
     hintdb_unfolds : Idset.t * Cset.t;
+    mutable hintdb_max_id : int;
     use_dn : bool;
     hintdb_map : search_entry Constr_map.t;
     (* A list of unindexed entries starting with an unfoldable constant
@@ -148,8 +315,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 +329,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 +390,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_left (fun db k -> add_one k db) db l
 
-  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 +418,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 +453,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 +481,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 +533,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 +550,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 +559,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 +612,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 +654,73 @@ 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
+    let name' = subst_path_atom subst data.name in
+    let data' =
+      if data.pat==pat' && data.name == name' && data.code==code' then data
+      else { data with pat = pat'; name = name'; code = code' }
     in
-      if k' == k && data' == data then hint else
-	(k',data')
+    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 +729,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 +764,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 +776,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,58 +786,100 @@ 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
       int * (patvar list * constr_pattern) option * glob_tactic_expr
-  | 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 e when Errors.noncritical e -> 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))
+	Dumpglob.dump_reference (fst (qualid_of_reference qid)) "<>" (string_of_reference qid) "ind";
+        list_tabulate (fun i -> let c = (ind,i+1) in
+			 None, true, PathHints [ConstructRef c], mkConstruct c)
 	  (nconstructors ind) in
 	HintsResolveEntry (List.flatten (List.map constr_hints_of_ind lqid))
   | HintsExtern (pri, patcom, tacexp) ->
       let pat =	Option.map fp patcom in
       let tacexp = !forward_intern_tac (match pat with None -> [] | Some (l, _) -> l) tacexp in
       HintsExternEntry (pri, pat, tacexp)
-  | HintsDestruct(na,pri,loc,pat,code) ->
-      let (l,_ as pat) = fp pat in
-      HintsDestructEntry (na,pri,loc,pat,!forward_intern_tac l code)
 
 let add_hints local dbnames0 h =
+  if List.mem "nocore" dbnames0 then
+    error "The hint database \"nocore\" is meant to stay empty.";
   let dbnames = if dbnames0 = [] then ["core"] else dbnames0 in
   let env = Global.env() and sigma = Evd.empty in
   match h with
   | HintsResolveEntry lhints -> add_resolves env sigma lhints local dbnames
   | HintsImmediateEntry lhints -> add_trivials env sigma lhints local dbnames
+  | HintsCutEntry lhints -> add_cuts lhints local dbnames
   | HintsUnfoldEntry lhints -> add_unfolds lhints local dbnames
   | HintsTransparencyEntry (lhints, b) ->
       add_transparency lhints b local dbnames
   | HintsExternEntry (pri, pat, tacexp) ->
       add_externs pri pat tacexp local dbnames
-  | HintsDestructEntry (na,pri,loc,pat,code) ->
-      if dbnames0<>[] then
-        warn (str"Database selection not implemented for destruct hints");
-      Dhyp.add_destructor_hint local na loc pat pri code
 
 (**************************************************************************)
 (*                    Functions for printing the hints                    *)
@@ -630,17 +887,17 @@ let add_hints local dbnames0 h =
 
 let pr_autotactic =
   function
-  | Res_pf (c,clenv) -> (str"apply " ++ pr_lconstr c)
-  | ERes_pf (c,clenv) -> (str"eapply " ++ pr_lconstr c)
-  | Give_exact c -> (str"exact " ++ pr_lconstr c)
+  | Res_pf (c,clenv) -> (str"apply " ++ pr_constr c)
+  | ERes_pf (c,clenv) -> (str"eapply " ++ pr_constr c)
+  | Give_exact c -> (str"exact " ++ pr_constr c)
   | Res_pf_THEN_trivial_fail (c,clenv) ->
-      (str"apply " ++ pr_lconstr c ++ str" ; trivial")
+      (str"apply " ++ pr_constr c ++ str" ; trivial")
   | Unfold_nth c -> (str"unfold " ++  pr_evaluable_reference c)
   | Extern tac ->
-      (str "(external) " ++ Pptactic.pr_glob_tactic (Global.env()) 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,19 @@ 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;
+  modulo_delta_in_merge = None;
+  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 +1041,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 +1055,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")
@@ -832,13 +1108,138 @@ let conclPattern concl pat tac gl =
 	with PatternMatchingFailure -> error "conclPattern" in
     !forward_interp_tactic constr_bindings tac gl
 
+(***********************************************************)
+(** A debugging / verbosity framework for trivial and auto *)
+(***********************************************************)
+
+(** The following options allow to trigger debugging/verbosity
+    without having to adapt the scripts.
+    Note: if Debug and Info are both activated, Debug take precedence. *)
+
+let global_debug_trivial = ref false
+let global_debug_auto = ref false
+let global_info_trivial = ref false
+let global_info_auto = ref false
+
+let add_option ls refe =
+  let _ = Goptions.declare_bool_option
+    { Goptions.optsync  = true;
+      Goptions.optdepr  = false;
+      Goptions.optname  = String.concat " " ls;
+      Goptions.optkey   = ls;
+      Goptions.optread  = (fun () -> !refe);
+      Goptions.optwrite = (:=) refe }
+  in ()
+
+let _ =
+  add_option ["Debug";"Trivial"] global_debug_trivial;
+  add_option ["Debug";"Auto"] global_debug_auto;
+  add_option ["Info";"Trivial"] global_info_trivial;
+  add_option ["Info";"Auto"] global_info_auto
+
+let no_dbg () = (Off,0,ref [])
+
+let mk_trivial_dbg debug =
+  let d =
+    if debug = Debug || !global_debug_trivial then Debug
+    else if debug = Info || !global_info_trivial then Info
+    else Off
+  in (d,0,ref [])
+
+(** Note : we start the debug depth of auto at 1 to distinguish it
+   for trivial (whose depth is 0). *)
+
+let mk_auto_dbg debug =
+  let d =
+    if debug = Debug || !global_debug_auto then Debug
+    else if debug = Info || !global_info_auto then Info
+    else Off
+  in (d,1,ref [])
+
+let incr_dbg = function (dbg,depth,trace) -> (dbg,depth+1,trace)
+
+(** A tracing tactic for debug/info trivial/auto *)
+
+let tclLOG (dbg,depth,trace) pp tac =
+  match dbg with
+    | Off -> tac
+    | Debug ->
+       (* For "debug (trivial/auto)", we directly output messages *)
+      let s = String.make depth '*' in
+      begin fun gl ->
+	try
+	  let out = tac gl in
+	  msg_debug (str s ++ spc () ++ pp () ++ str ". (*success*)");
+	  out
+	with reraise ->
+	  msg_debug (str s ++ spc () ++ pp () ++ str ". (*fail*)");
+	  raise reraise
+      end
+    | Info ->
+      (* For "info (trivial/auto)", we store a log trace *)
+      begin fun gl ->
+	try
+	  let out = tac gl in
+	  trace := (depth, Some pp) :: !trace;
+	  out
+	with reraise ->
+	  trace := (depth, None) :: !trace;
+	  raise reraise
+      end
+
+(** For info, from the linear trace information, we reconstitute the part
+    of the proof tree we're interested in. The last executed tactic
+    comes first in the trace (and it should be a successful one).
+    [depth] is the root depth of the tree fragment we're visiting.
+    [keep] means we're in a successful tree fragment (the very last
+    tactic has been successful). *)
+
+let rec cleanup_info_trace depth acc = function
+  | [] -> acc
+  | (d,Some pp) :: l -> cleanup_info_trace d ((d,pp)::acc) l
+  | l -> cleanup_info_trace depth acc (erase_subtree depth l)
+
+and erase_subtree depth = function
+  | [] -> []
+  | (d,_) :: l -> if d = depth then l else erase_subtree depth l
+
+let pr_info_atom (d,pp) =
+  msg_debug (str (String.make d ' ') ++ pp () ++ str ".")
+
+let pr_info_trace = function
+  | (Info,_,{contents=(d,Some pp)::l}) ->
+      List.iter pr_info_atom (cleanup_info_trace d [(d,pp)] l)
+  | _ -> ()
+
+let pr_info_nop = function
+  | (Info,_,_) -> msg_debug (str "idtac.")
+  | _ -> ()
+
+let pr_dbg_header = function
+  | (Off,_,_) -> ()
+  | (Debug,0,_) -> msg_debug (str "(* debug trivial : *)")
+  | (Debug,_,_) -> msg_debug (str "(* debug auto : *)")
+  | (Info,0,_) -> msg_debug (str "(* info trivial : *)")
+  | (Info,_,_) -> msg_debug (str "(* info auto : *)")
+
+let tclTRY_dbg d tac =
+  tclORELSE0
+    (fun gl ->
+      pr_dbg_header d;
+      let out = tac gl in
+      pr_info_trace d;
+      out)
+    (fun gl ->
+      pr_info_nop d;
+      tclIDTAC gl)
+
 (**************************************************************************)
 (*                           The Trivial tactic                           *)
 (**************************************************************************)
 
 (* 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
@@ -855,17 +1256,20 @@ let exists_evaluable_reference env = function
   | EvalConstRef _ -> true
   | EvalVarRef v -> try ignore(lookup_named v env); true with Not_found -> false
 
-let rec trivial_fail_db mod_delta db_list local_db gl =
+let dbg_intro dbg = tclLOG dbg (fun () -> str "intro") intro
+let dbg_assumption dbg = tclLOG dbg (fun () -> str "assumption") assumption
+
+let rec trivial_fail_db dbg mod_delta db_list local_db gl =
   let intro_tac =
-    tclTHEN intro
+    tclTHEN (dbg_intro dbg)
       (fun g'->
 	 let hintl = make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g')
-	 in trivial_fail_db mod_delta db_list (Hint_db.add_list hintl local_db) g')
+	 in trivial_fail_db dbg mod_delta db_list (Hint_db.add_list hintl local_db) g')
   in
   tclFIRST
-    (assumption::intro_tac::
+    ((dbg_assumption dbg)::intro_tac::
      (List.map tclCOMPLETE
-       (trivial_resolve mod_delta db_list local_db (pf_concl gl)))) gl
+       (trivial_resolve dbg mod_delta db_list local_db (pf_concl gl)))) gl
 
 and my_find_search_nodelta db_list local_db hdc concl =
   List.map (fun hint -> (None,hint))
@@ -876,7 +1280,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,300 +1310,171 @@ 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 dbg 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))
-        (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
-
-and trivial_resolve mod_delta db_list local_db cl =
+        (unify_resolve_gen flags (c,cl))
+	(* With "(debug) trivial", we shouldn't end here, and
+	   with "debug auto" we don't display the details of inner trivial *)
+        (trivial_fail_db (no_dbg ()) (flags <> None) db_list local_db)
+    | 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
+  tclLOG dbg (fun () -> pr_autotactic t) tactic
+
+and trivial_resolve dbg mod_delta db_list local_db cl =
   try
     let head =
       try let hdconstr,_ = head_constr_bound cl in
 	    Some (head_of_constr_reference hdconstr)
       with Bound -> None
     in
-      List.map (tac_of_hint db_list local_db cl)
+      List.map (tac_of_hint dbg db_list local_db cl)
 	(priority
 	    (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
-  tclTRY (trivial_fail_db false db_list (make_local_hint_db false lems gl)) gl
+  List.map lookup dbnames
+
+let trivial ?(debug=Off) lems dbnames gl =
+  let db_list = make_db_list dbnames in
+  let d = mk_trivial_dbg debug in
+  tclTRY_dbg d
+    (trivial_fail_db d false db_list (make_local_hint_db false lems gl)) gl
 
-let full_trivial lems gl =
+let full_trivial ?(debug=Off) 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
+  let d = mk_trivial_dbg debug in
+  tclTRY_dbg d
+    (trivial_fail_db d false db_list (make_local_hint_db false lems gl)) gl
 
-let gen_trivial lems = function
-  | None -> full_trivial lems
-  | Some l -> trivial lems l
+let gen_trivial ?(debug=Off) lems = function
+  | None -> full_trivial ~debug lems
+  | Some l -> trivial ~debug lems l
 
-let inj_open c = (Evd.empty,c)
-
-let h_trivial lems l =
-  Refiner.abstract_tactic (TacTrivial (lems,l))
-    (gen_trivial lems l)
+let h_trivial ?(debug=Off) lems l =
+  Refiner.abstract_tactic (TacTrivial (debug,List.map snd lems,l))
+    (gen_trivial ~debug lems l)
 
 (**************************************************************************)
 (*                       The classical Auto tactic                        *)
 (**************************************************************************)
 
-let possible_resolve mod_delta db_list local_db cl =
+let possible_resolve dbg mod_delta db_list local_db cl =
   try
     let head =
       try let hdconstr,_ = head_constr_bound cl in
 	    Some (head_of_constr_reference hdconstr)
       with Bound -> None
     in
-      List.map (tac_of_hint db_list local_db cl)
+      List.map (tac_of_hint dbg db_list local_db cl)
 	(my_find_search mod_delta db_list local_db head cl)
   with Not_found -> []
 
-let decomp_unary_term_then (id,_,typc) kont1 kont2 gl =
+let dbg_case dbg id =
+  tclLOG dbg (fun () -> str "case " ++ pr_id id) (simplest_case (mkVar id))
+
+let decomp_unary_term_then dbg (id,_,typc) kont1 kont2 gl =
   try
     let ccl = applist (head_constr typc) in
     match Hipattern.match_with_conjunction ccl with
     | Some (_,args) ->
-	tclTHEN (simplest_case (mkVar id)) (kont1 (List.length args)) gl
+	tclTHEN (dbg_case dbg id) (kont1 (List.length args)) gl
     | None ->
 	kont2 gl
   with UserError _ -> kont2 gl
 
-let decomp_empty_term (id,_,typc) gl =
+let decomp_empty_term dbg (id,_,typc) gl =
   if Hipattern.is_empty_type typc then
-    simplest_case (mkVar id) gl
+    dbg_case dbg id gl
   else
     errorlabstrm "Auto.decomp_empty_term" (str "Not an empty type.")
 
 let extend_local_db gl decl db =
   Hint_db.add_list (make_resolve_hyp (pf_env gl) (project gl) decl) db
 
-(* Try to decompose hypothesis [decl] into atomic components of a
-   conjunction with maximum depth [p] (or solve the goal from an
-   empty type) then call the continuation tactic with hint db extended
-   with the obtained not-further-decomposable hypotheses *)
-
-let rec decomp_and_register_decl p kont (id,_,_ as decl) db gl =
-  if p = 0 then
-    kont (extend_local_db gl decl db) gl
-  else
-    tclORELSE0
-      (decomp_empty_term decl)
-      (decomp_unary_term_then decl (intros_decomp (p-1) kont [] db)
-	(kont (extend_local_db gl decl db))) gl
-
-(* Introduce [n] hypotheses, then decompose then with maximum depth [p] and
-   call the continuation tactic [kont] with the hint db extended
-   with the so-obtained not-further-decomposable hypotheses *)
-
-and intros_decomp p kont decls db n =
-  if n = 0 then
-    decomp_and_register_decls p kont decls db
-  else
-    tclTHEN intro (onLastDecl (fun d ->
-      (intros_decomp p kont (d::decls) db (n-1))))
+(* Introduce an hypothesis, then call the continuation tactic [kont]
+   with the hint db extended with the so-obtained hypothesis *)
 
-(* Decompose hypotheses [hyps] with maximum depth [p] and
-   call the continuation tactic [kont] with the hint db extended
-   with the so-obtained not-further-decomposable hypotheses *)
+let intro_register dbg kont db =
+  tclTHEN (dbg_intro dbg)
+    (onLastDecl (fun decl gl -> kont (extend_local_db gl decl db) gl))
 
-and decomp_and_register_decls p kont decls =
-  List.fold_left (decomp_and_register_decl p) kont decls
-
-
-(* decomp is an natural number giving an indication on decomposition
-   of conjunction in hypotheses, 0 corresponds to no decomposition *)
 (* n is the max depth of search *)
 (* local_db contains the local Hypotheses *)
 
 exception Uplift of tactic list
 
-let search_gen p n mod_delta db_list local_db =
-  let rec search n local_db =
+let search d n mod_delta db_list local_db =
+  let rec search d n local_db =
     if n=0 then (fun gl -> error "BOUND 2") else
-      tclORELSE0 assumption
-	(tclORELSE0 (intros_decomp p (search n) [] local_db 1)
-	   (fun gl -> tclFIRST
-	      (List.map (fun ntac -> tclTHEN ntac (search (n-1) local_db))
-		 (possible_resolve mod_delta db_list local_db (pf_concl gl))) gl))
+      tclORELSE0 (dbg_assumption d)
+	(tclORELSE0 (intro_register d (search d n) local_db)
+	   (fun gl ->
+	     let d' = incr_dbg d in
+	     tclFIRST
+	       (List.map
+		  (fun ntac -> tclTHEN ntac (search d' (n-1) local_db))
+		  (possible_resolve d mod_delta db_list local_db (pf_concl gl))) gl))
   in
-  search n local_db
-
-let search = search_gen 0
+  search d n local_db
 
 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
-  tclTRY (search n mod_delta db_list (make_local_hint_db false lems gl)) gl
+let delta_auto ?(debug=Off) mod_delta n lems dbnames gl =
+  let db_list = make_db_list dbnames in
+  let d = mk_auto_dbg debug in
+  tclTRY_dbg d
+    (search d n mod_delta db_list (make_local_hint_db false lems gl)) gl
 
-let auto = delta_auto false
+let auto ?(debug=Off) n = delta_auto ~debug false n
 
-let new_auto = delta_auto true
+let new_auto ?(debug=Off) n = delta_auto ~debug true n
 
 let default_auto = auto !default_search_depth [] []
 
-let delta_full_auto mod_delta n lems gl =
+let delta_full_auto ?(debug=Off) 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
+  let d = mk_auto_dbg debug in
+  tclTRY_dbg d
+    (search d n mod_delta db_list (make_local_hint_db false lems gl)) gl
 
-let full_auto = delta_full_auto false
-let new_full_auto = delta_full_auto true
+let full_auto ?(debug=Off) n = delta_full_auto ~debug false n
+let new_full_auto ?(debug=Off) n = delta_full_auto ~debug true n
 
 let default_full_auto gl = full_auto !default_search_depth [] gl
 
-let gen_auto n lems dbnames =
+let gen_auto ?(debug=Off) n lems dbnames =
   let n = match n with None -> !default_search_depth | Some n -> n in
   match dbnames with
-  | None -> full_auto n lems
-  | Some l -> auto n lems l
+  | None -> full_auto ~debug n lems
+  | Some l -> auto ~debug n lems l
 
 let inj_or_var = Option.map (fun n -> ArgArg n)
 
-let h_auto n lems l =
-  Refiner.abstract_tactic (TacAuto (inj_or_var n,lems,l))
-    (gen_auto n lems l)
-
-(**************************************************************************)
-(*                  The "destructing Auto" from Eduardo                   *)
-(**************************************************************************)
-
-(* Depth of search after decomposition of hypothesis, by default
-   one look for an immediate solution *)
-let default_search_decomp = ref 20
-
-let destruct_auto p lems n gl =
-  decomp_and_register_decls p (fun local_db gl ->
-    search_gen p n false (List.map searchtable_map ["core";"extcore"])
-      (add_hint_lemmas false lems local_db gl) gl)
-    (pf_hyps gl)
-    (Hint_db.empty empty_transparent_state false)
-    gl
-
-let dautomatic des_opt lems n = tclTRY (destruct_auto des_opt lems n)
-
-let dauto (n,p) lems =
-  let p = match p with Some p -> p | None -> !default_search_decomp in
-  let n = match n with Some n -> n | None -> !default_search_depth in
-  dautomatic p lems n
-
-let default_dauto = dauto (None,None) []
-
-let h_dauto (n,p) lems =
-  Refiner.abstract_tactic (TacDAuto (inj_or_var n,p,lems))
-    (dauto (n,p) lems)
-
-(***************************************)
-(*** A new formulation of Auto *********)
-(***************************************)
-
-let make_resolve_any_hyp env sigma (id,_,ty) =
-  let ents =
-    map_succeed
-      (fun f -> f (mkVar id,ty))
-      [make_exact_entry sigma None; make_apply_entry env sigma (true,true,false) None]
-  in
-  ents
-
-type autoArguments =
-  | UsingTDB
-  | Destructing
-
-let compileAutoArg contac = function
-  | Destructing ->
-      (function g ->
-         let ctx = pf_hyps g in
-	 tclFIRST
-           (List.map
-              (fun (id,_,typ) ->
-                let cl = (strip_prod_assum typ) in
-                 if Hipattern.is_conjunction cl
-		 then
-		   tclTHENSEQ [simplest_elim (mkVar id); clear [id]; contac]
-                 else
-		   tclFAIL 0 (pr_id id ++ str" is not a conjunction"))
-	     ctx) g)
-  | UsingTDB ->
-      (tclTHEN
-         (Tacticals.tryAllHypsAndConcl
-            (function
-               | Some id -> Dhyp.h_destructHyp false id
-               | None    -> Dhyp.h_destructConcl))
-         contac)
-
-let compileAutoArgList contac = List.map (compileAutoArg contac)
-
-let rec super_search n db_list local_db argl gl =
-  if n = 0 then error "BOUND 2";
-  tclFIRST
-    (assumption
-     ::
-     tclTHEN intro
-        (fun g ->
-	   let hintl = pf_apply make_resolve_any_hyp g (pf_last_hyp g) in
-	   super_search n db_list (Hint_db.add_list hintl local_db)
-	     argl g)
-     ::
-     List.map (fun ntac ->
-            tclTHEN ntac
-              (super_search (n-1) db_list local_db argl))
-         (possible_resolve false db_list local_db (pf_concl gl))
-      @
-      compileAutoArgList (super_search (n-1) db_list local_db argl) argl) gl
-
-let search_superauto n to_add argl g =
-  let sigma =
-    List.fold_right
-      (fun (id,c) -> add_named_decl (id, None, pf_type_of g c))
-      to_add empty_named_context in
-  let db0 = list_map_append (make_resolve_hyp (pf_env g) (project g)) sigma in
-  let db = Hint_db.add_list db0 (make_local_hint_db false [] g) in
-  super_search n [Hintdbmap.find "core" !searchtable] db argl g
-
-let superauto n to_add argl  =
-  tclTRY (tclCOMPLETE (search_superauto n to_add argl))
-
-let interp_to_add gl r =
-  let r = locate_global_with_alias (qualid_of_reference r) in
-  let id = basename_of_global r in
-  (next_ident_away id (pf_ids_of_hyps gl), constr_of_global r)
-
-let gen_superauto nopt l a b gl =
-  let n = match nopt with Some n -> n | None -> !default_search_depth in
-  let al = (if a then [Destructing] else [])@(if b then [UsingTDB] else []) in
-  superauto n (List.map (interp_to_add gl) l) al gl
-
-let h_superauto no l a b =
-  Refiner.abstract_tactic (TacSuperAuto (no,l,a,b)) (gen_superauto no l a b)
-
+let h_auto ?(debug=Off) n lems l =
+  Refiner.abstract_tactic (TacAuto (debug,inj_or_var n,List.map snd lems,l))
+    (gen_auto ~debug n lems l)
diff --git a/tactics/auto.mli b/tactics/auto.mli
index eef6a0ee..7daebb36 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-2012     *)
 (*   \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,32 +95,35 @@ 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
       int * (patvar list * constr_pattern) option * Tacexpr.glob_tactic_expr
-  | HintsDestructEntry of identifier * int * (bool,unit) Tacexpr.location *
-      (patvar list * constr_pattern) * Tacexpr.glob_tactic_expr
 
 val searchtable_map : hint_db_name -> hint_db
 
 val searchtable_add : (hint_db_name * hint_db) -> unit
 
-(* [create_hint_db local name st use_dn].
+(** [create_hint_db local name st use_dn].
    [st] is a transparency state for unification using this db
    [use_dn] switches the use of the discrimination net for all hints
    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 +134,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 +148,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 +170,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 +187,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,72 +199,70 @@ 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 *)
+
+(** The use of the "core" database can be de-activated by passing
+    "nocore" amongst the databases. *)
+
+val make_db_list : hint_db_name list -> hint_db list
 
-val auto : int -> constr list -> hint_db_name list -> tactic
+val auto : ?debug:Tacexpr.debug ->
+  int -> open_constr list -> hint_db_name list -> tactic
 
-(* Auto with more delta. *)
+(** Auto with more delta. *)
 
-val new_auto : int -> constr list -> hint_db_name list -> tactic
+val new_auto : ?debug:Tacexpr.debug ->
+  int -> open_constr list -> hint_db_name list -> tactic
 
-(* auto with default search depth and with the hint database "core" *)
+(** 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 : ?debug:Tacexpr.debug ->
+  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 : ?debug:Tacexpr.debug ->
+  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 hidden version of auto *)
-val h_auto   : int option -> 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
-
-val pr_autotactic : auto_tactic -> Pp.std_ppcmds
-
-(*s The following is not yet up to date -- Papageno. *)
+(** The generic form of auto (second arg [None] means all bases) *)
+val gen_auto : ?debug:Tacexpr.debug ->
+  int option -> open_constr list -> hint_db_name list option -> tactic
 
-(* DAuto *)
-val dauto : int option * int option -> constr list -> tactic
-val default_search_decomp : int ref
-val default_dauto : tactic
+(** The hidden version of auto *)
+val h_auto   : ?debug:Tacexpr.debug ->
+  int option -> open_constr list -> hint_db_name list option -> tactic
 
-val h_dauto : int option * int option -> constr list -> tactic
-(* SuperAuto *)
+(** Trivial *)
 
-type autoArguments =
-  | UsingTDB
-  | Destructing
+val trivial : ?debug:Tacexpr.debug ->
+  open_constr list -> hint_db_name list -> tactic
+val gen_trivial : ?debug:Tacexpr.debug ->
+  open_constr list -> hint_db_name list option -> tactic
+val full_trivial : ?debug:Tacexpr.debug ->
+  open_constr list -> tactic
+val h_trivial : ?debug:Tacexpr.debug ->
+  open_constr list -> hint_db_name list option -> tactic
 
-(*
-val superauto : int -> (identifier * constr) list -> autoArguments list -> tactic
-*)
+val pr_autotactic : 'a auto_tactic -> Pp.std_ppcmds
 
-val h_superauto : int option -> reference list -> bool -> bool -> tactic
+(** Hook for changing the initialization of auto *)
 
-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..8e1d7cbf 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-2012     *)
 (*   \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
@@ -210,8 +208,14 @@ let auto_multi_rewrite_with ?(conds=Naive) tac_main lbas cl gl =
 
 (* Functions necessary to the library object declaration *)
 let cache_hintrewrite (_,(rbase,lrl)) =
-  let base = try find_base rbase with _ -> HintDN.empty in
-  let max = try fst (Util.list_last (HintDN.find_all base)) with _ -> 0 in
+  let base =
+    try find_base rbase
+    with e when Errors.noncritical e -> HintDN.empty
+  in
+  let max =
+    try fst (Util.list_last (HintDN.find_all base))
+    with e when Errors.noncritical e -> 0
+  in
   let lrl = HintDN.map (fun (i,h) -> (i + max, h)) lrl in
     rewtab:=Stringmap.add rbase (HintDN.union lrl base) !rewtab
 
@@ -225,7 +229,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,9 +252,9 @@ 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
+  with e when Errors.noncritical e -> false
 
 let decompose_applied_relation metas env sigma c ctype left2right =
   let find_rel ty =
diff --git a/tactics/autorewrite.mli b/tactics/autorewrite.mli
index ec285500..96830d95 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-2012     *)
 (*   \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..fcf9efeb 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-2012     *)
 (*   \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..fedc6804 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-2012     *)
 (*   \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 cf9213dd..d05ae680 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-2012     *)
 (*   \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 15025 2012-03-09 14:27:07Z glondu $ *)
-
 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,58 @@ 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;
+  modulo_delta_in_merge = None;
+  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 +104,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 +135,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 +148,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 +168,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 +176,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
-  | Compat.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 +241,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 +309,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 +335,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)
-	  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
+      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 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 +445,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 +519,222 @@ 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)
+
+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
 
-exception FoundTerm of constr
+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)
 
+(** [split_evars] returns groups of undefined evars according to dependencies *)
+
+let split_evars evm =
+  let p = Intpart.create () in
+  evar_dependencies evm p;
+  deps_of_constraints (snd (extract_all_conv_pbs evm)) evm p;
+  Intpart.partition p
+
+(** [evars_in_comp] filters an [evar_map], keeping only evars
+    that belongs to a certain component *)
+
+let evars_in_comp comp evm =
+  try
+    evars_reset_evd 
+      (Intset.fold (fun ev acc -> Evd.add acc ev (Evd.find_undefined evm ev))
+	 comp Evd.empty) evm
+  with Not_found -> assert false
+
+let is_inference_forced p evd ev =
+  try
+    let evi = Evd.find_undefined evd ev in
+    if Typeclasses.is_resolvable evi && snd (p ev evi)
+    then
+      let (loc, k) = evar_source ev evd in
+      match k with
+	| ImplicitArg (_, _, b) -> b
+	| QuestionMark _ -> false
+	| _ -> true
+    else true
+  with Not_found -> assert false
+
+let is_mandatory p comp evd =
+  Intset.exists (is_inference_forced p evd) comp
+
+(** In case of unsatisfiable constraints, build a nice error message *)
+
+let error_unresolvable env comp do_split evd =
+  let evd = Evarutil.nf_evar_map_undefined evd in
+  let evm = if do_split then evars_in_comp comp evd else evd in
+  let _, ev = Evd.fold_undefined
+    (fun ev evi (b,acc) ->
+      (* focus on one instance if only one was searched for *)
+      if class_of_constr evi.evar_concl <> None then
+	if not b (* || do_split *) then
+	  true, Some ev
+	else b, None
+      else b, acc) evm (false, None)
+  in
+  Typeclasses_errors.unsatisfiable_constraints
+    (Evarutil.nf_env_evar evm env) evm ev
+
+(** Check if an evar is concerned by the current resolution attempt,
+    (and in particular is in the current component), and also update
+    its evar_info.
+    Invariant : this should only be applied to undefined evars,
+    and return undefined evar_info *)
+
+let select_and_update_evars p oevd in_comp evd ev evi =
+  assert (evi.evar_body = Evar_empty);
+  try
+    let oevi = Evd.find_undefined oevd ev in
+    if Typeclasses.is_resolvable oevi then
+      Typeclasses.mark_unresolvable evi,
+      (in_comp ev && p evd ev evi)
+    else evi, false
+  with Not_found ->
+    Typeclasses.mark_unresolvable evi, p evd ev evi
+
+(** Do we still have unresolved evars that should be resolved ? *)
+
 let has_undefined p oevd evd =
-  Evd.fold (fun ev evi has -> has ||
-    (evi.evar_body = Evar_empty && snd (p oevd ev evi)))
+  Evd.fold_undefined (fun ev evi has -> has ||
+    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 []
+(** Revert the resolvability status of evars after resolution,
+    potentially unprotecting some evars that were set unresolvable
+    just for this call to resolution. *)
 
-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 revert_resolvability oevd evd = 
+  Evd.fold_undefined
+    (fun ev evi evm ->
+     try 
+       if not (Typeclasses.is_resolvable evi) then
+	 let evi' = Evd.find_undefined oevd ev in
+	   if Typeclasses.is_resolvable evi' then
+	     Evd.add evm ev (Typeclasses.mark_resolvable evi)
+	   else evm
+       else evm
+     with Not_found -> evm)
+  evd evd
 
-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
+(** If [do_split] is [true], we try to separate the problem in
+    several components and then solve them separately *)
 
-let is_inference_forced p ev evd =
-  try
-    let evi = Evd.find evd ev in
-      if evi.evar_body = Evar_empty then
-	if Typeclasses.is_resolvable evi
-	  && snd (p ev evi)
-	then
-	  let (loc, k) = evar_source ev evd in
-	    match k with
-	    | ImplicitArg (_, _, b) -> b
-	    | QuestionMark _ -> false
-	    | _ -> true
-	else true
-      else false
-  with Not_found -> true
-
-let is_optional p comp evd =
-  Intset.fold (fun ev acc ->
-    acc && not (is_inference_forced p ev evd))
-    comp true
+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
+    | [] -> revert_resolvability oevd 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 filter evd ev evi =
+  filter (snd evi.Evd.evar_source) &&
+  Typeclasses.is_class_evar evd evi
 
-let solve_inst debug mode depth env evd onlyargs split fail =
-  resolve_typeclass_evars debug (mode, depth) env evd onlyargs split fail
+let resolve_typeclass_evars debug m env evd filter split fail =
+  let evd = 
+    try Evarconv.consider_remaining_unif_problems
+      ~ts:(Typeclasses.classes_transparent_state ()) env evd
+    with e when Errors.noncritical e -> evd
+  in
+    resolve_all_evars debug m env (initial_select_evars filter) evd split fail
+
+let solve_inst debug depth env evd filter split fail =
+  resolve_typeclass_evars debug depth env evd filter split fail
 
 let _ =
   Typeclasses.solve_instanciations_problem :=
-    solve_inst false 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 +757,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,22 +765,24 @@ 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
 
 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 dbs = list_map_filter
+      (fun db -> try Some (Auto.searchtable_map db)
+        with e when Errors.noncritical e -> None) dbs
+    in
     let st = match dbs with x :: _ -> Hint_db.transparent_state x | _ -> st in
-      eauto ~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..85d669a1 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-2012     *)
 (*   \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..dd91c30a 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-2012     *)
 (*   \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
deleted file mode 100644
index 041e58df..00000000
--- a/tactics/dhyp.ml
+++ /dev/null
@@ -1,361 +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: dhyp.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
-(* Chet's comments about this tactic :
-
- Programmable destruction of hypotheses and conclusions.
-
-   The idea here is that we are going to store patterns.  These
-   patterns look like:
-
-   TYP=<pattern>
-   SORT=<pattern>
-
-   and from these patterns, we will be able to decide which tactic to
-   execute.
-
-   For hypotheses, we have a vector of 4 patterns:
-
-   HYP[TYP] HYP[SORT] CONCL[TYP] CONCL[SORT]
-
-   and for conclusions, we have 2:
-
-   CONCL[TYP] CONCL[SORT]
-
-   If the user doesn't supply some of these, they are just replaced
-   with empties.
-
-   The process of matching goes like this:
-
-   We use a discrimination net to look for matches between the pattern
-   for HYP[TOP] (CONCL[TOP]) and the type of the chosen hypothesis.
-   Then, we use this to look for the right tactic to apply, by
-   matching the rest of the slots.  Each match is tried, and if there
-   is more than one, this fact is reported, and the one with the
-   lowest priority is taken.  The priority is a parameter of the
-   tactic input.
-
-   The tactic input is an expression to hand to the
-   tactic-interpreter, and its priority.
-
-   For most tactics, the priority should be the number of subgoals
-   generated.
-
-   Matching is compatible with second-order matching of sopattern.
-
-   SYNTAX:
-
-   Hint DHyp <hyp-pattern> pri <tac-pattern>.
-
-   and
-
-   Hint DConcl <concl-pattern> pri <tac-pattern>.
-
-   The bindings at the end allow us to transfer information from the
-   patterns on terms into the patterns on tactics in a safe way - we
-   will perform second-order normalization and conversion to an AST
-   before substitution into the tactic-expression.
-
-   WARNING: The binding mechanism is NOT intended to facilitate the
-   transfer of large amounts of information from the terms to the
-   tactic.  This should be done in a special-purpose tactic.
-
- *)
-
-(*
-
-Example : The tactic "if there is a hypothesis saying that the
-successor of some number is smaller than zero, then invert such
-hypothesis" is defined in this way:
-
-Require DHyp.
-Hint Destruct Hypothesis less_than_zero (le (S ?) O) 1
-  (:tactic:<Inversion $0>).
-
-Then, the tactic is used like this:
-
-Goal (le (S O) O) -> False.
-Intro H.
-DHyp  H.
-Qed.
-
-The name "$0" refers to the matching hypothesis --in this case the
-hypothesis H.
-
-Similarly for the conclusion :
-
-Hint Destruct Conclusion equal_zero  (? = ?) 1 (:tactic:<Reflexivity>).
-
-Goal (plus O O)=O.
-DConcl.
-Qed.
-
-The "Discardable" option clears the hypothesis after using it.
-
-Require DHyp.
-Hint Destruct  Discardable Hypothesis less_than_zero (le (S ?) O) 1
-  (:tactic:<Inversion $0>).
-
-Goal (n:nat)(le (S n) O) -> False.
-Intros n H.
-DHyp  H.
-Qed.
--- Eduardo (9/3/97 )
-
-*)
-
-open Pp
-open Util
-open Names
-open Term
-open Environ
-open Reduction
-open Proof_type
-open Rawterm
-open Tacmach
-open Refiner
-open Tactics
-open Clenv
-open Tactics
-open Tacticals
-open Libobject
-open Library
-open Pattern
-open Matching
-open Pcoq
-open Tacexpr
-open Termops
-open Libnames
-
-(* two patterns - one for the type, and one for the type of the type *)
-type destructor_pattern = {
-  d_typ: constr_pattern;
-  d_sort: constr_pattern }
-
-let subst_destructor_pattern subst { d_typ = t; d_sort = s } =
-  { d_typ = subst_pattern subst t; d_sort = subst_pattern subst s }
-
-(* hypothesis patterns might need to do matching on the conclusion, too.
- * conclusion-patterns only need to do matching on the hypothesis *)
-type located_destructor_pattern =
-   (* discardable, pattern for hyp, pattern for concl *)
-   (bool * destructor_pattern * destructor_pattern,
-   (* pattern for concl *)
-   destructor_pattern) location
-
-let subst_located_destructor_pattern subst = function
-  | HypLocation (b,d,d') ->
-      HypLocation
-        (b,subst_destructor_pattern subst d, subst_destructor_pattern subst d')
-  | ConclLocation d ->
-      ConclLocation (subst_destructor_pattern subst d)
-
-
-type destructor_data = {
-  d_pat : located_destructor_pattern;
-  d_pri : int;
-  d_code : identifier option * glob_tactic_expr (* should be of phylum tactic *)
-}
-
-module Dest_data = struct 
-  type t = destructor_data
-  let compare = Pervasives.compare
-    end
-
-module Nbterm_net = Nbtermdn.Make(Dest_data)
-
-type t = identifier Nbterm_net.t
-type frozen_t = identifier Nbterm_net.frozen_t
-
-let tactab = (Nbterm_net.create () : t)
-
-let lookup pat = Nbterm_net.lookup tactab pat
-
-
-let init () = Nbterm_net.empty tactab
-
-let freeze () = Nbterm_net.freeze tactab
-let unfreeze fs = Nbterm_net.unfreeze fs tactab
-
-let add (na,dd) =
-  let pat = match dd.d_pat with
-    | HypLocation(_,p,_) -> p.d_typ
-    | ConclLocation p -> p.d_typ
-  in
-  if Nbterm_net.in_dn tactab na then begin
-    msgnl (str "Warning [Overriding Destructor Entry " ++
-             str (string_of_id na) ++ str"]");
-    Nbterm_net.remap tactab na (pat,dd)
-  end else
-    Nbterm_net.add tactab (na,(pat,dd))
-
-let _ =
-  Summary.declare_summary "destruct-hyp-concl"
-    { Summary.freeze_function = freeze;
-      Summary.unfreeze_function = unfreeze;
-      Summary.init_function = init }
-
-let forward_subst_tactic =
-  ref (fun _ -> failwith "subst_tactic is not installed for DHyp")
-
-let cache_dd (_,(_,na,dd)) =
-  try
-    add (na,dd)
-  with _ ->
-    anomalylabstrm "Dhyp.add"
-      (str"The code which adds destructor hints broke;" ++ spc () ++
-	 str"this is not supposed to happen")
-
-let classify_dd (local,_,_ as o) =
-  if local then Dispose else Substitute o
-
-let subst_dd (subst,(local,na,dd)) =
-  (local,na,
-  { d_pat = subst_located_destructor_pattern subst dd.d_pat;
-    d_pri = dd.d_pri;
-    d_code = !forward_subst_tactic subst dd.d_code })
-
-let (inDD,_) =
-  declare_object {(default_object "DESTRUCT-HYP-CONCL-DATA") with
-                    cache_function = cache_dd;
-		    open_function = (fun i o -> if i=1 then cache_dd o);
-                    subst_function = subst_dd;
-		    classify_function = classify_dd }
-
-let catch_all_sort_pattern = PMeta(Some (id_of_string "SORT"))
-let catch_all_type_pattern = PMeta(Some (id_of_string "TYPE"))
-
-let add_destructor_hint local na loc (_,pat) pri code =
-  let code =
-    begin match loc, code with
-      | HypLocation _, TacFun ([id],body) -> (id,body)
-      | ConclLocation _, _ -> (None, code)
-      | _ ->
-	  errorlabstrm "add_destructor_hint"
-          (str "The tactic should be a function of the hypothesis name.") end
-  in
-  let pat = match loc with
-    | HypLocation b ->
-	HypLocation
-	  (b,{d_typ=pat;d_sort=catch_all_sort_pattern},
-	     {d_typ=catch_all_type_pattern;d_sort=catch_all_sort_pattern})
-    | ConclLocation () ->
-	ConclLocation({d_typ=pat;d_sort=catch_all_sort_pattern}) in
-  Lib.add_anonymous_leaf
-    (inDD (local,na,{ d_pat = pat; d_pri=pri; d_code=code }))
-
-let match_dpat dp cls gls =
-  let onconcl = cls.concl_occs <> no_occurrences_expr in
-  match (cls,dp) with
-    | ({onhyps=lo},HypLocation(_,hypd,concld)) when not onconcl ->
-        let hl = match lo with
-            Some l -> l
-          | None -> List.map (fun id -> ((all_occurrences_expr,id),InHyp))
-	              (pf_ids_of_hyps gls) in
-        if not
-          (List.for_all
-            (fun ((_,id),hl) ->
-              let cltyp = pf_get_hyp_typ gls id in
-              let cl = pf_concl gls in
-              (hl=InHyp) &
-              (is_matching hypd.d_typ cltyp) &
-              (is_matching hypd.d_sort (pf_type_of gls cltyp)) &
-              (is_matching concld.d_typ cl) &
-              (is_matching concld.d_sort (pf_type_of gls cl)))
-            hl)
-        then error "No match."
-    | ({onhyps=Some[]},ConclLocation concld) when onconcl ->
-        let cl = pf_concl gls in
-        if not
-          ((is_matching concld.d_typ cl) &
-           (is_matching concld.d_sort (pf_type_of gls cl)))
-        then error "No match."
-    | _ -> error "ApplyDestructor"
-
-let forward_interp_tactic =
-  ref (fun _ -> failwith "interp_tactic is not installed for DHyp")
-
-let set_extern_interp f = forward_interp_tactic := f
-
-let applyDestructor cls discard dd gls =
-  match_dpat dd.d_pat cls gls;
-  let cll = simple_clause_of cls gls in
-  let tacl =
-    List.map (fun cl ->
-      match cl, dd.d_code with
-        | Some id, (Some x, tac) ->
-	    let arg =
-              ConstrMayEval(ConstrTerm (RRef(dummy_loc,VarRef id),None)) in
-            TacLetIn (false, [(dummy_loc, x), arg], tac)
-        | None, (None, tac) -> tac
-        | _, (Some _,_) -> error "Destructor expects an hypothesis."
-        | _, (None,_) -> error "Destructor is for conclusion.")
-      cll in
-  let discard_0 =
-    List.map (fun cl ->
-      match (cl,dd.d_pat) with
-        | (Some id,HypLocation(discardable,_,_)) ->
-            if discard & discardable then thin [id] else tclIDTAC
-        | (None,ConclLocation _) -> tclIDTAC
-        | _ -> error "ApplyDestructor" ) cll in
-  tclTHEN (tclMAP !forward_interp_tactic tacl) (tclTHENLIST discard_0) gls
-
-
-(* [DHyp id gls]
-
-   will take an identifier, get its type, look it up in the
-   discrimination net, get the destructors stored there, and then try
-   them in order of priority. *)
-
-let destructHyp discard id gls =
-  let hyptyp = pf_get_hyp_typ gls id in
-  let ddl = List.map snd (lookup hyptyp) in
-  let sorted_ddl = Sort.list (fun dd1 dd2 -> dd1.d_pri > dd2.d_pri) ddl in
-  tclFIRST (List.map (applyDestructor (onHyp id) discard) sorted_ddl) gls
-
-let dHyp id gls = destructHyp false id gls
-
-let h_destructHyp b id =
-  abstract_tactic (TacDestructHyp (b,(dummy_loc,id))) (destructHyp b id)
-
-(* [DConcl gls]
-
-   will take a goal, get its concl, look it up in the
-   discrimination net, get the destructors stored there, and then try
-   them in order of priority. *)
-
-let dConcl gls =
-  let ddl = List.map snd (lookup (pf_concl gls)) in
-  let sorted_ddl = Sort.list (fun dd1 dd2 -> dd1.d_pri > dd2.d_pri) ddl in
-  tclFIRST (List.map (applyDestructor onConcl false) sorted_ddl) gls
-
-let h_destructConcl = abstract_tactic TacDestructConcl dConcl
-
-let rec search n =
-  if n=0 then error "Search has reached zero.";
-  tclFIRST
-    [intros;
-     assumption;
-     (tclTHEN
-        (Tacticals.tryAllHypsAndConcl
-           (function
-              | Some id -> (dHyp id)
-              | None    ->  dConcl ))
-        (search (n-1)))]
-
-let auto_tdb n = tclTRY (tclCOMPLETE (search n))
-
-let search_depth_tdb = ref(5)
-
-let depth_tdb = function
-  | None -> !search_depth_tdb
-  | Some n -> n
-
-let h_auto_tdb n = abstract_tactic (TacAutoTDB n) (auto_tdb (depth_tdb n))
diff --git a/tactics/dhyp.mli b/tactics/dhyp.mli
deleted file mode 100644
index 4cde3b49..00000000
--- a/tactics/dhyp.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: 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. *)
-
-val set_extern_interp : (glob_tactic_expr -> tactic) -> unit
-
-(*
-val dHyp : identifier -> tactic
-val dConcl : tactic
-*)
-val h_destructHyp : bool -> identifier -> tactic
-val h_destructConcl : tactic
-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_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..6981a733 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-2012     *)
 (*   \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,8 +25,9 @@ open Tactics
 open Pattern
 open Clenv
 open Auto
-open Rawterm
+open Glob_term
 open Hiddentac
+open Tacexpr
 
 let eauto_unif_flags = { auto_unif_flags with Unification.modulo_delta = full_transparent_state }
 
@@ -71,6 +69,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 +80,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 +94,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,24 +169,31 @@ 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 }
+  localdb :  Auto.hint_db list;
+  prev : prev_search_state
+}
+
+and prev_search_state = (* for info eauto *)
+  | Unknown
+  | Init
+  | State of search_state
 
 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,26 +201,27 @@ 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
-	  with e -> Refiner.catch_failerror e; aux tacl
+	      (lgls,pptac) :: aux tacl
+	  with e when Errors.noncritical e ->
+            Refiner.catch_failerror e; aux tacl
     in aux l
 
   (* Ordering of states is lexicographic on depth (greatest first) then
      number of remaining goals. *)
   let compare s s' =
     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 ps = if s.prev = Unknown then Unknown else State s in
+      let lg = s.tacres in
       let nbgl = List.length (sig_it lg) in
       assert (nbgl > 0);
       let g = find_first_goal lg in
@@ -228,11 +235,12 @@ module SearchProblem = struct
 	in
 	List.map (fun (res,pp) -> { depth = s.depth; tacres = res;
 				    last_tactic = pp; dblist = s.dblist;
-				    localdb = List.tl s.localdb }) l
+				    localdb = List.tl s.localdb;
+				    prev = ps}) l
       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')
@@ -240,7 +248,7 @@ module SearchProblem = struct
              let ldb = Hint_db.add_list hintl (List.hd s.localdb) in
 	     { depth = s.depth; tacres = res;
 	       last_tactic = pp; dblist = s.dblist;
-	       localdb = ldb :: List.tl s.localdb })
+	       localdb = ldb :: List.tl s.localdb; prev = ps })
 	  (filter_tactics s.tacres [Tactics.intro,lazy (str "intro")])
       in
       let rec_tacs =
@@ -248,82 +256,125 @@ 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;
+	       { depth = s.depth; tacres = res; last_tactic = pp; prev = ps;
 		 dblist = s.dblist; localdb = List.tl s.localdb }
 	     else
 	       { depth = pred s.depth; tacres = res;
-		 dblist = s.dblist; last_tactic = pp;
+		 dblist = s.dblist; last_tactic = pp; prev = ps;
 		 localdb =
 		   list_addn (nbgl'-nbgl) (List.hd s.localdb) s.localdb })
 	  l
       in
       List.sort compare (assumption_tacs @ intro_tac @ rec_tacs)
 
-  let pp s =
-    msg (hov 0 (str " depth=" ++ int s.depth ++ spc () ++
-		  (Lazy.force s.last_tactic) ++ str "\n"))
+  let pp s = hov 0 (str " depth=" ++ int s.depth ++ spc () ++
+		      (Lazy.force s.last_tactic))
 
 end
 
 module Search = Explore.Make(SearchProblem)
 
-let make_initial_state n gl dblist localdb =
+(** Utilities for debug eauto / info eauto *)
+
+let global_debug_eauto = ref false
+let global_info_eauto = ref false
+
+let _ =
+  Goptions.declare_bool_option
+    { Goptions.optsync  = true;
+      Goptions.optdepr  = false;
+      Goptions.optname  = "Debug Eauto";
+      Goptions.optkey   = ["Debug";"Eauto"];
+      Goptions.optread  = (fun () -> !global_debug_eauto);
+      Goptions.optwrite = (:=) global_debug_eauto }
+
+let _ =
+  Goptions.declare_bool_option
+    { Goptions.optsync  = true;
+      Goptions.optdepr  = false;
+      Goptions.optname  = "Info Eauto";
+      Goptions.optkey   = ["Info";"Eauto"];
+      Goptions.optread  = (fun () -> !global_info_eauto);
+      Goptions.optwrite = (:=) global_info_eauto }
+
+let mk_eauto_dbg d =
+  if d = Debug || !global_debug_eauto then Debug
+  else if d = Info || !global_info_eauto then Info
+  else Off
+
+let pr_info_nop = function
+  | Info -> msg_debug (str "idtac.")
+  | _ -> ()
+
+let pr_dbg_header = function
+  | Off -> ()
+  | Debug -> msg_debug (str "(* debug eauto : *)")
+  | Info -> msg_debug (str "(* info eauto : *)")
+
+let pr_info dbg s =
+  if dbg <> Info then ()
+  else
+    let rec loop s =
+      match s.prev with
+	| Unknown | Init -> s.depth
+	| State sp ->
+	  let mindepth = loop sp in
+	  let indent = String.make (mindepth - sp.depth) ' ' in
+	  msg_debug (str indent ++ Lazy.force s.last_tactic ++ str ".");
+	  mindepth
+    in
+    ignore (loop s)
+
+(** Eauto main code *)
+
+let make_initial_state dbg n gl dblist localdb =
   { depth = n;
     tacres = tclIDTAC gl;
     last_tactic = lazy (mt());
     dblist = dblist;
-    localdb = [localdb] }
+    localdb = [localdb];
+    prev = if dbg=Info then Init else Unknown;
+  }
 
-let e_depth_search debug p db_list local_db gl =
-  try
-    let tac = if debug then Search.debug_depth_first else Search.depth_first in
-    let s = tac (make_initial_state p gl db_list local_db) in
-    s.tacres
-  with Not_found -> error "eauto: depth first search failed."
-
-let e_breadth_search debug n db_list local_db gl =
+let e_search_auto debug (in_depth,p) lems db_list gl =
+  let local_db = make_local_hint_db ~ts:full_transparent_state true lems gl in
+  let d = mk_eauto_dbg debug in
+  let tac = match in_depth,d with
+    | (true,Debug) -> Search.debug_depth_first
+    | (true,_) -> Search.depth_first
+    | (false,Debug) -> Search.debug_breadth_first
+    | (false,_) -> Search.breadth_first
+  in
   try
-    let tac =
-      if debug then Search.debug_breadth_first else Search.breadth_first
-    in
-    let s = tac (make_initial_state n gl db_list local_db) in
+    pr_dbg_header d;
+    let s = tac (make_initial_state d p gl db_list local_db) in
+    pr_info d s;
     s.tacres
-  with Not_found -> error "eauto: breadth first search failed."
-
-let e_search_auto debug (in_depth,p) lems db_list gl =
-  let local_db = make_local_hint_db true lems gl in
-  if in_depth then
-    e_depth_search debug p db_list local_db gl
-  else
-    e_breadth_search debug p db_list local_db gl
+  with Not_found ->
+    pr_info_nop d;
+    error "eauto: search failed"
 
 open Evd
 
-let eauto_with_bases debug np lems db_list =
+let eauto_with_bases ?(debug=Off) 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 eauto ?(debug=Off) np lems dbnames =
+  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 full_eauto ?(debug=Off) 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
 
-let gen_eauto d np lems = function
-  | None -> full_eauto d np lems
-  | Some l -> eauto d np lems l
+let gen_eauto ?(debug=Off) np lems = function
+  | None -> full_eauto ~debug np lems
+  | Some l -> eauto ~debug np lems l
 
 let make_depth = function
   | None -> !default_search_depth
@@ -349,19 +400,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 ]
 | [ ] -> [ [] ]
@@ -370,7 +422,7 @@ END
 TACTIC EXTEND eauto
 | [ "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems)
     hintbases(db) ] ->
-    [ gen_eauto false (make_dimension n p) lems db ]
+    [ gen_eauto (make_dimension n p) lems db ]
 END
 
 TACTIC EXTEND new_eauto
@@ -378,20 +430,25 @@ TACTIC EXTEND new_eauto
     hintbases(db) ] ->
     [ match db with
       | None -> new_full_auto (make_depth n) lems
-      | Some l ->
-	  new_auto (make_depth n) lems l ]
+      | Some l -> new_auto (make_depth n) lems l ]
 END
 
 TACTIC EXTEND debug_eauto
 | [ "debug" "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems)
     hintbases(db) ] ->
-    [ gen_eauto true (make_dimension n p) lems db ]
+    [ gen_eauto ~debug:Debug (make_dimension n p) lems db ]
+END
+
+TACTIC EXTEND info_eauto
+| [ "info_eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems)
+    hintbases(db) ] ->
+    [ gen_eauto ~debug:Info (make_dimension n p) lems db ]
 END
 
 TACTIC EXTEND dfs_eauto
 | [ "dfs" "eauto" int_or_var_opt(p) auto_using(lems)
       hintbases(db) ] ->
-    [ gen_eauto false (true, make_depth p) lems db ]
+    [ gen_eauto (true, make_depth p) lems db ]
 END
 
 let cons a l = a :: l
@@ -414,19 +471,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 +564,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..10494710 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-2012     *)
 (*   \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 : ?debug:Tacexpr.debug -> bool * int -> open_constr list ->
   hint_db_name list option -> tactic
 
-
 val eauto_with_bases :
-  bool ->
+  ?debug:Tacexpr.debug ->
   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..f909b983 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-2012     *)
 (*   \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..97bb6c08 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-2012     *)
 (*   \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..fd21d84b 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-2012     *)
 (*   \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..98e4d3d9 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-2012     *)
 (*   \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..fd6393e3 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-2012     *)
 (*   \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..c8937087 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-2012     *)
 (*   \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..31a96e6d 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-2012     *)
 (*   \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..1c5e4b2f 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-2012     *)
 (*   \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,43 @@ 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.modulo_delta_in_merge = None;
+  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 +130,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 +145,62 @@ 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.modulo_delta_in_merge = None;
+  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 +209,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 +241,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 +256,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 +272,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 +291,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 +316,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,39 +329,44 @@ 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
 				 lft2rgt occs (c,l) ~new_goals:[]) tac gl
-	  with e -> (* Try to see if there's an equality hidden *)
+	  with e when Errors.noncritical e ->
+            (* Try to see if there's an equality hidden *)
 	    let env' = push_rel_context rels env in
 	    let rels',t' = splay_prod_assum env' sigma t in (* Search for underlying eq *)
 	      match match_with_equality_type t' with
 	      | Some (hdcncl,args) ->
 		  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 +382,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 +396,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 +408,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 +433,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 +574,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 +693,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 +744,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 +955,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 +1118,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
@@ -1094,7 +1157,7 @@ let injEq ipats (eq,_,(t,t1,t2) as u) eq_clause =
                 ]
 (* not a dep eq or no decidable type found *)
             ) else (raise Not_dep_pair)
-        ) with _ ->
+        ) with e when Errors.noncritical e ->
 	  inject_at_positions env sigma u eq_clause posns
 	    (fun _ -> intros_pattern no_move ipats)
 
@@ -1186,26 +1249,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 +1404,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 +1434,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 +1551,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..8128209d 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-2012     *)
 (*   \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..e0871479 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-2012     *)
 (*   \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..fa559b77 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-2012     *)
 (*   \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..613779c2 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-2012     *)
 (*   \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,23 @@ 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 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
-  RAW_TYPED AS int list
-  RAW_PRINTED BY pr_int_list
-  GLOB_TYPED AS int list
-  GLOB_PRINTED BY pr_int_list
-| [ integer(x) int_nelist(l) ] -> [x::l]
-| [ integer(x) ] -> [ [x] ]
-END
+let pr_orient = pr_orient () () ()
+
+
+let pr_int_list = Util.pr_sequence Pp.int
+let pr_int_list_full _prc _prlc _prt l = pr_int_list l
 
-open Rawterm
+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
@@ -72,6 +58,8 @@ let interp_occs ist gl l =
     | ArgVar (_,id as locid) ->
 	(try int_list_of_VList (List.assoc id ist.lfun)
 	  with Not_found | CannotCoerceTo _ -> [interp_int ist locid])
+let interp_occs ist gl l =
+  Tacmach.project gl , interp_occs ist gl l
 
 let glob_occs ist l = l
 
@@ -81,8 +69,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
@@ -94,36 +81,38 @@ ARGUMENT EXTEND occurrences
   GLOB_TYPED AS occurrences_or_var
   GLOB_PRINTED BY pr_occurrences
 
-| [ int_nelist(l) ] -> [ ArgArg l ]
+| [ ne_integer_list(l) ] -> [ ArgArg l ]
 | [ 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,_) = Tacmach.project gl , (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 +128,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 ()
@@ -148,10 +138,12 @@ let interp_place ist gl = function
     ConclLocation () -> ConclLocation ()
   | HypLocation (id,hl) -> HypLocation (interp_hyp ist gl id,hl)
 
+let interp_place ist gl p =
+  Tacmach.project gl , interp_place ist gl p
+
 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 +185,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
@@ -201,7 +194,7 @@ let pr_in_hyp  pr_id (lo,concl) :  Pp.std_ppcmds =
     | None,false -> str "in" ++ spc () ++ str "*" ++ spc () ++ str "|-"
     | Some l,_ ->
 	str "in" ++
-	  Util.prlist (fun id -> spc () ++ pr_id id) l ++
+         spc () ++ Util.prlist_with_sep Util.pr_comma pr_id l ++
 	  match concl with
 	    | true -> spc () ++ str "|-" ++ spc () ++ str "*"
 	    | _ -> mt ()
@@ -220,7 +213,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 +223,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 +244,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 +257,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=
@@ -287,13 +278,13 @@ let glob_in_arg_hyp_to_clause = gen_in_arg_hyp_to_clause (fun x -> x)
 (* spiwack argument for the commands of the retroknowledge *)
 
 let (wit_r_nat_field, globwit_r_nat_field, rawwit_r_nat_field) =
-  Genarg.create_arg "r_nat_field"
+  Genarg.create_arg None "r_nat_field"
 let (wit_r_n_field, globwit_r_n_field, rawwit_r_n_field) =
-  Genarg.create_arg "r_n_field"
+  Genarg.create_arg None "r_n_field"
 let (wit_r_int31_field, globwit_r_int31_field, rawwit_r_int31_field) =
-  Genarg.create_arg "r_int31_field"
+  Genarg.create_arg None "r_int31_field"
 let (wit_r_field, globwit_r_field, rawwit_r_field) =
-  Genarg.create_arg "r_field"
+  Genarg.create_arg None "r_field"
 
 (* spiwack: the print functions are incomplete, but I don't know what they are
 	used for *)
diff --git a/tactics/extraargs.mli b/tactics/extraargs.mli
index a3f27fde..9dec2513 100644
--- a/tactics/extraargs.mli
+++ b/tactics/extraargs.mli
@@ -1,32 +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-2012     *)
 (*   \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 globwit_orient : bool glob_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 +36,27 @@ 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 globwit_in_arg_hyp : (Names.identifier Util.located list option * bool) glob_abstract_argument_type
 val rawwit_in_arg_hyp : (Names.identifier Util.located list option * bool) raw_abstract_argument_type
 val wit_in_arg_hyp : (Names.identifier list option * bool) typed_abstract_argument_type
 val raw_in_arg_hyp_to_clause : (Names.identifier Util.located list option * bool) -> Tacticals.clause
 val glob_in_arg_hyp_to_clause :  (Names.identifier list option * bool)  -> Tacticals.clause
+val pr_in_arg_hyp : (Names.identifier list option * bool) -> Pp.std_ppcmds
 
-
-val by_arg_tac : Tacexpr.raw_tactic_expr option Pcoq.Gram.Entry.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 c7762c69..f6ecb47c 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-2012     *)
 (*   \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 15025 2012-03-09 14:27:07Z glondu $ *)
-
 open Pp
 open Pcoq
 open Genarg
@@ -17,17 +15,21 @@ 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                      *)
+(* admit, replace, discriminate, injection, simplify_eq               *)
 (* cutrewrite, dependent rewrite                                      *)
 
+TACTIC EXTEND admit
+  [ "admit" ] -> [ admit_as_an_axiom ]
+END
+
 let replace_in_clause_maybe_by (sigma1,c1) c2 in_hyp tac =
   Refiner.tclWITHHOLES false
     (replace_in_clause_maybe_by c1 c2 (glob_in_arg_hyp_to_clause in_hyp))
@@ -189,13 +191,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 +218,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 +227,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 +242,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 +290,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 +339,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 +398,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 +410,7 @@ END
 open Tactics
 open Tactics
 open Libnames
-open Rawterm
+open Glob_term
 open Summary
 open Libobject
 open Lib
@@ -433,7 +446,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 +480,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 +501,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 +552,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 +584,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 
-    | Compat.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
@@ -593,7 +606,7 @@ let hResolve_auto id c t gl =
       hResolve id c n t gl
     with
     | UserError _ as e -> raise e
-    | _ -> resolve_auto (n+1)
+    | e when Errors.noncritical e -> resolve_auto (n+1)
   in
   resolve_auto 1
 
@@ -625,8 +638,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
 
@@ -669,3 +765,21 @@ TACTIC EXTEND is_hyp
     | Var _ -> tclIDTAC
     | _ -> tclFAIL 0 (str "Not a variable or hypothesis") ]
 END
+
+TACTIC EXTEND is_fix
+| [ "is_fix" constr(x) ] ->
+  [ match kind_of_term x with
+    | Fix _ -> Tacticals.tclIDTAC
+    | _ -> Tacticals.tclFAIL 0 (Pp.str "not a fix definition") ]
+END;;
+
+(* Command to grab the evars left unresolved at the end of a proof. *)
+(* spiwack: I put it in extratactics because it is somewhat tied with
+   the semantics of the LCF-style tactics, hence with the classic tactic
+   mode. *)
+VERNAC COMMAND EXTEND GrabEvars
+[ "Grab" "Existential" "Variables" ] ->
+  [ let p = Proof_global.give_me_the_proof () in
+    Proof.V82.grab_evars p;
+    Flags.if_verbose (fun () -> Pp.msg (Printer.pr_open_subgoals ())) () ]
+END
diff --git a/tactics/extratactics.mli b/tactics/extratactics.mli
index ecad939c..3f30ddb4 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-2012     *)
 (*   \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..87f19105 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-2012     *)
 (*   \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
@@ -63,9 +61,16 @@ let h_generalize cl =
     cl)
 let h_generalize_dep c =
   abstract_tactic (TacGeneralizeDep c) (generalize_dep c)
-let h_let_tac b na c cl =
-  let with_eq = if b then None else Some (true,(dummy_loc,IntroAnonymous)) in
-  abstract_tactic (TacLetTac (na,c,cl,b)) (letin_tac with_eq na c None cl)
+let h_let_tac b na c cl eqpat =
+  let id = Option.default (dummy_loc,IntroAnonymous) eqpat in
+  let with_eq = if b then None else Some (true,id) in
+  abstract_tactic (TacLetTac (na,c,cl,b,eqpat))
+    (letin_tac with_eq na c None cl)
+let h_let_pat_tac b na c cl eqpat =
+  let id = Option.default (dummy_loc,IntroAnonymous) eqpat in
+  let with_eq = if b then None else Some (true,id) in
+  abstract_tactic (TacLetTac (na,snd c,cl,b,eqpat))
+    (letin_pat_tac with_eq na c None cl)
 
 (* Derived basic tactics *)
 let h_simple_induction_destruct isrec h =
@@ -74,11 +79,18 @@ 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_pi1 (List.map (fun (a,b) ->(out_indarg a,b))) lcl in
+  abstract_tactic (TacInductionDestruct (isrec,ev,lcl'))
     (induction_destruct isrec ev lcl)
-let h_new_induction ev c 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_new_induction ev c idl e cl =
+  h_induction_destruct true ev ([c,idl],e,cl)
+let h_new_destruct ev c idl e cl = h_induction_destruct false ev ([c,idl],e,cl)
 
 let h_specialize n d = abstract_tactic (TacSpecialize (n,d)) (specialize n d)
 let h_lapply c = abstract_tactic (TacLApply c) (cut_and_apply c)
@@ -102,9 +114,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..f31b3a80 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-2012     *)
 (*   \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
@@ -59,41 +55,47 @@ val h_cut             : constr -> tactic
 val h_generalize      : constr list -> tactic
 val h_generalize_gen  : (constr with_occurrences * name) list -> tactic
 val h_generalize_dep  : constr -> tactic
-val h_let_tac         : letin_flag -> name -> constr ->
-                        Tacticals.clause -> tactic
+val h_let_tac         : letin_flag -> name -> constr -> Tacticals.clause ->
+                        intro_pattern_expr located option -> tactic
+val h_let_pat_tac     : letin_flag -> name -> evar_map * constr ->
+                        Tacticals.clause -> intro_pattern_expr located option ->
+                        tactic
 
-(* Derived basic tactics *)
+(** 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 ->
   intro_pattern_expr located option * intro_pattern_expr located option ->
+  constr with_bindings 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 ->
   intro_pattern_expr located option * intro_pattern_expr located option ->
+  constr with_bindings option ->
   Tacticals.clause option -> tactic
 val h_induction_destruct : rec_flag -> evars_flag ->
-  (constr with_bindings induction_arg list * constr with_bindings option *
+  ((evar_map * constr with_bindings) induction_arg *
    (intro_pattern_expr located option * intro_pattern_expr located option)) list
+    * constr with_bindings option
     * Tacticals.clause option -> tactic
 
 val h_specialize      : int option -> constr with_bindings -> tactic
 val h_lapply          : constr -> tactic
 
-(* Automation tactic : see Auto *)
+(** 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 +106,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..c6f32ce2 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-2012     *)
 (*   \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
@@ -67,9 +64,12 @@ let is_non_recursive_type t = op2bool (match_with_non_recursive_type t)
 
 (* Test dependencies *)
 
+(* NB: we consider also the let-in case in the following function,
+   since they may appear in types of inductive constructors (see #2629) *)
+
 let rec has_nodep_prod_after n c =
   match kind_of_term c with
-    | Prod (_,_,b) ->
+    | Prod (_,_,b) | LetIn (_,_,_,b) ->
 	( n>0 || not (dependent (mkRel 1) b))
 	&& (has_nodep_prod_after (n-1) b)
     | _            -> true
@@ -98,7 +98,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 +145,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 =
@@ -154,8 +154,9 @@ let match_with_disjunction ?(strict=false) t =
   | Ind ind  ->
       let car = mis_constr_nargs ind in
       let (mib,mip) = Global.lookup_inductive ind in
-      if array_for_all (fun ar -> ar = 1) car &&
-	not (mis_is_recursive (ind,mib,mip))
+      if array_for_all (fun ar -> ar = 1) car
+        && not (mis_is_recursive (ind,mib,mip))
+        && (mip.mind_nrealargs = 0)
       then
 	if strict then
 	  if test_strict_disjunction mib.mind_nparams mip.mind_nf_lc then
@@ -357,7 +358,10 @@ let coq_jmeq_pattern = lazy PATTERN [ %coq_jmeq_ref ?X1 ?X2 ?X3 ?X4 ]
 let coq_eq_true_pattern = lazy PATTERN [ %coq_eq_true_ref ?X1 ]
 
 let match_eq eqn eq_pat =
-  let pat = try Lazy.force eq_pat with _ -> raise PatternMatchingFailure in
+  let pat =
+    try Lazy.force eq_pat
+    with e when Errors.noncritical e -> raise PatternMatchingFailure
+  in
   match matches pat eqn with
     | [(m1,t);(m2,x);(m3,y)] ->
 	assert (m1 = meta1 & m2 = meta2 & m3 = meta3);
@@ -426,6 +430,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 +442,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..fc1974b5 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-2012     *)
 (*   \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..e4b3bdb1 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-2012     *)
 (*   \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
 
@@ -497,7 +497,7 @@ let wrap_inv_error id = function
 (* The most general inversion tactic *)
 let inversion inv_kind status names id gls =
   try (raw_inversion inv_kind id status names) gls
-  with e -> wrap_inv_error id e
+  with e when Errors.noncritical e -> wrap_inv_error id e
 
 (* Specializing it... *)
 
@@ -540,7 +540,7 @@ let invIn k names ids id gls =
        inversion (false,k) NoDep names id;
        intros_replace_ids])
     gls
-  with e -> wrap_inv_error id e
+  with e when Errors.noncritical e -> wrap_inv_error id e
 
 let invIn_gen k names idl = try_intros_until (invIn k names idl)
 
diff --git a/tactics/inv.mli b/tactics/inv.mli
index 43e2a8de..a6db9715 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-2012     *)
 (*   \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..0c5a473c 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-2012     *)
 (*   \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..b6653678 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-2012     *)
 (*   \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..c4d73c65 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-2012     *)
 (*   \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..94919dbf 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-2012     *)
 (*   \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
@@ -394,12 +388,10 @@ let rec tcc_aux subst (TH (c,mm,sgp) as _th) gl =
 
 let refine (evd,c) gl =
   let sigma = project gl in
-  let evd = Typeclasses.resolve_typeclasses ~onlyargs:true (pf_env gl) evd in
+  let evd = Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals (pf_env gl) evd in
   let c = Evarutil.nf_evar evd c in
   let (evd,c) = Evarutil.evars_to_metas sigma (evd,c) in
   (* Relies on Cast's put on Meta's by evars_to_metas, because it is otherwise
      complicated to update meta types when passing through a binder *)
   let th = compute_metamap (pf_env gl) evd c in
   tclTHEN (Refiner.tclEVARS evd) (tcc_aux [] th) gl
-
-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..fc6b401a 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-2012     *)
 (*   \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 cf5fab0c..98885af8 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-2012     *)
 (*   \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,24 +102,7 @@ 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)
 
@@ -157,7 +121,7 @@ let is_applied_rewrite_relation env sigma rels t =
 	      let inst = mkApp (Lazy.force rewrite_relation_class, [| evar; mkApp (c, params) |]) in
 	      let _ = Typeclasses.resolve_one_typeclass env' evd inst in
 		Some (it_mkProd_or_LetIn t rels)
-	  with _ -> None)
+	  with e when Errors.noncritical e -> None)
   | _ -> None
 
 let _ =
@@ -167,25 +131,28 @@ 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 =
     new_cstr_evar evars env
       (* ~src:(dummy_loc, ImplicitArg (ConstRef (Lazy.force respectful), (n, Some na))) *) t
   in
-  let mk_relty evars env ty obj =
+  let mk_relty evars newenv ty obj =
     match obj with
       | None | Some (_, None) ->
 	  let relty = mk_relation ty in
-	    new_evar evars env relty
+	    if closed0 ty then 
+	      let env' = Environ.reset_with_named_context (Environ.named_context_val env) env in
+		new_evar evars env' relty
+	    else new_evar evars newenv relty
       | Some (x, Some rel) -> evars, rel
   in
   let rec aux env evars ty l =
@@ -220,11 +187,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,13 +220,17 @@ 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
+  with e when Errors.noncritical e -> false
 
 let rec decompose_app_rel env evd t = 
   match kind_of_term t with
@@ -270,11 +247,15 @@ 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 (equiv, args) = decompose_app_rel env sigma (Clenv.clenv_type eqclause) in
+    let eqclause = Clenv.make_clenv_binding_env_apply env sigma None (c',ty) l in
+    let (equiv, args) = decompose_app_rel env eqclause.evd (Clenv.clenv_type eqclause) in
     let c1 = args.(0) and c2 = args.(1) in 
     let ty1, ty2 =
       Typing.type_of env eqclause.evd c1, Typing.type_of env eqclause.evd c2
@@ -283,7 +264,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 +275,84 @@ 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.modulo_delta_in_merge = None;
+  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.modulo_delta_in_merge = None;
+     Unification.check_applied_meta_types = true;
+     Unification.resolve_evars = true;
+     Unification.use_pattern_unification = true;
+     Unification.use_meta_bound_pattern_unification = true;
+     Unification.frozen_evars = ExistentialSet.empty;
+     Unification.restrict_conv_on_strict_subterms = false;
+     Unification.modulo_betaiota = true;
+     Unification.modulo_eta = true;
+     Unification.allow_K_in_toplevel_higher_order_unification = true
+  }
+
+let general_rewrite_unif_flags () = 
+  let ts = rewrite_transparent_state () in
+    {  Unification.modulo_conv_on_closed_terms = Some ts;
+       Unification.use_metas_eagerly_in_conv_on_closed_terms = true;
+       Unification.modulo_delta = ts;
+       Unification.modulo_delta_types = ts;
+       Unification.modulo_delta_in_merge = None;
+       Unification.check_applied_meta_types = true;
+       Unification.resolve_evars = true;
+       Unification.use_pattern_unification = true;
+       Unification.use_meta_bound_pattern_unification = true;
+       Unification.frozen_evars = ExistentialSet.empty;
+       Unification.restrict_conv_on_strict_subterms = false;
+       Unification.modulo_betaiota = true;
+       Unification.modulo_eta = true;
+       Unification.allow_K_in_toplevel_higher_order_unification = true }
 
 let convertible env evd x y =
   Reductionops.is_conv env evd x y
 
-let 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 +364,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 +381,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,8 +465,15 @@ 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 arrow_morphism ta tb a b =
+  let ap = is_Prop ta and bp = is_Prop tb in
+    if ap && bp then mkApp (Lazy.force impl, [| a; b |]), unfold_impl
+    else if ap then (* Domain in Prop, CoDomain in Type *)
+      mkProd (Anonymous, a, b), (fun x -> x)
+    else if bp then (* Dummy forall *)
+      mkApp (Lazy.force coq_all, [| a; mkLambda (Anonymous, a, b) |]), unfold_forall
+    else (* None in Prop, use arrow *)
+      mkApp (Lazy.force arrow, [| a; b |]), unfold_impl
 
 let rec decomp_pointwise n c =
   if n = 0 then c
@@ -424,37 +496,41 @@ let rec apply_pointwise rel = function
   | [] -> rel
 
 let pointwise_or_dep_relation n t car rel =
-  if noccurn 1 car then
+  if noccurn 1 car && noccurn 1 rel then
     mkApp (Lazy.force pointwise_relation, [| t; lift (-1) car; lift (-1) rel |])
   else
     mkApp (Lazy.force forall_relation, 
 	  [| t; mkLambda (n, t, car); mkLambda (n, t, rel) |])
 
-let lift_cstr env sigma evars (args : constr list) 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 +546,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 +558,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 +585,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 +621,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 +633,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 +645,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 +737,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 +755,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 +767,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,16 +818,17 @@ 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 mor, unfold = arrow_morphism tx tb x b in
+	  let res = aux env avoid mor ty cstr evars in
 	    (match res with
-	    | Some (Some r) -> Some (Some { r with rew_to = unfold_impl r.rew_to })
+	    | Some (Some r) -> Some (Some { r with rew_to = unfold r.rew_to })
 	    | _ -> res)
 
       (* 		if x' = None && flags.under_lambdas then *)
@@ -740,22 +845,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 +878,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 +927,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 +955,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 +974,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 +1016,69 @@ 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 e when Errors.noncritical e ->
+            error "fold: the term is not unfoldable !"
+	in
+	  try
+	    let sigma = Unification.w_unify env sigma CONV ~flags:Unification.elim_flags unfolded t in
+	    let c' = Evarutil.nf_evar sigma c in
+	      Some (Some { rew_car = ty; rew_from = t; rew_to = c';
+			   rew_prf = RewCast DEFAULTcast; 
+			   rew_evars = sigma, cstrevars evars })
+	  with e when Errors.noncritical e -> None
+
+    let fold_glob c : strategy =
+      fun env avoid t ty cstr evars ->
+(* 	let sigma, (c,_) = Tacinterp.interp_open_constr_with_bindings is env (goalevars evars) c in *)
+	let sigma, c = Pretyping.Default.understand_tcc (goalevars evars) env c in
+	let unfolded =
+	  try Tacred.try_red_product env sigma c
+	  with e when Errors.noncritical e ->
+            error "fold: the term is not unfoldable !"
+	in
+	  try
+	    let sigma = Unification.w_unify env sigma CONV ~flags:Unification.elim_flags unfolded t in
+	    let c' = Evarutil.nf_evar sigma c in
+	      Some (Some { rew_car = ty; rew_from = t; rew_to = c';
+			   rew_prf = RewCast DEFAULTcast; 
+			   rew_evars = sigma, cstrevars evars })
+	  with e when Errors.noncritical e -> None
+  
 
 end
 
@@ -934,49 +1090,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 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 sigma concl cstr 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])
@@ -985,14 +1126,9 @@ let map_rewprf f = function
   | RewPrf (rel, prf) -> RewPrf (f rel, f prf)
   | RewCast c -> RewCast c
 
-exception RewriteFailure
+type result = (evar_map * constr option * types) option option
 
-let cl_rewrite_clause_aux ?(abs=None) strat goal_meta clause gl =
-  let concl, is_hyp =
-    match clause with
-	Some id -> pf_get_hyp_typ gl id, Some id
-      | None -> pf_concl gl, None
-  in
+let 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 +1136,211 @@ 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
-	  | Compat.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 -> tclFAIL 0 (str "Nothing to rewrite")
     | Some None ->
-	tclFAIL 0 (str"setoid rewrite failed: no progress made") gl
-    | None -> raise RewriteFailure
+	tclFAIL 0 (str"No progress made")
+    | Some (Some (undef, p, newt)) ->
+	let tac = 
+	  match clause, p with
+	  | Some id, Some p ->
+	      cut_replacing id newt (Tacmach.refine p)
+	  | Some id, None -> 
+	      change_in_hyp None newt (id, InHypTypeOnly)
+	  | None, Some p ->
+	      let name = next_name_away_with_default "H" Anonymous (pf_ids_of_hyps gl) in
+		tclTHENLAST
+		  (Tacmach.internal_cut_no_check false name newt)
+		  (tclTHEN (Tactics.revert [name]) (Tacmach.refine p))
+	  | None, None -> change_in_concl None newt
+	in tclTHEN (evartac undef) tac
+  in
+  let tac =
+    try
+      let concl, is_hyp =
+	match clause with
+	| Some id -> pf_get_hyp_typ gl id, Some id
+	| None -> pf_concl gl, None
+      in
+      let sigma = project gl in
+      let concl = Evarutil.nf_evar sigma concl in 
+      let res = cl_rewrite_clause_aux ?abs strat (pf_env gl) [] sigma concl is_hyp in
+	treat res
+    with
+    | Loc.Exc_located (_, TypeClassError (env, (UnsatisfiableConstraints _ as e)))
+    | TypeClassError (env, (UnsatisfiableConstraints _ as e)) ->
+	Refiner.tclFAIL_lazy 0
+	  (lazy (str"Unable to satisfy the rewriting constraints."
+		 ++ fnl () ++ Himsg.explain_typeclass_error env e))
+  in tac gl
+
+open Goal
+open Environ
+
+let bind_gl_info f =
+  bind concl (fun c -> bind env (fun v -> bind defs (fun ev -> f c v ev))) 
+
+let fail l s =
+  raise (Refiner.FailError (l, lazy s))
+
+let new_refine c : Goal.subgoals Goal.sensitive =
+  let refable = Goal.Refinable.make
+    (fun handle -> Goal.Refinable.constr_of_open_constr handle true c) 
+  in Goal.bind refable Goal.refine
+
+let assert_replacing id newt tac = 
+  let sens = bind_gl_info 
+    (fun concl env sigma ->
+       let nc' = 
+	 Environ.fold_named_context
+	   (fun _ (n, b, t as decl) nc' ->
+	      if n = id then (n, b, newt) :: nc'
+	      else decl :: nc')
+	   env ~init:[]
+       in
+       let reft = Refinable.make 
+	 (fun h -> 
+	    Goal.bind (Refinable.mkEvar h
+			 (Environ.reset_with_named_context (val_of_named_context nc') env) concl)
+	      (fun ev -> 
+		 Goal.bind (Refinable.mkEvar h env newt)
+		   (fun ev' ->
+		      let inst = 
+			fold_named_context
+			  (fun _ (n, b, t) inst ->
+			     if n = id then ev' :: inst
+			     else if b = None then mkVar n :: inst else inst)
+			  env ~init:[]
+		      in
+		      let (e, args) = destEvar ev in
+			Goal.return (mkEvar (e, Array.of_list inst)))))
+       in Goal.bind reft Goal.refine)
+  in Proofview.tclTHEN (Proofview.tclSENSITIVE sens) 
+       (Proofview.tclFOCUS 2 2 tac)
 
-let cl_rewrite_clause_strat strat clause gl =
+let newfail n s = 
+  Proofview.tclZERO (Refiner.FailError (n, lazy s))
+
+let cl_rewrite_clause_newtac ?abs strat clause =
+  let treat (res, is_hyp) = 
+    match res with
+    | None -> newfail 0 (str "Nothing to rewrite")
+    | Some None ->
+	newfail 0 (str"No progress made")
+    | Some (Some res) ->
+	match is_hyp, res with
+	| Some id, (undef, Some p, newt) ->
+	    assert_replacing id newt (Proofview.tclSENSITIVE (new_refine (undef, p)))
+	| Some id, (undef, None, newt) -> 
+	    Proofview.tclSENSITIVE (Goal.convert_hyp false (id, None, newt))
+	| None, (undef, Some p, newt) ->
+	    let refable = Goal.Refinable.make
+	      (fun handle -> 
+		 Goal.bind env
+		   (fun env -> Goal.bind (Refinable.mkEvar handle env newt)
+		      (fun ev ->
+			 Goal.Refinable.constr_of_open_constr handle true 
+			   (undef, mkApp (p, [| ev |])))))
+	    in
+	      Proofview.tclSENSITIVE (Goal.bind refable Goal.refine)
+	| None, (undef, None, newt) ->
+	    Proofview.tclSENSITIVE (Goal.convert_concl false newt)
+  in
+  let info =
+    bind_gl_info
+      (fun concl env sigma ->
+	 let ty, is_hyp =
+	   match clause with
+	   | Some id -> Environ.named_type id env, Some id
+	   | None -> concl, None
+	 in
+	 let res = 
+	   try cl_rewrite_clause_aux ?abs strat env [] sigma ty is_hyp 
+	   with
+	   | Loc.Exc_located (_, TypeClassError (env, (UnsatisfiableConstraints _ as e)))
+	   | TypeClassError (env, (UnsatisfiableConstraints _ as e)) ->
+	       fail 0 (str"setoid rewrite failed: unable to satisfy the rewriting constraints."
+		       ++ fnl () ++ Himsg.explain_typeclass_error env e)
+	 in return (res, is_hyp))
+  in Proofview.tclGOALBINDU info (fun i -> treat i)
+  
+let cl_rewrite_clause_new_strat ?abs strat clause =
   init_setoid ();
-  let meta = Evarutil.new_meta() in
-  let gl = { gl with sigma = Typeclasses.mark_unresolvables gl.sigma } in
-    try cl_rewrite_clause_aux strat meta clause gl
-    with RewriteFailure ->
-      tclFAIL 0 (str"setoid rewrite failed: strategy failed") gl
+  cl_rewrite_clause_newtac ?abs strat clause
+
+let cl_rewrite_clause_newtac' l left2right occs clause =
+  Proof_global.run_tactic 
+    (Proofview.tclFOCUS 1 1 
+       (cl_rewrite_clause_new_strat (rewrite_with rewrite_unif_flags l left2right occs) clause))
+
+
+let tactic_init_setoid () = 
+  init_setoid (); tclIDTAC
+
+let cl_rewrite_clause_strat strat clause =
+  tclTHEN (tactic_init_setoid ())
+  (fun gl ->
+   let meta = Evarutil.new_meta() in
+     try cl_rewrite_clause_tac strat (mkMeta meta) clause gl
+     with
+     | Refiner.FailError (n, pp) -> 
+       tclFAIL n (str"setoid rewrite failed: " ++ Lazy.force pp) gl)
 
 let cl_rewrite_clause l left2right occs clause gl =
-  cl_rewrite_clause_strat (rewrite_with 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,110 +1358,227 @@ 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 avoid t ty cstr evars ->
+  let evd, c = Constrintern.interp_open_constr (goalevars evars) env c in
+    apply_lemma (general_rewrite_unif_flags ()) (evd, (c, NoBindings)) 
+      l2r occs env avoid t ty cstr (evd, cstrevars evars)
 
-let apply_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_glob_constr c l2r occs = fun env avoid t ty cstr evars ->
+  let evd, c = (Pretyping.Default.understand_tcc (goalevars evars) env c) in
+    apply_lemma (general_rewrite_unif_flags ()) (evd, (c, NoBindings)) 
+      l2r occs env avoid t ty cstr (evd, cstrevars evars)
 
 let interp_constr_list env sigma =
   List.map (fun c -> 
 	      let evd, c = Constrintern.interp_open_constr sigma env c in
 		(evd, (c, NoBindings)), true)
 
+let interp_glob_constr_list env sigma =
+  List.map (fun c -> 
+	      let evd, c = Pretyping.Default.understand_tcc sigma env c in
+		(evd, (c, NoBindings)), true)
+
 open Pcoq
 
-let (wit_strategy, globwit_strategy, rawwit_strategy) =
-  (Genarg.create_arg "strategy" :
-      ((strategy, Genarg.tlevel) Genarg.abstract_argument_type *
-	  (strategy, Genarg.glevel) Genarg.abstract_argument_type *
-	  (strategy, Genarg.rlevel) Genarg.abstract_argument_type))
+(* Syntax for rewriting with strategies *)
+
+type constr_expr_with_bindings = constr_expr with_bindings
+type glob_constr_with_bindings = glob_constr_and_expr with_bindings
+type glob_constr_with_bindings_sign = interp_sign * glob_constr_and_expr with_bindings
+
+let pr_glob_constr_with_bindings_sign _ _ _ (ge : glob_constr_with_bindings_sign) = Printer.pr_glob_constr (fst (fst (snd ge)))
+let pr_glob_constr_with_bindings _ _ _ (ge : glob_constr_with_bindings) = Printer.pr_glob_constr (fst (fst ge))
+let pr_constr_expr_with_bindings prc _ _ (ge : constr_expr_with_bindings) = prc (fst ge)
+let interp_glob_constr_with_bindings ist gl c = Tacmach.project gl , (ist, c)
+let glob_glob_constr_with_bindings ist l = Tacinterp.intern_constr_with_bindings ist l
+let subst_glob_constr_with_bindings s c = subst_glob_with_bindings s c
+
+
+ARGUMENT EXTEND glob_constr_with_bindings 
+    PRINTED BY pr_glob_constr_with_bindings_sign
+
+    INTERPRETED BY interp_glob_constr_with_bindings
+    GLOBALIZED BY glob_glob_constr_with_bindings
+    SUBSTITUTED BY subst_glob_constr_with_bindings
+
+    RAW_TYPED AS constr_expr_with_bindings
+    RAW_PRINTED BY pr_constr_expr_with_bindings
 
+    GLOB_TYPED AS glob_constr_with_bindings
+    GLOB_PRINTED BY pr_glob_constr_with_bindings
+   
+   [ constr_with_bindings(bl) ] -> [ bl ]
+END
+
+type ('constr,'redexpr) strategy_ast = 
+  | StratId | StratFail | StratRefl
+  | StratUnary of string * ('constr,'redexpr) strategy_ast
+  | StratBinary of string * ('constr,'redexpr) strategy_ast * ('constr,'redexpr) strategy_ast
+  | StratConstr of 'constr * bool
+  | StratTerms of 'constr list
+  | StratHints of bool * string
+  | StratEval of 'redexpr 
+  | StratFold of 'constr
+
+let rec map_strategy (f : 'a -> 'a2) (g : 'b -> 'b2) : ('a,'b) strategy_ast -> ('a2,'b2) strategy_ast = function
+  | StratId | StratFail | StratRefl as s -> s
+  | StratUnary (s, str) -> StratUnary (s, map_strategy f g str)
+  | StratBinary (s, str, str') -> StratBinary (s, map_strategy f g str, map_strategy f g str')
+  | StratConstr (c, b) -> StratConstr (f c, b)
+  | StratTerms l -> StratTerms (List.map f l)
+  | StratHints (b, id) -> StratHints (b, id)
+  | StratEval r -> StratEval (g r)
+  | StratFold c -> StratFold (f c)
+
+let rec strategy_of_ast = function
+  | StratId -> Strategies.id
+  | StratFail -> Strategies.fail
+  | StratRefl -> Strategies.refl
+  | StratUnary (f, s) -> 
+    let s' = strategy_of_ast s in
+    let f' = match f with
+      | "subterms" -> all_subterms
+      | "subterm" -> one_subterm
+      | "innermost" -> Strategies.innermost
+      | "outermost" -> Strategies.outermost
+      | "bottomup" -> Strategies.bu
+      | "topdown" -> Strategies.td
+      | "progress" -> Strategies.progress
+      | "try" -> Strategies.try_
+      | "any" -> Strategies.any
+      | "repeat" -> Strategies.repeat
+      | _ -> anomalylabstrm "strategy_of_ast" (str"Unkwnon strategy: " ++ str f)
+    in f' s'
+  | StratBinary (f, s, t) ->
+    let s' = strategy_of_ast s in
+    let t' = strategy_of_ast t in
+    let f' = match f with
+      | "compose" -> Strategies.seq
+      | "choice" -> Strategies.choice
+      | _ -> anomalylabstrm "strategy_of_ast" (str"Unkwnon strategy: " ++ str f)
+    in f' s' t'
+  | StratConstr (c, b) -> apply_glob_constr (fst c) b all_occurrences
+  | StratHints (old, id) -> if old then Strategies.old_hints id else Strategies.hints id
+  | StratTerms l -> 
+    (fun env avoid t ty cstr evars ->
+     let l' = interp_glob_constr_list env (goalevars evars) (List.map fst l) in
+       Strategies.lemmas rewrite_unif_flags l' env avoid t ty cstr evars)
+  | StratEval r -> 
+    (fun env avoid t ty cstr evars ->
+     let (sigma,r_interp) = Tacinterp.interp_redexp env (goalevars evars) r in
+       Strategies.reduce r_interp env avoid t ty cstr (sigma,cstrevars evars))
+  | StratFold c -> Strategies.fold_glob (fst c)
+
+
+type raw_strategy = (constr_expr, Tacexpr.raw_red_expr) strategy_ast
+type glob_strategy = (glob_constr_and_expr, Tacexpr.raw_red_expr) strategy_ast
+
+let interp_strategy ist gl s = 
+  let sigma = project gl in
+    sigma, strategy_of_ast s
+let glob_strategy ist s = map_strategy (Tacinterp.intern_constr ist) (fun c -> c) s
+let subst_strategy s str = str
+
+let pr_strategy _ _ _ (s : strategy) = Pp.str "<strategy>"
+let pr_raw_strategy _ _ _ (s : raw_strategy) = Pp.str "<strategy>"
+let pr_glob_strategy _ _ _ (s : glob_strategy) = Pp.str "<strategy>"
 
-ARGUMENT EXTEND rewstrategy TYPED AS strategy
+ARGUMENT EXTEND rewstrategy
     PRINTED BY pr_strategy
+
     INTERPRETED BY interp_strategy
     GLOBALIZED BY glob_strategy
     SUBSTITUTED BY subst_strategy
 
-    [ constr(c) ] -> [ apply_constr_expr c true all_occurrences ]
-  | [ "<-" constr(c) ] -> [ apply_constr_expr c false all_occurrences ]
-  | [ "subterms" rewstrategy(h) ] -> [ all_subterms h ]
-  | [ "subterm" rewstrategy(h) ] -> [ one_subterm h ]
-  | [ "innermost" rewstrategy(h) ] -> [ Strategies.innermost h ]
-  | [ "outermost" rewstrategy(h) ] -> [ Strategies.outermost h ]
-  | [ "bottomup" rewstrategy(h) ] -> [ Strategies.bu h ]
-  | [ "topdown" rewstrategy(h) ] -> [ Strategies.td h ]
-  | [ "id" ] -> [ Strategies.id ]
-  | [ "refl" ] -> [ Strategies.refl ]
-  | [ "progress" rewstrategy(h) ] -> [ Strategies.progress h ]
-  | [ "fail" ] -> [ Strategies.fail ]
-  | [ "try" rewstrategy(h) ] -> [ Strategies.try_ h ]
-  | [ "any" rewstrategy(h) ] -> [ Strategies.any h ]
-  | [ "repeat" rewstrategy(h) ] -> [ Strategies.repeat h ]
-  | [ rewstrategy(h) ";" rewstrategy(h') ] -> [ Strategies.seq h h' ]
+    RAW_TYPED AS raw_strategy
+    RAW_PRINTED BY pr_raw_strategy
+
+    GLOB_TYPED AS glob_strategy
+    GLOB_PRINTED BY pr_glob_strategy
+
+    [ glob(c) ] -> [ StratConstr (c, true) ]
+  | [ "<-" constr(c) ] -> [ StratConstr (c, false) ]
+  | [ "subterms" rewstrategy(h) ] -> [ StratUnary ("all_subterms", h) ]
+  | [ "subterm" rewstrategy(h) ] -> [ StratUnary ("one_subterm", h) ]
+  | [ "innermost" rewstrategy(h) ] -> [ StratUnary("innermost", h) ]
+  | [ "outermost" rewstrategy(h) ] -> [ StratUnary("outermost", h) ]
+  | [ "bottomup" rewstrategy(h) ] -> [ StratUnary("bottomup", h) ]
+  | [ "topdown" rewstrategy(h) ] -> [ StratUnary("topdown", h) ]
+  | [ "id" ] -> [ StratId ]
+  | [ "fail" ] -> [ StratFail ]
+  | [ "refl" ] -> [ StratRefl ]
+  | [ "progress" rewstrategy(h) ] -> [ StratUnary ("progress", h) ]
+  | [ "try" rewstrategy(h) ] -> [ StratUnary ("try", h) ]
+  | [ "any" rewstrategy(h) ] -> [ StratUnary ("any", h) ]
+  | [ "repeat" rewstrategy(h) ] -> [ StratUnary ("repeat", h) ]
+  | [ rewstrategy(h) ";" rewstrategy(h') ] -> [ StratBinary ("compose", h, h') ]
   | [ "(" rewstrategy(h) ")" ] -> [ h ]
-  | [ "choice" rewstrategy(h) rewstrategy(h') ] -> [ 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 ]
+  | [ "choice" rewstrategy(h) rewstrategy(h') ] -> [ StratBinary ("choice", h, h') ]
+  | [ "old_hints" preident(h) ] -> [ StratHints (true, h) ]
+  | [ "hints" preident(h) ] -> [ StratHints (false, h) ]
+  | [ "terms" constr_list(h) ] -> [ StratTerms h ]
+  | [ "eval" red_expr(r) ] -> [ StratEval r ]
+  | [ "fold" constr(c) ] -> [ StratFold c ]
 END
 
-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) ] *)
-END
+(* By default the strategy for "rewrite_db" is top-down *)
 
+let db_strat db = Strategies.td (Strategies.hints db)
+let cl_rewrite_clause_db db cl = cl_rewrite_clause_strat (db_strat db) cl
+
+TACTIC EXTEND rewrite_strat
+| [ "rewrite_strat" rewstrategy(s) "in" hyp(id) ] -> [ cl_rewrite_clause_strat s (Some id) ]
+| [ "rewrite_strat" rewstrategy(s) ] -> [ cl_rewrite_clause_strat s None ]
+| [ "rewrite_db" preident(db) "in" hyp(id) ] -> [ cl_rewrite_clause_db db (Some id) ]
+| [ "rewrite_db" preident(db) ] -> [ cl_rewrite_clause_db db None ]
+END
 
 let clsubstitute o c =
-  let is_tac id = match 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)
+
+open Extraargs
 
 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 +1589,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 None "binders" :
+    Genarg.tlevel binders_argtype *
+    Genarg.glevel binders_argtype *
+    Genarg.rlevel binders_argtype)
 
 open Pcoq.Constr
 
@@ -1349,9 +1728,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 +1768,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 +1817,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 +1834,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 +1863,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 +1905,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 }
 
@@ -1577,15 +1956,10 @@ let apply_lemma gl (c,l) cl l2r occs =
 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
-    with RewriteFailure ->
-      let {l2r=l2r; c1=x; c2=y} = hypinfo in
-	raise (Pretype_errors.PretypeError
-		  (pf_env gl,
-		  Pretype_errors.NoOccurrenceFound ((if l2r then x else y), cl)))
+    tclWEAK_PROGRESS 
+      (tclTHEN
+       (Refiner.tclEVARS hypinfo.cl.evd)
+       (cl_rewrite_clause_tac ~abs:hypinfo.abs strat (mkMeta meta) cl)) gl
 
 let general_s_rewrite_clause x =
   init_setoid ();
@@ -1595,15 +1969,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 =
@@ -1614,9 +1979,10 @@ let setoid_proof gl ty fn fallback =
   let env = pf_env gl in
     try
       let rel, args = decompose_app_rel env (project gl) (pf_concl gl) in
-      let evm, car = project gl, pf_type_of gl args.(0) in
+      let evm = project gl in
+      let car = pi3 (List.hd (fst (Reduction.dest_prod env (Typing.type_of env evm rel)))) in
 	fn env evm car rel gl
-    with e ->
+    with e when Errors.noncritical e ->
       try fallback gl
       with Hipattern.NoEquationFound ->
 	  match e with
@@ -1641,7 +2007,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 =
@@ -1691,7 +2057,7 @@ let implify id gl =
 	let sigma = project gl in
 	let tyhd = Typing.type_of env sigma ty
 	and tyconcl = Typing.type_of (Environ.push_rel hd env) sigma concl in
-	let app = mkApp (arrow_morphism tyhd (subst1 mkProp tyconcl), [| ty; (subst1 mkProp concl) |]) in
+	let app, unfold = arrow_morphism tyhd (subst1 mkProp tyconcl) ty (subst1 mkProp concl) in
 	  it_mkProd_or_LetIn app tl
     | _ -> ctype
   in convert_hyp_no_check (id, b, ctype') gl
@@ -1721,3 +2087,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 929f1013..7479ee9a 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: tacinterp.ml 15025 2012-03-09 14:27:07Z glondu $ *)
-
 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,9 +46,11 @@ open Pretyping
 open Pretyping.Default
 open Extrawit
 open Pcoq
+open Compat
+open Evd
 
 let safe_msgnl s =
-    try msgnl s with e ->
+    try msgnl s with e when Errors.noncritical e ->
       msgnl
 	(str "bug in the debugger: " ++
          str "an exception is raised while printing debug information")
@@ -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
-  | Compat.Exc_located (_,LtacLocated _) as e -> raise e
-  | e ->
+  | Loc.Exc_located (_,LtacLocated _) as e -> raise e
+  | e when Errors.noncritical e ->
     let (nrep,loc',c),tail = list_sep_last call_trace in
-    let loc,e' = match e with Compat.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 (Compat.Exc_located(loc,e'))
+      raise (Loc.Exc_located(loc,e'))
     else
-      raise (Compat.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 =
@@ -196,8 +175,8 @@ let _ =
         "intros", TacIntroPattern [];
         "assumption", TacAssumption;
         "cofix", TacCofix None;
-        "trivial", TacTrivial ([],None);
-        "auto", TacAuto(None,[],None);
+        "trivial", TacTrivial (Off,[],None);
+        "auto", TacAuto(Off,None,[],None);
         "left", TacLeft(false,NoBindings);
         "eleft", TacLeft(true,NoBindings);
         "right", TacRight(false,NoBindings);
@@ -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
@@ -275,7 +254,7 @@ type glob_sign = {
 type interp_genarg_type =
   (glob_sign -> raw_generic_argument -> glob_generic_argument) *
   (interp_sign -> goal sigma -> glob_generic_argument ->
-    typed_generic_argument) *
+    Evd.evar_map * typed_generic_argument) *
   (substitution -> glob_generic_argument -> glob_generic_argument)
 
 let extragenargtab =
@@ -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,12 +556,28 @@ 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) =
   (l,intern_typed_pattern ist p)
 
+(* This seems fairly hacky, but it's the first way I've found to get proper
+   globalization of [unfold].  --adamc *)
+let dump_glob_red_expr = function
+  | Unfold occs -> List.iter (fun (_, r) ->
+    try
+      Dumpglob.add_glob (loc_of_or_by_notation Libnames.loc_of_reference r)
+	(Smartlocate.smart_global r)
+    with e when Errors.noncritical e -> ()) occs
+  | Cbv grf | Lazy grf ->
+    List.iter (fun r ->
+      try
+        Dumpglob.add_glob (loc_of_or_by_notation Libnames.loc_of_reference r)
+	  (Smartlocate.smart_global r)
+      with e when Errors.noncritical e -> ()) grf.rConst
+  | _ -> ()
+
 let intern_red_expr ist = function
   | Unfold l -> Unfold (List.map (intern_unfold ist) l)
   | Fold l -> Fold (List.map (intern_constr ist) l)
@@ -735,7 +715,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 ->
@@ -743,33 +723,27 @@ let rec intern_atomic lf ist x =
 	               intern_constr_with_occurrences ist c,
                        intern_name lf ist na) cl)
   | TacGeneralizeDep c -> TacGeneralizeDep (intern_constr ist c)
-  | TacLetTac (na,c,cls,b) ->
+  | TacLetTac (na,c,cls,b,eqpat) ->
       let na = intern_name lf ist na in
       TacLetTac (na,intern_constr ist c,
-                 (clause_app (intern_hyp_location ist) cls),b)
+                 (clause_app (intern_hyp_location ist) cls),b,
+		 (Option.map (intern_intro_pattern lf ist) eqpat))
 
   (* Automation tactics *)
-  | TacTrivial (lems,l) -> TacTrivial (List.map (intern_constr ist) lems,l)
-  | TacAuto (n,lems,l) ->
-      TacAuto (Option.map (intern_or_var ist) n,
+  | TacTrivial (d,lems,l) -> TacTrivial (d,List.map (intern_constr ist) lems,l)
+  | TacAuto (d,n,lems,l) ->
+      TacAuto (d,Option.map (intern_or_var ist) n,
         List.map (intern_constr ist) lems,l)
-  | TacAutoTDB n -> TacAutoTDB n
-  | TacDestructHyp (b,id) -> TacDestructHyp(b,intern_hyp ist id)
-  | TacDestructConcl -> TacDestructConcl
-  | TacSuperAuto (n,l,b1,b2) -> TacSuperAuto (n,l,b1,b2)
-  | TacDAuto (n,p,lems) ->
-      TacDAuto (Option.map (intern_or_var ist) n,p,
-        List.map (intern_constr ist) lems)
 
   (* Derived basic tactics *)
   | TacSimpleInductionDestruct (isrec,h) ->
       TacSimpleInductionDestruct (isrec,intern_quantified_hypothesis ist h)
-  | TacInductionDestruct (ev,isrec,(l,cls)) ->
-      TacInductionDestruct (ev,isrec,(List.map (fun (lc,cbo,(ipato,ipats)) ->
-	      (List.map (intern_induction_arg ist) lc,
-               Option.map (intern_constr_with_bindings ist) cbo,
+  | TacInductionDestruct (ev,isrec,(l,el,cls)) ->
+      TacInductionDestruct (ev,isrec,(List.map (fun (c,(ipato,ipats)) ->
+	      (intern_induction_arg ist c,
                (Option.map (intern_intro_pattern lf ist) ipato,
 	        Option.map (intern_intro_pattern lf ist) ipats))) l,
+               Option.map (intern_constr_with_bindings ist) el,
                Option.map (clause_app (intern_hyp_location ist)) cls))
   | TacDoubleInduction (h1,h2) ->
       let h1 = intern_quantified_hypothesis ist h1 in
@@ -797,11 +771,12 @@ 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) ->
+      dump_glob_red_expr r;
       TacReduce (intern_red_expr ist r, clause_app (intern_hyp_location ist) cl)
   | TacChange (None,c,cl) ->
       TacChange (None,
@@ -826,7 +801,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 +814,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 +826,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 +900,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 +984,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 +1033,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 +1141,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 +1254,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,19 +1266,21 @@ 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 =
-    catch_error trace (understand_ltac expand_evar sigma env vars kind) c in
-  let evd,c =
+  let evdc =
+    catch_error trace 
+      (understand_ltac ~resolve_classes:use_classes expand_evar sigma env vars kind) c in
+  let (evd,c) =
     if expand_evar then
-      solve_remaining_evars fail_evar use_classes env sigma evd c
+      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)
 
 (* Interprets a constr; expects evars to be solved *)
 let interp_constr_gen kind ist env sigma c =
-  snd (interp_gen kind ist false true true true env sigma c)
+  interp_gen kind ist false true true true env sigma c
 
 let interp_constr = interp_constr_gen (OfType None)
 
@@ -1370,8 +1290,11 @@ let interp_type = interp_constr_gen IsType
 let interp_open_constr_gen kind ist =
   interp_gen kind ist false true false false
 
-let interp_open_constr ccl =
-  interp_open_constr_gen (OfType ccl)
+let interp_open_constr ccl ist =
+  interp_gen (OfType ccl) ist false true false (ccl<>None)
+
+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 =
@@ -1393,7 +1316,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))
     | _ ->
@@ -1406,14 +1329,16 @@ let interp_constr_in_compound_list inj_fun dest_fun interp_fun ist env sigma l =
   sigma, List.flatten 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)
+  interp_constr_in_compound_list (fun x -> x) (fun x -> x) interp_constr ist env sigma c
 
 let interp_open_constr_list =
   interp_constr_in_compound_list (fun x -> x) (fun x -> x)
     (interp_open_constr None)
 
+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)
@@ -1426,7 +1351,8 @@ let interp_flag ist env red =
   { red with rConst = List.map (interp_evaluable ist env) red.rConst }
 
 let interp_constr_with_occurrences ist sigma env (occs,c) =
-  (interp_occurrences ist occs, interp_constr ist sigma env c)
+  let (sigma,c_interp) = interp_constr ist sigma env c in
+  sigma , (interp_occurrences ist occs, c_interp)
 
 let interp_typed_pattern_with_occurrences ist env sigma (occs,c) =
   let sign,p = interp_typed_pattern ist env sigma c in
@@ -1441,56 +1367,69 @@ let interp_constr_with_occurrences_and_name_as_list =
     (function ((occs,c),Anonymous) when occs = all_occurrences_expr -> c
       | _ -> raise Not_found)
     (fun ist env sigma (occ_c,na) ->
-      sigma, (interp_constr_with_occurrences ist env sigma occ_c,
+      let (sigma,c_interp) = interp_constr_with_occurrences ist env sigma occ_c in
+      sigma, (c_interp,
        interp_fresh_name ist env na))
 
 let interp_red_expr ist sigma env = function
-  | Unfold l -> Unfold (List.map (interp_unfold ist env) l)
-  | Fold l -> Fold (List.map (interp_constr ist env sigma) l)
-  | Cbv f -> Cbv (interp_flag ist env f)
-  | Lazy f -> Lazy (interp_flag ist env f)
+  | Unfold l -> sigma , Unfold (List.map (interp_unfold ist env) l)
+  | Fold l ->
+    let (sigma,l_interp) = interp_constr_list ist env sigma l in
+    sigma , Fold l_interp
+  | Cbv f -> sigma , Cbv (interp_flag ist env f)
+  | Lazy f -> sigma , Lazy (interp_flag ist env f)
   | Pattern l ->
-      Pattern (List.map (interp_constr_with_occurrences ist env sigma) l)
+    let (sigma,l_interp) =
+      List.fold_right begin fun c (sigma,acc) ->
+	let (sigma,c_interp) = interp_constr_with_occurrences ist env sigma c in
+	sigma , c_interp :: acc
+      end l (sigma,[])
+    in
+    sigma , Pattern l_interp
   | Simpl o ->
-      Simpl(Option.map (interp_closed_typed_pattern_with_occurrences ist env sigma) o)
-  | (Red _ |  Hnf | ExtraRedExpr _ | CbvVm as r) -> r
+      sigma , Simpl(Option.map (interp_closed_typed_pattern_with_occurrences ist env sigma) o)
+  | (Red _ |  Hnf | ExtraRedExpr _ | CbvVm as r) -> sigma , r
 
 let pf_interp_red_expr ist gl = interp_red_expr ist (project gl) (pf_env gl)
 
 let interp_may_eval f ist gl = function
   | ConstrEval (r,c) ->
-      let redexp = pf_interp_red_expr ist gl  r in
-      pf_reduction_of_red_expr gl redexp (f ist gl c)
+      let (sigma,redexp) = pf_interp_red_expr ist gl r in
+      let (sigma,c_interp) = f ist { gl with sigma=sigma } c in
+      sigma , pf_reduction_of_red_expr gl redexp c_interp
   | ConstrContext ((loc,s),c) ->
       (try
-	let ic = f ist gl c
+	let (sigma,ic) = f ist gl c
 	and ctxt = constr_of_VConstr_context (List.assoc s ist.lfun) in
-	subst_meta [special_meta,ic] ctxt
+	sigma , subst_meta [special_meta,ic] ctxt
       with
 	| Not_found ->
 	    user_err_loc (loc, "interp_may_eval",
 	    str "Unbound context identifier" ++ pr_id s ++ str"."))
-  | ConstrTypeOf c -> pf_type_of gl (f ist gl c)
+  | ConstrTypeOf c ->
+      let (sigma,c_interp) = f ist gl c in
+      sigma , pf_type_of gl c_interp
   | ConstrTerm c ->
      try
 	f ist gl c
-     with e ->
-       debugging_exception_step ist false e (fun () ->
-         str"interpretation of term " ++ pr_rawconstr_env (pf_env gl) (fst c));
-       raise e
+     with reraise ->
+       debugging_exception_step ist false reraise (fun () ->
+         str"interpretation of term " ++ pr_glob_constr_env (pf_env gl) (fst c));
+       raise reraise
 
 (* Interprets a constr expression possibly to first evaluate *)
 let interp_constr_may_eval ist gl c =
-  let csr =
+  let (sigma,csr) =
     try
       interp_may_eval pf_interp_constr ist gl c
-    with e ->
-      debugging_exception_step ist false e (fun () -> str"evaluation of term");
-      raise e
+    with reraise ->
+      debugging_exception_step ist false reraise (fun () ->
+        str"evaluation of term");
+      raise reraise
   in
   begin
     db_constr ist.debug (pf_env gl) csr;
-    csr
+    sigma , csr
   end
 
 let rec message_of_value gl = function
@@ -1612,41 +1551,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 (sigma,c) = interp_constr ist env sigma c in
+          ElimOnConstr (sigma,(c,NoBindings))
 
 (* Associates variables with values and gives the remaining variables and
    values *)
@@ -1805,31 +1751,32 @@ let apply_one_mhyp_context ist env gl lmatch (hypname,patv,pat) lhyps =
 
 (* misc *)
 
-let mk_constr_value ist gl c = VConstr ([],pf_interp_constr ist gl c)
+let mk_constr_value ist gl c =
+  let (sigma,c_interp) = pf_interp_constr ist gl c in
+  sigma,VConstr ([],c_interp)
+let mk_open_constr_value ist gl c = 
+  let (sigma,c_interp) = pf_apply (interp_open_constr None ist) gl c in
+  sigma,VConstr ([],c_interp)
 let mk_hyp_value ist gl c = VConstr ([],mkVar (interp_hyp ist gl c))
 let mk_int_or_var_value ist c = VInteger (interp_int_or_var ist c)
 
 let pack_sigma (sigma,c) = {it=c;sigma=sigma}
 
-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 =
+  Goal.V82.new_goal_with sigma gl sign
 
 (* Interprets an l-tac expression into a value *)
 let rec val_interp ist gl (tac:glob_tactic_expr) =
-
   let value_interp ist = match tac with
   (* Immediate evaluation *)
-  | TacFun (it,body) -> VFun (ist.trace,ist.lfun,it,body)
+  | TacFun (it,body) -> project gl , VFun (ist.trace,ist.lfun,it,body)
   | TacLetIn (true,l,u) -> interp_letrec ist gl l u
   | TacLetIn (false,l,u) -> interp_letin ist gl l u
   | TacMatchGoal (lz,lr,lmr) -> interp_match_goal ist gl lz lr lmr
   | TacMatch (lz,c,lmr) -> interp_match ist gl lz c lmr
-  | TacArg a -> interp_tacarg ist gl a
+  | TacArg (loc,a) -> interp_tacarg ist gl a
   (* Delayed evaluation *)
-  | t -> VFun (ist.trace,ist.lfun,[],t)
+  | t -> project gl , VFun (ist.trace,ist.lfun,[],t)
 
   in check_for_interrupt ();
     match ist.debug with
@@ -1849,7 +1796,9 @@ and eval_tactic ist = function
 	catch_error (push_trace(loc,call)ist.trace) tac gl
   | TacFun _ | TacLetIn _ -> assert false
   | TacMatchGoal _ | TacMatch _ -> assert false
-  | TacId s -> fun gl -> tclIDTAC_MESSAGE (interp_message_nl ist gl s) gl
+  | TacId s -> fun gl ->
+      let res = tclIDTAC_MESSAGE (interp_message_nl ist gl s) gl in
+      db_breakpoint ist.debug s; res
   | TacFail (n,s) -> fun gl -> tclFAIL (interp_int_or_var ist n) (interp_message ist gl s) gl
   | TacProgress tac -> tclPROGRESS (interp_tactic ist tac)
   | TacAbstract (tac,ido) ->
@@ -1860,15 +1809,8 @@ 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
-	tclINFO
-	  begin
-	    match tac with
-		TacAtom (_,_) -> t
-	      | _ -> abstract_tactic_expr (TacArg (Tacexp tac)) t
-	  end
   | TacRepeat tac -> tclREPEAT (interp_tactic ist tac)
   | TacOrelse (tac1,tac2) ->
         tclORELSE (interp_tactic ist tac1) (interp_tactic ist tac2)
@@ -1876,17 +1818,23 @@ and eval_tactic ist = function
   | TacSolve l -> tclSOLVE (List.map (interp_tactic ist) l)
   | TacComplete tac -> tclCOMPLETE (interp_tactic ist tac)
   | TacArg a -> interp_tactic ist (TacArg a)
+  | TacInfo tac ->
+      msg_warning
+	(str "The general \"info\" tactic is currently not working.\n" ++
+	 str "Some specific verbose tactics may exist instead, such as\n" ++
+	 str "info_trivial, info_auto, info_eauto.");
+      eval_tactic ist tac
 
 and force_vrec ist gl = function
   | VRec (lfun,body) -> val_interp {ist with lfun = !lfun} gl body
-  | v -> v
+  | v -> project gl , v
 
 and interp_ltac_reference loc' mustbetac ist gl = function
   | ArgVar (loc,id) ->
       let v = List.assoc id ist.lfun in
-      let v = force_vrec ist gl v in
+      let (sigma,v) = force_vrec ist gl v in
       let v = propagate_trace ist loc id v in
-      if mustbetac then coerce_to_tactic loc id v else v
+      sigma , if mustbetac then coerce_to_tactic loc id v else v
   | ArgArg (loc,r) ->
       let ids = extract_ids [] ist.lfun in
       let loc_info = ((if loc' = dloc then loc else loc'),LtacNameCall r) in
@@ -1895,36 +1843,69 @@ and interp_ltac_reference loc' mustbetac ist gl = function
           trace = push_trace loc_info ist.trace } in
       val_interp ist gl (lookup r)
 
-and interp_tacarg ist gl = function
-  | TacVoid -> VVoid
-  | Reference r -> interp_ltac_reference dloc false ist gl r
-  | Integer n -> VInteger n
-  | IntroPattern ipat -> VIntroPattern (snd (interp_intro_pattern ist gl ipat))
-  | ConstrMayEval c -> VConstr ([],interp_constr_may_eval ist gl c)
-  | MetaIdArg (loc,_,id) -> assert false
-  | TacCall (loc,r,[]) -> interp_ltac_reference loc true ist gl r
-  | TacCall (loc,f,l) ->
-      let fv = interp_ltac_reference loc true ist gl f
-      and largs = List.map (interp_tacarg ist gl) l in
-      List.iter check_is_value largs;
-      interp_app loc ist gl fv largs
-  | TacExternal (loc,com,req,la) ->
-      interp_external loc ist gl com req (List.map (interp_tacarg ist gl) la)
-  | TacFreshId l ->
-      let id = pf_interp_fresh_id ist gl l in
-      VIntroPattern (IntroIdentifier id)
-  | Tacexp t -> val_interp ist gl t
-  | TacDynamic(_,t) ->
-      let tg = (Dyn.tag t) in
-      if tg = "tactic" then
-        val_interp ist gl (tactic_out t ist)
-      else if tg = "value" then
-        value_out t
-      else if tg = "constr" then
+and interp_tacarg ist gl arg =
+  let evdref = ref (project gl) in
+  let v = match arg with
+    | TacVoid -> VVoid
+    | Reference r ->
+      let (sigma,v) = interp_ltac_reference dloc false ist gl r in
+      evdref := sigma;
+      v
+    | Integer n -> VInteger n
+    | IntroPattern ipat -> VIntroPattern (snd (interp_intro_pattern ist gl ipat))
+    | ConstrMayEval c ->
+      let (sigma,c_interp) = interp_constr_may_eval ist gl c in
+      evdref := sigma;
+      VConstr ([],c_interp)
+    | MetaIdArg (loc,_,id) -> assert false
+    | TacCall (loc,r,[]) ->
+      let (sigma,v) = interp_ltac_reference loc true ist gl r in
+      evdref := sigma;
+      v
+    | TacCall (loc,f,l) ->
+        let (sigma,fv) = interp_ltac_reference loc true ist gl f in
+	let (sigma,largs) =
+	  List.fold_right begin fun a (sigma',acc) ->
+	    let (sigma', a_interp) = interp_tacarg ist gl a in
+	    sigma' , a_interp::acc
+	  end l (sigma,[])
+	in
+	List.iter check_is_value largs;
+	let (sigma,v) = interp_app loc ist { gl with sigma=sigma } fv largs in
+	evdref:= sigma;
+	v
+    | TacExternal (loc,com,req,la) ->
+        let (sigma,la_interp) =
+	  List.fold_right begin fun a (sigma,acc) ->
+	    let (sigma,a_interp) = interp_tacarg ist {gl with sigma=sigma} a in
+	    sigma , a_interp::acc
+	  end la (project gl,[])
+	in
+        let (sigma,v) = interp_external loc ist { gl with sigma=sigma } com req la_interp in
+	evdref := sigma;
+	v
+    | TacFreshId l ->
+        let id = pf_interp_fresh_id ist gl l in
+	VIntroPattern (IntroIdentifier id)
+    | Tacexp t ->
+      let (sigma,v) = val_interp ist gl t in
+      evdref := sigma;
+      v
+    | TacDynamic(_,t) ->
+        let tg = (Dyn.tag t) in
+	if tg = "tactic" then
+          let (sigma,v) = val_interp ist gl (tactic_out t ist) in
+	  evdref := sigma;
+	  v
+	else if tg = "value" then
+          value_out t
+	else if tg = "constr" then
         VConstr ([],constr_out t)
-      else
-        anomaly_loc (dloc, "Tacinterp.val_interp",
-          (str "Unknown dynamic: <" ++ str (Dyn.tag t) ++ str ">"))
+	else
+          anomaly_loc (dloc, "Tacinterp.val_interp",
+		       (str "Unknown dynamic: <" ++ str (Dyn.tag t) ++ str ">"))
+  in
+  !evdref , v
 
 (* Interprets an application node *)
 and interp_app loc ist gl fv largs =
@@ -1938,19 +1919,22 @@ and interp_app loc ist gl fv largs =
          (TacFun _|TacLetIn _|TacMatchGoal _|TacMatch _| TacArg _ as body))) ->
 	let (newlfun,lvar,lval)=head_with_value (var,largs) in
 	if lvar=[] then
-	  let v =
+	  let (sigma,v) =
 	    try
 	      catch_error trace
 		(val_interp {ist with lfun=newlfun@olfun; trace=trace} gl) body
-	    with e ->
-              debugging_exception_step ist false e (fun () -> str "evaluation");
-	      raise e in
+	    with reraise ->
+              debugging_exception_step ist false reraise
+                (fun () -> str "evaluation");
+	      raise reraise
+          in
+	  let gl = { gl with sigma=sigma } in
           debugging_step ist
 	    (fun () ->
 	       str"evaluation returns"++fnl()++pr_value (Some (pf_env gl)) v);
-          if lval=[] then v else interp_app loc ist gl v lval
+          if lval=[] then sigma,v else interp_app loc ist gl v lval
 	else
-          VFun(trace,newlfun@olfun,lvar,body)
+          project gl , VFun(trace,newlfun@olfun,lvar,body)
     | _ ->
 	user_err_loc (loc, "Tacinterp.interp_app",
           (str"Illegal tactic application."))
@@ -1973,38 +1957,47 @@ and tactic_of_value ist vle g =
 (* Evaluation with FailError catching *)
 and eval_with_fail ist is_lazy goal tac =
   try
-    (match val_interp ist goal tac with
+    let (sigma,v) = val_interp ist goal tac in
+    sigma ,
+    (match v with
     | VFun (trace,lfun,[],t) when not is_lazy ->
 	let tac = eval_tactic {ist with lfun=lfun; trace=trace} t in
-	VRTactic (catch_error trace tac goal)
+	VRTactic (catch_error trace tac { goal with sigma=sigma })
     | a -> a)
   with
-    | FailError (0,s) | Compat.Exc_located(_, FailError (0,s))
-    | Compat.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))
-    | Compat.Exc_located(s,FailError (lvl,s')) ->
-	raise (Compat.Exc_located(s,FailError (lvl - 1, s')))
-    | Compat.Exc_located(s,LtacLocated (s'',FailError (lvl,s'))) ->
-	raise (Compat.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
 
 (* Interprets the clauses of a LetIn *)
 and interp_letin ist gl llc u =
-  let lve = list_map_left (fun ((_,id),body) ->
-    let v = interp_tacarg ist gl body in check_is_value v; (id,v)) llc in
+  let (sigma,lve) =
+    List.fold_right begin fun ((_,id),body) (sigma,acc) ->
+      let (sigma,v) = interp_tacarg ist { gl with sigma=sigma } body in
+      check_is_value v;
+      sigma, (id,v)::acc
+    end llc (project gl,[])
+  in
   let ist = { ist with lfun = lve@ist.lfun } in
-  val_interp ist gl u
+  val_interp ist { gl with sigma=sigma } 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
@@ -2092,80 +2085,103 @@ and interp_external loc ist gl com req la =
 
   (* Interprets extended tactic generic arguments *)
 and interp_genarg ist gl x =
-  match genarg_tag x with
-  | BoolArgType -> in_gen wit_bool (out_gen globwit_bool x)
-  | IntArgType -> in_gen wit_int (out_gen globwit_int x)
-  | IntOrVarArgType ->
+  let evdref = ref (project gl) in
+  let rec interp_genarg ist gl x =
+    let gl = { gl with sigma = !evdref } in
+    match genarg_tag x with
+    | BoolArgType -> in_gen wit_bool (out_gen globwit_bool x)
+    | IntArgType -> in_gen wit_int (out_gen globwit_int x)
+    | IntOrVarArgType ->
       in_gen wit_int_or_var
         (ArgArg (interp_int_or_var ist (out_gen globwit_int_or_var x)))
-  | StringArgType ->
+    | StringArgType ->
       in_gen wit_string (out_gen globwit_string x)
-  | PreIdentArgType ->
+    | PreIdentArgType ->
       in_gen wit_pre_ident (out_gen globwit_pre_ident x)
-  | IntroPatternArgType ->
+    | IntroPatternArgType ->
       in_gen wit_intro_pattern
         (interp_intro_pattern ist gl (out_gen globwit_intro_pattern x))
-  | IdentArgType b ->
+    | IdentArgType b ->
       in_gen (wit_ident_gen b)
         (pf_interp_fresh_ident ist gl (out_gen (globwit_ident_gen b) x))
-  | VarArgType ->
+    | VarArgType ->
       in_gen wit_var (interp_hyp ist gl (out_gen globwit_var x))
-  | RefArgType ->
+    | RefArgType ->
       in_gen wit_ref (pf_interp_reference ist gl (out_gen globwit_ref x))
-  | SortArgType ->
+    | SortArgType ->
+      let (sigma,c_interp) =
+	pf_interp_constr ist gl
+	  (GSort (dloc,out_gen globwit_sort x), None)
+      in
+      evdref := sigma;
       in_gen wit_sort
-        (destSort
-	  (pf_interp_constr ist gl
-	    (RSort (dloc,out_gen globwit_sort x), None)))
-  | ConstrArgType ->
-      in_gen wit_constr (pf_interp_constr ist gl (out_gen globwit_constr x))
-  | ConstrMayEvalArgType ->
-      in_gen wit_constr_may_eval (interp_constr_may_eval ist gl (out_gen globwit_constr_may_eval x))
-  | QuantHypArgType ->
+        (destSort c_interp)
+    | ConstrArgType ->
+      let (sigma,c_interp) = pf_interp_constr ist gl (out_gen globwit_constr x) in
+      evdref := sigma;
+      in_gen wit_constr c_interp
+    | ConstrMayEvalArgType ->
+      let (sigma,c_interp) = interp_constr_may_eval ist gl (out_gen globwit_constr_may_eval x) in
+      evdref := sigma;
+      in_gen wit_constr_may_eval c_interp
+    | QuantHypArgType ->
       in_gen wit_quant_hyp
         (interp_declared_or_quantified_hypothesis ist gl
-          (out_gen globwit_quant_hyp x))
-  | RedExprArgType ->
-      in_gen wit_red_expr (pf_interp_red_expr ist gl (out_gen globwit_red_expr x))
-  | OpenConstrArgType casted ->
+           (out_gen globwit_quant_hyp x))
+    | RedExprArgType ->
+      let (sigma,r_interp) = pf_interp_red_expr ist gl (out_gen globwit_red_expr x) in
+      evdref := sigma;
+      in_gen wit_red_expr r_interp
+    | OpenConstrArgType casted ->
       in_gen (wit_open_constr_gen casted)
         (interp_open_constr (if casted then Some (pf_concl gl) else None)
-          ist (pf_env gl) (project gl)
-          (snd (out_gen (globwit_open_constr_gen casted) x)))
-  | ConstrWithBindingsArgType ->
+           ist (pf_env gl) (project gl)
+           (snd (out_gen (globwit_open_constr_gen casted) x)))
+    | ConstrWithBindingsArgType ->
       in_gen wit_constr_with_bindings
         (pack_sigma (interp_constr_with_bindings ist (pf_env gl) (project gl)
-          (out_gen globwit_constr_with_bindings x)))
-  | BindingsArgType ->
+		       (out_gen globwit_constr_with_bindings x)))
+    | BindingsArgType ->
       in_gen wit_bindings
         (pack_sigma (interp_bindings ist (pf_env gl) (project gl) (out_gen globwit_bindings x)))
-  | List0ArgType ConstrArgType -> interp_genarg_constr_list0 ist gl x
-  | List1ArgType ConstrArgType -> interp_genarg_constr_list1 ist gl x
-  | List0ArgType VarArgType -> interp_genarg_var_list0 ist gl x
-  | List1ArgType VarArgType -> interp_genarg_var_list1 ist gl x
-  | List0ArgType _ -> app_list0 (interp_genarg ist gl) x
-  | List1ArgType _ -> app_list1 (interp_genarg ist gl) x
-  | OptArgType _ -> app_opt (interp_genarg ist gl) x
-  | PairArgType _ -> app_pair (interp_genarg ist gl) (interp_genarg ist gl) x
-  | ExtraArgType s ->
+    | List0ArgType ConstrArgType ->
+        let (sigma,v) = interp_genarg_constr_list0 ist gl x in
+	evdref := sigma;
+	v
+    | List1ArgType ConstrArgType ->
+        let (sigma,v) = interp_genarg_constr_list1 ist gl x in
+	evdref := sigma;
+	v
+    | List0ArgType VarArgType -> interp_genarg_var_list0 ist gl x
+    | List1ArgType VarArgType -> interp_genarg_var_list1 ist gl x
+    | List0ArgType _ -> app_list0 (interp_genarg ist gl) x
+    | List1ArgType _ -> app_list1 (interp_genarg ist gl) x
+    | OptArgType _ -> app_opt (interp_genarg ist gl) x
+    | PairArgType _ -> app_pair (interp_genarg ist gl) (interp_genarg ist gl) x
+    | ExtraArgType s ->
       match tactic_genarg_level s with
       | Some n ->
           (* Special treatment of tactic arguments *)
-          in_gen (wit_tactic n)
-	    (TacArg(valueIn(VFun(ist.trace,ist.lfun,[],
-				 out_gen (globwit_tactic n) x))))
+        in_gen (wit_tactic n)
+	  (TacArg(dloc,valueIn(VFun(ist.trace,ist.lfun,[],
+				    out_gen (globwit_tactic n) x))))
       | None ->
-          lookup_interp_genarg s ist gl x
+        let (sigma,v) = lookup_interp_genarg s ist gl x in
+	evdref:=sigma;
+	v
+  in
+  let v = interp_genarg ist gl x in
+  !evdref , v
 
 and interp_genarg_constr_list0 ist gl x =
   let lc = out_gen (wit_list0 globwit_constr) x in
-  let lc = pf_apply (interp_constr_list ist) gl lc in
-  in_gen (wit_list0 wit_constr) lc
+  let (sigma,lc) = pf_apply (interp_constr_list ist) gl lc in
+  sigma , in_gen (wit_list0 wit_constr) lc
 
 and interp_genarg_constr_list1 ist gl x =
   let lc = out_gen (wit_list1 globwit_constr) x in
-  let lc = pf_apply (interp_constr_list ist) gl lc in
-  in_gen (wit_list1 wit_constr) lc
+  let (sigma,lc) = pf_apply (interp_constr_list ist) gl lc in
+  sigma , in_gen (wit_list1 wit_constr) lc
 
 and interp_genarg_var_list0 ist gl x =
   let lc = out_gen (wit_list0 globwit_var) x in
@@ -2188,54 +2204,56 @@ and interp_match ist g lz constr lmr =
       with e when is_match_catchable e ->
         match_next_pattern find_next' () in
     match_next_pattern (fun () -> match_subterm_gen app c csr) () in
-  let rec apply_match ist csr = function
-    | (All t)::_ ->
+  let rec apply_match ist sigma csr = let g = { g with sigma=sigma } in function
+    | (All t)::tl ->
         (try eval_with_fail ist lz g t
-         with e when is_match_catchable e -> apply_match ist csr [])
+         with e when is_match_catchable e -> apply_match ist sigma csr tl)
     | (Pat ([],Term c,mt))::tl ->
         (try
             let lmatch =
               try extended_matches c csr
-              with e ->
-                debugging_exception_step ist false e (fun () ->
+              with reraise ->
+                debugging_exception_step ist false reraise (fun () ->
                   str "matching with pattern" ++ fnl () ++
                   pr_constr_pattern_env (pf_env g) c);
-                raise e in
+                raise reraise
+            in
             try
               let lfun = extend_values_with_bindings lmatch ist.lfun in
               eval_with_fail { ist with lfun=lfun } lz g mt
-            with e ->
-              debugging_exception_step ist false e (fun () ->
+            with reraise ->
+              debugging_exception_step ist false reraise (fun () ->
                 str "rule body for pattern" ++
                 pr_constr_pattern_env (pf_env g) c);
-              raise e
+              raise reraise
          with e when is_match_catchable e ->
            debugging_step ist (fun () -> str "switching to the next rule");
-           apply_match ist csr tl)
+           apply_match ist sigma csr tl)
 
     | (Pat ([],Subterm (b,id,c),mt))::tl ->
         (try apply_match_subterm b ist (id,c) csr mt
-         with PatternMatchingFailure -> apply_match ist csr tl)
+         with PatternMatchingFailure -> apply_match ist sigma csr tl)
     | _ ->
       errorlabstrm "Tacinterp.apply_match" (str
         "No matching clauses for match.") in
-  let csr =
-      try interp_ltac_constr ist g constr with e ->
-        debugging_exception_step ist true e
+  let (sigma,csr) =
+      try interp_ltac_constr ist g constr with reraise ->
+        debugging_exception_step ist true reraise
           (fun () -> str "evaluation of the matched expression");
-        raise e in
-  let ilr = read_match_rule (fst (extract_ltac_constr_values ist (pf_env g))) ist (pf_env g) (project g) lmr in
+        raise reraise in
+  let ilr = read_match_rule (fst (extract_ltac_constr_values ist (pf_env g))) ist (pf_env g) sigma lmr in
   let res =
-     try apply_match ist csr ilr with e ->
-       debugging_exception_step ist true e (fun () -> str "match expression");
-       raise e in
+     try apply_match ist sigma csr ilr with reraise ->
+       debugging_exception_step ist true reraise
+         (fun () -> str "match expression");
+       raise reraise in
   debugging_step ist (fun () ->
-    str "match expression returns " ++ pr_value (Some (pf_env g)) res);
+    str "match expression returns " ++ pr_value (Some (pf_env g)) (snd res));
   res
 
 (* Interprets tactic expressions : returns a "constr" *)
 and interp_ltac_constr ist gl e =
-  let result =
+  let (sigma, result) =
   try val_interp ist gl e with Not_found ->
     debugging_step ist (fun () ->
       str "evaluation failed for" ++ fnl() ++
@@ -2248,7 +2266,7 @@ and interp_ltac_constr ist gl e =
       str " has value " ++ fnl() ++
       pr_constr_under_binders_env (pf_env gl) cresult);
     if fst cresult <> [] then raise Not_found;
-    snd cresult
+    sigma , snd cresult
   with Not_found ->
     errorlabstrm ""
       (str "Must evaluate to a closed term" ++ fnl() ++
@@ -2281,7 +2299,8 @@ and interp_ltac_constr ist gl e =
 
 (* Interprets tactic expressions : returns a "tactic" *)
 and interp_tactic ist tac gl =
-  tactic_of_value ist (val_interp ist gl tac) gl
+  let (sigma,v) = val_interp ist gl tac in
+  tactic_of_value ist v { gl with sigma=sigma }
 
 (* Interprets a primitive tactic *)
 and interp_atomic ist gl tac =
@@ -2296,9 +2315,21 @@ and interp_atomic ist gl tac =
       h_intro_move (Option.map (interp_fresh_ident ist env) ido)
                    (interp_move_location ist gl hto)
   | TacAssumption -> h_assumption
-  | TacExact c -> h_exact (pf_interp_casted_constr ist gl c)
-  | TacExactNoCheck c -> h_exact_no_check (pf_interp_constr ist gl c)
-  | TacVmCastNoCheck c -> h_vm_cast_no_check (pf_interp_constr ist gl c)
+  | TacExact c ->
+      let (sigma,c_interp) = pf_interp_casted_constr ist gl c in
+      tclTHEN
+	(tclEVARS sigma)
+	(h_exact c_interp)
+  | TacExactNoCheck c ->
+      let (sigma,c_interp) = pf_interp_constr ist gl c in
+      tclTHEN
+	(tclEVARS sigma)
+	(h_exact_no_check c_interp)
+  | TacVmCastNoCheck c ->
+      let (sigma,c_interp) = pf_interp_constr ist gl c in
+      tclTHEN
+	(tclEVARS sigma)
+	(h_vm_cast_no_check c_interp)
   | TacApply (a,ev,cb,cl) ->
       let sigma, l =
         list_fold_map (interp_open_constr_with_bindings_loc ist env) sigma cb
@@ -2312,77 +2343,133 @@ and interp_atomic ist gl tac =
       let sigma, cb = interp_constr_with_bindings ist env sigma cb in
       let sigma, cbo = Option.fold_map (interp_constr_with_bindings ist env) sigma cbo in
       tclWITHHOLES ev (h_elim ev cb) sigma cbo
-  | TacElimType c -> h_elim_type (pf_interp_type ist gl c)
+  | TacElimType c ->
+      let (sigma,c_interp) = pf_interp_type ist gl c in
+      tclTHEN
+	(tclEVARS sigma)
+	(h_elim_type c_interp)
   | TacCase (ev,cb) ->
       let sigma, cb = interp_constr_with_bindings ist env sigma cb in
       tclWITHHOLES ev (h_case ev) sigma cb
-  | TacCaseType c -> h_case_type (pf_interp_type ist gl c)
+  | TacCaseType c ->
+      let (sigma,c_interp) = pf_interp_type ist gl c in
+      tclTHEN
+	(tclEVARS sigma)
+	(h_case_type c_interp)
   | TacFix (idopt,n) -> h_fix (Option.map (interp_fresh_ident ist env) idopt) n
   | TacMutualFix (b,id,n,l) ->
-      let f (id,n,c) = (interp_fresh_ident ist env id,n,pf_interp_type ist gl c)
-      in h_mutual_fix b (interp_fresh_ident ist env id) n (List.map f l)
+      let f sigma (id,n,c) =
+	let (sigma,c_interp) = pf_interp_type ist { gl with sigma=sigma } c in
+	sigma , (interp_fresh_ident ist env id,n,c_interp) in
+      let (sigma,l_interp) =
+	List.fold_right begin fun c (sigma,acc) ->
+	  let (sigma,c_interp) = f sigma c in
+	  sigma , c_interp::acc
+	end l (project gl,[])
+      in
+      tclTHEN
+	(tclEVARS sigma)
+	(h_mutual_fix b (interp_fresh_ident ist env id) n l_interp)
   | TacCofix idopt -> h_cofix (Option.map (interp_fresh_ident ist env) idopt)
   | TacMutualCofix (b,id,l) ->
-      let f (id,c) = (interp_fresh_ident ist env id,pf_interp_type ist gl c) in
-      h_mutual_cofix b (interp_fresh_ident ist env id) (List.map f l)
-  | TacCut c -> h_cut (pf_interp_type ist gl c)
+      let f sigma (id,c) =
+	let (sigma,c_interp) = pf_interp_type ist { gl with sigma=sigma } c in
+	sigma , (interp_fresh_ident ist env id,c_interp) in
+      let (sigma,l_interp) =
+	List.fold_right begin fun c (sigma,acc) ->
+	  let (sigma,c_interp) = f sigma c in
+	  sigma , c_interp::acc
+	end l (project gl,[])
+      in
+      tclTHEN
+	(tclEVARS sigma)
+	(h_mutual_cofix b (interp_fresh_ident ist env id) l_interp)
+  | TacCut c ->
+      let (sigma,c_interp) = pf_interp_type ist gl c in
+      tclTHEN
+	(tclEVARS sigma)
+	(h_cut c_interp)
   | TacAssert (t,ipat,c) ->
-      let c = (if t=None then interp_constr else interp_type) ist env sigma c in
-      abstract_tactic (TacAssert (t,ipat,c))
-        (Tactics.forward (Option.map (interp_tactic ist) t)
-	  (Option.map (interp_intro_pattern ist gl) ipat) c)
+      let (sigma,c) = (if t=None then interp_constr else interp_type) ist env sigma c in
+      tclTHEN
+	(tclEVARS sigma)
+	(abstract_tactic (TacAssert (t,ipat,c))
+           (Tactics.forward (Option.map (interp_tactic ist) t)
+	      (Option.map (interp_intro_pattern ist gl) ipat) c))
   | TacGeneralize cl ->
       let sigma, cl = interp_constr_with_occurrences_and_name_as_list ist env sigma cl in
       tclWITHHOLES false (h_generalize_gen) sigma cl
-  | TacGeneralizeDep c -> h_generalize_dep (pf_interp_constr ist gl c)
-  | TacLetTac (na,c,clp,b) ->
+  | TacGeneralizeDep c ->
+      let (sigma,c_interp) = pf_interp_constr ist gl c in
+      tclTHEN
+	(tclEVARS sigma)
+	(h_generalize_dep c_interp)
+  | TacLetTac (na,c,clp,b,eqpat) ->
       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
+      let eqpat = Option.map (interp_intro_pattern ist gl) eqpat in
+      if clp = nowhere then
+        (* We try to fully-typecheck the term *)
+	let (sigma,c_interp) = pf_interp_constr ist gl c in
+	tclTHEN
+	  (tclEVARS sigma)
+          (h_let_tac b (interp_fresh_name ist env na) c_interp clp eqpat)
+      else
+        (* We try to keep the pattern structure as much as possible *)
+        h_let_pat_tac b (interp_fresh_name ist env na)
+          (interp_pure_open_constr ist env sigma c) clp eqpat
 
   (* Automation tactics *)
-  | TacTrivial (lems,l) ->
-      Auto.h_trivial (interp_constr_list ist env sigma lems)
+  | TacTrivial (debug,lems,l) ->
+      Auto.h_trivial ~debug
+	(interp_auto_lemmas ist env sigma lems)
+	(Option.map (List.map (interp_hint_base ist)) l)
+  | TacAuto (debug,n,lems,l) ->
+      Auto.h_auto ~debug (Option.map (interp_int_or_var ist) n)
+	(interp_auto_lemmas ist env sigma lems)
 	(Option.map (List.map (interp_hint_base ist)) l)
-  | 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)
-  | 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)
 
   (* Derived basic tactics *)
   | TacSimpleInductionDestruct (isrec,h) ->
       h_simple_induction_destruct isrec (interp_quantified_hypothesis ist h)
-  | TacInductionDestruct (isrec,ev,(l,cls)) ->
+  | TacInductionDestruct (isrec,ev,(l,el,cls)) ->
       let sigma, l =
-        list_fold_map (fun sigma (lc,cbo,(ipato,ipats)) ->
-          let sigma,lc =
-            list_fold_map (interp_induction_arg ist gl) sigma lc in
-	  let sigma,cbo =
-            Option.fold_map (interp_constr_with_bindings ist env) sigma cbo in
-          (sigma,(lc,cbo,
+        list_fold_map (fun sigma (c,(ipato,ipats)) ->
+          let c = interp_induction_arg ist gl c in
+          (sigma,(c,
             (Option.map (interp_intro_pattern ist gl) ipato,
 	     Option.map (interp_intro_pattern ist gl) ipats)))) sigma l in
+      let sigma,el =
+        Option.fold_map (interp_constr_with_bindings ist env) sigma el in
       let cls = Option.map (interp_clause ist gl) cls in
-      tclWITHHOLES ev (h_induction_destruct isrec ev) sigma (l,cls)
+      tclWITHHOLES ev (h_induction_destruct isrec ev) sigma (l,el,cls)
   | TacDoubleInduction (h1,h2) ->
       let h1 = interp_quantified_hypothesis ist h1 in
       let h2 = interp_quantified_hypothesis ist h2 in
       Elim.h_double_induction h1 h2
-  | TacDecomposeAnd c -> Elim.h_decompose_and (pf_interp_constr ist gl c)
-  | TacDecomposeOr c -> Elim.h_decompose_or (pf_interp_constr ist gl c)
+  | TacDecomposeAnd c ->
+      let (sigma,c_interp) = pf_interp_constr ist gl c in
+      tclTHEN
+	(tclEVARS sigma)
+	(Elim.h_decompose_and c_interp)
+  | TacDecomposeOr c ->
+      let (sigma,c_interp) = pf_interp_constr ist gl c in
+      tclTHEN
+	(tclEVARS sigma)
+	(Elim.h_decompose_or c_interp)
   | TacDecompose (l,c) ->
       let l = List.map (interp_inductive ist) l in
-      Elim.h_decompose l (pf_interp_constr ist gl c)
+      let (sigma,c_interp) = pf_interp_constr ist gl c in
+      tclTHEN
+	(tclEVARS sigma)
+	(Elim.h_decompose l c_interp)
   | TacSpecialize (n,cb) ->
       let sigma, cb = interp_constr_with_bindings ist env sigma cb in
       tclWITHHOLES false (h_specialize n) sigma cb
-  | TacLApply c -> h_lapply (pf_interp_constr ist gl c)
+  | TacLApply c ->
+      let (sigma,c_interp) = pf_interp_constr ist gl c in
+      tclTHEN
+	(tclEVARS sigma)
+	(h_lapply c_interp)
 
   (* Context management *)
   | TacClear (b,l) -> h_clear b (interp_hyp_list ist gl l)
@@ -2410,31 +2497,52 @@ 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) ->
-      h_reduce (pf_interp_red_expr ist gl r) (interp_clause ist gl cl)
+      let (sigma,r_interp) = pf_interp_red_expr ist gl r in
+      tclTHEN
+	(tclEVARS sigma)
+	(h_reduce r_interp (interp_clause ist gl cl))
   | TacChange (None,c,cl) ->
-      h_change None
-        (if (cl.onhyps = None or cl.onhyps = Some []) &
+      let (sigma,c_interp) =
+	if (cl.onhyps = None or cl.onhyps = Some []) &
 	    (cl.concl_occs = all_occurrences_expr or
 	     cl.concl_occs = no_occurrences_expr)
 	 then pf_interp_type ist gl c
-	 else pf_interp_constr ist gl c)
-        (interp_clause ist gl cl)
+	 else pf_interp_constr ist gl c
+      in
+      tclTHEN
+	(tclEVARS sigma)
+	(h_change None c_interp (interp_clause ist gl cl))
   | TacChange (Some op,c,cl) ->
       let sign,op = interp_typed_pattern ist env sigma op in
-      h_change (Some op)
-        (try pf_interp_constr ist (extend_gl_hyps gl sign) c
-	 with Not_found | Anomaly _ (* Hack *) ->
-	   errorlabstrm "" (strbrk "Failed to get enough information from the left-hand side to type the right-hand side."))
-        (interp_clause ist gl cl)
+      (* spiwack: (2012/04/18) the evar_map output by pf_interp_constr
+	 is dropped as the evar_map taken as input (from
+	 extend_gl_hyps) is incorrect.  This means that evar
+	 instantiated by pf_interp_constr may be lost, there. *)
+      let (_,c_interp) =
+	try pf_interp_constr ist (extend_gl_hyps gl sign) c
+	with Not_found | Anomaly _ (* Hack *) ->
+	   errorlabstrm "" (strbrk "Failed to get enough information from the left-hand side to type the right-hand side.")
+      in
+      tclTHEN
+	(tclEVARS sigma)
+	(h_change (Some op) c_interp (interp_clause ist { gl with sigma=sigma } cl))
 
   (* Equivalence relations *)
   | TacReflexivity -> h_reflexivity
   | TacSymmetry c -> h_symmetry (interp_clause ist gl c)
-  | TacTransitivity c -> h_transitivity (Option.map (pf_interp_constr ist gl) c)
+  | TacTransitivity c ->
+    begin match c with
+    | None -> h_transitivity None
+    | Some c ->
+      let (sigma,c_interp) = pf_interp_constr ist gl c in
+      tclTHEN
+	(tclEVARS sigma)
+	(h_transitivity (Some c_interp))
+    end
 
   (* Equality and inversion *)
   | TacRewrite (ev,l,cl,by) ->
@@ -2445,7 +2553,14 @@ and interp_atomic ist gl tac =
       Equality.general_multi_multi_rewrite ev l cl
         (Option.map (fun by -> tclCOMPLETE (interp_tactic ist by), Equality.Naive) by)
   | TacInversion (DepInversion (k,c,ids),hyp) ->
-      Inv.dinv k (Option.map (pf_interp_constr ist gl) c)
+      let (sigma,c_interp) =
+	match c with
+	| None -> sigma , None
+	| Some c ->
+	  let (sigma,c_interp) = pf_interp_constr ist gl c in
+	  sigma , Some c_interp
+      in
+      Inv.dinv k c_interp
         (Option.map (interp_intro_pattern ist gl) ids)
         (interp_declared_or_quantified_hypothesis ist gl hyp)
   | TacInversion (NonDepInversion (k,idl,ids),hyp) ->
@@ -2454,16 +2569,23 @@ and interp_atomic ist gl tac =
         (interp_hyp_list ist gl idl)
         (interp_declared_or_quantified_hypothesis ist gl hyp)
   | TacInversion (InversionUsing (c,idl),hyp) ->
+      let (sigma,c_interp) = pf_interp_constr ist gl c in
       Leminv.lemInv_clause (interp_declared_or_quantified_hypothesis ist gl hyp)
-        (pf_interp_constr ist gl c)
+        c_interp
         (interp_hyp_list ist gl idl)
 
   (* For extensions *)
   | TacExtend (loc,opn,l) ->
       let tac = lookup_tactic opn in
-      let args = List.map (interp_genarg ist gl) l in
+      let (sigma,args) = 
+	List.fold_right begin fun a (sigma,acc) ->
+	  let (sigma,a_interp) = interp_genarg ist { gl with sigma=sigma } a in
+	  sigma , a_interp::acc
+	end l (project gl,[])
+      in
       abstract_extended_tactic opn args (tac args)
   | TacAlias (loc,s,l,(_,body)) -> fun gl ->
+    let evdref = ref gl.sigma in
     let rec f x = match genarg_tag x with
     | IntArgType ->
         VInteger (out_gen globwit_int x)
@@ -2485,17 +2607,34 @@ and interp_atomic ist gl tac =
     | SortArgType ->
         VConstr ([],mkSort (interp_sort (out_gen globwit_sort x)))
     | ConstrArgType ->
-        mk_constr_value ist gl (out_gen globwit_constr x)
+        let (sigma,v) = mk_constr_value ist gl (out_gen globwit_constr x) in
+	evdref := sigma;
+	v
+    | OpenConstrArgType false ->
+        let (sigma,v) = mk_open_constr_value ist gl (snd (out_gen globwit_open_constr x)) in
+	evdref := sigma;
+	v
     | ConstrMayEvalArgType ->
-	VConstr
-          ([],interp_constr_may_eval ist gl (out_gen globwit_constr_may_eval x))
+        let (sigma,c_interp) = interp_constr_may_eval ist gl (out_gen globwit_constr_may_eval x) in
+	evdref := sigma;
+	VConstr ([],c_interp)
     | ExtraArgType s when tactic_genarg_level s <> None ->
           (* Special treatment of tactic arguments *)
-	val_interp ist gl
+	let (sigma,v) = val_interp ist gl
           (out_gen (globwit_tactic (Option.get (tactic_genarg_level s))) x)
+	in
+	evdref := sigma;
+	v
     | List0ArgType ConstrArgType ->
         let wit = wit_list0 globwit_constr in
-        VList (List.map (mk_constr_value ist gl) (out_gen wit x))
+	let (sigma,l_interp) =
+	  List.fold_right begin fun c (sigma,acc) ->
+	    let (sigma,c_interp) = mk_constr_value ist { gl with sigma=sigma } c in
+	    sigma , c_interp::acc
+	  end (out_gen wit x) (project gl,[])
+	in
+	evdref := sigma;
+        VList (l_interp)
     | List0ArgType VarArgType ->
         let wit = wit_list0 globwit_var in
         VList (List.map (mk_hyp_value ist gl) (out_gen wit x))
@@ -2515,7 +2654,14 @@ and interp_atomic ist gl tac =
         VList (List.map mk_ipat (out_gen wit x))
     | List1ArgType ConstrArgType ->
         let wit = wit_list1 globwit_constr in
-        VList (List.map (mk_constr_value ist gl) (out_gen wit x))
+	let (sigma, l_interp) =
+	  List.fold_right begin fun c (sigma,acc) ->
+	    let (sigma,c_interp) = mk_constr_value ist { gl with sigma=sigma } c in
+	    sigma , c_interp::acc
+	  end (out_gen wit x) (project gl,[])
+	in
+	evdref:=sigma;
+        VList l_interp
     | List1ArgType VarArgType ->
         let wit = wit_list1 globwit_var in
         VList (List.map (mk_hyp_value ist gl) (out_gen wit x))
@@ -2539,25 +2685,31 @@ and interp_atomic ist gl tac =
     | ExtraArgType _ | BindingsArgType
     | OptArgType _ | PairArgType _
     | List0ArgType _ | List1ArgType _
-	-> error "This generic type is not supported in alias."
+	-> error "This argument type is not supported in tactic notations."
 
     in
     let lfun = (List.map (fun (x,c) -> (x,f c)) l)@ist.lfun in
     let trace = push_trace (loc,LtacNotationCall s) ist.trace in
+    let gl = { gl with sigma = !evdref } in
     interp_tactic { ist with lfun=lfun; trace=trace } body gl
 
 let make_empty_glob_sign () =
   { ltacvars = ([],[]); ltacrecvars = [];
     gsigma = Evd.empty; genv = Global.env() }
 
+let fully_empty_glob_sign =
+  { ltacvars = ([],[]); ltacrecvars = [];
+    gsigma = Evd.empty; genv = Environ.empty_env }
+
 (* 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
 
 let eval_tactic t gls =
+  db_initialize ();
   interp_tactic { lfun=[]; avoid_ids=[]; debug=get_debug(); trace=[] }
     t gls
 
@@ -2566,18 +2718,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 +2738,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 +2797,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 +2815,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 +2837,50 @@ 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,eqpat) ->
+    TacLetTac (id,subst_glob_constr subst c,clp,b,eqpat)
 
   (* 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)
-  | 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)
+  | TacTrivial (d,lems,l) -> TacTrivial (d,List.map (subst_glob_constr subst) lems,l)
+  | TacAuto (d,n,lems,l) -> TacAuto (d,n,List.map (subst_glob_constr subst) lems,l)
 
   (* Derived basic tactics *)
   | TacSimpleInductionDestruct (isrec,h) as x -> x
-  | TacInductionDestruct (isrec,ev,(l,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))
+  | TacInductionDestruct (isrec,ev,(l,el,cls)) ->
+      let l' = List.map (fun (c,ids) -> subst_induction_arg subst c, ids) l in
+      let el' = Option.map (subst_glob_with_bindings subst) el in
+      TacInductionDestruct (isrec,ev,(l',el',cls))
   | TacDoubleInduction (h1,h2) as x -> x
-  | TacDecomposeAnd c -> TacDecomposeAnd (subst_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 +2899,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 +2944,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 +2953,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 +3004,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 +3015,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 +3038,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 +3082,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 +3090,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 +3145,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 +3163,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 +3179,17 @@ 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 when Errors.noncritical 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 +3208,5 @@ 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..573efb19 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-2012     *)
 (*   \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,39 +70,38 @@ 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;
   gsigma : Evd.evar_map;
   genv : Environ.env }
 
+val fully_empty_glob_sign : glob_sign
+
 val add_interp_genarg :
   string ->
     (glob_sign -> raw_generic_argument -> glob_generic_argument) *
     (interp_sign -> goal sigma -> glob_generic_argument ->
-      typed_generic_argument) *
+      Evd.evar_map * typed_generic_argument) *
     (substitution -> glob_generic_argument -> glob_generic_argument)
     -> unit
 
 val interp_genarg :
-  interp_sign -> goal sigma -> glob_generic_argument -> typed_generic_argument
+  interp_sign -> goal sigma -> glob_generic_argument -> Evd.evar_map * typed_generic_argument
 
 val intern_genarg :
   glob_sign -> raw_generic_argument -> glob_generic_argument
 
-val intern_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 +109,35 @@ 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 val_interp : interp_sign -> goal sigma -> glob_tactic_expr -> value
+val subst_glob_with_bindings :
+  substitution -> glob_constr_and_expr Glob_term.with_bindings -> glob_constr_and_expr Glob_term.with_bindings
 
-(* Interprets an expression that evaluates to a constr *)
+(** Interprets any expression *)
+val val_interp : interp_sign -> goal sigma -> glob_tactic_expr -> Evd.evar_map * value
+
+(** Interprets an expression that evaluates to a constr *)
 val interp_ltac_constr : interp_sign -> goal sigma -> glob_tactic_expr ->
-  constr
+  Evd.evar_map * constr
 
-(* Interprets redexp arguments *)
-val interp_redexp : Environ.env -> Evd.evar_map -> raw_red_expr -> red_expr
+(** Interprets redexp arguments *)
+val dump_glob_red_expr : raw_red_expr -> unit
+val interp_redexp : Environ.env -> Evd.evar_map -> raw_red_expr -> Evd.evar_map * red_expr
 
-(* Interprets tactic expressions *)
+(** 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
@@ -148,25 +146,22 @@ val eval_tactic : glob_tactic_expr -> tactic
 
 val interp : raw_tactic_expr -> tactic
 
-val eval_ltac_constr : goal sigma -> raw_tactic_expr -> constr
+val eval_ltac_constr : goal sigma -> raw_tactic_expr -> Evd.evar_map * 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 +170,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..b846c9eb 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-2012     *)
 (*   \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..91440836 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-2012     *)
 (*   \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..ddb2fa40 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-2012     *)
 (*   \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
@@ -55,14 +53,14 @@ let tclREPEAT_MAIN   = Refiner.tclREPEAT_MAIN
 let tclFIRST         = Refiner.tclFIRST
 let tclSOLVE         = Refiner.tclSOLVE
 let tclTRY           = Refiner.tclTRY
-let tclINFO          = Refiner.tclINFO
 let tclCOMPLETE      = Refiner.tclCOMPLETE
 let tclAT_LEAST_ONCE = Refiner.tclAT_LEAST_ONCE
 let tclFAIL          = Refiner.tclFAIL
 let tclFAIL_lazy     = Refiner.tclFAIL_lazy
 let tclDO            = Refiner.tclDO
-let tclPROGRESS      = Refiner.tclPROGRESS
+let 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 +171,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 +287,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 +362,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..6b4351ac 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-2012     *)
 (*   \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
@@ -49,14 +45,13 @@ val tclREPEAT_MAIN   : tactic -> tactic
 val tclFIRST         : tactic list -> tactic
 val tclSOLVE         : tactic list -> tactic
 val tclTRY           : tactic -> tactic
-val tclINFO          : tactic -> tactic
 val tclCOMPLETE      : tactic -> tactic
 val tclAT_LEAST_ONCE : tactic -> tactic
 val tclFAIL          : int -> std_ppcmds -> tactic
 val tclFAIL_lazy     : int -> std_ppcmds Lazy.t -> tactic
 val tclDO            : int -> tactic -> tactic
-val tclPROGRESS      : tactic -> tactic
 val tclWEAK_PROGRESS : tactic -> tactic
+val tclPROGRESS      : tactic -> tactic
 val tclNOTSAMEGOAL   : tactic -> tactic
 val tclTHENTRY       : tactic -> tactic -> tactic
 val tclMAP           : ('a -> tactic) -> 'a list -> tactic
@@ -68,7 +63,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 +91,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 +116,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 +142,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..ac00a73d 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-2012     *)
 (*   \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
@@ -556,7 +546,7 @@ let depth_of_quantified_hypothesis red h gl =
 	  str".")
 
 let intros_until_gen red h g =
-  tclDO (depth_of_quantified_hypothesis red h g) intro g
+  tclDO (depth_of_quantified_hypothesis red h g) (if red then introf else intro) g
 
 let intros_until_id id = intros_until_gen true (NamedHyp id)
 let intros_until_n_gen red n = intros_until_gen red (AnonHyp n)
@@ -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
@@ -1016,15 +1018,14 @@ let apply_in_once_main flags innerclause (d,lbind) gl =
   let thm = nf_betaiota gl.sigma (pf_type_of gl d) in
   let rec aux clause =
     try progress_with_clause flags innerclause clause
-    with err ->
+    with err when Errors.noncritical err ->
     try aux (clenv_push_prod clause)
     with NotExtensibleClause -> raise err in
   aux (make_clenv_binding gl (d,thm) lbind)
 
 let apply_in_once sidecond_first with_delta with_destruct with_evars id
   (loc,(d,lbind)) gl0 =
-  let flags =
-    if with_delta then 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,49 @@ 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;
+  modulo_delta_in_merge = Some full_transparent_state;
+  check_applied_meta_types = true;
+  resolve_evars = false;
+  use_pattern_unification = false;
+  use_meta_bound_pattern_unification = false;
+  frozen_evars =
+    fold_undefined (fun evk _ evars -> ExistentialSet.add evk evars)
+      sigma ExistentialSet.empty;
+  restrict_conv_on_strict_subterms = false;
+  modulo_betaiota = false;
+  modulo_eta = false;
+  allow_K_in_toplevel_higher_order_unification = false
+}
+
+let make_pattern_test env sigma0 (sigma,c) =
+  let flags = default_matching_flags sigma0 in
+  let matching_fun t =
+    try let sigma = w_unify env sigma Reduction.CONV ~flags c t in Some(sigma,t)
+    with e when Errors.noncritical e -> raise NotUnifiable in
+  let merge_fun c1 c2 =
+    match c1, c2 with
+    | Some (_,c1), Some (_,c2) when not (is_fconv Reduction.CONV env sigma0 c1 c2) ->
+        raise NotUnifiable
+    | _ -> c1 in
+  { match_fun = matching_fun; merge_fun = merge_fun; 
+    testing_state = None; last_found = None },
+  (fun test -> match test.testing_state with
+   | None -> finish_evar_resolution env sigma0 (sigma,c)
+   | Some (sigma,_) -> nf_evar sigma c)
+
+let letin_abstract id c (test,out) (occs,check_occs) gl =
   let env = pf_env gl in
   let compute_dependency _ (hyp,_,_ as d) depdecls =
     match occurrences_of_hyp hyp occs with
       | None -> depdecls
       | Some occ ->
-          let newdecl = subst_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 +1736,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 +1774,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 +1825,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 +1870,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 +1885,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 +1896,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 +1945,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 +2149,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 +2258,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 +2268,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 +2290,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 +2337,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 +2352,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 +2370,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 +2413,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 +2441,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 +2462,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
@@ -2426,23 +2499,29 @@ let abstract_generalize ?(generalize_vars=true) ?(force_dep=false) id gl =
 				   tclMAP (fun id -> 
 				     tclTRY (generalize_dep ~with_let:true (mkVar id))) vars] gl) gl
 
+let rec compare_upto_variables x y =
+  if (isVar x || isRel x) && (isVar y || isRel y) then true
+  else compare_constr compare_upto_variables x y
+
 let specialize_eqs id gl =
   let env = pf_env gl in
   let ty = pf_get_hyp_typ gl id in
-  let evars = ref (create_evar_defs (project gl)) in
-  let unif env evars c1 c2 = Evarconv.e_conv env evars c2 c1 in
+  let evars = ref (project gl) in
+  let unif env evars c1 c2 = 
+    compare_upto_variables c1 c2 && Evarconv.e_conv env evars c1 c2 
+  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 +2533,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) ->
@@ -2477,7 +2554,10 @@ let specialize_eqs id gl =
       
 
 let specialize_eqs id gl =
-  if try ignore(clear [id] gl); false with _ -> true then
+  if
+    (try ignore(clear [id] gl); false
+     with e when Errors.noncritical e -> true)
+  then
     tclFAIL 0 (str "Specialization not allowed on dependent hypotheses") gl 
   else specialize_eqs id gl
 
@@ -2485,33 +2565,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 =
@@ -2666,88 +2719,68 @@ let compute_elim_sig ?elimc elimt =
       | Some ( _,None,ind) ->
 	  let indhd,indargs = decompose_app ind in
 	  try {!res with indref = Some (global_of_constr indhd) }
-	  with _ -> error "Cannot find the inductive type of the inductive scheme.";;
+	  with e when Errors.noncritical e ->
+            error "Cannot find the inductive type of the inductive scheme.";;
 
 let compute_scheme_signature scheme names_info ind_type_guess =
   let f,l = decompose_app scheme.concl in
   (* 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 +2918,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 +2928,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 +3014,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 +3052,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 +3081,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 +3094,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 +3161,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 +3173,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 +3182,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 ->
@@ -3163,12 +3194,19 @@ let induct_destruct isrec with_evars (lc,elim,names,cls) gl =
   end
 
 let induction_destruct isrec with_evars = function
-  | [],_ -> tclIDTAC
-  | [a,b,c],cl -> induct_destruct isrec with_evars (a,b,c,cl)
-  | (a,b,c)::l,cl ->
+  | [],_,_ -> tclIDTAC
+  | [a,b],el,cl -> induct_destruct isrec with_evars ([a],el,b,cl)
+  | (a,b)::l,None,cl ->
       tclTHEN
-        (induct_destruct isrec with_evars (a,b,c,cl))
-        (tclMAP (fun (a,b,c) -> induct_destruct false with_evars (a,b,c,cl)) l)
+        (induct_destruct isrec with_evars ([a],None,b,cl))
+        (tclMAP (fun (a,b) -> induct_destruct false with_evars ([a],None,b,cl)) l)
+  | l,Some el,cl ->
+      let check_basic_using = function
+        | a,(None,None) -> a
+	| _ -> error "Unsupported syntax for \"using\"."
+      in
+      let l' = List.map check_basic_using l in
+      induct_destruct isrec with_evars (l', Some el, (None,None), cl)
 
 let new_induct ev lc e idl cls = induct_destruct true ev (lc,e,idl,cls)
 let new_destruct ev lc e idl cls = induct_destruct false ev (lc,e,idl,cls)
@@ -3179,11 +3217,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 +3248,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 =
@@ -3383,7 +3418,7 @@ let intros_symmetry =
 
 (* Transitivity tactics *)
 
-(* This tactic first tries to apply a constant named trans_eq, where eq
+(* This tactic first tries to apply a constant named eq_trans, where eq
    is the name of the equality predicate. If this constant is not
    defined and the conclusion is a=b, it solves the goal doing
    Cut x1=x2;
@@ -3472,7 +3507,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 +3536,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 +3553,7 @@ 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
+  with e when Errors.noncritical e ->
+    tclFAIL 0 (str"Not unifiable") gl
diff --git a/tactics/tactics.mli b/tactics/tactics.mli
index 5ceade1f..7e24156a 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-2012     *)
 (*   \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 *
-  constr with_bindings option *
+  ((evar_map * constr with_bindings) induction_arg *
   (intro_pattern_expr located option * intro_pattern_expr located option))
   list *
+  constr with_bindings option *
   clause option -> tactic
 
-(*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..f1324809 100644
--- a/tactics/tactics.mllib
+++ b/tactics/tactics.mllib
@@ -10,7 +10,6 @@ Elimschemes
 Tactics
 Hiddentac
 Elim
-Dhyp
 Auto
 Equality
 Contradiction
@@ -19,6 +18,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..4189832e 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-2012     *)
 (*   \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..231c03eb 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-2012     *)
 (*   \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..57d97cb8 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-2012     *)
 (*   \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..f9821f76 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-2012     *)
 (*   \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..f9821f76 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-2012     *)
 (*   \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/2955.v b/test-suite/bugs/closed/2955.v
new file mode 100644
index 00000000..45e24b5f
--- /dev/null
+++ b/test-suite/bugs/closed/2955.v
@@ -0,0 +1,52 @@
+Require Import Coq.Arith.Arith.
+
+Module A.
+
+  Fixpoint foo (n:nat) :=
+  match n with
+  | 0 => 0
+  | S n => bar n
+  end
+
+  with bar (n:nat) :=
+  match n with
+  | 0 => 0
+  | S n => foo n
+  end.
+
+  Lemma using_foo:
+    forall (n:nat), foo n = 0 /\ bar n = 0.
+  Proof.
+    induction n ; split ; auto ;
+    destruct IHn ; auto.
+  Qed.
+
+End A.
+
+
+Module B.
+  
+  Module A := A.
+  Import A.
+
+End B.
+
+Module E.
+
+  Module B := B.
+  Import B.A.
+
+  (* Bug 1 *)
+  Lemma test_1:
+    forall (n:nat), foo n = 0.
+  Proof.
+    intros ; destruct n.
+    reflexivity.
+    specialize (A.using_foo (S n)) ; intros.
+    simpl in H.
+    simpl.
+    destruct H.
+    assumption.
+  Qed.
+
+End E.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/shouldfail/2406.v b/test-suite/bugs/closed/shouldfail/2406.v
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/1414.v b/test-suite/bugs/closed/shouldsucceed/1414.v
index 495a16bc..ee9e2504 100644
--- a/test-suite/bugs/closed/shouldsucceed/1414.v
+++ b/test-suite/bugs/closed/shouldsucceed/1414.v
@@ -26,13 +26,13 @@ Program Fixpoint union
     | t1,Leaf => t1
     | Node l1 v1 r1 h1, Node l2 v2 r2 h2 =>
         if (Z_ge_lt_dec h1 h2) then
-          if (Z_eq_dec h2 1)
+          if (Z.eq_dec h2 1)
           then add v2 s
           else
             let (l2', r2') := split v1 u in
             join (union l1 l2' _ _ _ _) v1 (union r1 (snd r2') _ _ _ _)
         else
-          if (Z_eq_dec h1 1)
+          if (Z.eq_dec h1 1)
           then add v1 s
           else
             let (l1', r1') := split v2 u in
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/1784.v b/test-suite/bugs/closed/shouldsucceed/1784.v
index 718b0e86..fb2f0ca9 100644
--- a/test-suite/bugs/closed/shouldsucceed/1784.v
+++ b/test-suite/bugs/closed/shouldsucceed/1784.v
@@ -58,7 +58,7 @@ Program Fixpoint lt_dec (x y:sv) { struct x } : {slt x y}+{~slt x y} :=
   match x with
     | I x =>
       match y with
-        | I y => if (Z_eq_dec x y) then in_left else in_right
+        | I y => if (Z.eq_dec x y) then in_left else in_right
         | S ys => in_right
       end
     | S xs =>
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/1844.v b/test-suite/bugs/closed/shouldsucceed/1844.v
index 5627612f..17eeb352 100644
--- a/test-suite/bugs/closed/shouldsucceed/1844.v
+++ b/test-suite/bugs/closed/shouldsucceed/1844.v
@@ -1,6 +1,6 @@
 Require Import ZArith.
 
-Definition zeq := Z_eq_dec.
+Definition zeq := Z.eq_dec.
 
 Definition update (A: Set) (x: Z) (v: A) (s: Z -> A) : Z -> A :=
  fun y => if zeq x y then v else s y.
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/1935.v b/test-suite/bugs/closed/shouldsucceed/1935.v
index 72396d49..d5837619 100644
--- a/test-suite/bugs/closed/shouldsucceed/1935.v
+++ b/test-suite/bugs/closed/shouldsucceed/1935.v
@@ -13,7 +13,7 @@ Qed.
 
 Require Import ZArith.
 
-Definition f'' (a:bool) := if a then eq (A:= Z) else Zlt.
+Definition f'' (a:bool) := if a then eq (A:= Z) else Z.lt.
 
 Lemma f_refl'' : forall n , f'' true n n.
 Proof.
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..142ada26 100644
--- a/test-suite/bugs/closed/shouldsucceed/2127.v
+++ b/test-suite/bugs/closed/shouldsucceed/2127.v
@@ -1,11 +1,8 @@
-(* Check that "apply refl_equal" is not exported as an interactive
+(* Check that "apply eq_refl" is not exported as an interactive
    tactic but as a statically globalized one *)
 
 (* (this is a simplification of the original bug report) *)
 
 Module A.
-Hint Rewrite sym_equal using apply refl_equal : foo.
+Hint Rewrite eq_sym using apply eq_refl : 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..371bfdc5
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2603.v
@@ -0,0 +1,33 @@
+(** Namespace of module vs. namescope of definitions/constructors/...
+
+As noticed by A. Appel in bug #2603, module names and definition
+names used to be in the same namespace. But conflict with names
+of constructors (or 2nd mutual inductive...) used to not be checked
+enough, leading to stange situations.
+
+- In 8.3pl3 we introduced checks that forbid uniformly the following
+  situations.
+
+- For 8.4 we finally managed to make module names and other names
+  live in two separate namespace, hence allowing all of the following
+  situations.
+*)
+
+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.
+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.
+Module E := K. (* Used to be accepted *)
+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/2629.v b/test-suite/bugs/closed/shouldsucceed/2629.v
new file mode 100644
index 00000000..759cd3dd
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2629.v
@@ -0,0 +1,22 @@
+Class Join (t: Type) : Type := mkJoin {join: t -> t -> t -> Prop}.
+
+Class sepalg (t: Type) {JOIN: Join t} : Type :=
+  SepAlg   {
+   join_eq: forall {x y z z'}, join x y z -> join x y z' -> z = z';
+   join_assoc: forall {a b c d e}, join a b d -> join d c e ->
+                    {f : t & join b c f /\ join a f e};
+   join_com: forall {a b c}, join a b c -> join b a c;
+   join_canc: forall {a1 a2 b c}, join a1 b c -> join a2 b c -> a1=a2;
+
+   unit_for : t -> t -> Prop := fun e a => join e a a;
+   join_ex_units: forall a, {e : t & unit_for e a}
+}.
+
+Definition joins {A} `{Join A} (a b : A) : Prop :=
+ exists c, join a b c.
+
+Lemma join_joins {A} `{sepalg A}: forall {a b c},
+ join a b c -> joins a b.
+Proof.
+ firstorder.
+Qed.
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/closed/shouldsucceed/2668.v b/test-suite/bugs/closed/shouldsucceed/2668.v
new file mode 100644
index 00000000..74c8fa34
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2668.v
@@ -0,0 +1,6 @@
+Require Import MSetPositive.
+Require Import MSetProperties.
+
+Module Pos := MSetPositive.PositiveSet.
+Module PPPP := MSetProperties.WPropertiesOn(Pos).
+Print Module PPPP.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/shouldsucceed/2732.v b/test-suite/bugs/closed/shouldsucceed/2732.v
new file mode 100644
index 00000000..f22a8ccc
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2732.v
@@ -0,0 +1,19 @@
+(* Check correct behavior of add_primitive_tactic in TACEXTEND *)
+
+(* Added also the case of eauto and congruence *)
+
+Ltac thus H := solve [H].
+
+Lemma test: forall n : nat, n <= n.
+Proof.
+  intro.
+  thus firstorder.
+  Undo.
+  thus eauto.
+Qed.
+
+Lemma test2: false = true -> False.
+Proof.
+  intro.
+  thus congruence.
+Qed.
diff --git a/test-suite/bugs/closed/shouldsucceed/2733.v b/test-suite/bugs/closed/shouldsucceed/2733.v
new file mode 100644
index 00000000..fd7bd3bd
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2733.v
@@ -0,0 +1,26 @@
+Definition goodid : forall {A} (x: A), A := fun A x => x.
+Definition wrongid : forall A (x: A), A := fun {A} x => x.
+
+Inductive ty := N | B.
+
+Inductive alt_list : ty -> ty -> Type :=
+  | nil {k} : alt_list k k
+  | Ncons {k} : nat -> alt_list B k -> alt_list N k
+  | Bcons {k} : bool -> alt_list N k -> alt_list B k.
+
+Definition trullynul k {k'} (l : alt_list k k') :=
+match k,l with
+ |N,l' => Ncons 0 (Bcons true l')
+ |B,l' => Bcons true (Ncons 0 l')
+end.
+
+Fixpoint app (P : forall {k k'}, alt_list k k' -> alt_list k k') {t1 t2} (l : alt_list t1 t2) {struct l}: forall {t3}, alt_list t2 t3 ->
+alt_list t1 t3 :=
+  match l with
+  | nil _ => fun _ l2 => P l2
+  | Ncons _ n l1 => fun _ l2 => Ncons n (app (@P) l1 l2)
+  | Bcons _ b l1 => fun _ l2 => Bcons b (app (@P) l1 l2)
+  end.
+
+Check (fun {t t'} (l: alt_list t t') =>
+ app trullynul (goodid l) (wrongid _ nil)).
diff --git a/test-suite/bugs/closed/shouldsucceed/2734.v b/test-suite/bugs/closed/shouldsucceed/2734.v
new file mode 100644
index 00000000..826361be
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2734.v
@@ -0,0 +1,15 @@
+Require Import Arith List.
+Require Import OrderedTypeEx.
+
+Module Adr.
+ Include Nat_as_OT.
+ Definition nat2t (i: nat) : t := i.
+End Adr.
+
+Inductive expr :=  Const: Adr.t -> expr.
+
+Inductive control := Go: expr ->  control.
+
+Definition program :=  (Adr.t * (control))%type.
+
+Fail Definition myprog : program := (Adr.nat2t 0,   Go (Adr.nat2t 0) ).
\ No newline at end of file
diff --git a/test-suite/bugs/closed/shouldsucceed/2750.v b/test-suite/bugs/closed/shouldsucceed/2750.v
new file mode 100644
index 00000000..fc580f10
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2750.v
@@ -0,0 +1,23 @@
+
+Module Type ModWithRecord.
+
+  Record foo : Type :=
+  { A : nat
+  ; B : nat
+  }.
+End ModWithRecord.
+
+Module Test_ModWithRecord (M : ModWithRecord).
+
+  Definition test1 : M.foo :=
+    {| M.A := 0
+     ; M.B := 2
+     |}.
+
+  Module B := M.
+
+  Definition test2 : M.foo :=
+    {| M.A := 0
+     ; M.B := 2
+     |}.
+End Test_ModWithRecord.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/shouldsucceed/2817.v b/test-suite/bugs/closed/shouldsucceed/2817.v
new file mode 100644
index 00000000..08dff992
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2817.v
@@ -0,0 +1,9 @@
+(** Occur-check for Meta (up to application of already known instances) *)
+
+Goal forall (f: nat -> nat -> Prop) (x:bool)
+  (H: forall  (u: nat), f u u -> True)
+  (H0: forall x0, f (if x then x0 else x0) x0),
+False.
+
+intros.
+Fail apply H in H0. (* should fail without exhausting the stack *)
diff --git a/test-suite/bugs/closed/shouldsucceed/2836.v b/test-suite/bugs/closed/shouldsucceed/2836.v
new file mode 100644
index 00000000..a948b75e
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2836.v
@@ -0,0 +1,39 @@
+(* Check that possible instantiation made during evar materialization
+   are taken into account and do not raise Not_found *)
+
+Set Implicit Arguments.
+
+Record SpecializedCategory (obj : Type) (Morphism : obj -> obj -> Type) := {
+  Object :> _ := obj;
+
+  Identity' : forall o, Morphism o o;
+  Compose' : forall s d d', Morphism d d' -> Morphism s d -> Morphism s d'
+}.
+
+Section SpecializedCategoryInterface.
+  Variable obj : Type.
+  Variable mor : obj -> obj -> Type.
+  Variable C : @SpecializedCategory obj mor.
+
+  Definition Morphism (s d : C) := mor s d.
+  Definition Identity (o : C) : Morphism o o := C.(Identity') o.
+  Definition Compose (s d d' : C) (m : Morphism d d') (m0 : Morphism s d) :
+Morphism s d' := C.(Compose') s d d' m m0.
+End SpecializedCategoryInterface.
+
+Section ProductCategory.
+  Variable objC : Type.
+  Variable morC : objC -> objC -> Type.
+  Variable objD : Type.
+  Variable morD : objD -> objD -> Type.
+  Variable C : SpecializedCategory morC.
+  Variable D : SpecializedCategory morD.
+
+(* Should fail nicely *)
+Definition ProductCategory : @SpecializedCategory (objC * objD)%type (fun s d
+=> (morC (fst s) (fst d) * morD (snd s) (snd d))%type).
+Fail refine {|
+      Identity' := (fun o => (Identity (fst o), Identity (snd o)));
+      Compose' := (fun s d d' m2 m1 => (Compose (fst m2) (fst m1), Compose (snd
+m2) (snd m1)))
+    |}.
diff --git a/test-suite/bugs/closed/shouldsucceed/2928.v b/test-suite/bugs/closed/shouldsucceed/2928.v
new file mode 100644
index 00000000..21e92ae2
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2928.v
@@ -0,0 +1,11 @@
+Class Equiv A := equiv: A -> A -> Prop.
+Infix "=" := equiv : type_scope.
+
+Class Associative {A} f `{Equiv A} := associativity x y z : f x (f y z) = f (f x y) z.
+
+Class SemiGroup A op `{Equiv A} := { sg_ass :>> Associative op }.
+
+Class SemiLattice A op `{Equiv A} :=
+    { semilattice_sg :>> SemiGroup A op
+    ; redundant : Associative op
+    }.
diff --git a/test-suite/bugs/closed/shouldsucceed/2983.v b/test-suite/bugs/closed/shouldsucceed/2983.v
new file mode 100644
index 00000000..15598352
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2983.v
@@ -0,0 +1,8 @@
+Module Type ModA.
+End ModA.
+Module Type ModB(A : ModA).
+End ModB.
+Module Foo(A : ModA)(B : ModB A).
+End Foo.
+
+Print Module Foo.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/shouldsucceed/2995.v b/test-suite/bugs/closed/shouldsucceed/2995.v
new file mode 100644
index 00000000..ba3acd08
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2995.v
@@ -0,0 +1,9 @@
+Module Type Interface.
+  Parameter error: nat.
+End Interface.
+
+Module Implementation <: Interface.
+  Definition t := bool.
+  Definition error: t := false.
+Fail End Implementation.
+(* A UserError here is expected, not an uncaught Not_found *)
\ No newline at end of file
diff --git a/test-suite/bugs/closed/shouldsucceed/3000.v b/test-suite/bugs/closed/shouldsucceed/3000.v
new file mode 100644
index 00000000..27de34ed
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/3000.v
@@ -0,0 +1,2 @@
+Inductive t (t':Type) : Type := A | B.
+Definition d := match t with _ => 1 end. (* used to fail on list_chop *)
diff --git a/test-suite/bugs/closed/shouldsucceed/3004.v b/test-suite/bugs/closed/shouldsucceed/3004.v
new file mode 100644
index 00000000..896b1958
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/3004.v
@@ -0,0 +1,7 @@
+Set Implicit Arguments.
+Unset Strict Implicit.
+Parameter (M : nat -> Type).
+Parameter (mp : forall (T1 T2 : Type) (f : T1 -> T2), list T1 -> list T2).
+
+Definition foo (s : list {n : nat & M n}) :=
+  let exT := existT in mp (fun x => projT1 x) s.
diff --git a/test-suite/bugs/closed/shouldsucceed/3008.v b/test-suite/bugs/closed/shouldsucceed/3008.v
new file mode 100644
index 00000000..3f3a979a
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/3008.v
@@ -0,0 +1,29 @@
+Module Type Intf1.
+Parameter T : Type.
+Inductive a := A.
+End Intf1.
+
+Module Impl1 <: Intf1.
+Definition T := unit.
+Inductive a := A.
+End Impl1.
+
+Module Type Intf2
+  (Impl1 : Intf1).
+Parameter x : Impl1.A=Impl1.A -> Impl1.T.
+End Intf2.
+
+Module Type Intf3
+  (Impl1 : Intf1)
+  (Impl2 : Intf2(Impl1)).
+End Intf3.
+
+Fail Module Toto
+  (Impl1' : Intf1)
+  (Impl2 : Intf2(Impl1'))
+  (Impl3 : Intf3(Impl1)(Impl2)).
+(* A UserError is expected here, not an uncaught Not_found *)
+
+(* NB : the Inductive above and the A=A weren't in the initial test,
+   they are here only to force an access to the environment
+   (cf [Printer.qualid_of_global]) and check that this env is ok. *)
\ No newline at end of file
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/autodecomp.v b/test-suite/complexity/autodecomp.v
deleted file mode 100644
index 85589ff7..00000000
--- a/test-suite/complexity/autodecomp.v
+++ /dev/null
@@ -1,11 +0,0 @@
-(* This example used to be in (at least) exponential time in the number of
-   conjunctive types in the hypotheses before revision 11713 *)
-(* Expected time < 1.50s *)
-
-Goal
-True/\True->
-True/\True->
-True/\True->
-False/\False.
-
-Timeout 5 Time auto decomp.
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..52dae265 100644
--- a/test-suite/complexity/ring2.v
+++ b/test-suite/complexity/ring2.v
@@ -3,7 +3,7 @@
 
 Require Import BinInt Zbool.
 
-Definition Zplus x y :=
+Definition Zadd x y :=
 match x with
 | 0%Z => y
 | Zpos x' =>
@@ -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')
@@ -30,9 +30,10 @@ match x with
     end
 end.
 
+
 Require Import Ring.
 
-Lemma Zth : ring_theory Z0 (Zpos xH) Zplus Zmult Zminus Zopp (@eq Z).
+Lemma Zth : ring_theory Z0 (Zpos xH) Zadd Z.mul Z.sub Z.opp (@eq Z).
 Admitted.
 
 Ltac Zcst t :=
@@ -45,7 +46,7 @@ Add Ring Zr : Zth
   (decidable Zeq_bool_eq, constants [Zcst]).
 
 Open Scope Z_scope.
-Infix "+" := Zplus : Z_scope.
+Infix "+" := Zadd : Z_scope.
 
 Goal forall a, a+a+a+a+a+a+a+a+a+a+a+a+a = a*13.
 Timeout 5 Time intro; ring.
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..cbe7473c 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/test-suite/failure/Uminus.v b/test-suite/failure/Uminus.v
index 6866f19a..3c3bf375 100644
--- a/test-suite/failure/Uminus.v
+++ b/test-suite/failure/Uminus.v
@@ -31,7 +31,7 @@ Lemma Omega : forall i:U -> prop, induct i -> up (i WF).
 Proof.
 intros i y.
 apply y.
-unfold le, WF, induct in |- *.
+unfold le, WF, induct.
 intros x H0.
 apply y.
 exact H0.
@@ -39,7 +39,7 @@ Qed.
 
 Lemma lemma1 : induct (fun u => down (I u)).
 Proof.
-unfold induct in |- *.
+unfold induct.
 intros x p.
 intro q.
 apply (q (fun u => down (I u)) p).
diff --git a/test-suite/failure/clash_cons.v b/test-suite/failure/clash_cons.v
index 3f8d8784..25d3c165 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-2012     *)
 (*   \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..6abf6332 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-2012     *)
 (*   \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..324dc603 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-2012     *)
 (*   \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..6c14c2c3 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-2012     *)
 (*   \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/pattern.v b/test-suite/failure/pattern.v
index 129c380e..a24beaa2 100644
--- a/test-suite/failure/pattern.v
+++ b/test-suite/failure/pattern.v
@@ -6,4 +6,4 @@ Variable P : forall m : nat, m = n -> Prop.
 
 Goal forall p : n = n, P n p.
 intro.
-pattern n, p in |- *.
+pattern n, p.
diff --git a/test-suite/failure/positivity.v b/test-suite/failure/positivity.v
index c02661e0..03cc1109 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-2012     *)
 (*   \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..0c39b276 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-2012     *)
 (*   \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..38a62766 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/test-suite/failure/subtyping2.v b/test-suite/failure/subtyping2.v
index addd3b45..48fc2fff 100644
--- a/test-suite/failure/subtyping2.v
+++ b/test-suite/failure/subtyping2.v
@@ -54,7 +54,7 @@ Section Inverse_Image.
     Qed.
 
   Lemma WF_inverse_image : WF B R -> WF A Rof.
-    red in |- *; intros; apply ACC_inverse_image; auto.
+    red; intros; apply ACC_inverse_image; auto.
     Qed.
 
 End Inverse_Image.
@@ -104,7 +104,7 @@ generalize eqx0; clear eqx0.
 elim eqy using eq_ind_r; intro.
 case (inj _ _ _ _ eqx0); intros.
 exists X1 R1 X3 R3 (fun x : X1 => f0 (x0 (f x))) maj0; trivial.
-red in |- *; auto.
+red; auto.
 Defined.
 
 
@@ -122,7 +122,7 @@ apply sym_eq; assumption.
 
 intros.
 apply H1 with (y := f (x1 maj)) (f := fun x : X1 => f (x1 (f0 x)));
- try red in |- *; auto.
+ try red; auto.
 Defined.
 
   (* The embedding relation is well founded *)
@@ -158,7 +158,7 @@ Section Subsets.
 exists sub (Rof _ _ emb witness) A0 emb witness a; trivial.
 exact WF_emb.
 
-red in |- *; trivial.
+red; trivial.
 
 exact emb_wit.
 Defined.
@@ -174,7 +174,7 @@ End Subsets.
       - the upper bound is a, which is in F(b) since a < b
    *)
   Lemma F_morphism : morphism A0 emb A0 emb F.
-red in |- *; intros.
+red; intros.
 exists
  (sub x)
    (Rof _ _ emb (witness x))
@@ -185,10 +185,10 @@ exists
 apply WF_inverse_image.
 exact WF_emb.
 
-unfold morphism, Rof, fsub in |- *; simpl in |- *; intros.
+unfold morphism, Rof, fsub; simpl; intros.
 trivial.
 
-unfold Rof, fsub in |- *; simpl in |- *; intros.
+unfold Rof, fsub; simpl; intros.
 apply emb_wit.
 Defined.
 
@@ -230,10 +230,10 @@ intros.
 change
   match i0' X1 R1, i0' X2 R2 with
   | i0 x1 r1, i0 x2 r2 => exists f : _, morphism x1 r1 x2 r2 f
-  end in |- *.
-case H; simpl in |- *.
+  end.
+case H; simpl.
 exists (fun x : X1 => x).
-red in |- *; trivial.
+red; trivial.
 Defined.
 
 (* The following command raises 'Error: Universe Inconsistency'.
diff --git a/test-suite/failure/universes-buraliforti-redef.v b/test-suite/failure/universes-buraliforti-redef.v
index 034b7f09..a8b5b975 100644
--- a/test-suite/failure/universes-buraliforti-redef.v
+++ b/test-suite/failure/universes-buraliforti-redef.v
@@ -54,7 +54,7 @@ Section Inverse_Image.
     Qed.
 
   Lemma WF_inverse_image : WF B R -> WF A Rof.
-    red in |- *; intros; apply ACC_inverse_image; auto.
+    red; intros; apply ACC_inverse_image; auto.
     Qed.
 
 End Inverse_Image.
@@ -106,7 +106,7 @@ generalize eqx0; clear eqx0.
 elim eqy using eq_ind_r; intro.
 case (inj _ _ _ _ eqx0); intros.
 exists X1 R1 X4 R4 (fun x : X1 => f0 (x0 (f x))) maj0; trivial.
-red in |- *; auto.
+red; auto.
 Defined.
 
 
@@ -124,7 +124,7 @@ apply sym_eq; assumption.
 
 intros.
 apply H1 with (y := f (x1 maj)) (f := fun x : X1 => f (x1 (f0 x)));
- try red in |- *; auto.
+ try red; auto.
 Defined.
 
   (* The embedding relation is well founded *)
@@ -160,7 +160,7 @@ Section Subsets.
 exists sub (Rof _ _ emb witness) A0 emb witness a; trivial.
 exact WF_emb.
 
-red in |- *; trivial.
+red; trivial.
 
 exact emb_wit.
 Defined.
@@ -176,7 +176,7 @@ End Subsets.
       - the upper bound is a, which is in F(b) since a < b
    *)
   Lemma F_morphism : morphism A0 emb A0 emb F.
-red in |- *; intros.
+red; intros.
 exists
  (sub x)
    (Rof _ _ emb (witness x))
@@ -187,10 +187,10 @@ exists
 apply WF_inverse_image.
 exact WF_emb.
 
-unfold morphism, Rof, fsub in |- *; simpl in |- *; intros.
+unfold morphism, Rof, fsub; simpl; intros.
 trivial.
 
-unfold Rof, fsub in |- *; simpl in |- *; intros.
+unfold Rof, fsub; simpl; intros.
 apply emb_wit.
 Defined.
 
@@ -231,10 +231,10 @@ intros.
 change
   match i0 X1 R1, i0 X2 R2 with
   | i1 x1 r1, i1 x2 r2 => exists f : _, morphism x1 r1 x2 r2 f
-  end in |- *.
-case H; simpl in |- *.
+  end.
+case H; simpl.
 exists (fun x : X1 => x).
-red in |- *; trivial.
+red; trivial.
 Defined.
 
 (* The following command raises 'Error: Universe Inconsistency'.
diff --git a/test-suite/failure/universes-buraliforti.v b/test-suite/failure/universes-buraliforti.v
index 1f96ab34..7b62a0c5 100644
--- a/test-suite/failure/universes-buraliforti.v
+++ b/test-suite/failure/universes-buraliforti.v
@@ -37,7 +37,7 @@ Section Inverse_Image.
     Qed.
 
   Lemma WF_inverse_image : WF B R -> WF A Rof.
-    red in |- *; intros; apply ACC_inverse_image; auto.
+    red; intros; apply ACC_inverse_image; auto.
     Qed.
 
 End Inverse_Image.
@@ -90,7 +90,7 @@ generalize eqx0; clear eqx0.
 elim eqy using eq_ind_r; intro.
 case (inj _ _ _ _ eqx0); intros.
 exists X1 R1 X3 R3 (fun x : X1 => f0 (x0 (f x))) maj0; trivial.
-red in |- *; auto.
+red; auto.
 Defined.
 
 
@@ -108,7 +108,7 @@ apply sym_eq; assumption.
 
 intros.
 apply H1 with (y := f (x1 maj)) (f := fun x : X1 => f (x1 (f0 x)));
- try red in |- *; auto.
+ try red; auto.
 Defined.
 
   (* The embedding relation is well founded *)
@@ -144,7 +144,7 @@ Section Subsets.
 exists sub (Rof _ _ emb witness) A0 emb witness a; trivial.
 exact WF_emb.
 
-red in |- *; trivial.
+red; trivial.
 
 exact emb_wit.
 Defined.
@@ -160,7 +160,7 @@ End Subsets.
       - the upper bound is a, which is in F(b) since a < b
    *)
   Lemma F_morphism : morphism A0 emb A0 emb F.
-red in |- *; intros.
+red; intros.
 exists
  (sub x)
    (Rof _ _ emb (witness x))
@@ -171,10 +171,10 @@ exists
 apply WF_inverse_image.
 exact WF_emb.
 
-unfold morphism, Rof, fsub in |- *; simpl in |- *; intros.
+unfold morphism, Rof, fsub; simpl; intros.
 trivial.
 
-unfold Rof, fsub in |- *; simpl in |- *; intros.
+unfold Rof, fsub; simpl; intros.
 apply emb_wit.
 Defined.
 
@@ -222,10 +222,10 @@ intros.
 change
   match i0 X1 R1, i0 X2 R2 with
   | i0 x1 r1, i0 x2 r2 => exists f : _, morphism x1 r1 x2 r2 f
-  end in |- *.
-case H; simpl in |- *.
+  end.
+case H; simpl.
 exists (fun x : X1 => x).
-red in |- *; trivial.
+red; trivial.
 Defined.
 
 (* The following command raises 'Error: Universe Inconsistency'.
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..7628b961 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-2012     *)
 (*   \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/ideal-features/eapply_evar.v b/test-suite/ideal-features/eapply_evar.v
index 547860bf..bb61afb8 100644
--- a/test-suite/ideal-features/eapply_evar.v
+++ b/test-suite/ideal-features/eapply_evar.v
@@ -4,6 +4,6 @@
    and not "O = O" *)
 
 Lemma eapply_evar : O=O -> 0=O.
-intro H; eapply trans_equal;
+intro H; eapply eq_trans;
   [apply H | match goal with |- ?x = ?x => reflexivity end].
 Qed.
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/micromega/example.v b/test-suite/micromega/example.v
index f424f0fc..d648c2e4 100644
--- a/test-suite/micromega/example.v
+++ b/test-suite/micromega/example.v
@@ -77,13 +77,13 @@ Definition rbound2 (C:Z -> Z -> Z) : Prop :=
 
 Lemma bounded_drift : forall s t p q C D, s <= t /\ correct p t  /\ correct q t /\
   rbound1 C /\ rbound2 C /\ rbound1 D /\ rbound2 D  ->
-  Zabs (C p t - D q t) <= Zabs (C p s - D q s) + 2 * rho * (t- s).
+  Z.abs (C p t - D q t) <= Z.abs (C p s - D q s) + 2 * rho * (t- s).
 Proof.
   intros.
-  generalize (Zabs_eq (C p t - D q t)).
-  generalize (Zabs_non_eq (C p t - D q t)).
-  generalize (Zabs_eq (C p s -D q s)).
-  generalize (Zabs_non_eq (C p s - D q s)).
+  generalize (Z.abs_eq (C p t - D q t)).
+  generalize (Z.abs_neq (C p t - D q t)).
+  generalize (Z.abs_eq (C p s -D q s)).
+  generalize (Z.abs_neq (C p s - D q s)).
   unfold rbound2 in H.
   unfold rbound1 in H.
   intuition.
diff --git a/test-suite/micromega/square.v b/test-suite/micromega/square.v
index 4c00ffe4..8767f687 100644
--- a/test-suite/micromega/square.v
+++ b/test-suite/micromega/square.v
@@ -9,17 +9,17 @@
 Require Import ZArith Zwf Psatz QArith.
 Open Scope Z_scope.
 
-Lemma Zabs_square : forall x,  (Zabs  x)^2 = x^2.
+Lemma Zabs_square : forall x,  (Z.abs  x)^2 = x^2.
 Proof.
  intros ; case (Zabs_dec x) ; intros ; psatz Z 2.
 Qed.
-Hint Resolve Zabs_pos Zabs_square.
+Hint Resolve Z.abs_nonneg Zabs_square.
 
 Lemma integer_statement :  ~exists n, exists p, n^2 = 2*p^2 /\ n <> 0.
 Proof.
-intros [n [p [Heq Hnz]]]; pose (n' := Zabs n); pose (p':=Zabs p).
-assert (facts : 0 <= Zabs n /\ 0 <= Zabs p /\ Zabs n^2=n^2
-         /\ Zabs p^2 = p^2) by auto.
+intros [n [p [Heq Hnz]]]; pose (n' := Z.abs n); pose (p':=Z.abs p).
+assert (facts : 0 <= Z.abs n /\ 0 <= Z.abs p /\ Z.abs n^2=n^2
+         /\ Z.abs p^2 = p^2) by auto.
 assert (H : (0 < n' /\ 0 <= p' /\ n' ^2 = 2* p' ^2)) by
   (destruct facts as [Hf1 [Hf2 [Hf3 Hf4]]]; unfold n', p' ; psatz Z 2).
 generalize p' H; elim n' using (well_founded_ind (Zwf_well_founded 0)); clear.
@@ -35,7 +35,7 @@ Lemma QnumZpower : forall x : Q, Qnum (x ^ 2)%Q = ((Qnum x) ^ 2) %Z.
 Proof.
   intros.
   destruct x.
-  cbv beta  iota zeta delta - [Zmult].
+  cbv beta  iota zeta delta - [Z.mul].
   ring.
 Qed.
 
@@ -45,15 +45,15 @@ Proof.
   intros.
   destruct x.
   simpl.
-  unfold Zpower_pos.
+  unfold Z.pow_pos.
   simpl.
-  rewrite Pmult_1_r.
+  rewrite Pos.mul_1_r.
   reflexivity.
 Qed.
 
 Theorem sqrt2_not_rational : ~exists x:Q, x^2==2#1.
 Proof.
- unfold Qeq; intros [x]; simpl (Qden (2#1)); rewrite Zmult_1_r.
+ unfold Qeq; intros [x]; simpl (Qden (2#1)); rewrite Z.mul_1_r.
  intros HQeq.
  assert (Heq : (Qnum x ^ 2 = 2 * ' Qden x ^ 2%Q)%Z) by
    (rewrite QnumZpower in HQeq ; rewrite QdenZpower in HQeq ; auto).
diff --git a/test-suite/misc/berardi_test.v b/test-suite/misc/berardi_test.v
index da54166a..38377573 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-2012     *)
 (*   \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).
@@ -47,7 +45,7 @@ Lemma AC_IF :
    (B -> Q e1) -> (~ B -> Q e2) -> Q (IFProp B e1 e2).
 Proof.
 intros P B e1 e2 Q p1 p2.
-unfold IFProp in |- *.
+unfold IFProp.
 case (EM B); assumption.
 Qed.
 
@@ -78,7 +76,7 @@ Record retract_cond : Prop :=
 Lemma AC : forall r:retract_cond, retract -> forall a:A, j2 r (i2 r a) = a.
 Proof.
 intros r.
-case r; simpl in |- *.
+case r; simpl.
 trivial.
 Qed.
 
@@ -115,7 +113,7 @@ Lemma retract_pow_U_U : retract (pow U) U.
 Proof.
 exists g f.
 intro a.
-unfold f, g in |- *; simpl in |- *.
+unfold f, g; simpl.
 apply AC.
 exists (fun x:pow U => x) (fun x:pow U => x).
 trivial.
@@ -132,8 +130,8 @@ Definition R : U := g (fun u:U => Not_b (u U u)).
 
 Lemma not_has_fixpoint : R R = Not_b (R R).
 Proof.
-unfold R at 1 in |- *.
-unfold g in |- *.
+unfold R at 1.
+unfold g.
 rewrite AC with (r := L1 U U) (a := fun u:U => Not_b (u U u)).
 trivial.
 exists (fun x:pow U => x) (fun x:pow U => x); trivial.
@@ -143,7 +141,7 @@ Qed.
 Theorem classical_proof_irrelevence : T = F.
 Proof.
 generalize not_has_fixpoint.
-unfold Not_b in |- *.
+unfold Not_b.
 apply AC_IF.
 intros is_true is_false.
 elim is_true; elim is_false; trivial.
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/PO.v b/test-suite/modules/PO.v
index 71d33177..6198f29a 100644
--- a/test-suite/modules/PO.v
+++ b/test-suite/modules/PO.v
@@ -27,13 +27,13 @@ Module Pair (X: PO) (Y: PO) <: PO.
   Qed.
 
   Lemma le_trans : forall p1 p2 p3 : T, le p1 p2 -> le p2 p3 -> le p1 p3.
-    unfold le in |- *;  intuition; info  eauto.
+    unfold le;  intuition; info  eauto.
   Qed.
 
   Lemma le_antis : forall p1 p2 : T, le p1 p2 -> le p2 p1 -> p1 = p2.
     destruct p1.
     destruct p2.
-    unfold le in |- *.
+    unfold le.
      intuition.
      cutrewrite (t = t1).
      cutrewrite (t0 = t2).
diff --git a/test-suite/modules/Przyklad.v b/test-suite/modules/Przyklad.v
index e3694b81..341805a1 100644
--- a/test-suite/modules/Przyklad.v
+++ b/test-suite/modules/Przyklad.v
@@ -66,7 +66,7 @@ Module FuncDict (E: ELEM).
   Lemma find_add_true : forall (s : T) (e : E.T), find e (add e s) = true.
 
     intros.
-    unfold find, add in |- *.
+    unfold find, add.
     elim (Reflexivity_provable _ _ (E.eq_dec e e)).
     intros.
      rewrite H.
@@ -77,13 +77,13 @@ Module FuncDict (E: ELEM).
   Lemma find_add_false :
    forall (s : T) (e e' : E.T), e <> e' -> find e (add e' s) = find e s.
     intros.
-    unfold add, find in |- *.
+    unfold add, find.
     cut (exists x : _, E.eq_dec e' e = right _ x).
     intros.
     elim H0.
     intros.
      rewrite H1.
-    unfold ifte in |- *.
+    unfold ifte.
     reflexivity.
 
     apply Disequality_provable.
@@ -123,7 +123,7 @@ Module Lemmas (G: SET) (E: ELEM).
    forall a : E.T, ESet.find a S1 = ESet.find a S2.
 
     intros.
-    unfold S1, S2 in |- *.
+    unfold S1, S2.
     elim (E.eq_dec a a1); elim (E.eq_dec a a2); intros H1 H2;
      try  rewrite <- H1; try  rewrite <- H2;
      repeat
@@ -153,7 +153,7 @@ Module ListDict (E: ELEM).
 
   Lemma find_add_true : forall (s : T) (e : E.T), find e (add e s) = true.
     intros.
-    simpl in |- *.
+    simpl.
     elim (Reflexivity_provable _ _ (E.eq_dec e e)).
     intros.
      rewrite H.
@@ -165,11 +165,11 @@ Module ListDict (E: ELEM).
   Lemma find_add_false :
    forall (s : T) (e e' : E.T), e <> e' -> find e (add e' s) = find e s.
     intros.
-    simpl in |- *.
+    simpl.
     elim (Disequality_provable _ _ _ H (E.eq_dec e e')).
     intros.
      rewrite H0.
-    simpl in |- *.
+    simpl.
     reflexivity.
   Qed.
 
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..7c9b1e27
--- /dev/null
+++ b/test-suite/output/Arguments.out
@@ -0,0 +1,101 @@
+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
+forall w : r, w 3 true = tt
+     : Prop
+The command has indeed failed with message:
+=> Error: Unknown interpretation for notation "$".
+w 3 true = tt
+     : Prop
+The command has indeed failed with message:
+=> Error: Extra argument _.
diff --git a/test-suite/output/Arguments.v b/test-suite/output/Arguments.v
new file mode 100644
index 00000000..573cfdab
--- /dev/null
+++ b/test-suite/output/Arguments.v
@@ -0,0 +1,52 @@
+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.
+Record r := { pi :> nat -> bool -> unit }.
+Notation "$" := 3 (only parsing) : foo_scope.
+Notation "$" := true (only parsing) : bar_scope.
+Delimit Scope bar_scope with B.
+Arguments pi _ _%F _%B. 
+Check (forall w : r, pi w $ $ = tt).
+Fail Check (forall w : r, w $ $ = tt).
+Axiom w : r.
+Arguments w  _%F _%B : extra scopes.
+Check (w $ $ = tt).
+Fail Arguments w  _%F _%B.
+
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..66307236 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,19 @@ fun x : option Z => match x with
                     | NONE3 => 0
                     end
      : option Z -> Z
+s
+     : s
+Identifier 'foo' now a keyword
+10
+     : nat
+fun _ : nat => 9
+     : nat -> nat
+Identifier 'ONE' now a keyword
+fun (x : nat) (p : x = x) => match p with
+                             | ONE => ONE
+                             end = p
+     : forall x : nat, x = x -> Prop
+fun (x : nat) (p : x = x) => match p with
+                             | 1 => 1
+                             end = p
+     : forall x : nat, x = x -> Prop
diff --git a/test-suite/output/Notations.v b/test-suite/output/Notations.v
index b8f8f48f..612b5325 100644
--- a/test-suite/output/Notations.v
+++ b/test-suite/output/Notations.v
@@ -245,3 +245,33 @@ 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.
+
+(* Test bug #2835: notations were not uniformly managed under prod and lambda *)
+
+Open Scope nat_scope.
+
+Notation "'foo' n" := (S n) (at level 50): nat_scope.
+
+Check (foo 9).
+Check (fun _ : nat => 9).
+
+(* Checking parsing and printing of numerical and non-numerical notations for eq_refl *)
+
+(* This notation was not correctly printed until Pierre B.'s
+   improvements to the interpretation of patterns *)
+
+Notation "'ONE'" := eq_refl.
+Check fun (x:nat) (p : x=x) => match p with ONE => ONE end = p.
+
+(* This one used to failed at parsing until now *)
+
+Notation "1" := eq_refl.
+Check fun (x:nat) (p : x=x) => match p with 1 => 1 end = p.
diff --git a/test-suite/output/Notations2.out b/test-suite/output/Notations2.out
index 6731d505..cf45025e 100644
--- a/test-suite/output/Notations2.out
+++ b/test-suite/output/Notations2.out
@@ -10,10 +10,21 @@ end
      : nat
 let '(a, _, _) := (2, 3, 4) in a
      : nat
+exists myx (y : bool), myx = y
+     : Prop
+fun (P : nat -> nat -> Prop) (x : nat) => exists x0, P x x0
+     : (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 +33,22 @@ 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
+# x : nat => x
+     : nat -> nat
+# _ : nat => 2
+     : nat -> nat
diff --git a/test-suite/output/Notations2.v b/test-suite/output/Notations2.v
index 57d8ebbc..e53c94ef 100644
--- a/test-suite/output/Notations2.v
+++ b/test-suite/output/Notations2.v
@@ -25,19 +25,30 @@ 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.
 
+(* Check printing of notations with mixed reserved binders (see bug #2571) *)
+
+Implicit Type myx : bool.
+Check exists myx y, myx = y.
+
+(* 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 +64,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
@@ -65,3 +88,13 @@ Notation "'mylet' f [ x ; .. ; y ]  :=  t 'in' u":=
 
 Check mylet f [x;y;z;(a:bool)] := x+y+z+1 in f 0 1 2.
 *)
+
+(* Check notations for functional terms which do not necessarily
+   depend on their parameter *)
+(* Old request mentioned again on coq-club 20/1/2012 *)
+
+Notation "#  x : T => t" := (fun x : T => t)
+  (at level 0, t at level 200, x ident).
+
+Check # x : nat => x.
+Check # _ : nat => 2.
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..598bb728
--- /dev/null
+++ b/test-suite/output/PrintInfos.out
@@ -0,0 +1,130 @@
+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) {struct n} : 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..dc41b0aa 100644
--- a/test-suite/output/ZSyntax.out
+++ b/test-suite/output/ZSyntax.out
@@ -2,25 +2,25 @@
      : Z
 fun f : nat -> Z => (f 0%nat + 0)%Z
      : (nat -> Z) -> Z
-fun x : positive => Zpos x~0
+fun x : positive => Z.pos x~0
      : positive -> Z
-fun x : positive => (Zpos x + 1)%Z
+fun x : positive => (Z.pos x + 1)%Z
      : positive -> Z
-fun x : positive => Zpos x
+fun x : positive => Z.pos x
      : positive -> Z
-fun x : positive => Zneg x~0
+fun x : positive => Z.neg x~0
      : positive -> Z
-fun x : positive => (Zpos x~0 + 0)%Z
+fun x : positive => (Z.pos x~0 + 0)%Z
      : positive -> Z
-fun x : positive => (- Zpos x~0)%Z
+fun x : positive => (- Z.pos x~0)%Z
      : positive -> Z
-fun x : positive => (- Zpos x~0 + 0)%Z
+fun x : positive => (- Z.pos 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..4f8de1dc
--- /dev/null
+++ b/test-suite/output/inference.out
@@ -0,0 +1,10 @@
+P = 
+fun e : option L => match e with
+                    | Some cl => Some cl
+                    | None => None
+                    end
+     : option L -> option L
+fun n : nat => let x := A n in ?12 ?15:T n
+     : forall n : nat, T n
+fun n : nat => ?20 ?23:T n
+     : forall n : nat, T n
diff --git a/test-suite/output/inference.v b/test-suite/output/inference.v
new file mode 100644
index 00000000..2b564f48
--- /dev/null
+++ b/test-suite/output/inference.v
@@ -0,0 +1,26 @@
+(* 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.
+
+(* Check that the heuristic to solve constraints is not artificially
+   dependent on the presence of a let-in, and in particular that the
+   second [_] below is not inferred to be n, as if obtained by
+   first-order unification with [T n] of the conclusion [T _] of the
+   type of the first [_]. *)
+
+(* Note: exact numbers of evars are not important... *)
+
+Inductive T (n:nat) : Type := A : T n.
+Check fun n (x:=A n:T n) => _ _ : T n.
+Check fun n => _ _ : T n.
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..c9a3c08e 100644
--- a/test-suite/success/Cases.v
+++ b/test-suite/success/Cases.v
@@ -100,7 +100,7 @@ Type (fun x : nat => match x return nat with
                      | x => x
                      end).
 
-Section testlist.
+Module Type testlist.
 Parameter A : Set.
 Inductive list : Set :=
   | nil : list
@@ -119,7 +119,6 @@ Definition titi (a : A) (l : list) :=
   | nil => l
   | cons b l => l
   end.
-Reset list.
 End testlist.
 
 
@@ -543,7 +542,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 +610,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
@@ -892,71 +912,77 @@ Type
    | LeS n m _ => (S n, S m)
    end).
 
-
+Module Type F_v1.
 Fixpoint F (n m : nat) (h : Le n m) {struct h} : Le n (S m) :=
   match h in (Le n m) return (Le n (S m)) with
   | LeO m' => LeO (S m')
   | LeS n' m' h' => LeS n' (S m') (F n' m' h')
   end.
+End F_v1.
 
-Reset F.
-
+Module Type F_v2.
 Fixpoint F (n m : nat) (h : Le n m) {struct h} : Le n (S m) :=
   match h in (Le n m) return (Le n (S m)) with
   | LeS n m h => LeS n (S m) (F n m h)
   | LeO m => LeO (S m)
   end.
+End F_v2.
 
 (* Rend la longueur de la liste *)
-Definition length1 (n : nat) (l : listn n) :=
+
+Module Type L1.
+Definition length (n : nat) (l : listn n) :=
   match l return nat with
   | consn n _ (consn m _ _) => S (S m)
   | consn n _ _ => 1
   | _ => 0
   end.
+End L1.
 
-Reset length1.
-Definition length1 (n : nat) (l : listn n) :=
+Module Type L1'.
+Definition length (n : nat) (l : listn n) :=
   match l with
   | consn n _ (consn m _ _) => S (S m)
   | consn n _ _ => 1
   | _ => 0
   end.
+End L1'.
 
-
-Definition length2 (n : nat) (l : listn n) :=
+Module Type L2.
+Definition length (n : nat) (l : listn n) :=
   match l return nat with
   | consn n _ (consn m _ _) => S (S m)
   | consn n _ _ => S n
   | _ => 0
   end.
+End L2.
 
-Reset length2.
-
-Definition length2 (n : nat) (l : listn n) :=
+Module Type L2'.
+Definition length (n : nat) (l : listn n) :=
   match l with
   | consn n _ (consn m _ _) => S (S m)
   | consn n _ _ => S n
   | _ => 0
   end.
+End L2'.
 
-Definition length3 (n : nat) (l : listn n) :=
+Module Type L3.
+Definition length (n : nat) (l : listn n) :=
   match l return nat with
   | consn n _ (consn m _ l) => S n
   | consn n _ _ => 1
   | _ => 0
   end.
+End L3.
 
-
-Reset length3.
-
-Definition length3 (n : nat) (l : listn n) :=
+Module Type L3'.
+Definition length (n : nat) (l : listn n) :=
   match l with
   | consn n _ (consn m _ l) => S n
   | consn n _ _ => 1
   | _ => 0
   end.
-
+End L3'.
 
 Type match LeO 0 return nat with
      | LeS n m h => n + m
@@ -1064,7 +1090,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 +1098,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
@@ -1235,7 +1261,7 @@ Type match (0, 0) with
      | (x, y) => (S x, S y)
      end.
 
-
+Module Type test_concat.
 
 Parameter concat : forall A : Set, List A -> List A -> List A.
 
@@ -1252,6 +1278,7 @@ Type
   | _, _ => Nil nat
   end.
 
+End test_concat.
 
 Inductive redexes : Set :=
   | VAR : nat -> redexes
@@ -1274,7 +1301,6 @@ Type (fun n : nat => match n with
                      | _ => 0
                      end).
 
-Reset concat.
 Parameter
   concat :
     forall n : nat, listn n -> forall m : nat, listn m -> listn (n + m).
@@ -1362,6 +1388,7 @@ Type
 (* I.e. to test manipulation of elimination predicate                    *)
 (* ===================================================================== *)
 
+Module Type test_term.
 
 Parameter LTERM : nat -> Set.
 Inductive TERM : Type :=
@@ -1376,7 +1403,8 @@ Type
   | oper op1 l1, oper op2 l2 => False
   | _, _ => False
   end.
-Reset LTERM.
+
+End test_term.
 
 
 
@@ -1472,6 +1500,7 @@ Type
   end.
 
 
+Module Type ff.
 
 Parameter ff : forall n m : nat, n <> m -> S n <> S m.
 Parameter discr_r : forall n : nat, 0 <> S n.
@@ -1484,6 +1513,7 @@ Type
    | S x => or_intror (S x = 0) (discr_l x)
    end).
 
+Module Type eqdec.
 
 Fixpoint eqdec (n m : nat) {struct n} : n = m \/ n <> m :=
   match n, m return (n = m \/ n <> m) with
@@ -1497,7 +1527,9 @@ Fixpoint eqdec (n m : nat) {struct n} : n = m \/ n <> m :=
       end
   end.
 
-Reset eqdec.
+End eqdec.
+
+Module Type eqdec'.
 
 Fixpoint eqdec (n : nat) : forall m : nat, n = m \/ n <> m :=
   match n return (forall m : nat, n = m \/ n <> m) with
@@ -1519,6 +1551,7 @@ Fixpoint eqdec (n : nat) : forall m : nat, n = m \/ n <> m :=
       end
   end.
 
+End eqdec'.
 
 Inductive empty : forall n : nat, listn n -> Prop :=
     intro_empty : empty 0 niln.
@@ -1533,7 +1566,10 @@ Type
    | consn n a y as b => or_intror (empty (S n) b) (inv_empty n a y)
    end).
 
-Reset ff.
+End ff.
+
+Module Type ff'.
+
 Parameter ff : forall n m : nat, n <> m -> S n <> S m.
 Parameter discr_r : forall n : nat, 0 <> S n.
 Parameter discr_l : forall n : nat, S n <> 0.
@@ -1545,6 +1581,7 @@ Type
    | S x => or_intror (S x = 0) (discr_l x)
    end).
 
+Module Type eqdec.
 
 Fixpoint eqdec (n m : nat) {struct n} : n = m \/ n <> m :=
   match n, m return (n = m \/ n <> m) with
@@ -1557,7 +1594,10 @@ Fixpoint eqdec (n m : nat) {struct n} : n = m \/ n <> m :=
       | or_intror h => or_intror (S x = S y) (ff x y h)
       end
   end.
-Reset eqdec.
+
+End eqdec.
+
+Module Type eqdec'.
 
 Fixpoint eqdec (n : nat) : forall m : nat, n = m \/ n <> m :=
   match n return (forall m : nat, n = m \/ n <> m) with
@@ -1579,6 +1619,8 @@ Fixpoint eqdec (n : nat) : forall m : nat, n = m \/ n <> m :=
       end
   end.
 
+End eqdec'.
+End ff'.
 
 (* ================================================== *)
 (* Pour tester parametres                             *)
@@ -1823,3 +1865,9 @@ Type (fun n => match n with
                | Z0 => true
                | _ => false
                end).
+
+(* Check that types with unknown sort, as A below, are not fatal to
+   the pattern-matching compilation *)
+
+Definition transport {A} (P : A->Type) {x y : A} (p : x=y) (u : P x) : P y :=
+  match p with eq_refl => u end.
diff --git a/test-suite/success/CasesDep.v b/test-suite/success/CasesDep.v
index 29721843..bfead53c 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  *)
@@ -188,7 +222,7 @@ Definition Dposint := Build_DSetoid Set_of_posint Eq_posint_deci.
  de l'arite de chaque operateur *)
 
 
-Section Sig.
+Module Sig.
 
 Record Signature : Type :=
   {Sigma : DSetoid; Arity : Map (Set_of Sigma) (Set_of Dposint)}.
@@ -243,7 +277,7 @@ Type
   | _, _ => False
   end.
 
-
+Module Type Version1.
 
 Definition equalT (t1 t2 : TERM) : Prop :=
   match t1, t2 with
@@ -260,12 +294,15 @@ Definition EqListT (n1 : posint) (l1 : LTERM n1) (n2 : posint)
   | _, _ => False
   end.
 
+End Version1.
+
 
-Reset equalT.
 (* ------------------------------------------------------------------*)
 (*          Initial exemple (without patterns)                       *)
 (*-------------------------------------------------------------------*)
 
+Module Version2.
+
 Fixpoint equalT (t1 : TERM) : TERM -> Prop :=
   match t1 return (TERM -> Prop) with
   | var v1 =>
@@ -313,11 +350,13 @@ Fixpoint equalT (t1 : TERM) : TERM -> Prop :=
       end
   end.
 
+End Version2.
 
 (* ---------------------------------------------------------------- *)
 (*                Version with simple patterns                      *)
 (* ---------------------------------------------------------------- *)
-Reset equalT.
+
+Module Version3.
 
 Fixpoint equalT (t1 : TERM) : TERM -> Prop :=
   match t1 with
@@ -354,8 +393,9 @@ Fixpoint equalT (t1 : TERM) : TERM -> Prop :=
       end
   end.
 
+End Version3.
 
-Reset equalT.
+Module Version4.
 
 Fixpoint equalT (t1 : TERM) : TERM -> Prop :=
   match t1 with
@@ -389,10 +429,13 @@ Fixpoint equalT (t1 : TERM) : TERM -> Prop :=
       end
   end.
 
+End Version4.
+
 (* ---------------------------------------------------------------- *)
 (*                  Version with multiple patterns                  *)
 (* ---------------------------------------------------------------- *)
-Reset equalT.
+
+Module Version5.
 
 Fixpoint equalT (t1 t2 : TERM) {struct t1} : Prop :=
   match t1, t2 with
@@ -411,6 +454,7 @@ Fixpoint equalT (t1 t2 : TERM) {struct t1} : Prop :=
   | _, _ => False
   end.
 
+End Version5.
 
 (* ------------------------------------------------------------------ *)
 
@@ -506,3 +550,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..21a9722d 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-2012     *)
 (*   \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..9301cd27 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-2012     *)
 (*   \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/Funind.v b/test-suite/success/Funind.v
index b17adef6..ccce3bbe 100644
--- a/test-suite/success/Funind.v
+++ b/test-suite/success/Funind.v
@@ -9,7 +9,7 @@ Functional Scheme iszero_ind := Induction for iszero Sort Prop.
 
 Lemma toto : forall n : nat, n = 0 -> iszero n = true.
 intros x eg.
- functional induction iszero x; simpl in |- *.
+ functional induction iszero x; simpl.
 trivial.
 inversion eg.
 Qed.
@@ -212,19 +212,19 @@ Function plus_x_not_five'' (n m : nat) {struct n} : nat :=
 
 Lemma notplusfive'' : forall x y : nat, y = 5 -> plus_x_not_five'' x y = x.
 intros a b.
- functional induction plus_x_not_five'' a b; intros hyp; simpl in |- *; auto.
+ functional induction plus_x_not_five'' a b; intros hyp; simpl; auto.
 Qed.
 
 Lemma iseq_eq : forall n m : nat, n = m -> nat_equal_bool n m = true.
 intros n m.
- functional induction nat_equal_bool n m; simpl in |- *; intros hyp; auto.
+ functional induction nat_equal_bool n m; simpl; intros hyp; auto.
 rewrite <- hyp in y; simpl in y;tauto.
 inversion hyp.
 Qed.
 
 Lemma iseq_eq' : forall n m : nat, nat_equal_bool n m = true -> n = m.
 intros n m.
- functional induction nat_equal_bool n m; simpl in |- *; intros eg; auto.
+ functional induction nat_equal_bool n m; simpl; intros eg; auto.
 inversion eg.
 inversion eg.
 Qed.
@@ -245,7 +245,7 @@ Qed.
 
 Lemma inf_x_plusxy'' : forall x : nat, x <= x + 0.
 intros n.
-unfold plus in |- *.
+unfold plus.
  functional induction plus n 0; intros.
 auto with arith.
 apply le_n_S.
@@ -266,7 +266,7 @@ Function mod2 (n : nat) : nat :=
 
 Lemma princ_mod2 : forall n : nat, mod2 n <= n.
 intros n.
- functional induction mod2 n; simpl in |- *; auto with arith.
+ functional induction mod2 n; simpl; auto with arith.
 Qed.
 
 Function isfour (n : nat) : bool :=
@@ -284,7 +284,7 @@ Function isononeorfour (n : nat) : bool :=
 
 Lemma toto'' : forall n : nat, istrue (isfour n) -> istrue (isononeorfour n).
 intros n.
- functional induction isononeorfour n; intros istr; simpl in |- *;
+ functional induction isononeorfour n; intros istr; simpl;
  inversion istr.
 apply istrue0.
 destruct n. inversion istr.
@@ -367,7 +367,7 @@ Function ftest2 (n m : nat) {struct n} : nat :=
 
 Lemma test2' : forall n m : nat, ftest2 n m <= 2.
 intros n m.
- functional induction ftest2 n m; simpl in |- *; intros; auto.
+ functional induction ftest2 n m; simpl; intros; auto.
 Qed.
 
 Function ftest3 (n m : nat) {struct n} : nat :=
@@ -387,7 +387,7 @@ auto.
 intros.
 auto.
 intros.
-simpl in |- *.
+simpl.
 auto.
 Qed.
 
@@ -408,7 +408,7 @@ auto.
 intros.
 auto.
 intros.
-simpl in |- *.
+simpl.
 auto.
 Qed.
 
@@ -451,7 +451,7 @@ Qed.
 
 Lemma essai6 : forall n m : nat, ftest6 n m <= 2.
 intros n m.
- functional induction ftest6 n m; simpl in |- *; auto.
+ functional induction ftest6 n m; simpl; auto.
 Qed.
 
 (* Some tests with modules *)
diff --git a/test-suite/success/Hints.v b/test-suite/success/Hints.v
index 4aa00e68..cc8cec47 100644
--- a/test-suite/success/Hints.v
+++ b/test-suite/success/Hints.v
@@ -2,31 +2,26 @@
 (* Checks that qualified names are accepted *)
 
 (* New-style syntax *)
-Hint Resolve refl_equal: core arith.
-Hint Immediate trans_equal.
-Hint Unfold sym_equal: core.
+Hint Resolve eq_refl: core arith.
+Hint Immediate eq_trans.
+Hint Unfold eq_sym: core.
 Hint Constructors eq: foo bar.
-Hint Extern 3 (_ = _) => apply refl_equal: foo bar.
+Hint Extern 3 (_ = _) => apply eq_refl: foo bar.
 
 (* Old-style syntax *)
-Hint Resolve refl_equal sym_equal.
-Hint Resolve refl_equal sym_equal: foo.
-Hint Immediate refl_equal sym_equal.
-Hint Immediate refl_equal sym_equal: foo.
-Hint Unfold fst sym_equal.
-Hint Unfold fst sym_equal: foo.
-
-(* What's this stranged syntax ? *)
-Hint Destruct h6 := 4 Conclusion (_ <= _) => fun H => apply H.
-Hint Destruct h7 := 4 Discardable Hypothesis (_ <= _) => fun H => apply H.
-Hint Destruct h8 := 4 Hypothesis (_ <= _) => fun H => apply H.
+Hint Resolve eq_refl eq_sym.
+Hint Resolve eq_refl eq_sym: foo.
+Hint Immediate eq_refl eq_sym.
+Hint Immediate eq_refl eq_sym: foo.
+Hint Unfold fst eq_sym.
+Hint Unfold fst eq_sym: foo.
 
 (* Checks that local names are accepted *)
 Section A.
   Remark Refl : forall (A : Set) (x : A), x = x.
-  Proof. exact refl_equal. Defined.
-  Definition Sym := sym_equal.
-  Let Trans := trans_equal.
+  Proof. exact @eq_refl. Defined.
+  Definition Sym := eq_sym.
+  Let Trans := eq_trans.
 
   Hint Resolve Refl: foo.
   Hint Resolve Sym: bar.
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..d55ae384 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-2012     *)
 (*   \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/MatchFail.v b/test-suite/success/MatchFail.v
index 660ca3cb..c2d87a44 100644
--- a/test-suite/success/MatchFail.v
+++ b/test-suite/success/MatchFail.v
@@ -12,13 +12,13 @@ Ltac compute_POS :=
       let v := constr:X1 in
       match constr:v with
       | 1%positive => fail 1
-      | _ =>  rewrite (BinInt.Zpos_xI v)
+      | _ =>  rewrite (BinInt.Pos2Z.inj_xI v)
       end
   |  |- context [(Zpos (xO ?X1))] =>
       let v := constr:X1 in
       match constr:v with
       | 1%positive => fail 1
-      | _ =>  rewrite (BinInt.Zpos_xO v)
+      | _ =>  rewrite (BinInt.Pos2Z.inj_xO v)
       end
   end.
 
diff --git a/test-suite/success/Mod_params.v b/test-suite/success/Mod_params.v
index 74228bbb..51516166 100644
--- a/test-suite/success/Mod_params.v
+++ b/test-suite/success/Mod_params.v
@@ -20,59 +20,31 @@ End Q.
 #trace Nametab.exists_cci;;
 *)
 
-Module M.
-Reset M.
-Module M (X: SIG).
-Reset M.
-Module M (X Y: SIG).
-Reset M.
-Module M (X: SIG) (Y: SIG).
-Reset M.
-Module M (X Y: SIG) (Z1 Z: SIG).
-Reset M.
-Module M (X: SIG) (Y: SIG).
-Reset M.
-Module M (X Y: SIG) (Z1 Z: SIG).
-Reset M.
-Module M : SIG.
-Reset M.
-Module M (X: SIG) : SIG.
-Reset M.
-Module M (X Y: SIG) : SIG.
-Reset M.
-Module M (X: SIG) (Y: SIG) : SIG.
-Reset M.
-Module M (X Y: SIG) (Z1 Z: SIG) : SIG.
-Reset M.
-Module M (X: SIG) (Y: SIG) : SIG.
-Reset M.
-Module M (X Y: SIG) (Z1 Z: SIG) : SIG.
-Reset M.
-Module M := F Q.
-Reset M.
-Module M (X: FSIG) := X Q.
-Reset M.
-Module M (X Y: FSIG) := X Q.
-Reset M.
-Module M (X: FSIG) (Y: SIG) := X Y.
-Reset M.
-Module M (X Y: FSIG) (Z1 Z: SIG) := X Z.
-Reset M.
-Module M (X: FSIG) (Y: SIG) := X Y.
-Reset M.
-Module M (X Y: FSIG) (Z1 Z: SIG) := X Z.
-Reset M.
-Module M : SIG := F Q.
-Reset M.
-Module M (X: FSIG) : SIG := X Q.
-Reset M.
-Module M (X Y: FSIG) : SIG := X Q.
-Reset M.
-Module M (X: FSIG) (Y: SIG) : SIG := X Y.
-Reset M.
-Module M (X Y: FSIG) (Z1 Z: SIG) : SIG := X Z.
-Reset M.
-Module M (X: FSIG) (Y: SIG) : SIG := X Y.
-Reset M.
-Module M (X Y: FSIG) (Z1 Z: SIG) : SIG := X Z.
-Reset M.
+Module M01. End M01.
+Module M02 (X: SIG). End M02.
+Module M03 (X Y: SIG). End M03.
+Module M04 (X: SIG) (Y: SIG). End M04.
+Module M05 (X Y: SIG) (Z1 Z: SIG). End M05.
+Module M06 (X: SIG) (Y: SIG). End M06.
+Module M07 (X Y: SIG) (Z1 Z: SIG). End M07.
+Module M08 : SIG. End M08.
+Module M09 (X: SIG) : SIG. End M09.
+Module M10 (X Y: SIG) : SIG. End M10.
+Module M11 (X: SIG) (Y: SIG) : SIG. End M11.
+Module M12 (X Y: SIG) (Z1 Z: SIG) : SIG. End M12.
+Module M13 (X: SIG) (Y: SIG) : SIG. End M13.
+Module M14 (X Y: SIG) (Z1 Z: SIG) : SIG. End M14.
+Module M15 := F Q.
+Module M16 (X: FSIG) := X Q.
+Module M17 (X Y: FSIG) := X Q.
+Module M18 (X: FSIG) (Y: SIG) := X Y.
+Module M19 (X Y: FSIG) (Z1 Z: SIG) := X Z.
+Module M20 (X: FSIG) (Y: SIG) := X Y.
+Module M21 (X Y: FSIG) (Z1 Z: SIG) := X Z.
+Module M22 : SIG := F Q.
+Module M23 (X: FSIG) : SIG := X Q.
+Module M24 (X Y: FSIG) : SIG := X Q.
+Module M25 (X: FSIG) (Y: SIG) : SIG := X Y.
+Module M26 (X Y: FSIG) (Z1 Z: SIG) : SIG := X Z.
+Module M27 (X: FSIG) (Y: SIG) : SIG := X Y.
+Module M28 (X Y: FSIG) (Z1 Z: SIG) : SIG := X Z.
diff --git a/test-suite/success/Mod_type.v b/test-suite/success/Mod_type.v
index b847833f..d5e1a38c 100644
--- a/test-suite/success/Mod_type.v
+++ b/test-suite/success/Mod_type.v
@@ -17,3 +17,15 @@ Module Bar : BAR.
   Module Foo := Fu.
 
 End Bar.
+
+(* Check bug #2809: correct printing of modules with notations *)
+
+Module C.
+  Inductive test : Type :=
+    | c1 : test
+    | c2 : nat -> test.
+
+  Notation "! x" := (c2 x) (at level 50).
+End C.
+
+Print C. (* Should print test_rect without failing *)
diff --git a/test-suite/success/Notations.v b/test-suite/success/Notations.v
index 661a8757..2371d32c 100644
--- a/test-suite/success/Notations.v
+++ b/test-suite/success/Notations.v
@@ -17,10 +17,12 @@ Check (nat |= nat --> nat).
 (* Check that first non empty definition at an empty level can be of any
    associativity *)
 
-Definition marker := O.
+Module Type v1.
 Notation "x +1" := (S x) (at level 8, left associativity).
-Reset marker.
+End v1.
+Module Type v2.
 Notation "x +1" := (S x) (at level 8, right associativity).
+End v2.
 
 (* Check that empty levels (here 8 and 2 in pattern) are added in the
    right order *)
@@ -59,3 +61,43 @@ 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.
+
+(* Check correct failure handling when a non-constructor notation is
+   used in cases pattern (bug #2724 in 8.3 and 8.4beta) *)
+
+Notation "'FORALL'  x .. y , P" := (forall x, .. (forall y, P) ..)
+  (at level 200, x binder, y binder, right associativity) : type_scope.
+
+Fail Check fun x => match x with S (FORALL x, _) => 0 end.
+
+(* Bug #2708: don't check for scope of variables used as binder *)
+
+Parameter traverse : (nat -> unit) -> (nat -> unit).
+Notation traverse_var f l := (traverse (fun l => f l) l).
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/OmegaPre.v b/test-suite/success/OmegaPre.v
index f4996734..17531064 100644
--- a/test-suite/success/OmegaPre.v
+++ b/test-suite/success/OmegaPre.v
@@ -14,38 +14,38 @@ Open Scope Z_scope.
 
 (* zify_op *)
 
-Goal forall a:Z, Zmax a a = a.
+Goal forall a:Z, Z.max a a = a.
 intros.
 omega with *.
 Qed.
 
-Goal forall a b:Z, Zmax a b = Zmax b a.
+Goal forall a b:Z, Z.max a b = Z.max b a.
 intros.
 omega with *.
 Qed.
 
-Goal forall a b c:Z, Zmax a (Zmax b c) = Zmax (Zmax a b) c.
+Goal forall a b c:Z, Z.max a (Z.max b c) = Z.max (Z.max a b) c.
 intros.
 omega with *.
 Qed.
 
-Goal forall a b:Z, Zmax a b + Zmin a b = a + b.
+Goal forall a b:Z, Z.max a b + Z.min a b = a + b.
 intros.
 omega with *.
 Qed.
 
-Goal forall a:Z, (Zabs a)*(Zsgn a) = a.
+Goal forall a:Z, (Z.abs a)*(Z.sgn a) = a.
 intros.
 zify.
 intuition; subst; omega. (* pure multiplication: omega alone can't do it *)
 Qed.
 
-Goal forall a:Z, Zabs a = a -> a >= 0.
+Goal forall a:Z, Z.abs a = a -> a >= 0.
 intros.
 omega with *.
 Qed.
 
-Goal forall a:Z, Zsgn a = a -> a = 1 \/ a = 0 \/ a = -1.
+Goal forall a:Z, Z.sgn a = a -> a = 1 \/ a = 0 \/ a = -1.
 intros.
 omega with *.
 Qed.
@@ -119,7 +119,7 @@ Qed.
 
 (* mix of datatypes *)
 
-Goal forall p, Z_of_N (N_of_nat (nat_of_N (Npos p))) = Zpos p.
+Goal forall p, Z.of_N (N.of_nat (N.to_nat (Npos p))) = Zpos p.
 intros.
 omega with *.
 Qed.
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..3b7f0d84 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.
 
@@ -16,14 +22,14 @@ Program Fixpoint merge (n m : nat) {measure (n + m) (lt)} : nat :=
 Print merge.
 
 
-Print Zlt.
+Print Z.lt.
 Print Zwf.
 
-Open Local Scope Z_scope.
+Local Open Scope Z_scope.
 
 Program Fixpoint Zwfrec (n m : Z) {measure (n + m) (Zwf 0)} : Z :=
   match n ?= m with
-    | Lt => Zwfrec n (Zpred m)
+    | Lt => Zwfrec n (Z.pred m)
     | _ => 0
   end.
 
diff --git a/test-suite/success/ROmegaPre.v b/test-suite/success/ROmegaPre.v
index bd473fa6..fa659273 100644
--- a/test-suite/success/ROmegaPre.v
+++ b/test-suite/success/ROmegaPre.v
@@ -14,38 +14,38 @@ Open Scope Z_scope.
 
 (* zify_op *)
 
-Goal forall a:Z, Zmax a a = a.
+Goal forall a:Z, Z.max a a = a.
 intros.
 romega with *.
 Qed.
 
-Goal forall a b:Z, Zmax a b = Zmax b a.
+Goal forall a b:Z, Z.max a b = Z.max b a.
 intros.
 romega with *.
 Qed.
 
-Goal forall a b c:Z, Zmax a (Zmax b c) = Zmax (Zmax a b) c.
+Goal forall a b c:Z, Z.max a (Z.max b c) = Z.max (Z.max a b) c.
 intros.
 romega with *.
 Qed.
 
-Goal forall a b:Z, Zmax a b + Zmin a b = a + b.
+Goal forall a b:Z, Z.max a b + Z.min a b = a + b.
 intros.
 romega with *.
 Qed.
 
-Goal forall a:Z, (Zabs a)*(Zsgn a) = a.
+Goal forall a:Z, (Z.abs a)*(Z.sgn a) = a.
 intros.
 zify.
 intuition; subst; romega. (* pure multiplication: omega alone can't do it *)
 Qed.
 
-Goal forall a:Z, Zabs a = a -> a >= 0.
+Goal forall a:Z, Z.abs a = a -> a >= 0.
 intros.
 romega with *.
 Qed.
 
-Goal forall a:Z, Zsgn a = a -> a = 1 \/ a = 0 \/ a = -1.
+Goal forall a:Z, Z.sgn a = a -> a = 1 \/ a = 0 \/ a = -1.
 intros.
 romega with *.
 Qed.
@@ -119,7 +119,7 @@ Qed.
 
 (* mix of datatypes *)
 
-Goal forall p, Z_of_N (N_of_nat (nat_of_N (Npos p))) = Zpos p.
+Goal forall p, Z.of_N (N.of_nat (N.to_nat (Npos p))) = Zpos p.
 intros.
 romega with *.
 Qed.
diff --git a/test-suite/success/RecTutorial.v b/test-suite/success/RecTutorial.v
index d4e6a82e..459645f6 100644
--- a/test-suite/success/RecTutorial.v
+++ b/test-suite/success/RecTutorial.v
@@ -1,3 +1,5 @@
+Module Type LocalNat.
+
 Inductive nat : Set :=
  | O : nat
  | S : nat->nat.
@@ -5,7 +7,8 @@ Check nat.
 Check O.
 Check S.
 
-Reset nat.
+End LocalNat.
+
 Print nat.
 
 
@@ -55,13 +58,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 +318,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.
@@ -375,18 +378,18 @@ Inductive itree : Set :=
 
 Definition isingle l := inode l (fun i => ileaf).
 
-Definition t1 := inode 0 (fun n => isingle (Z_of_nat (2*n))).
+Definition t1 := inode 0 (fun n => isingle (Z.of_nat (2*n))).
 
 Definition t2 := inode 0
                       (fun n : nat =>
-                               inode (Z_of_nat n)
-                                     (fun p => isingle (Z_of_nat (n*p)))).
+                               inode (Z.of_nat n)
+                                     (fun p => isingle (Z.of_nat (n*p)))).
 
 
 Inductive itree_le : itree-> itree -> Prop :=
   | le_leaf : forall t, itree_le  ileaf t
   | le_node  : forall l l' s s',
-                       Zle l l' ->
+                       Z.le l l' ->
                       (forall i, exists j:nat, itree_le (s i) (s' j)) ->
                       itree_le  (inode  l s) (inode  l' s').
 
@@ -421,7 +424,7 @@ Qed.
 Inductive itree_le' : itree-> itree -> Prop :=
   | le_leaf' : forall t, itree_le'  ileaf t
   | le_node' : forall l l' s s' g,
-                       Zle l l' ->
+                       Z.le l l' ->
                       (forall i, itree_le' (s i) (s' (g i))) ->
                        itree_le'  (inode  l s) (inode  l' s').
 
@@ -477,10 +480,10 @@ Qed.
 
 
 
-(*
 
-Check (fun (P:Prop->Prop)(p: ex_Prop P) =>
+Fail Check (fun (P:Prop->Prop)(p: ex_Prop P) =>
       match p with exP_intro X HX => X end).
+(*
 Error:
 Incorrect elimination of "p" in the inductive type
 "ex_Prop", the return type has sort "Type" while it should be
@@ -489,12 +492,11 @@ Incorrect elimination of "p" in the inductive type
 Elimination of an inductive object of sort "Prop"
 is not allowed on a predicate in sort "Type"
 because proofs can be eliminated only to build proofs
-
 *)
 
-(*
-Check (match prop_inject with (prop_intro P p) => P end).
 
+Fail Check (match prop_inject with (prop_intro p) => p end).
+(*
 Error:
 Incorrect elimination of "prop_inject" in the inductive type
 "prop", the return type has sort "Type" while it should be
@@ -503,13 +505,12 @@ Incorrect elimination of "prop_inject" in the inductive type
 Elimination of an inductive object of sort "Prop"
 is not allowed on a predicate in sort "Type"
 because proofs can be eliminated only to build proofs
-
 *)
 Print prop_inject.
 
 (*
 prop_inject =
-prop_inject = prop_intro prop (fun H : prop => H)
+prop_inject = prop_intro prop
      : prop
 *)
 
@@ -520,30 +521,28 @@ Inductive  typ : Type :=
 Definition typ_inject: typ.
 split.
 exact typ.
+Fail Defined.
 (*
-Defined.
-
 Error: Universe Inconsistency.
 *)
 Abort.
-(*
 
-Inductive aSet : Set :=
+Fail Inductive aSet : Set :=
   aSet_intro: Set -> aSet.
-
-
+(*
 User error: Large non-propositional inductive types must be in Type
-
 *)
 
 Inductive ex_Set  (P : Set -> Prop) : Type :=
   exS_intro : forall X : Set, P X -> ex_Set P.
 
 
+Module Type Version1.
+
 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.
 
@@ -553,21 +552,15 @@ Goal ~(comes_from_the_left _ _ (or_intror True I)).
  *)
 Abort.
 
-Reset comes_from_the_left.
-
-(*
+End Version1.
 
-
-
-
-
-
- Definition comes_from_the_left (P Q:Prop)(H:P \/ Q): Prop :=
+Fail Definition comes_from_the_left (P Q:Prop)(H:P \/ Q): Prop :=
   match H with
          |  or_introl p => True
          |  or_intror q => False
   end.
 
+(*
 Error:
 Incorrect elimination of "H" in the inductive type
 "or", the return type has sort "Type" while it should be
@@ -576,7 +569,6 @@ Incorrect elimination of "H" in the inductive type
 Elimination of an inductive object of sort "Prop"
 is not allowed on a predicate in sort "Type"
 because proofs can be eliminated only to build proofs
-
 *)
 
 Definition comes_from_the_left_sumbool
@@ -737,6 +729,7 @@ Fixpoint plus'' (n p:nat) {struct n} : nat :=
           | S m => plus'' m (S p)
  end.
 
+Module Type even_test_v1.
 
 Fixpoint even_test (n:nat) : bool :=
   match n
@@ -745,8 +738,9 @@ Fixpoint even_test (n:nat) : bool :=
      | S (S p) => even_test p
   end.
 
+End even_test_v1.
 
-Reset even_test.
+Module even_test_v2.
 
 Fixpoint even_test (n:nat) : bool :=
   match n
@@ -761,12 +755,8 @@ with odd_test (n:nat) : bool :=
      | S p => even_test p
  end.
 
-
-
 Eval simpl in even_test.
 
-
-
 Eval simpl in (fun x : nat => even_test x).
 
 Eval simpl in (fun x : nat => plus 5 x).
@@ -774,6 +764,8 @@ Eval simpl in (fun x : nat => even_test (plus 5 x)).
 
 Eval simpl in (fun x : nat => even_test (plus x 5)).
 
+End even_test_v2.
+
 
 Section Principle_of_Induction.
 Variable    P               : nat -> Prop.
@@ -866,14 +858,13 @@ Print Acc.
 
 Require Import Minus.
 
-(*
-Fixpoint div (x y:nat){struct x}: nat :=
+Fail Fixpoint div (x y:nat){struct x}: nat :=
  if eq_nat_dec x 0
   then 0
   else if eq_nat_dec y 0
        then x
        else S (div (x-y) y).
-
+(*
 Error:
 Recursive definition of div is ill-formed.
 In environment
@@ -966,37 +957,33 @@ 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),
-                                  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.
->                                                                                                                 ^^^^^^
+Fail Lemma vector0_is_vnil_aux : forall (A:Set)(n:nat)(v:Vector.t A n),
+                                  n= 0 -> v = Vector.nil A.
+(*
 Error: In environment
 A : Set
 n : nat
-v : vector A n
-e : n = 0
-The term "Vnil A" has type "vector A 0" while it is expected to have type
- "vector A n"
+v : Vector.t A n
+The term "[]" 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 +991,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 +1050,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/Reg.v b/test-suite/success/Reg.v
index 89b3032c..c2d5cb2f 100644
--- a/test-suite/success/Reg.v
+++ b/test-suite/success/Reg.v
@@ -39,7 +39,7 @@ Lemma essai7 :
  derivable_pt (fun x : R => (cos (/ sqrt x) * Rsqr (sin x + 1))%R) 1.
 reg.
 apply Rlt_0_1.
-red in |- *; intro;  rewrite sqrt_1 in H; assert (H0 := R1_neq_R0); elim H0;
+red; intro;  rewrite sqrt_1 in H; assert (H0 := R1_neq_R0); elim H0;
  assumption.
 Qed.
 
@@ -127,7 +127,7 @@ Lemma essai23 :
    (fun x : R => (sin (sqrt (x - 1)) + exp (Rsqr (sqrt x + 3)))%R) 1.
 reg.
 left; apply Rlt_0_1.
-right; unfold Rminus in |- *;  rewrite Rplus_opp_r; reflexivity.
+right; unfold Rminus;  rewrite Rplus_opp_r; reflexivity.
 Qed.
 
 Lemma essai24 :
@@ -135,8 +135,8 @@ Lemma essai24 :
 reg.
  replace (x * x + 2 * x + 2)%R with (Rsqr (x + 1) + 1)%R.
 apply Rplus_le_lt_0_compat; [ apply Rle_0_sqr | apply Rlt_0_1 ].
-unfold Rsqr in |- *;  ring.
-red in |- *; intro; cut (0 < x * x + 1)%R.
+unfold Rsqr;  ring.
+red; intro; cut (0 < x * x + 1)%R.
 intro;  rewrite H in H0; elim (Rlt_irrefl _ H0).
 apply Rplus_le_lt_0_compat;
  [  replace (x * x)%R with (Rsqr x); [ apply Rle_0_sqr | reflexivity ]
diff --git a/test-suite/success/Reset.v b/test-suite/success/Reset.v
deleted file mode 100644
index b71ea69d..00000000
--- a/test-suite/success/Reset.v
+++ /dev/null
@@ -1,7 +0,0 @@
-(* Check Reset Section *)
-
-Section A.
-Definition B := Prop.
-End A.
-
-Reset A.
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/Scopes.v b/test-suite/success/Scopes.v
index 55d8343e..a79d28fa 100644
--- a/test-suite/success/Scopes.v
+++ b/test-suite/success/Scopes.v
@@ -3,6 +3,6 @@
 Require Import ZArith.
 
 Module A.
-Definition opp := Zopp.
+Definition opp := Z.opp.
 End A.
 Check (A.opp 3).
diff --git a/test-suite/success/Tauto.v b/test-suite/success/Tauto.v
index 324d340a..73ef3720 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-2012     *)
 (*   \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..e9d6a969 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/test-suite/success/Try.v b/test-suite/success/Try.v
index b356f277..361c787e 100644
--- a/test-suite/success/Try.v
+++ b/test-suite/success/Try.v
@@ -2,7 +2,7 @@
    non-existent names in Unfold [cf bug #263] *)
 
 Lemma lem1 : True.
-try unfold i_dont_exist in |- *.
+try unfold i_dont_exist.
 trivial.
 Qed.
 
diff --git a/test-suite/success/apply.v b/test-suite/success/apply.v
index a6f9fa23..0d8bf556 100644
--- a/test-suite/success/apply.v
+++ b/test-suite/success/apply.v
@@ -8,8 +8,8 @@ Qed.
 
 Require Import ZArith.
 Goal (forall x y z, ~ z <= 0 -> x * z < y * z -> x <= y)%Z.
-intros; apply Znot_le_gt, Zgt_lt in H.
-apply Zmult_lt_reg_r, Zlt_le_weak in H0; auto.
+intros; apply Znot_le_gt, Z.gt_lt in H.
+apply Zmult_lt_reg_r, Z.lt_le_incl in H0; auto.
 Qed.
 
 (* Test application under tuples *)
@@ -97,13 +97,14 @@ Qed.
 
 (* Check use of unification of bindings types in specialize *)
 
+Module Type Test.
 Variable P : nat -> Prop.
 Variable L : forall (l : nat), P l -> P l.
 Goal P 0 -> True.
 intros.
 specialize L with (1:=H).
 Abort.
-Reset P.
+End Test.
 
 (* Two examples that show that hnf_constr is used when unifying types
    of bindings (a simplification of a script from Field_Theory) *)
@@ -202,6 +203,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 *)
 
@@ -258,7 +266,7 @@ Qed.
   (* This works because unfold calls clos_norm_flags which calls nf_evar *)
 
 Lemma eapply_evar_unfold : let x:=O in O=x -> 0=O.
-intros x H; eapply trans_equal;
+intros x H; eapply eq_trans;
 [apply H | unfold x;match goal with |- ?x = ?x => reflexivity end].
 Qed.
 
@@ -326,13 +334,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 +398,35 @@ 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.
+
+(* Check "with" clauses refer to names as they are printed *)
+
+Definition hide p := forall n:nat, p = n.
+
+Goal forall n, (forall n, n=0) -> hide n -> n=0.
+unfold hide.
+intros n H H'.
+(* H is displayed as (forall n, n=0) *)
+apply H with (n:=n).
+Undo.
+(* H' is displayed as (forall n0, n=n0) *)
+apply H' with (n0:=0).
+Qed.
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..7bed7ecb 100644
--- a/test-suite/success/change.v
+++ b/test-suite/success/change.v
@@ -14,7 +14,7 @@ Abort.
 (* Check the combination of at, with and in (see bug #2146) *)
 
 Goal 3=3 -> 3=3. intro H.
-change 3 at 2 with (1+2) in |- *.
+change 3 at 2 with (1+2).
 change 3 at 2 with (1+2) in H |-.
 change 3 with (1+2) in H at 1 |- * at 1.
 (* Now check that there are no more 3's *)
@@ -25,8 +25,16 @@ Qed.
 change 3 at 1 with (1+2) at 3.
 change 3 at 1 with (1+2) in *.
 change 3 at 1 with (1+2) in H at 2 |-.
-change 3 at 1 with (1+2) in |- * at 3.
+change 3 at 1 with (1+2) at 3.
 change 3 at 1 with (1+2) in H |- *.
 change 3 at 1 with (1+2) in H, H|-.
-change 3 in |- * at 1.
+change 3 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..4292ecb6 100644
--- a/test-suite/success/coercions.v
+++ b/test-suite/success/coercions.v
@@ -81,3 +81,53 @@ 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.
+
+(* Tests after the inheritance condition constraint is relaxed *)
+
+Inductive list (A : Type) : Type := 
+  nil : list A | cons : A -> list A -> list A.
+Inductive vect (A : Type) : nat -> Type :=
+  vnil : vect A 0 | vcons : forall n, A -> vect A n -> vect A (1+n).
+Fixpoint size A (l : list A) : nat := match l with nil => 0 | cons _ tl => 1+size _ tl end.
+
+Section test_non_unif_but_complete.
+Fixpoint l2v A (l : list A) : vect A (size A l) :=
+  match l as l return vect A (size A l) with
+  | nil => vnil A
+  | cons x xs => vcons A (size A xs) x (l2v A xs)
+  end.
+
+Local Coercion l2v : list >-> vect.
+Check (fun l : list nat =>  (l : vect _ _)).
+
+End test_non_unif_but_complete.
+
+Section what_we_could_do.
+Variables T1 T2 : Type.
+Variable c12 : T1 -> T2.
+
+Class coercion (A B : Type) : Type := cast : A -> B.
+Instance atom : coercion T1 T2 := c12.
+Instance pair A B C D (c1 : coercion A B) (c2 : coercion C D) : coercion (A * C) (B * D) :=
+  fun x => (c1 (fst x), c2 (snd x)).
+
+Fixpoint l2v2 {A B} {c : coercion A B} (l : list A) : (vect B (size A l)) := 
+  match l as l return vect B (size A l) with
+  | nil => vnil B
+  | cons x xs => vcons _ _ (c x) (l2v2 xs) end.
+
+Local Coercion l2v2 : list >-> vect.
+
+(* This shows that there is still something to do to take full profit
+   of coercions *)
+Fail Check (fun l : list (T1 * T1) => (l : vect _ _)).
+Check (fun l : list (T1 * T1) => (l2v2 l : vect _ _)).
+Section what_we_could_do.
\ No newline at end of file
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/decl_mode.v b/test-suite/success/decl_mode.v
index bc1757fd..52575eca 100644
--- a/test-suite/success/decl_mode.v
+++ b/test-suite/success/decl_mode.v
@@ -138,7 +138,7 @@ Coercion IZR: Z >->R.*)
 Open Scope R_scope.
 
 Lemma square_abs_square:
-  forall p,(INR (Zabs_nat p) * INR (Zabs_nat p)) = (IZR p * IZR p).
+  forall p,(INR (Z.abs_nat p) * INR (Z.abs_nat p)) = (IZR p * IZR p).
 proof.
   assume p:Z.
   per cases on p.
@@ -147,7 +147,7 @@ proof.
     suppose it is (Zpos z).
       thus thesis.
     suppose it is (Zneg z).
-      have ((INR (Zabs_nat (Zneg z)) * INR (Zabs_nat (Zneg z))) =
+      have ((INR (Z.abs_nat (Zneg z)) * INR (Z.abs_nat (Zneg z))) =
       (IZR (Zpos z) * IZR (Zpos z))).
            ~= ((- IZR (Zpos z)) * (- IZR (Zpos z))).
       thus ~= (IZR (Zneg z) * IZR (Zneg z)).
@@ -165,15 +165,15 @@ proof.
   have H_in_R:(INR q<>0:>R) by H.
   have triv:((IZR p/INR q* INR q) =IZR p :>R) by * using field.
   have sqrt2:((sqrt (INR 2%nat) * sqrt (INR 2%nat))= INR 2%nat:>R) by sqrt_def.
-  have (INR (Zabs_nat p * Zabs_nat p)
-     = (INR (Zabs_nat p) * INR (Zabs_nat p)))
+  have (INR (Z.abs_nat p * Z.abs_nat p)
+     = (INR (Z.abs_nat p) * INR (Z.abs_nat p)))
     by mult_INR.
     ~=  (IZR p* IZR p) by square_abs_square.
     ~=  ((IZR p/INR q*INR q)*(IZR p/INR q*INR q)) by triv. (* we have to factor because field is too weak *)
     ~=  ((IZR p/INR q)*(IZR p/INR q)*(INR q*INR q)) using ring.
     ~=  (sqrt (INR 2%nat) * sqrt (INR 2%nat)*(INR q*INR q)) by H0.
     ~= (INR (2%nat * (q*q)))  by sqrt2,mult_INR.
-  then  (Zabs_nat p * Zabs_nat p = 2* (q * q))%nat.
+  then  (Z.abs_nat p * Z.abs_nat p = 2* (q * q))%nat.
     ~= ((q*q)+(q*q))%nat.
     ~= (Div2.double (q*q)).
   then (q=0%nat) by main_theorem.
diff --git a/test-suite/success/dependentind.v b/test-suite/success/dependentind.v
index fe0165d0..12ddbda8 100644
--- a/test-suite/success/dependentind.v
+++ b/test-suite/success/dependentind.v
@@ -1,5 +1,11 @@
 Require Import Coq.Program.Program Coq.Program.Equality.
 
+Goal forall (H: forall n m : nat, n = m -> n = 0) x, x = tt.
+intros.
+dependent destruction x.
+reflexivity.
+Qed.
+
 Variable A : Set.
 
 Inductive vector : nat -> Type := vnil : vector 0 | vcons : A -> forall {n}, vector n -> vector (S n).
@@ -62,7 +68,7 @@ where " Γ ⊢ τ " := (term Γ τ) : type_scope.
 
 Hint Constructors term : lambda.
 
-Open Local Scope context_scope.
+Local Open Scope context_scope.
 
 Ltac eqns := subst ; reverse ; simplify_dep_elim ; simplify_IH_hyps.
 
@@ -84,6 +90,29 @@ Proof with simpl in * ; eqns ; eauto with lambda.
   intro. eapply app...
 Defined.
 
+Lemma weakening_ctx : forall Γ Δ τ, Γ ; Δ ⊢ τ ->
+  forall Δ', Γ ; Δ' ; Δ ⊢ τ.
+Proof with simpl in * ; eqns ; eauto with lambda.
+  intros Γ Δ τ H.
+
+  dependent induction H.
+
+  destruct Δ as [|Δ τ'']...
+  induction Δ'...
+
+  destruct Δ as [|Δ τ'']...
+  induction Δ'...
+
+  destruct Δ as [|Δ τ'']...
+    apply abs.
+    specialize (IHterm Γ (empty, τ))...
+
+    apply abs.
+    specialize (IHterm Γ (Δ, τ'', τ))...
+
+  intro. eapply app...
+Defined.
+
 Lemma exchange : forall Γ Δ α β τ, term (Γ, α, β ; Δ) τ -> term (Γ, β, α ; Δ) τ.
 Proof with simpl in * ; eqns ; eauto.
   intros until 1.
@@ -105,6 +134,8 @@ Proof with simpl in * ; eqns ; eauto.
   eapply app...
 Defined.
 
+
+
 (** Example by Andrew Kenedy, uses simplification of the first component of dependent pairs. *)
 
 Set Implicit Arguments.
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..49bf8b15 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-2012     *)
 (*   \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..df73383a 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-2012     *)
 (*   \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..e6088091 100644
--- a/test-suite/success/evars.v
+++ b/test-suite/success/evars.v
@@ -238,3 +238,144 @@ 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).
+
+(* An example that uses materialize_evar under binders *)
+(* Extracted from bigop.v in the mathematical components library *)
+
+Section Bigop.
+
+Variable bigop : forall R I: Type,
+  R -> (R -> R -> R) -> list I -> (I->Prop) -> (I -> R) -> R.
+
+Hypothesis eq_bigr :
+forall (R : Type) (idx : R) (op : R -> R -> R)
+       (I : Type) (r : list I) (P : I -> Prop) (F1 F2 : I -> R),
+       (forall i : I, P i -> F1 i = F2 i) ->
+       bigop R I idx op r (fun i : I => P i) (fun i : I => F1 i) = idx.
+
+Hypothesis big_tnth :
+forall (R : Type) (idx : R) (op : R -> R -> R)
+     (I : Type) (r : list I) (P : I -> Prop) (F : I -> R),
+     bigop R I idx op r (fun i : I => P i) (fun i : I => F i) = idx.
+
+Hypothesis big_tnth_with_letin :
+forall (R : Type) (idx : R) (op : R -> R -> R)
+     (I : Type) (r : list I) (P : I -> Prop) (F : I -> R),
+     bigop R I idx op r (fun i : I => let i:=i in P i) (fun i : I => F i) = idx.
+
+Variable R : Type.
+Variable idx : R.
+Variable op : R -> R -> R.
+Variable I : Type.
+Variable J : Type.
+Variable rI : list I.
+Variable rJ : list J.
+Variable xQ : J -> Prop.
+Variable P : I -> Prop.
+Variable Q : I -> J -> Prop.
+Variable F : I -> J -> R.
+
+(* Check unification under binders *)
+
+Check (eq_bigr _ _ _ _ _ _ _ _ (fun _ _ => big_tnth _ _ _ _ rI _ _))
+  : (bigop R J idx op rJ
+        (fun j : J => let k:=j in xQ k)
+        (fun j : J => let k:=j in 
+         bigop R I idx
+           op rI
+           (fun i : I => P i /\ Q i k) (fun i : I => let k:=j in F i k))) = idx.
+
+(* Check also with let-in *)
+
+Check (eq_bigr _ _ _ _ _ _ _ _ (fun _ _ => big_tnth_with_letin _ _ _ _ rI _ _))
+  : (bigop R J idx op rJ
+        (fun j : J => let k:=j in xQ k)
+        (fun j : J => let k:=j in 
+         bigop R I idx
+           op rI
+           (fun i : I => P i /\ Q i k) (fun i : I => let k:=j in F i k))) = idx.
+
+End Bigop.
+
+(* Check the use of (at least) an heuristic to solve problems of the form
+   "?x[t] = ?y" where ?y occurs in t without easily knowing if ?y can
+   eventually be erased in t *)
+
+Section evar_evar_occur.
+  Variable id : nat -> nat.
+  Variable f : forall x, id x = 0 -> id x = 0 -> x = 1 /\ x = 2.
+  Variable g : forall y, id y = 0 /\ id y = 0.
+  (* Still evars in the resulting type, but constraints should be solved *)
+  Check match g _ with conj a b => f _ a b end.
+End evar_evar_occur.
diff --git a/test-suite/success/extraction.v b/test-suite/success/extraction.v
index 4fec6e7f..acd1da66 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-2012     *)
 (*   \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..8623f718 100644
--- a/test-suite/success/fix.v
+++ b/test-suite/success/fix.v
@@ -9,17 +9,16 @@ 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 := Pos.compare_cont 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 (Pos.compare_cont n m Eq).
 intros H' H'0 H'1; right; right; auto.
-intros H' H'0 H'1; left; unfold rlt in |- *.
+intros H' H'0 H'1; left; unfold rlt.
 apply nat_of_P_lt_Lt_compare_complement_morphism; auto.
-intros H' H'0 H'1; right; left; unfold rlt in |- *.
+intros H' H'0 H'1; right; left; unfold rlt.
 apply nat_of_P_lt_Lt_compare_complement_morphism; auto.
 apply H'0; auto.
 Defined.
diff --git a/test-suite/success/hyps_inclusion.v b/test-suite/success/hyps_inclusion.v
index af81e53d..ebd90a40 100644
--- a/test-suite/success/hyps_inclusion.v
+++ b/test-suite/success/hyps_inclusion.v
@@ -19,14 +19,16 @@ red in H.
 (* next tactic was failing wrt bug #1325 because type-checking the goal
    detected a syntactically different type for the section variable H *)
 case 0.
-Reset A.
+Abort.
+End A.
 
 (* Variant with polymorphic inductive types for bug #1325 *)
 
-Section A.
+Section B.
 Variable H:not True.
 Inductive I (n:nat) : Type := C : H=H -> I n.
 Goal I 0.
 red in H.
 case 0.
-Reset A.
+Abort.
+End B.
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..9316ac03 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-2012     *)
 (*   \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..cc8e8dd8 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-2012     *)
 (*   \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..c2eb8bd7 100644
--- a/test-suite/success/ltac.v
+++ b/test-suite/success/ltac.v
@@ -2,7 +2,7 @@
 
 (* Submitted by Pierre Crégut *)
 (* Checks substitution of x *)
-Ltac f x := unfold x in |- *; idtac.
+Ltac f x := unfold x; idtac.
 
 Lemma lem1 : 0 + 0 = 0.
 f plus.
@@ -86,7 +86,7 @@ assert t.
 exact H.
 intro H1.
 apply H.
-symmetry  in |- *.
+symmetry .
 assumption.
 Qed.
 
@@ -105,7 +105,7 @@ sym'.
 exact H.
 intro H1.
 apply H.
-symmetry  in |- *.
+symmetry .
 assumption.
 Qed.
 
@@ -193,7 +193,7 @@ Abort.
 (* Used to fail in V8.1 *)
 
 Tactic Notation "test" constr(t) integer(n) :=
-   set (k := t) in |- * at n.
+   set (k := t) at n.
 
 Goal forall x : nat, x = 1 -> x + x + x = 3.
 intros x H.
@@ -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..5fe760bf 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-2012     *)
 (*   \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..bf302df4
--- /dev/null
+++ b/test-suite/success/proof_using.v
@@ -0,0 +1,67 @@
+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.
+
+Lemma deep2 : v1 = v2.
+Proof using v1 v2.
+Admitted.
+
+End S2.
+
+Check (deep 3 : v1 = 3).
+Check (deep2 3 : v1 = 3).
+
+End S1.
+
+Check (deep 3 4 : 3 = 4).
+Check (deep2 3 4 : 3 = 4).
+
diff --git a/test-suite/success/remember.v b/test-suite/success/remember.v
new file mode 100644
index 00000000..0befe054
--- /dev/null
+++ b/test-suite/success/remember.v
@@ -0,0 +1,16 @@
+(* 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.
+Abort.
+
+(* Testing Ltac interpretation of remember (was not working up to r16181) *)
+
+Goal (1 + 2 + 3 = 6).
+let name := fresh "fresh" in
+remember (1 + 2) as x eqn:name.
+rewrite fresh.
+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..9edfd825
--- /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 Z.mul Z.add "distr".
+SearchAbout "+"%Z "*"%Z "distr" -positive -Prop.
+SearchAbout (?x * _ + ?x * _)%Z outside OmegaLemmas.
diff --git a/test-suite/success/set.v b/test-suite/success/set.v
index 23019275..8116e897 100644
--- a/test-suite/success/set.v
+++ b/test-suite/success/set.v
@@ -1,8 +1,19 @@
+(* This used to fail in 8.0pl1 *)
+
 Goal forall n, n+n=0->0=n+n.
 intros.
-
-(* This used to fail in 8.0pl1 *)
 set n in * |-.
+Abort.
+
+(* This works from 8.4pl1, since merging of different instances of the
+   same metavariable in a pattern is done modulo conversion *)
+
+Notation "p .+1" := (S p) (at level 1, left associativity, format "p .+1").
+
+Goal forall (f:forall n, n=0 -> Prop) n (H:(n+n).+1=0), f (n.+1+n) H.
+intros.
+set (f _ _).
+Abort.
 
 
 
diff --git a/test-suite/success/setoid_test.v b/test-suite/success/setoid_test.v
index 033b3f48..653b5bf9 100644
--- a/test-suite/success/setoid_test.v
+++ b/test-suite/success/setoid_test.v
@@ -18,10 +18,10 @@ Definition same (s t : set) : Prop := forall a : A, In a s <-> In a t.
 
 Lemma setoid_set : Setoid_Theory set same.
 
-unfold same in |- *; split ; red.
-red in |- *; auto.
+unfold same; split ; red.
+red; auto.
 
-red in |- *.
+red.
 intros.
 elim (H a); auto.
 
@@ -33,19 +33,19 @@ Qed.
 Add Setoid set same setoid_set as setsetoid.
 
 Add Morphism In : In_ext.
-unfold same in |- *; intros a s t H; elim (H a); auto.
+unfold same; intros a s t H; elim (H a); auto.
 Qed.
 
 Lemma add_aux :
  forall s t : set,
  same s t -> forall a b : A, In a (Add b s) -> In a (Add b t).
-unfold same in |- *; simple induction 2; intros.
+unfold same; simple induction 2; intros.
 rewrite H1.
-simpl in |- *; left; reflexivity.
+simpl; left; reflexivity.
 
 elim (H a).
 intros.
-simpl in |- *; right.
+simpl; right.
 apply (H2 H1).
 Qed.
 
@@ -74,15 +74,15 @@ setoid_replace (remove a (Add a Empty)) with Empty.
 
 auto.
 
-unfold same in |- *.
+unfold same.
 split.
-simpl in |- *.
+simpl.
 case (eq_dec a a).
 intros e ff; elim ff.
 
 intros; absurd (a = a); trivial.
 
-simpl in |- *.
+simpl.
 intro H; elim H.
 Qed.
 
@@ -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/specialize.v b/test-suite/success/specialize.v
index 57837321..c5f032be 100644
--- a/test-suite/success/specialize.v
+++ b/test-suite/success/specialize.v
@@ -5,20 +5,20 @@ intros.
 (* "compatibility" mode: specializing a global name
    means a kind of generalize *)
 
-specialize trans_equal. intros _.
-specialize trans_equal with (1:=H)(2:=H0). intros _.
-specialize trans_equal with (x:=a)(y:=b)(z:=c). intros _.
-specialize trans_equal with (1:=H)(z:=c). intros _.
-specialize trans_equal with nat a b c. intros _.
-specialize (@trans_equal nat). intros _.
-specialize (@trans_equal _ a b c). intros _.
-specialize (trans_equal (x:=a)). intros _.
-specialize (trans_equal (x:=a)(y:=b)). intros _.
-specialize (trans_equal H H0). intros _.
-specialize (trans_equal H0 (z:=b)). intros _.
+specialize eq_trans. intros _.
+specialize eq_trans with (1:=H)(2:=H0). intros _.
+specialize eq_trans with (x:=a)(y:=b)(z:=c). intros _.
+specialize eq_trans with (1:=H)(z:=c). intros _.
+specialize eq_trans with nat a b c. intros _.
+specialize (@eq_trans nat). intros _.
+specialize (@eq_trans _ a b c). intros _.
+specialize (eq_trans (x:=a)). intros _.
+specialize (eq_trans (x:=a)(y:=b)). intros _.
+specialize (eq_trans H H0). intros _.
+specialize (eq_trans H0 (z:=b)). intros _.
 
 (* local "in place" specialization *)
-assert (Eq:=trans_equal).
+assert (Eq:=eq_trans).
 
 specialize Eq.
 specialize Eq with (1:=H)(2:=H0). Undo.
@@ -38,10 +38,10 @@ specialize (Eq _ _ _ b H0). Undo.
     presque ok... *)
 
 (* 2) echoue moins lorsque zero premise de mangé *)
-specialize trans_equal with (1:=Eq).  (* mal typé !! *)
+specialize eq_trans with (1:=Eq).  (* mal typé !! *)
 
 (* 3) *)
-specialize trans_equal with _ a b c. intros _.
+specialize eq_trans with _ a b c. intros _.
 (* Anomaly: Evar ?88 was not declared. Please report. *)
 *)
 
diff --git a/test-suite/success/telescope_canonical.v b/test-suite/success/telescope_canonical.v
new file mode 100644
index 00000000..73df5ca9
--- /dev/null
+++ b/test-suite/success/telescope_canonical.v
@@ -0,0 +1,72 @@
+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 test1 (n : hidden_nat) : P _ n.
+Admitted.
+
+Structure Pnat := mkP { getp : nat }.
+Definition my_getp := getp.
+Axiom W : nat -> Prop.
+
+(* Fix *)
+Canonical Structure add1Pnat n := mkP (plus n 1).
+Definition test_fix n := (refl_equal _ : W (my_getp _)  = W (n + 1)).
+
+(* Case *)
+Definition pred n := match n with 0 => 0 | S m => m end.
+Canonical Structure predSS n := mkP (pred n).
+Definition test_case x := (refl_equal _ : W (my_getp _)  = W (pred x)).
+Fail Definition test_case' := (refl_equal _ : W (my_getp _)  = W (pred 0)).
+
+Canonical Structure letPnat' := mkP 0.
+Definition letin := (let n := 0 in n).
+Definition test4 := (refl_equal _ : W (getp _)  = W letin).
+Definition test41 := (refl_equal _ : W (my_getp _)  = W letin).
+Definition letin2 (x : nat) := (let n := x in n).
+Canonical Structure letPnat'' x := mkP (letin2 x).
+Definition test42 x := (refl_equal _ : W (my_getp _)  = W (letin2 x)).
+Fail Definition test42' x := (refl_equal _ : W (my_getp _)  = W x).
+
+Structure Morph := mkM { f :> nat -> nat }.
+Definition my_f := f.
+Axiom Q : (nat -> nat) -> Prop.
+
+(* Lambda *)
+Canonical Structure addMorh x := mkM (plus x).
+Definition test_lam x := (refl_equal _ : Q (my_f _) = Q (plus x)).
+Definition test_lam' := (refl_equal _ : Q (my_f _) = Q (plus 0)).
+
+(* Simple tests to justify Sort and Prod as "named". 
+   They are already normal, so they cannot loose their names, 
+   but still... *)
+Structure Sot := mkS { T : Type }.
+Axiom R : Type -> Prop.
+Canonical Structure tsot := mkS (Type).
+Definition test_sort := (refl_equal _ : R (T _) = R Type).
+Canonical Structure tsot2 := mkS (nat -> nat).
+Definition test_prod := (refl_equal _ : R (T _) = R (nat -> nat)).
+
+(* Var *)
+Section Foo.
+Variable v : nat.
+Definition my_v := v.
+Canonical Structure vP := mkP my_v.
+Definition test_var := (refl_equal _ : W (getp _)  = W my_v).
+Canonical Structure vP' := mkP v.
+Definition test_var' := (refl_equal _ : W (my_getp _)  = W my_v).
+End Foo.
+
+(* Rel *)
+Definition test_rel v := (refl_equal _ : W (my_getp _)  = W (my_v v)).
+Goal True.
+pose (x := test_rel 2).
+match goal with x := _ : W (my_getp (vP 2)) = _ |- _ => idtac end.
+apply I.
+Qed.
+
+
+
+
diff --git a/test-suite/success/unfold.v b/test-suite/success/unfold.v
index 66c4e080..62ecb1aa 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/test-suite/success/unicode_utf8.v b/test-suite/success/unicode_utf8.v
index 8b7764e5..42e32ccc 100644
--- a/test-suite/success/unicode_utf8.v
+++ b/test-suite/success/unicode_utf8.v
@@ -75,7 +75,7 @@ Notation "x ≤ y" := (x<=y) (at level 70, no associativity).
 
 Require Import ZArith.
 Open Scope Z_scope.
-Locate "≤". (* still le, not Zle *)
+Locate "≤". (* still le, not Z.le *)
 Notation "x ≤ y" := (x<=y) (at level 70, no associativity).
 Locate "≤".
 Close Scope Z_scope.
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/univers.v b/test-suite/success/univers.v
index 469cbeb7..e00701fb 100644
--- a/test-suite/success/univers.v
+++ b/test-suite/success/univers.v
@@ -16,7 +16,7 @@ auto.
 Qed.
 
 Lemma lem3 : forall P : Prop, P.
-intro P; pattern P in |- *.
+intro P; pattern P.
 apply lem2.
 Abort.
 
@@ -34,7 +34,7 @@ Require Import Relations.
 
 Theorem dep_eq_trans : forall X : Type, transitive X (dep_eq X).
 Proof.
-  unfold transitive in |- *.
+  unfold transitive.
   intros X f g h H1 H2.
   inversion H1.
 Abort.
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..63f5d985 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-2012     *)
 (*   \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..fea10ce1 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-2012     *)
 (*   \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..9f0f05db 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-2012     *)
 (*   \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..fb488526 100644
--- a/theories/Arith/Between.v
+++ b/theories/Arith/Between.v
@@ -1,17 +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-2012     *)
 (*   \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.
 
-Open Local Scope nat_scope.
+Local Open Scope nat_scope.
 
 Implicit Types k l p q r : nat.
 
@@ -76,7 +74,7 @@ Section Between.
 
   Lemma in_int_intro : forall p q r, p <= r -> r < q -> in_int p q r.
   Proof.
-    red in |- *; auto with arith.
+    red; auto with arith.
   Qed.
   Hint Resolve in_int_intro: arith v62.
 
@@ -151,7 +149,7 @@ Section Between.
       between k l ->
       (forall n:nat, in_int k l n -> P n -> ~ Q n) -> ~ exists_between k l.
   Proof.
-    induction 1; red in |- *; intros.
+    induction 1; red; intros.
     absurd (k < k); auto with arith.
     absurd (Q l); auto with arith.
     elim (exists_in_int k (S l)); auto with arith; intros l' inl' Ql'.
diff --git a/theories/Arith/Bool_nat.v b/theories/Arith/Bool_nat.v
index b3dcd8ec..4c15a173 100644
--- a/theories/Arith/Bool_nat.v
+++ b/theories/Arith/Bool_nat.v
@@ -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-2012     *)
 (*   \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.
 
-Open Local Scope nat_scope.
+Local Open Scope nat_scope.
 
 Implicit Types m n x y : nat.
 
@@ -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..65219655 100644
--- a/theories/Arith/Compare.v
+++ b/theories/Arith/Compare.v
@@ -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-2012     *)
 (*   \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.
+Local Open Scope nat_scope.
 
-Notation not_eq_sym := sym_not_eq.
+Notation not_eq_sym := not_eq_sym (only parsing).
 
 Implicit Types m n p q : nat.
 
@@ -43,7 +41,7 @@ Proof.
   lapply (lt_le_S m n); auto with arith.
   intro H'; lapply (le_lt_or_eq (S m) n); auto with arith.
   induction 1; auto with arith.
-  right; exists (n - S (S m)); simpl in |- *.
+  right; exists (n - S (S m)); simpl.
   rewrite (plus_comm m (n - S (S m))).
   rewrite (plus_n_Sm (n - S (S m)) m).
   rewrite (plus_n_Sm (n - S (S m)) (S m)).
@@ -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..a90a9ce9 100644
--- a/theories/Arith/Compare_dec.v
+++ b/theories/Arith/Compare_dec.v
@@ -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-2012     *)
 (*   \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.
 Require Import Decidable.
 
-Open Local Scope nat_scope.
+Local Open Scope nat_scope.
 
 Implicit Types m n x y : nat.
 
@@ -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.
@@ -140,7 +138,7 @@ Proof.
 Qed.
 
 
-(** A ternary comparison function in the spirit of [Zcompare]. *)
+(** A ternary comparison function in the spirit of [Z.compare]. *)
 
 Fixpoint nat_compare n m :=
   match n, m with
@@ -200,16 +198,16 @@ 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.
+ destruct (nat_compare x y) eqn:?; constructor.
  apply nat_compare_eq; auto.
  apply <- nat_compare_lt; auto.
  apply <- nat_compare_gt; auto.
 Qed.
 
-
 (** Some projections of the above equivalences. *)
 
 Lemma nat_compare_Lt_lt : forall n m, nat_compare n m = Lt -> n<m.
@@ -258,7 +256,7 @@ Lemma leb_correct : forall m n, m <= n -> leb m n = true.
 Proof.
   induction m as [| m IHm]. trivial.
   destruct n. intro H. elim (le_Sn_O _ H).
-  intros. simpl in |- *. apply IHm. apply le_S_n. assumption.
+  intros. simpl. apply IHm. apply le_S_n. assumption.
 Qed.
 
 Lemma leb_complete : forall m n, leb m n = true -> m <= n.
diff --git a/theories/Arith/Div2.v b/theories/Arith/Div2.v
index 89620f5f..56115c7f 100644
--- a/theories/Arith/Div2.v
+++ b/theories/Arith/Div2.v
@@ -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-2012     *)
 (*   \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.
 Require Import Even.
 
-Open Local Scope nat_scope.
+Local Open Scope nat_scope.
 
 Implicit Type n : nat.
 
@@ -45,7 +43,7 @@ Qed.
 
 Lemma lt_div2 : forall n, 0 < n -> div2 n < n.
 Proof.
-  intro n. pattern n in |- *. apply ind_0_1_SS.
+  intro n. pattern n. apply ind_0_1_SS.
   (* n = 0 *)
   inversion 1.
   (* n=1 *)
@@ -71,24 +69,24 @@ Proof.
     (* S n *) inversion_clear H. apply even_div2 in H0 as <-. trivial.
 Qed.
 
-Lemma div2_even : forall n, div2 n = div2 (S n) -> even n
-with div2_odd : forall n, S (div2 n) = div2 (S n) -> odd n.
+Lemma div2_even n : div2 n = div2 (S n) -> even n
+with div2_odd n : S (div2 n) = div2 (S n) -> odd n.
 Proof.
-  destruct n; intro H.
-    (* 0 *) constructor.
-    (* S n *) constructor. apply div2_odd. rewrite H. trivial.
-  destruct n; intro H.
-    (* 0 *) discriminate.
-    (* S n *) constructor. apply div2_even. injection H as <-. trivial.
+{ destruct n; intro H.
+  - constructor.
+  - constructor. apply div2_odd. rewrite H. trivial. }
+{ destruct n; intro H.
+  - discriminate.
+  - constructor. apply div2_even. injection H as <-. trivial. }
 Qed.
 
 Hint Resolve even_div2 div2_even odd_div2 div2_odd: arith.
 
-Lemma even_odd_div2 :
-  forall n,
-    (even n <-> div2 n = div2 (S n)) /\ (odd n <-> S (div2 n) = div2 (S n)).
+Lemma even_odd_div2 n :
+ (even n <-> div2 n = div2 (S n)) /\
+ (odd n <-> S (div2 n) = div2 (S n)).
 Proof.
-  auto decomp using div2_odd, div2_even, odd_div2, even_div2.
+ split; split; auto using div2_odd, div2_even, odd_div2, even_div2.
 Qed.
 
 
@@ -101,12 +99,12 @@ Hint Unfold double: arith.
 
 Lemma double_S : forall n, double (S n) = S (S (double n)).
 Proof.
-  intro. unfold double in |- *. simpl in |- *. auto with arith.
+  intro. unfold double. simpl. auto with arith.
 Qed.
 
 Lemma double_plus : forall n (m:nat), double (n + m) = double n + double m.
 Proof.
-  intros m n. unfold double in |- *.
+  intros m n. unfold double.
   do 2 rewrite plus_assoc_reverse. rewrite (plus_permute n).
   reflexivity.
 Qed.
@@ -117,7 +115,7 @@ Lemma even_odd_double :
   forall n,
     (even n <-> n = double (div2 n)) /\ (odd n <-> n = S (double (div2 n))).
 Proof.
-  intro n. pattern n in |- *. apply ind_0_1_SS.
+  intro n. pattern n. apply ind_0_1_SS.
   (* n = 0 *)
   split; split; auto with arith.
   intro H. inversion H.
@@ -128,11 +126,11 @@ Proof.
   intros. destruct H as ((IH1,IH2),(IH3,IH4)).
   split; split.
   intro H. inversion H. inversion H1.
-  simpl in |- *. rewrite (double_S (div2 n0)). auto with arith.
-  simpl in |- *. rewrite (double_S (div2 n0)). intro H. injection H. auto with arith.
+  simpl. rewrite (double_S (div2 n0)). auto with arith.
+  simpl. rewrite (double_S (div2 n0)). intro H. injection H. auto with arith.
   intro H. inversion H. inversion H1.
-  simpl in |- *. rewrite (double_S (div2 n0)). auto with arith.
-  simpl in |- *. rewrite (double_S (div2 n0)). intro H. injection H. auto with arith.
+  simpl. rewrite (double_S (div2 n0)). auto with arith.
+  simpl. rewrite (double_S (div2 n0)). intro H. injection H. auto with arith.
 Qed.
 (** Specializations *)
 
diff --git a/theories/Arith/EqNat.v b/theories/Arith/EqNat.v
index 60575beb..ce8eb478 100644
--- a/theories/Arith/EqNat.v
+++ b/theories/Arith/EqNat.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-2012     *)
 (*   \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.
+Local Open Scope nat_scope.
 
 Implicit Types m n x y : nat.
 
@@ -25,7 +23,7 @@ Fixpoint eq_nat n m : Prop :=
   end.
 
 Theorem eq_nat_refl : forall n, eq_nat n n.
-  induction n; simpl in |- *; auto.
+  induction n; simpl; auto.
 Qed.
 Hint Resolve eq_nat_refl: arith v62.
 
@@ -37,7 +35,7 @@ Qed.
 Hint Immediate eq_eq_nat: arith v62.
 
 Lemma eq_nat_eq : forall n m, eq_nat n m -> n = m.
-  induction n; induction m; simpl in |- *; contradiction || auto with arith.
+  induction n; induction m; simpl; contradiction || auto with arith.
 Qed.
 Hint Immediate eq_nat_eq: arith v62.
 
@@ -57,11 +55,11 @@ Proof.
   induction n.
   destruct m as [| n].
   auto with arith.
-  intros; right; red in |- *; trivial with arith.
+  intros; right; red; trivial with arith.
   destruct m as [| n0].
-  right; red in |- *; auto with arith.
+  right; red; auto with arith.
   intros.
-  simpl in |- *.
+  simpl.
   apply IHn.
 Defined.
 
@@ -78,12 +76,12 @@ Fixpoint beq_nat n m : bool :=
 
 Lemma beq_nat_refl : forall n, true = beq_nat n n.
 Proof.
-  intro x; induction x; simpl in |- *; auto.
+  intro x; induction x; simpl; auto.
 Qed.
 
 Definition beq_nat_eq : forall x y, true = beq_nat x y -> x = y.
 Proof.
-  double induction x y; simpl in |- *.
+  double induction x y; simpl.
     reflexivity.
     intros n H1 H2. discriminate H2.
     intros n H1 H2. discriminate H2.
diff --git a/theories/Arith/Euclid.v b/theories/Arith/Euclid.v
index f32e1ad4..3abdff98 100644
--- a/theories/Arith/Euclid.v
+++ b/theories/Arith/Euclid.v
@@ -1,71 +1,68 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*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.
+  intros b H a; pattern a; apply gt_wf_rec; intros n H0.
   elim (le_gt_dec b n).
   intro lebn.
   elim (H0 (n - b)); auto with arith.
   intros q r g e.
-  apply divex with (S q) r; simpl in |- *; auto with arith.
+  apply divex with (S q) r; simpl; auto with arith.
   elim plus_assoc.
   elim e; auto with arith.
   intros gtbn.
-  apply divex with 0 n; simpl in |- *; auto with arith.
-Qed.
+  apply divex with 0 n; simpl; auto with arith.
+Defined.
 
 Lemma quotient :
   forall n,
     n > 0 ->
     forall m:nat, {q : nat |  exists r : nat, m = q * n + r /\ n > r}.
 Proof.
-  intros b H a; pattern a in |- *; apply gt_wf_rec; intros n H0.
+  intros b H a; pattern a; apply gt_wf_rec; intros n H0.
   elim (le_gt_dec b n).
   intro lebn.
   elim (H0 (n - b)); auto with arith.
   intros q Hq; exists (S q).
   elim Hq; intros r Hr.
-  exists r; simpl in |- *; elim Hr; intros.
+  exists r; simpl; elim Hr; intros.
   elim plus_assoc.
   elim H1; auto with arith.
   intros gtbn.
-  exists 0; exists n; simpl in |- *; auto with arith.
-Qed.
+  exists 0; exists n; simpl; auto with arith.
+Defined.
 
 Lemma modulo :
   forall n,
     n > 0 ->
     forall m:nat, {r : nat |  exists q : nat, m = q * n + r /\ n > r}.
 Proof.
-  intros b H a; pattern a in |- *; apply gt_wf_rec; intros n H0.
+  intros b H a; pattern a; apply gt_wf_rec; intros n H0.
   elim (le_gt_dec b n).
   intro lebn.
   elim (H0 (n - b)); auto with arith.
   intros r Hr; exists r.
   elim Hr; intros q Hq.
-  elim Hq; intros; exists (S q); simpl in |- *.
+  elim Hq; intros; exists (S q); simpl.
   elim plus_assoc.
   elim H1; auto with arith.
   intros gtbn.
-  exists n; exists 0; simpl in |- *; auto with arith.
-Qed.
+  exists n; exists 0; simpl; auto with arith.
+Defined.
diff --git a/theories/Arith/Even.v b/theories/Arith/Even.v
index 5bab97c2..4f679fe2 100644
--- a/theories/Arith/Even.v
+++ b/theories/Arith/Even.v
@@ -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-2012     *)
 (*   \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. *)
 
-Open Local Scope nat_scope.
+Local Open Scope nat_scope.
 
 Implicit Types m n : nat.
 
@@ -147,7 +145,7 @@ Lemma even_mult_aux :
   forall n m,
     (odd (n * m) <-> odd n /\ odd m) /\ (even (n * m) <-> even n \/ even m).
 Proof.
-  intros n; elim n; simpl in |- *; auto with arith.
+  intros n; elim n; simpl; auto with arith.
   intros m; split; split; auto with arith.
   intros H'; inversion H'.
   intros H'; elim H'; auto.
diff --git a/theories/Arith/Factorial.v b/theories/Arith/Factorial.v
index 3b434b96..37aa1b2c 100644
--- a/theories/Arith/Factorial.v
+++ b/theories/Arith/Factorial.v
@@ -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-2012     *)
 (*   \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.
-Open Local Scope nat_scope.
+Local Open 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.
-  simple induction n; unfold lt in |- *; simpl in |- *; auto with arith.
+  simple induction n; unfold lt; simpl; auto with arith.
 Qed.
 
 Lemma fact_neq_0 : forall n:nat, fact n <> 0.
 Proof.
   intro.
-  apply sym_not_eq.
+  apply not_eq_sym.
   apply lt_O_neq.
   apply lt_O_fact.
 Qed.
diff --git a/theories/Arith/Gt.v b/theories/Arith/Gt.v
index 43df01c0..31b15507 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-2012     *)
 (*   \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.
@@ -17,7 +15,7 @@ Definition gt (n m:nat) := m < n.
 Require Import Le.
 Require Import Lt.
 Require Import Plus.
-Open Local Scope nat_scope.
+Local Open Scope nat_scope.
 
 Implicit Types m n p : nat.
 
@@ -49,7 +47,7 @@ Hint Immediate gt_S_n: arith v62.
 
 Theorem gt_S : forall n m, S n > m -> n > m \/ m = n.
 Proof.
-  intros n m H; unfold gt in |- *; apply le_lt_or_eq; auto with arith.
+  intros n m H; unfold gt; apply le_lt_or_eq; auto with arith.
 Qed.
 
 Lemma gt_pred : forall n m, m > S n -> pred m > n.
@@ -112,23 +110,23 @@ Hint Resolve le_gt_S: arith v62.
 
 Theorem le_gt_trans : forall n m p, m <= n -> m > p -> n > p.
 Proof.
-  red in |- *; intros; apply lt_le_trans with m; auto with arith.
+  red; intros; apply lt_le_trans with m; auto with arith.
 Qed.
 
 Theorem gt_le_trans : forall n m p, n > m -> p <= m -> n > p.
 Proof.
-  red in |- *; intros; apply le_lt_trans with m; auto with arith.
+  red; intros; apply le_lt_trans with m; auto with arith.
 Qed.
 
 Lemma gt_trans : forall n m p, n > m -> m > p -> n > p.
 Proof.
-  red in |- *; intros n m p H1 H2.
+  red; intros n m p H1 H2.
   apply lt_trans with m; auto with arith.
 Qed.
 
 Theorem gt_trans_S : forall n m p, S n > m -> m > p -> n > p.
 Proof.
-  red in |- *; intros; apply lt_le_trans with m; auto with arith.
+  red; intros; apply lt_le_trans with m; auto with arith.
 Qed.
 
 Hint Resolve gt_trans_S le_gt_trans gt_le_trans: arith v62.
@@ -144,7 +142,7 @@ Qed.
 
 Lemma plus_gt_reg_l : forall n m p, p + n > p + m -> n > m.
 Proof.
-  red in |- *; intros n m p H; apply plus_lt_reg_l with p; auto with arith.
+  red; intros n m p H; apply plus_lt_reg_l with p; auto with arith.
 Qed.
 
 Lemma plus_gt_compat_l : forall n m p, n > m -> p + n > p + m.
diff --git a/theories/Arith/Le.v b/theories/Arith/Le.v
index b73959e7..1febb76b 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-2012     *)
 (*   \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 :=
@@ -18,7 +16,7 @@ where "n <= m" := (le n m) : nat_scope.
 >>
  *)
 
-Open Local Scope nat_scope.
+Local Open Scope nat_scope.
 
 Implicit Types m n p : nat.
 
@@ -48,8 +46,8 @@ Qed.
 
 Theorem le_Sn_0 : forall n, ~ S n <= 0.
 Proof.
-  red in |- *; intros n H.
-  change (IsSucc 0) in |- *; elim H; simpl in |- *; auto with arith.
+  red; intros n H.
+  change (IsSucc 0); elim H; simpl; auto with arith.
 Qed.
 
 Hint Resolve le_0_n le_Sn_0: arith v62.
@@ -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..8559b782 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-2012     *)
 (*   \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.
@@ -16,7 +14,7 @@ Infix "<" := lt : nat_scope.
 *)
 
 Require Import Le.
-Open Local Scope nat_scope.
+Local Open Scope nat_scope.
 
 Implicit Types m n p : nat.
 
@@ -53,7 +51,7 @@ Qed.
 
 Theorem lt_not_le : forall n m, n < m -> ~ m <= n.
 Proof.
-  red in |- *; intros n m Lt Le; exact (le_not_lt m n Le Lt).
+  red; intros n m Lt Le; exact (le_not_lt m n Le Lt).
 Qed.
 Hint Immediate le_not_lt lt_not_le: arith v62.
 
@@ -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 *)
 
@@ -109,12 +107,12 @@ Qed.
 
 Lemma lt_pred : forall n m, S n < m -> n < pred m.
 Proof.
-induction 1; simpl in |- *; auto with arith.
+induction 1; simpl; auto with arith.
 Qed.
 Hint Immediate lt_pred: arith v62.
 
 Lemma lt_pred_n_n : forall n, 0 < n -> pred n < n.
-destruct 1; simpl in |- *; auto with arith.
+destruct 1; simpl; auto with arith.
 Qed.
 Hint Resolve lt_pred_n_n: arith v62.
 
@@ -161,7 +159,7 @@ Hint Immediate lt_le_weak: arith v62.
 
 Theorem le_or_lt : forall n m, n <= m \/ m < n.
 Proof.
-  intros n m; pattern n, m in |- *; apply nat_double_ind; auto with arith.
+  intros n m; pattern n, m; apply nat_double_ind; auto with arith.
   induction 1; auto with arith.
 Qed.
 
@@ -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..5623564a 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-2012     *)
 (*   \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..a2a7930d 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-2012     *)
 (*   \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 Import NPeano.
 
-Require Export MinMax.
-
-Open Local Scope nat_scope.
+Local Open 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..48024331 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-2012     *)
 (*   \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 :=
@@ -23,7 +21,7 @@ where "n - m" := (minus n m) : nat_scope.
 Require Import Lt.
 Require Import Le.
 
-Open Local Scope nat_scope.
+Local Open Scope nat_scope.
 
 Implicit Types m n p : nat.
 
@@ -31,7 +29,7 @@ Implicit Types m n p : nat.
 
 Lemma minus_n_O : forall n, n = n - 0.
 Proof.
-  induction n; simpl in |- *; auto with arith.
+  induction n; simpl; auto with arith.
 Qed.
 Hint Resolve minus_n_O: arith v62.
 
@@ -39,21 +37,21 @@ Hint Resolve minus_n_O: arith v62.
 
 Lemma minus_Sn_m : forall n m, m <= n -> S (n - m) = S n - m.
 Proof.
-  intros n m Le; pattern m, n in |- *; apply le_elim_rel; simpl in |- *;
+  intros n m Le; pattern m, n; apply le_elim_rel; simpl;
     auto with arith.
 Qed.
 Hint Resolve minus_Sn_m: arith v62.
 
 Theorem pred_of_minus : forall n, pred n = n - 1.
 Proof.
-  intro x; induction x; simpl in |- *; auto with arith.
+  intro x; induction x; simpl; auto with arith.
 Qed.
 
 (** * Diagonal *)
 
 Lemma minus_diag : forall n, n - n = 0.
 Proof.
-  induction n; simpl in |- *; auto with arith.
+  induction n; simpl; auto with arith.
 Qed.
 
 Lemma minus_diag_reverse : forall n, 0 = n - n.
@@ -68,7 +66,7 @@ Notation minus_n_n := minus_diag_reverse.
 
 Lemma minus_plus_simpl_l_reverse : forall n m p, n - m = p + n - (p + m).
 Proof.
-  induction p; simpl in |- *; auto with arith.
+  induction p; simpl; auto with arith.
 Qed.
 Hint Resolve minus_plus_simpl_l_reverse: arith v62.
 
@@ -76,7 +74,7 @@ Hint Resolve minus_plus_simpl_l_reverse: arith v62.
 
 Lemma plus_minus : forall n m p, n = m + p -> p = n - m.
 Proof.
-  intros n m p; pattern m, n in |- *; apply nat_double_ind; simpl in |- *;
+  intros n m p; pattern m, n; apply nat_double_ind; simpl;
     intros.
   replace (n0 - 0) with n0; auto with arith.
   absurd (0 = S (n0 + p)); auto with arith.
@@ -85,20 +83,20 @@ Qed.
 Hint Immediate plus_minus: arith v62.
 
 Lemma minus_plus : forall n m, n + m - n = m.
-  symmetry  in |- *; auto with arith.
+  symmetry ; auto with arith.
 Qed.
 Hint Resolve minus_plus: arith v62.
 
 Lemma le_plus_minus : forall n m, n <= m -> m = n + (m - n).
 Proof.
-  intros n m Le; pattern n, m in |- *; apply le_elim_rel; simpl in |- *;
+  intros n m Le; pattern n, m; apply le_elim_rel; simpl;
     auto with arith.
 Qed.
 Hint Resolve le_plus_minus: arith v62.
 
 Lemma le_plus_minus_r : forall n m, n <= m -> n + (m - n) = m.
 Proof.
-  symmetry  in |- *; auto with arith.
+  symmetry ; auto with arith.
 Qed.
 Hint Resolve le_plus_minus_r: arith v62.
 
@@ -134,7 +132,7 @@ Qed.
 
 Lemma lt_minus : forall n m, m <= n -> 0 < m -> n - m < n.
 Proof.
-  intros n m Le; pattern m, n in |- *; apply le_elim_rel; simpl in |- *;
+  intros n m Le; pattern m, n; apply le_elim_rel; simpl;
     auto using le_minus with arith.
     intros; absurd (0 < 0); auto with arith.
 Qed.
@@ -142,7 +140,7 @@ Hint Resolve lt_minus: arith v62.
 
 Lemma lt_O_minus_lt : forall n m, 0 < n - m -> m < n.
 Proof.
-  intros n m; pattern n, m in |- *; apply nat_double_ind; simpl in |- *;
+  intros n m; pattern n, m; apply nat_double_ind; simpl;
     auto with arith.
   intros; absurd (0 < 0); trivial with arith.
 Qed.
@@ -150,9 +148,9 @@ Hint Immediate lt_O_minus_lt: arith v62.
 
 Theorem not_le_minus_0 : forall n m, ~ m <= n -> n - m = 0.
 Proof.
-  intros y x; pattern y, x in |- *; apply nat_double_ind;
-    [ simpl in |- *; trivial with arith
+  intros y x; pattern y, x; apply nat_double_ind;
+    [ simpl; trivial with arith
       | intros n H; absurd (0 <= S n); [ assumption | apply le_O_n ]
-      | simpl in |- *; intros n m H1 H2; apply H1; unfold not in |- *; intros H3;
+      | simpl; intros n m H1 H2; apply H1; unfold not; intros H3;
 	apply H2; apply le_n_S; assumption ].
 Qed.
diff --git a/theories/Arith/Mult.v b/theories/Arith/Mult.v
index 5dd61d67..cbb9b376 100644
--- a/theories/Arith/Mult.v
+++ b/theories/Arith/Mult.v
@@ -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-2012     *)
 (*   \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.
 Require Export Le.
 
-Open Local Scope nat_scope.
+Local Open Scope nat_scope.
 
 Implicit Types m n p : nat.
 
@@ -25,7 +23,7 @@ Implicit Types m n p : nat.
 
 Lemma mult_0_r : forall n, n * 0 = 0.
 Proof.
-  intro; symmetry  in |- *; apply mult_n_O.
+  intro; symmetry ; apply mult_n_O.
 Qed.
 
 Lemma mult_0_l : forall n, 0 * n = 0.
@@ -37,7 +35,7 @@ Qed.
 
 Lemma mult_1_l : forall n, 1 * n = n.
 Proof.
-  simpl in |- *; auto with arith.
+  simpl; auto with arith.
 Qed.
 Hint Resolve mult_1_l: arith v62.
 
@@ -70,12 +68,12 @@ Hint Resolve mult_plus_distr_r: arith v62.
 Lemma mult_plus_distr_l : forall n m p, n * (m + p) = n * m + n * p.
 Proof.
   induction n. trivial.
-  intros. simpl in |- *. rewrite IHn. symmetry. apply plus_permute_2_in_4.
+  intros. simpl. rewrite IHn. symmetry. apply plus_permute_2_in_4.
 Qed.
 
 Lemma mult_minus_distr_r : forall n m p, (n - m) * p = n * p - m * p.
 Proof.
-  intros; induction n m using nat_double_ind; simpl; auto with arith.
+  intros; induction n, m using nat_double_ind; simpl; auto with arith.
   rewrite <- minus_plus_simpl_l_reverse; auto with arith.
 Qed.
 Hint Resolve mult_minus_distr_r: arith v62.
@@ -139,13 +137,13 @@ Qed.
 
 Lemma mult_O_le : forall n m, m = 0 \/ n <= m * n.
 Proof.
-  induction m; simpl in |- *; auto with arith.
+  induction m; simpl; auto with arith.
 Qed.
 Hint Resolve mult_O_le: arith v62.
 
 Lemma mult_le_compat_l : forall n m p, n <= m -> p * n <= p * m.
 Proof.
-  induction p as [| p IHp]; intros; simpl in |- *.
+  induction p as [| p IHp]; intros; simpl.
   apply le_n.
   auto using plus_le_compat.
 Qed.
@@ -169,7 +167,7 @@ Proof.
   assumption.
   apply le_plus_l.
   (* m*p<=m0*q -> m*p<=(S m0)*q *)
-  simpl in |- *; apply le_trans with (m0 * q).
+  simpl; apply le_trans with (m0 * q).
   assumption.
   apply le_plus_r.
 Qed.
@@ -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.
@@ -231,7 +232,7 @@ Fixpoint mult_acc (s:nat) m n : nat :=
 
 Lemma mult_acc_aux : forall n m p, m + n * p = mult_acc m p n.
 Proof.
-  induction n as [| p IHp]; simpl in |- *; auto.
+  induction n as [| p IHp]; simpl; auto.
   intros s m; rewrite <- plus_tail_plus; rewrite <- IHp.
   rewrite <- plus_assoc_reverse; apply f_equal2; auto.
   rewrite plus_comm; auto.
@@ -241,7 +242,7 @@ Definition tail_mult n m := mult_acc 0 m n.
 
 Lemma mult_tail_mult : forall n m, n * m = tail_mult n m.
 Proof.
-  intros; unfold tail_mult in |- *; rewrite <- mult_acc_aux; auto.
+  intros; unfold tail_mult; rewrite <- mult_acc_aux; auto.
 Qed.
 
 (** [TailSimpl] transforms any [tail_plus] and [tail_mult] into [plus]
@@ -249,4 +250,4 @@ Qed.
 
 Ltac tail_simpl :=
   repeat rewrite <- plus_tail_plus; repeat rewrite <- mult_tail_mult;
-    simpl in |- *.
+    simpl.
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..e0bed0d3 100644
--- a/theories/Arith/Peano_dec.v
+++ b/theories/Arith/Peano_dec.v
@@ -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-2012     *)
 (*   \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.
-
-Open Local Scope nat_scope.
+Require Eqdep_dec.
+Require Import Le Lt.
+Local Open Scope nat_scope.
 
 Implicit Types m n x y : nat.
 
@@ -30,5 +29,24 @@ Defined.
 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.
+  intros x y; unfold decidable; 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..5428ada3 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 :=
@@ -22,45 +20,32 @@ where "n + m" := (plus n m) : nat_scope.
 Require Import Le.
 Require Import Lt.
 
-Open Local Scope nat_scope.
+Local Open 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 *)
 
 Lemma plus_comm : forall n m, n + m = m + n.
 Proof.
-  intros n m; elim n; simpl in |- *; auto with arith.
+  intros n m; elim n; simpl; auto with arith.
   intros y H; elim (plus_n_Sm m y); auto with arith.
 Qed.
 Hint Immediate plus_comm: arith v62.
 
 (** * Associativity *)
 
-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.
-  intros n m p; elim n; simpl in |- *; auto with arith.
+  intros n m p; elim n; simpl; auto with arith.
 Qed.
 Hint Resolve plus_assoc: arith v62.
 
@@ -79,42 +64,42 @@ Hint Resolve plus_assoc_reverse: arith v62.
 
 Lemma plus_reg_l : forall n m p, p + n = p + m -> n = m.
 Proof.
-  intros m p n; induction n; simpl in |- *; auto with arith.
+  intros m p n; induction n; simpl; auto with arith.
 Qed.
 
 Lemma plus_le_reg_l : forall n m p, p + n <= p + m -> n <= m.
 Proof.
-  induction p; simpl in |- *; auto with arith.
+  induction p; simpl; auto with arith.
 Qed.
 
 Lemma plus_lt_reg_l : forall n m p, p + n < p + m -> n < m.
 Proof.
-  induction p; simpl in |- *; auto with arith.
+  induction p; simpl; auto with arith.
 Qed.
 
 (** * Compatibility with order *)
 
 Lemma plus_le_compat_l : forall n m p, n <= m -> p + n <= p + m.
 Proof.
-  induction p; simpl in |- *; auto with arith.
+  induction p; simpl; auto with arith.
 Qed.
 Hint Resolve plus_le_compat_l: arith v62.
 
 Lemma plus_le_compat_r : forall n m p, n <= m -> n + p <= m + p.
 Proof.
-  induction 1; simpl in |- *; auto with arith.
+  induction 1; simpl; auto with arith.
 Qed.
 Hint Resolve plus_le_compat_r: arith v62.
 
 Lemma le_plus_l : forall n m, n <= n + m.
 Proof.
-  induction n; simpl in |- *; auto with arith.
+  induction n; simpl; auto with arith.
 Qed.
 Hint Resolve le_plus_l: arith v62.
 
 Lemma le_plus_r : forall n m, m <= n + m.
 Proof.
-  intros n m; elim n; simpl in |- *; auto with arith.
+  intros n m; elim n; simpl; auto with arith.
 Qed.
 Hint Resolve le_plus_r: arith v62.
 
@@ -132,7 +117,7 @@ Hint Immediate lt_plus_trans: arith v62.
 
 Lemma plus_lt_compat_l : forall n m p, n < m -> p + n < p + m.
 Proof.
-  induction p; simpl in |- *; auto with arith.
+  induction p; simpl; auto with arith.
 Qed.
 Hint Resolve plus_lt_compat_l: arith v62.
 
@@ -146,18 +131,18 @@ Hint Resolve plus_lt_compat_r: arith v62.
 Lemma plus_le_compat : forall n m p q, n <= m -> p <= q -> n + p <= m + q.
 Proof.
   intros n m p q H H0.
-  elim H; simpl in |- *; auto with arith.
+  elim H; simpl; auto with arith.
 Qed.
 
 Lemma plus_le_lt_compat : forall n m p q, n <= m -> p < q -> n + p < m + q.
 Proof.
-  unfold lt in |- *. intros. change (S n + p <= m + q) in |- *. rewrite plus_Snm_nSm.
+  unfold lt. intros. change (S n + p <= m + q). rewrite plus_Snm_nSm.
   apply plus_le_compat; assumption.
 Qed.
 
 Lemma plus_lt_le_compat : forall n m p q, n < m -> p <= q -> n + p < m + q.
 Proof.
-  unfold lt in |- *. intros. change (S n + p <= m + q) in |- *. apply plus_le_compat; assumption.
+  unfold lt. intros. change (S n + p <= m + q). apply plus_le_compat; assumption.
 Qed.
 
 Lemma plus_lt_compat : forall n m p q, n < m -> p < q -> n + p < m + q.
@@ -205,8 +190,8 @@ Fixpoint tail_plus n m : nat :=
   end.
 
 Lemma plus_tail_plus : forall n m, n + m = tail_plus n m.
-induction n as [| n IHn]; simpl in |- *; auto.
-intro m; rewrite <- IHn; simpl in |- *; auto.
+induction n as [| n IHn]; simpl; auto.
+intro m; rewrite <- IHn; simpl; auto.
 Qed.
 
 (** * Discrimination *)
diff --git a/theories/Arith/Wf_nat.v b/theories/Arith/Wf_nat.v
index 23419531..b5545123 100644
--- a/theories/Arith/Wf_nat.v
+++ b/theories/Arith/Wf_nat.v
@@ -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-2012     *)
 (*   \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.
 
-Open Local Scope nat_scope.
+Local Open Scope nat_scope.
 
 Implicit Types m n p : nat.
 
@@ -26,14 +24,14 @@ Definition gtof (a b:A) := f b > f a.
 
 Theorem well_founded_ltof : well_founded ltof.
 Proof.
-  red in |- *.
+  red.
   cut (forall n (a:A), f a < n -> Acc ltof a).
   intros H a; apply (H (S (f a))); auto with arith.
   induction n.
   intros; absurd (f a < 0); auto with arith.
   intros a ltSma.
   apply Acc_intro.
-  unfold ltof in |- *; intros b ltfafb.
+  unfold ltof; intros b ltfafb.
   apply IHn.
   apply lt_le_trans with (f a); auto with arith.
 Defined.
@@ -75,7 +73,7 @@ Proof.
   intros; absurd (f a < 0); auto with arith.
   intros a ltSma.
   apply F.
-  unfold ltof in |- *; intros b ltfafb.
+  unfold ltof; intros b ltfafb.
   apply IHn.
   apply lt_le_trans with (f a); auto with arith.
 Defined.
@@ -110,7 +108,7 @@ Hypothesis H_compat : forall x y:A, R x y -> f x < f y.
 
 Theorem well_founded_lt_compat : well_founded R.
 Proof.
-  red in |- *.
+  red.
   cut (forall n (a:A), f a < n -> Acc R a).
   intros H a; apply (H (S (f a))); auto with arith.
   induction n.
@@ -163,8 +161,8 @@ Lemma lt_wf_double_rec :
      (forall p q, p < n -> P p q) ->
      (forall p, p < m -> P n p) -> P n m) -> forall n m, P n m.
 Proof.
-  intros P Hrec p; pattern p in |- *; apply lt_wf_rec.
-  intros n H q; pattern q in |- *; apply lt_wf_rec; auto with arith.
+  intros P Hrec p; pattern p; apply lt_wf_rec.
+  intros n H q; pattern q; apply lt_wf_rec; auto with arith.
 Defined.
 
 Lemma lt_wf_double_ind :
@@ -173,8 +171,8 @@ Lemma lt_wf_double_ind :
       (forall p (q:nat), p < n -> P p q) ->
       (forall p, p < m -> P n p) -> P n m) -> forall n m, P n m.
 Proof.
-  intros P Hrec p; pattern p in |- *; apply lt_wf_ind.
-  intros n H q; pattern q in |- *; apply lt_wf_ind; auto with arith.
+  intros P Hrec p; pattern p; apply lt_wf_ind.
+  intros n H q; pattern q; apply lt_wf_ind; auto with arith.
 Qed.
 
 Hint Resolve lt_wf: arith.
@@ -192,7 +190,7 @@ Section LT_WF_REL.
   Remark acc_lt_rel : forall x:A, (exists n, F x n) -> Acc R x.
   Proof.
     intros x [n fxn]; generalize dependent x.
-    pattern n in |- *; apply lt_wf_ind; intros.
+    pattern n; apply lt_wf_ind; intros.
     constructor; intros.
     destruct (F_compat y x) as (x0,H1,H2); trivial.
     apply (H x0); auto.
@@ -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..a947e4fd 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-2012     *)
 (*   \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).
@@ -592,12 +615,12 @@ Proof.
 Qed.
 Hint Resolve absurd_eq_true.
 
-(* A specific instance of trans_eq that preserves compatibility with
+(* A specific instance of eq_trans that preserves compatibility with
    old hint bool_2 *)
 
 Lemma trans_eq_bool : forall x y z:bool, x = y -> y = z -> x = z.
 Proof.
-  apply trans_eq.
+  apply eq_trans.
 Qed.
 Hint Resolve trans_eq_bool.
 
@@ -731,7 +754,7 @@ Notation "a &&& b" := (if a then b else false)
 Notation "a ||| b" := (if a then true else b)
  (at level 50, left associativity) : lazy_bool_scope.
 
-Open Local Scope lazy_bool_scope.
+Local Open Scope lazy_bool_scope.
 
 Lemma andb_lazy_alt : forall a b : bool, a && b = a &&& b.
 Proof.
@@ -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..34777491 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-2012     *)
 (*   \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   *)
@@ -53,12 +52,12 @@ Section Bool_eq_dec.
   Definition not_eq_false_beq : forall x y:A, x <> y -> false = beq x y.
   Proof.
     intros x y H.
-    symmetry  in |- *.
+    symmetry .
     apply not_true_is_false.
     intro.
     apply H.
     apply beq_eq.
-    symmetry  in |- *.
+    symmetry .
     assumption.
   Defined.
 
diff --git a/theories/Bool/Bvector.v b/theories/Bool/Bvector.v
index daf3a9fb..d7162e62 100644
--- a/theories/Bool/Bvector.v
+++ b/theories/Bool/Bvector.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-2012     *)
 (*   \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.
+Local Open Scope nat_scope.
 
 (**
 We build bit vectors in the spirit of List.v.
@@ -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..ae01b9da 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-2012     *)
 (*   \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..57ffa6a4 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-2012     *)
 (*   \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..5a9daa94 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-2012     *)
 (*   \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..e8798d0d 100644
--- a/theories/Bool/Zerob.v
+++ b/theories/Bool/Zerob.v
@@ -1,17 +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-2012     *)
 (*   \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.
 
-Open Local Scope nat_scope.
+Local Open Scope nat_scope.
 
 Definition zerob (n:nat) : bool :=
   match n with
@@ -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..cb1bdb1d 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-2012     *)
 (*   \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.
@@ -51,7 +49,7 @@ Definition swap_sumbool {A B} (x : { A } + { B }) : { B } + { A } :=
     | right H => @left _ _ H
   end.
 
-Open Local Scope program_scope.
+Local Open Scope program_scope.
 
 (** Invert the branches. *)
 
diff --git a/theories/Classes/Equivalence.v b/theories/Classes/Equivalence.v
index e562328d..e0f5a395 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-2012     *)
 (*   \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.
 
@@ -28,7 +26,7 @@ Unset Strict Implicit.
 Generalizable Variables A R eqA B S eqB.
 Local Obligation Tactic := simpl_relation.
 
-Open Local Scope signature_scope.
+Local Open Scope signature_scope.
 
 Definition equiv `{Equivalence A R} : relation A := R.
 
@@ -39,7 +37,7 @@ Notation " x === y " := (equiv x y) (at level 70, no associativity) : equiv_scop
 
 Notation " x =/= y " := (complement equiv x y) (at level 70, no associativity) : equiv_scope.
 
-Open Local Scope equiv_scope.
+Local Open Scope equiv_scope.
 
 (** Overloading for [PER]. *)
 
diff --git a/theories/Classes/Init.v b/theories/Classes/Init.v
index eea16129..06730095 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-2012     *)
 (*   \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..617ff190 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-2012     *)
 (*   \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.
 
@@ -81,19 +73,60 @@ End ProperNotations.
 
 Export ProperNotations.
 
-Open Local Scope signature_scope.
+Local Open Scope signature_scope.
+
+(** [solve_proper] try to solve the goal [Proper (?==> ... ==>?) f]
+    by repeated introductions and setoid rewrites. It should work
+    fine when [f] is a combination of already known morphisms and
+    quantifiers. *)
+
+Ltac solve_respectful t :=
+ match goal with
+   | |- respectful _ _ _ _ =>
+     let H := fresh "H" in
+     intros ? ? H; solve_respectful ltac:(setoid_rewrite H; t)
+   | _ => t; reflexivity
+ end.
+
+Ltac solve_proper := unfold Proper; solve_respectful ltac:(idtac).
+
+(** [f_equiv] is a clone of [f_equal] that handles setoid equivalences.
+    For example, if we know that [f] is a morphism for [E1==>E2==>E],
+    then the goal [E (f x y) (f x' y')] will be transformed by [f_equiv]
+    into the subgoals [E1 x x'] and [E2 y y'].
+*)
+
+Ltac f_equiv :=
+ match goal with
+  | |- ?R (?f ?x) (?f' _) =>
+    let T := type of x in
+    let Rx := fresh "R" in
+    evar (Rx : 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..2252e42f 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-2012     *)
 (*   \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..ea2afb30 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-2012     *)
 (*   \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..71647953 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-2012     *)
 (*   \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. *)
@@ -284,7 +286,7 @@ Definition predicate_implication {l : list Type} :=
 Infix "<∙>" := predicate_equivalence (at level 95, no associativity) : predicate_scope.
 Infix "-∙>" := predicate_implication (at level 70, right associativity) : predicate_scope.
 
-Open Local Scope predicate_scope.
+Local Open Scope predicate_scope.
 
 (** The pointwise liftings of conjunction and disjunctions.
    Note that these are [binary_operation]s, building new relations out of old ones. *)
@@ -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..6efc2302 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-2012     *)
 (*   \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..ac1e1dc4 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-2012     *)
 (*   \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.
@@ -55,7 +50,7 @@ Definition swap_sumbool {A B} (x : { A } + { B }) : { B } + { A } :=
 
 Require Import Coq.Program.Program.
 
-Open Local Scope program_scope.
+Local Open Scope program_scope.
 
 (** Invert the branches. *)
 
@@ -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..fa939e22 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-2012     *)
 (*   \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.
@@ -148,7 +146,7 @@ Tactic Notation "setoid_replace" constr(x) "with" constr(y)
 
 Require Import Coq.Program.Tactics.
 
-Open Local Scope signature_scope.
+Local Open Scope signature_scope.
 
 Ltac red_subst_eq_morphism concl :=
   match concl with
diff --git a/theories/FSets/FMapAVL.v b/theories/FSets/FMapAVL.v
index 49f595d7..c68216e6 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.
@@ -34,11 +32,13 @@ Notation "s #2" := (snd s) (at level 9, format "s '#2'") : pair_scope.
    preservation *)
 
 Module Raw (Import I:Int)(X: OrderedType).
-Open Local Scope pair_scope.
-Open Local Scope lazy_bool_scope.
-Open Local Scope Int_scope.
+Local Open Scope pair_scope.
+Local Open Scope lazy_bool_scope.
+Local Open Scope Int_scope.
+Local Notation int := I.t.
 
 Definition key := X.t.
+Hint Transparent key.
 
 (** * Trees *)
 
@@ -542,12 +542,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]
@@ -604,12 +604,12 @@ Qed.
 
 Lemma lt_leaf : forall x, lt_tree x (Leaf elt).
 Proof.
- unfold lt_tree in |- *; intros; intuition_in.
+ unfold lt_tree; intros; intuition_in.
 Qed.
 
 Lemma gt_leaf : forall x, gt_tree x (Leaf elt).
 Proof.
-  unfold gt_tree in |- *; intros; intuition_in.
+  unfold gt_tree; intros; intuition_in.
 Qed.
 
 Lemma lt_tree_node : forall x y l r e h,
@@ -823,7 +823,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 +1113,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 +1333,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).
@@ -1389,8 +1389,8 @@ Lemma fold_equiv_aux :
  L.fold f (elements_aux acc s) a = L.fold f acc (fold f s a).
 Proof.
  simple induction s.
- simpl in |- *; intuition.
- simpl in |- *; intros.
+ simpl; intuition.
+ simpl; intros.
  rewrite H.
  simpl.
  apply H0.
@@ -1400,11 +1400,11 @@ Lemma fold_equiv :
  forall (A : Type) (s : t elt) (f : key -> elt -> A -> A) (a : A),
  fold f s a = fold' f s a.
 Proof.
- unfold fold', elements in |- *.
- simple induction s; simpl in |- *; auto; intros.
+ unfold fold', elements.
+ simple induction s; simpl; auto; intros.
  rewrite fold_equiv_aux.
  rewrite H0.
- simpl in |- *; auto.
+ simpl; auto.
 Qed.
 
 Lemma fold_1 :
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..e1c60351 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].
@@ -36,8 +34,8 @@ Module AvlProofs (Import I:Int)(X: OrderedType).
 Module Import Raw := Raw I X.
 Module Import II:=MoreInt(I).
 Import Raw.Proofs.
-Open Local Scope pair_scope.
-Open Local Scope Int_scope.
+Local Open Scope pair_scope.
+Local Open Scope Int_scope.
 
 Ltac omega_max := i2z_refl; romega with Z.
 
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..c59f7c22 100644
--- a/theories/FSets/FMapPositive.v
+++ b/theories/FSets/FMapPositive.v
@@ -6,14 +6,12 @@
 (*         *       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.
 
 Set Implicit Arguments.
-Open Local Scope positive_scope.
+Local Open Scope positive_scope.
 
 Local Unset Elimination Schemes.
 Local Unset Case Analysis Schemes.
@@ -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..1ac544e1 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
@@ -46,7 +44,7 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E.
   Definition add : forall (x : elt) (s : t), {s' : t | Add x s s'}.
   Proof.
     intros; exists (add x s); auto.
-    unfold Add in |- *; intuition.
+    unfold Add; intuition.
     elim (E.eq_dec x y); auto.
     intros; right.
     eapply add_3; eauto.
@@ -133,7 +131,7 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E.
    forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}),
    compat_P E.eq P -> compat_bool E.eq (fdec Pdec).
   Proof.
-    unfold compat_P, compat_bool, Proper, respectful, fdec in |- *; intros.
+    unfold compat_P, compat_bool, Proper, respectful, fdec; intros.
     generalize (E.eq_sym H0); case (Pdec x); case (Pdec y); firstorder.
   Qed.
 
@@ -149,11 +147,11 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E.
     intuition.
     eauto with set.
     generalize (filter_2 H0 H1).
-    unfold fdec in |- *.
+    unfold fdec.
     case (Pdec x); intuition.
     inversion H2.
     apply filter_3; auto.
-    unfold fdec in |- *; simpl in |- *.
+    unfold fdec; simpl.
     case (Pdec x); intuition.
   Qed.
 
@@ -164,17 +162,17 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E.
     intros.
     generalize (for_all_1 (s:=s) (f:=fdec Pdec))
      (for_all_2 (s:=s) (f:=fdec Pdec)).
-    case (for_all (fdec Pdec) s); unfold For_all in |- *; [ left | right ];
+    case (for_all (fdec Pdec) s); unfold For_all; [ left | right ];
      intros.
     assert (compat_bool E.eq (fdec Pdec)); auto.
-    generalize (H0 H3 (refl_equal _) _ H2).
-    unfold fdec in |- *.
+    generalize (H0 H3 Logic.eq_refl _ H2).
+    unfold fdec.
     case (Pdec x); intuition.
     inversion H4.
     intuition.
     absurd (false = true); [ auto with bool | apply H; auto ].
     intro.
-    unfold fdec in |- *.
+    unfold fdec.
     case (Pdec x); intuition.
   Qed.
 
@@ -185,19 +183,19 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E.
     intros.
     generalize (exists_1 (s:=s) (f:=fdec Pdec))
      (exists_2 (s:=s) (f:=fdec Pdec)).
-    case (exists_ (fdec Pdec) s); unfold Exists in |- *; [ left | right ];
+    case (exists_ (fdec Pdec) s); unfold Exists; [ left | right ];
      intros.
     elim H0; auto; intros.
     exists x; intuition.
     generalize H4.
-    unfold fdec in |- *.
+    unfold fdec.
     case (Pdec x); intuition.
     inversion H2.
     intuition.
     elim H2; intros.
     absurd (false = true); [ auto with bool | apply H; auto ].
     exists x; intuition.
-    unfold fdec in |- *.
+    unfold fdec.
     case (Pdec x); intuition.
   Qed.
 
@@ -214,26 +212,26 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E.
     exists (partition (fdec Pdec) s).
     generalize (partition_1 s (f:=fdec Pdec)) (partition_2 s (f:=fdec Pdec)).
     case (partition (fdec Pdec) s).
-    intros s1 s2; simpl in |- *.
+    intros s1 s2; simpl.
     intros; assert (compat_bool E.eq (fdec Pdec)); auto.
     intros; assert (compat_bool E.eq (fun x => negb (fdec Pdec x))).
-    generalize H2; unfold compat_bool, Proper, respectful in |- *; intuition;
+    generalize H2; unfold compat_bool, Proper, respectful; intuition;
      apply (f_equal negb); auto.
     intuition.
-    generalize H4; unfold For_all, Equal in |- *; intuition.
+    generalize H4; unfold For_all, Equal; intuition.
     elim (H0 x); intros.
     assert (fdec Pdec x = true).
      eapply filter_2; eauto with set.
-    generalize H8; unfold fdec in |- *; case (Pdec x); intuition.
+    generalize H8; unfold fdec; case (Pdec x); intuition.
     inversion H9.
-    generalize H; unfold For_all, Equal in |- *; intuition.
+    generalize H; unfold For_all, Equal; intuition.
     elim (H0 x); intros.
     cut ((fun x => negb (fdec Pdec x)) x = true).
-    unfold fdec in |- *; case (Pdec x); intuition.
-      change ((fun x => negb (fdec Pdec x)) x = true) in |- *.
+    unfold fdec; case (Pdec x); intuition.
+      change ((fun x => negb (fdec Pdec x)) x = true).
       apply (filter_2 (s:=s) (x:=x)); auto.
-    set (b := fdec Pdec x) in *; generalize (refl_equal b);
-     pattern b at -1 in |- *; case b; unfold b in |- *;
+    set (b := fdec Pdec x) in *; generalize (Logic.eq_refl b);
+     pattern b at -1; case b; unfold b;
      [ left | right ].
     elim (H4 x); intros _ B; apply B; auto with set.
     elim (H x); intros _ B; apply B; auto with set.
@@ -310,7 +308,7 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E.
     intros;
      generalize (min_elt_1 (s:=s)) (min_elt_2 (s:=s)) (min_elt_3 (s:=s)).
     case (min_elt s); [ left | right ]; auto.
-    exists e; unfold For_all in |- *; eauto.
+    exists e; unfold For_all; eauto.
   Qed.
 
   Definition max_elt :
@@ -320,7 +318,7 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E.
     intros;
      generalize (max_elt_1 (s:=s)) (max_elt_2 (s:=s)) (max_elt_3 (s:=s)).
     case (max_elt s); [ left | right ]; auto.
-    exists e; unfold For_all in |- *; eauto.
+    exists e; unfold For_all; eauto.
   Qed.
 
   Definition elt := elt.
@@ -362,7 +360,7 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E.
 
   Lemma empty_1 : Empty empty.
   Proof.
-    unfold empty in |- *; case M.empty; auto.
+    unfold empty; case M.empty; auto.
   Qed.
 
   Definition is_empty (s : t) : bool :=
@@ -370,12 +368,12 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E.
 
   Lemma is_empty_1 : forall s : t, Empty s -> is_empty s = true.
   Proof.
-    intros; unfold is_empty in |- *; case (M.is_empty s); auto.
+    intros; unfold is_empty; case (M.is_empty s); auto.
   Qed.
 
   Lemma is_empty_2 : forall s : t, is_empty s = true -> Empty s.
   Proof.
-    intro s; unfold is_empty in |- *; case (M.is_empty s); auto.
+    intro s; unfold is_empty; case (M.is_empty s); auto.
     intros; discriminate H.
   Qed.
 
@@ -384,12 +382,12 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E.
 
   Lemma mem_1 : forall (s : t) (x : elt), In x s -> mem x s = true.
   Proof.
-    intros; unfold mem in |- *; case (M.mem x s); auto.
+    intros; unfold mem; case (M.mem x s); auto.
   Qed.
 
   Lemma mem_2 : forall (s : t) (x : elt), mem x s = true -> In x s.
   Proof.
-    intros s x; unfold mem in |- *; case (M.mem x s); auto.
+    intros s x; unfold mem; case (M.mem x s); auto.
     intros; discriminate H.
   Qed.
 
@@ -400,12 +398,12 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E.
 
   Lemma equal_1 : forall s s' : t, Equal s s' -> equal s s' = true.
   Proof.
-    intros; unfold equal in |- *; case M.equal; intuition.
+    intros; unfold equal; case M.equal; intuition.
   Qed.
 
   Lemma equal_2 : forall s s' : t, equal s s' = true -> Equal s s'.
   Proof.
-    intros s s'; unfold equal in |- *; case (M.equal s s'); intuition;
+    intros s s'; unfold equal; case (M.equal s s'); intuition;
      inversion H.
   Qed.
 
@@ -414,12 +412,12 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E.
 
   Lemma subset_1 : forall s s' : t, Subset s s' -> subset s s' = true.
   Proof.
-    intros; unfold subset in |- *; case M.subset; intuition.
+    intros; unfold subset; case M.subset; intuition.
   Qed.
 
   Lemma subset_2 : forall s s' : t, subset s s' = true -> Subset s s'.
   Proof.
-    intros s s'; unfold subset in |- *; case (M.subset s s'); intuition;
+    intros s s'; unfold subset; case (M.subset s s'); intuition;
      inversion H.
   Qed.
 
@@ -431,14 +429,14 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E.
 
   Lemma choose_1 : forall (s : t) (x : elt), choose s = Some x -> In x s.
   Proof.
-    intros s x; unfold choose in |- *; case (M.choose s).
+    intros s x; unfold choose; case (M.choose s).
     simple destruct s0; intros; injection H; intros; subst; auto.
     intros; discriminate H.
   Qed.
 
   Lemma choose_2 : forall s : t, choose s = None -> Empty s.
   Proof.
-    intro s; unfold choose in |- *; case (M.choose s); auto.
+    intro s; unfold choose; case (M.choose s); auto.
     simple destruct s0; intros; discriminate H.
   Qed.
 
@@ -455,17 +453,17 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E.
 
   Lemma elements_1 : forall (s : t) (x : elt), In x s -> InA E.eq x (elements s).
   Proof.
-    intros; unfold elements in |- *; case (M.elements s); firstorder.
+    intros; unfold elements; case (M.elements s); firstorder.
   Qed.
 
   Lemma elements_2 : forall (s : t) (x : elt), InA E.eq x (elements s) -> In x s.
   Proof.
-    intros s x; unfold elements in |- *; case (M.elements s); firstorder.
+    intros s x; unfold elements; case (M.elements s); firstorder.
   Qed.
 
   Lemma elements_3 : forall s : t, sort E.lt (elements s).
   Proof.
-    intros; unfold elements in |- *; case (M.elements s); firstorder.
+    intros; unfold elements; case (M.elements s); firstorder.
   Qed.
   Hint Resolve elements_3.
 
@@ -480,7 +478,7 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E.
 
   Lemma min_elt_1 : forall (s : t) (x : elt), min_elt s = Some x -> In x s.
   Proof.
-    intros s x; unfold min_elt in |- *; case (M.min_elt s).
+    intros s x; unfold min_elt; case (M.min_elt s).
     simple destruct s0; intros; injection H; intros; subst; intuition.
     intros; discriminate H.
   Qed.
@@ -488,15 +486,15 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E.
   Lemma min_elt_2 :
    forall (s : t) (x y : elt), min_elt s = Some x -> In y s -> ~ E.lt y x.
   Proof.
-    intros s x y; unfold min_elt in |- *; case (M.min_elt s).
-    unfold For_all in |- *; simple destruct s0; intros; injection H; intros;
+    intros s x y; unfold min_elt; case (M.min_elt s).
+    unfold For_all; simple destruct s0; intros; injection H; intros;
      subst; firstorder.
     intros; discriminate H.
   Qed.
 
   Lemma min_elt_3 : forall s : t, min_elt s = None -> Empty s.
   Proof.
-    intros s; unfold min_elt in |- *; case (M.min_elt s); auto.
+    intros s; unfold min_elt; case (M.min_elt s); auto.
     simple destruct s0; intros; discriminate H.
   Qed.
 
@@ -508,7 +506,7 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E.
 
   Lemma max_elt_1 : forall (s : t) (x : elt), max_elt s = Some x -> In x s.
   Proof.
-    intros s x; unfold max_elt in |- *; case (M.max_elt s).
+    intros s x; unfold max_elt; case (M.max_elt s).
     simple destruct s0; intros; injection H; intros; subst; intuition.
     intros; discriminate H.
   Qed.
@@ -516,15 +514,15 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E.
   Lemma max_elt_2 :
    forall (s : t) (x y : elt), max_elt s = Some x -> In y s -> ~ E.lt x y.
   Proof.
-    intros s x y; unfold max_elt in |- *; case (M.max_elt s).
-    unfold For_all in |- *; simple destruct s0; intros; injection H; intros;
+    intros s x y; unfold max_elt; case (M.max_elt s).
+    unfold For_all; simple destruct s0; intros; injection H; intros;
      subst; firstorder.
     intros; discriminate H.
   Qed.
 
   Lemma max_elt_3 : forall s : t, max_elt s = None -> Empty s.
   Proof.
-    intros s; unfold max_elt in |- *; case (M.max_elt s); auto.
+    intros s; unfold max_elt; case (M.max_elt s); auto.
     simple destruct s0; intros; discriminate H.
   Qed.
 
@@ -532,20 +530,20 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E.
 
   Lemma add_1 : forall (s : t) (x y : elt), E.eq x y -> In y (add x s).
   Proof.
-    intros; unfold add in |- *; case (M.add x s); unfold Add in |- *;
+    intros; unfold add; case (M.add x s); unfold Add;
      firstorder.
   Qed.
 
   Lemma add_2 : forall (s : t) (x y : elt), In y s -> In y (add x s).
   Proof.
-    intros; unfold add in |- *; case (M.add x s); unfold Add in |- *;
+    intros; unfold add; case (M.add x s); unfold Add;
      firstorder.
   Qed.
 
   Lemma add_3 :
    forall (s : t) (x y : elt), ~ E.eq x y -> In y (add x s) -> In y s.
   Proof.
-    intros s x y; unfold add in |- *; case (M.add x s); unfold Add in |- *;
+    intros s x y; unfold add; case (M.add x s); unfold Add;
      firstorder.
   Qed.
 
@@ -553,30 +551,30 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E.
 
   Lemma remove_1 : forall (s : t) (x y : elt), E.eq x y -> ~ In y (remove x s).
   Proof.
-    intros; unfold remove in |- *; case (M.remove x s); firstorder.
+    intros; unfold remove; case (M.remove x s); firstorder.
   Qed.
 
   Lemma remove_2 :
    forall (s : t) (x y : elt), ~ E.eq x y -> In y s -> In y (remove x s).
   Proof.
-    intros; unfold remove in |- *; case (M.remove x s); firstorder.
+    intros; unfold remove; case (M.remove x s); firstorder.
   Qed.
 
   Lemma remove_3 : forall (s : t) (x y : elt), In y (remove x s) -> In y s.
   Proof.
-    intros s x y; unfold remove in |- *; case (M.remove x s); firstorder.
+    intros s x y; unfold remove; case (M.remove x s); firstorder.
   Qed.
 
   Definition singleton (x : elt) : t := let (s, _) := singleton x in s.
 
   Lemma singleton_1 : forall x y : elt, In y (singleton x) -> E.eq x y.
   Proof.
-    intros x y; unfold singleton in |- *; case (M.singleton x); firstorder.
+    intros x y; unfold singleton; case (M.singleton x); firstorder.
   Qed.
 
   Lemma singleton_2 : forall x y : elt, E.eq x y -> In y (singleton x).
   Proof.
-    intros x y; unfold singleton in |- *; case (M.singleton x); firstorder.
+    intros x y; unfold singleton; case (M.singleton x); firstorder.
   Qed.
 
   Definition union (s s' : t) : t := let (s'', _) := union s s' in s''.
@@ -584,60 +582,60 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E.
   Lemma union_1 :
    forall (s s' : t) (x : elt), In x (union s s') -> In x s \/ In x s'.
   Proof.
-    intros s s' x; unfold union in |- *; case (M.union s s'); firstorder.
+    intros s s' x; unfold union; case (M.union s s'); firstorder.
   Qed.
 
   Lemma union_2 : forall (s s' : t) (x : elt), In x s -> In x (union s s').
   Proof.
-    intros s s' x; unfold union in |- *; case (M.union s s'); firstorder.
+    intros s s' x; unfold union; case (M.union s s'); firstorder.
   Qed.
 
   Lemma union_3 : forall (s s' : t) (x : elt), In x s' -> In x (union s s').
   Proof.
-    intros s s' x; unfold union in |- *; case (M.union s s'); firstorder.
+    intros s s' x; unfold union; case (M.union s s'); firstorder.
   Qed.
 
   Definition inter (s s' : t) : t := let (s'', _) := inter s s' in s''.
 
   Lemma inter_1 : forall (s s' : t) (x : elt), In x (inter s s') -> In x s.
   Proof.
-    intros s s' x; unfold inter in |- *; case (M.inter s s'); firstorder.
+    intros s s' x; unfold inter; case (M.inter s s'); firstorder.
   Qed.
 
   Lemma inter_2 : forall (s s' : t) (x : elt), In x (inter s s') -> In x s'.
   Proof.
-    intros s s' x; unfold inter in |- *; case (M.inter s s'); firstorder.
+    intros s s' x; unfold inter; case (M.inter s s'); firstorder.
   Qed.
 
   Lemma inter_3 :
    forall (s s' : t) (x : elt), In x s -> In x s' -> In x (inter s s').
   Proof.
-    intros s s' x; unfold inter in |- *; case (M.inter s s'); firstorder.
+    intros s s' x; unfold inter; case (M.inter s s'); firstorder.
   Qed.
 
   Definition diff (s s' : t) : t := let (s'', _) := diff s s' in s''.
 
   Lemma diff_1 : forall (s s' : t) (x : elt), In x (diff s s') -> In x s.
   Proof.
-    intros s s' x; unfold diff in |- *; case (M.diff s s'); firstorder.
+    intros s s' x; unfold diff; case (M.diff s s'); firstorder.
   Qed.
 
   Lemma diff_2 : forall (s s' : t) (x : elt), In x (diff s s') -> ~ In x s'.
   Proof.
-    intros s s' x; unfold diff in |- *; case (M.diff s s'); firstorder.
+    intros s s' x; unfold diff; case (M.diff s s'); firstorder.
   Qed.
 
   Lemma diff_3 :
    forall (s s' : t) (x : elt), In x s -> ~ In x s' -> In x (diff s s').
   Proof.
-    intros s s' x; unfold diff in |- *; case (M.diff s s'); firstorder.
+    intros s s' x; unfold diff; case (M.diff s s'); firstorder.
   Qed.
 
   Definition cardinal (s : t) : nat := let (f, _) := cardinal s in f.
 
   Lemma cardinal_1 : forall s, cardinal s = length (elements s).
   Proof.
-    intros; unfold cardinal in |- *; case (M.cardinal s); unfold elements in *;
+    intros; unfold cardinal; case (M.cardinal s); unfold elements in *;
     destruct (M.elements s); auto.
   Qed.
 
@@ -648,7 +646,7 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E.
    forall (s : t) (A : Type) (i : A) (f : elt -> A -> A),
    fold f s i = fold_left (fun a e => f e a) (elements s) i.
   Proof.
-    intros; unfold fold in |- *; case (M.fold f s i); unfold elements in *;
+    intros; unfold fold; case (M.fold f s i); unfold elements in *;
     destruct (M.elements s); auto.
   Qed.
 
@@ -675,7 +673,7 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E.
    forall (s : t) (x : elt) (f : elt -> bool),
    compat_bool E.eq f -> In x (filter f s) -> In x s.
   Proof.
-    intros s x f; unfold filter in |- *; case M.filter; intuition.
+    intros s x f; unfold filter; case M.filter; intuition.
     generalize (i (compat_P_aux H)); firstorder.
   Qed.
 
@@ -683,7 +681,7 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E.
    forall (s : t) (x : elt) (f : elt -> bool),
    compat_bool E.eq f -> In x (filter f s) -> f x = true.
   Proof.
-    intros s x f; unfold filter in |- *; case M.filter; intuition.
+    intros s x f; unfold filter; case M.filter; intuition.
     generalize (i (compat_P_aux H)); firstorder.
   Qed.
 
@@ -691,7 +689,7 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E.
    forall (s : t) (x : elt) (f : elt -> bool),
    compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s).
   Proof.
-    intros s x f; unfold filter in |- *; case M.filter; intuition.
+    intros s x f; unfold filter; case M.filter; intuition.
     generalize (i (compat_P_aux H)); firstorder.
   Qed.
 
@@ -705,7 +703,7 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E.
    compat_bool E.eq f ->
    For_all (fun x => f x = true) s -> for_all f s = true.
   Proof.
-    intros s f; unfold for_all in |- *; case M.for_all; intuition; elim n;
+    intros s f; unfold for_all; case M.for_all; intuition; elim n;
      auto.
   Qed.
 
@@ -714,7 +712,7 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E.
    compat_bool E.eq f ->
    for_all f s = true -> For_all (fun x => f x = true) s.
   Proof.
-    intros s f; unfold for_all in |- *; case M.for_all; intuition;
+    intros s f; unfold for_all; case M.for_all; intuition;
      inversion H0.
   Qed.
 
@@ -727,7 +725,7 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E.
    forall (s : t) (f : elt -> bool),
    compat_bool E.eq f -> Exists (fun x => f x = true) s -> exists_ f s = true.
   Proof.
-    intros s f; unfold exists_ in |- *; case M.exists_; intuition; elim n;
+    intros s f; unfold exists_; case M.exists_; intuition; elim n;
      auto.
   Qed.
 
@@ -735,7 +733,7 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E.
    forall (s : t) (f : elt -> bool),
    compat_bool E.eq f -> exists_ f s = true -> Exists (fun x => f x = true) s.
   Proof.
-    intros s f; unfold exists_ in |- *; case M.exists_; intuition;
+    intros s f; unfold exists_; case M.exists_; intuition;
      inversion H0.
   Qed.
 
@@ -747,10 +745,10 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E.
    forall (s : t) (f : elt -> bool),
    compat_bool E.eq f -> Equal (fst (partition f s)) (filter f s).
   Proof.
-    intros s f; unfold partition in |- *; case M.partition.
+    intros s f; unfold partition; case M.partition.
     intro p; case p; clear p; intros s1 s2 H C.
     generalize (H (compat_P_aux C)); clear H; intro H.
-    simpl in |- *; unfold Equal in |- *; intuition.
+    simpl; unfold Equal; intuition.
     apply filter_3; firstorder.
     elim (H2 a); intros.
     assert (In a s).
@@ -765,13 +763,13 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E.
    forall (s : t) (f : elt -> bool),
    compat_bool E.eq f -> Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
   Proof.
-    intros s f; unfold partition in |- *; case M.partition.
+    intros s f; unfold partition; case M.partition.
     intro p; case p; clear p; intros s1 s2 H C.
     generalize (H (compat_P_aux C)); clear H; intro H.
     assert (D : compat_bool E.eq (fun x => negb (f x))).
     generalize C; unfold compat_bool, Proper, respectful; intros; apply (f_equal negb);
      auto.
-    simpl in |- *; unfold Equal in |- *; intuition.
+    simpl; unfold Equal; intuition.
     apply filter_3; firstorder.
     elim (H2 a); intros.
     assert (In a s).
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..ac495c04 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
@@ -208,7 +206,7 @@ intros.
 generalize (@choose_1 s) (@choose_2 s).
 destruct (choose s);intros.
 exists e;auto with set.
-generalize (H1 (refl_equal None)); clear H1.
+generalize (H1 Logic.eq_refl); clear H1.
 intros; rewrite (is_empty_1 H1) in H; discriminate.
 Qed.
 
@@ -633,7 +631,7 @@ destruct (choose (filter f s)).
 intros H0 _; apply exists_1; auto.
 exists e; generalize (H0 e); rewrite filter_iff; auto.
 intros _ H0.
-rewrite (is_empty_1 (H0 (refl_equal None))) in H; auto; discriminate.
+rewrite (is_empty_1 (H0 Logic.eq_refl)) in H; auto; discriminate.
 Qed.
 
 Lemma partition_filter_1:
@@ -883,8 +881,8 @@ generalize (@add_filter_1 f Hf s0 (add x s0) x) (@add_filter_2 f Hf s0 (add x s0
 assert (~ In x (filter f s0)).
  intro H1; rewrite (mem_1 (filter_1 Hf H1)) in H; discriminate H.
 case (f x); simpl; intros.
-rewrite (MP.cardinal_2 H1 (H2 (refl_equal true) (MP.Add_add s0 x))); auto.
-rewrite <- (MP.Equal_cardinal (H3 (refl_equal false) (MP.Add_add s0 x))); auto.
+rewrite (MP.cardinal_2 H1 (H2 Logic.eq_refl (MP.Add_add s0 x))); auto.
+rewrite <- (MP.Equal_cardinal (H3 Logic.eq_refl (MP.Add_add s0 x))); auto.
 intros; rewrite fold_empty;auto.
 rewrite MP.cardinal_1; auto.
 unfold Empty; intros.
diff --git a/theories/FSets/FSetFacts.v b/theories/FSets/FSetFacts.v
index 45b43d83..b240ede4 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
@@ -317,11 +315,11 @@ symmetry.
 rewrite <- H1; intros a Ha.
 rewrite <- (H a) in Ha.
 destruct H0 as (_,H0).
-exact (H0 (refl_equal true) _ Ha).
+exact (H0 Logic.eq_refl _ Ha).
 rewrite <- H0; intros a Ha.
 rewrite (H a) in Ha.
 destruct H1 as (_,H1).
-exact (H1 (refl_equal true) _ Ha).
+exact (H1 Logic.eq_refl _ Ha).
 Qed.
 
 Instance Empty_m : Proper (Equal ==> iff) Empty.
@@ -491,5 +489,3 @@ End WFacts_fun.
 
 Module WFacts (M:WS) := WFacts_fun M.E M.
 Module Facts := WFacts.
-
-
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..d53ce0c8 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
@@ -820,7 +823,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E).
   rewrite (inter_subset_equal H).
   generalize (@cardinal_inv_1 (diff s' s)).
   destruct (cardinal (diff s' s)).
-  intro H2; destruct (H2 (refl_equal _) x).
+  intro H2; destruct (H2 Logic.eq_refl x).
   set_iff; auto.
   intros _.
   change (0 + cardinal s < S n + cardinal s).
@@ -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..fc620f71 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-2012     *)
 (*   \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.
@@ -66,7 +72,7 @@ Hint Resolve andb_prop: bool.
 Lemma andb_true_intro :
   forall b1 b2:bool, b1 = true /\ b2 = true -> andb b1 b2 = true.
 Proof.
-  destruct b1; destruct b2; simpl in |- *; tauto || auto with bool.
+  destruct b1; destruct b2; simpl; intros [? ?]; assumption.
 Qed.
 Hint Resolve andb_true_intro: bool.
 
@@ -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
@@ -188,7 +203,7 @@ Lemma injective_projections :
   forall (A B:Type) (p1 p2:A * B),
     fst p1 = fst p2 -> snd p1 = snd p2 -> p1 = p2.
 Proof.
-  destruct p1; destruct p2; simpl in |- *; intros Hfst Hsnd.
+  destruct p1; destruct p2; simpl; intros Hfst Hsnd.
   rewrite Hfst; rewrite Hsnd; reflexivity.
 Qed.
 
@@ -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,81 +277,81 @@ 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 *)
 
 (* Compatibility *)
 
-Notation prodT := prod (only parsing).
-Notation pairT := pair (only parsing).
-Notation prodT_rect := prod_rect (only parsing).
-Notation prodT_rec := prod_rec (only parsing).
-Notation prodT_ind := prod_ind (only parsing).
-Notation fstT := fst (only parsing).
-Notation sndT := snd (only parsing).
-Notation prodT_uncurry := prod_uncurry (only parsing).
-Notation prodT_curry := prod_curry (only parsing).
+Notation prodT := prod (compat "8.2").
+Notation pairT := pair (compat "8.2").
+Notation prodT_rect := prod_rect (compat "8.2").
+Notation prodT_rec := prod_rec (compat "8.2").
+Notation prodT_ind := prod_ind (compat "8.2").
+Notation fstT := fst (compat "8.2").
+Notation sndT := snd (compat "8.2").
+Notation prodT_uncurry := prod_uncurry (compat "8.2").
+Notation prodT_curry := prod_curry (compat "8.2").
 
 (* end hide *)
diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v
index b95d78a4..4e6df444 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-2012     *)
 (*   \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))
@@ -241,12 +240,12 @@ Section universal_quantification.
 
   Theorem inst : forall x:A, all (fun x => P x) -> P x.
   Proof.
-    unfold all in |- *; auto.
+    unfold all; auto.
   Qed.
 
   Theorem gen : forall (B:Prop) (f:forall y:A, B -> P y), B -> all P.
   Proof.
-    red in |- *; auto.
+    red; auto.
   Qed.
 
 End universal_quantification.
@@ -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.
@@ -284,7 +284,7 @@ Section Logic_lemmas.
 
   Theorem absurd : forall A C:Prop, A -> ~ A -> C.
   Proof.
-    unfold not in |- *; intros A C h1 h2.
+    unfold not; intros A C h1 h2.
     destruct (h2 h1).
   Qed.
 
@@ -313,7 +313,7 @@ Section Logic_lemmas.
 
     Theorem not_eq_sym : x <> y -> y <> x.
     Proof.
-      red in |- *; intros h1 h2; apply h1; destruct h2; trivial.
+      red; intros h1 h2; apply h1; destruct h2; trivial.
     Qed.
 
   End equality.
@@ -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.
@@ -369,14 +378,14 @@ Qed.
 
 (* Aliases *)
 
-Notation sym_eq := eq_sym (only parsing).
-Notation trans_eq := eq_trans (only parsing).
-Notation sym_not_eq := not_eq_sym (only parsing).
+Notation sym_eq := eq_sym (compat "8.3").
+Notation trans_eq := eq_trans (compat "8.3").
+Notation sym_not_eq := not_eq_sym (compat "8.3").
 
-Notation refl_equal := eq_refl (only parsing).
-Notation sym_equal := eq_sym (only parsing).
-Notation trans_equal := eq_trans (only parsing).
-Notation sym_not_equal := not_eq_sym (only parsing).
+Notation refl_equal := eq_refl (compat "8.3").
+Notation sym_equal := eq_sym (compat "8.3").
+Notation trans_equal := eq_trans (compat "8.3").
+Notation sym_not_equal := not_eq_sym (compat "8.3").
 
 Hint Immediate eq_sym not_eq_sym: core.
 
@@ -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..0281c516 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-2012     *)
 (*   \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]) *)
 
@@ -46,7 +44,7 @@ Section identity_is_a_congruence.
 
  Lemma not_identity_sym : notT (identity x y) -> notT (identity y x).
  Proof.
-  red in |- *; intros H H'; apply H; destruct H'; trivial.
+  red; intros H H'; apply H; destruct H'; trivial.
  Qed.
 
 End identity_is_a_congruence.
@@ -68,7 +66,7 @@ Defined.
 
 Hint Immediate identity_sym not_identity_sym: core v62.
 
-Notation refl_id := identity_refl (only parsing).
-Notation sym_id := identity_sym (only parsing).
-Notation trans_id := identity_trans (only parsing).
-Notation sym_not_id := not_identity_sym (only parsing).
+Notation refl_id := identity_refl (compat "8.3").
+Notation sym_id := identity_sym (compat "8.3").
+Notation trans_id := identity_trans (compat "8.3").
+Notation sym_not_id := not_identity_sym (compat "8.3").
diff --git a/theories/Init/Notations.v b/theories/Init/Notations.v
index 3619d827..323dab90 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-2012     *)
 (*   \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..8c6fba50 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-2012     *)
 (*   \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,18 +49,12 @@ 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.
 Proof.
-  red in |- *; auto.
+  red; auto.
 Qed.
 Hint Resolve not_eq_S: core.
 
@@ -102,7 +93,7 @@ Hint Resolve (f_equal2 (A1:=nat) (A2:=nat)): core.
 
 Lemma plus_n_O : forall n:nat, n = n + 0.
 Proof.
-  induction n; simpl in |- *; auto.
+  induction n; simpl; auto.
 Qed.
 Hint Resolve plus_n_O: core.
 
@@ -113,7 +104,7 @@ Qed.
 
 Lemma plus_n_Sm : forall n m:nat, S (n + m) = n + S m.
 Proof.
-  intros n m; induction n; simpl in |- *; auto.
+  intros n m; induction n; simpl; auto.
 Qed.
 Hint Resolve plus_n_Sm: core.
 
@@ -124,8 +115,8 @@ Qed.
 
 (** Standard associated names *)
 
-Notation plus_0_r_reverse := plus_n_O (only parsing).
-Notation plus_succ_r_reverse := plus_n_Sm (only parsing).
+Notation plus_0_r_reverse := plus_n_O (compat "8.2").
+Notation plus_succ_r_reverse := plus_n_Sm (compat "8.2").
 
 (** Multiplication *)
 
@@ -141,22 +132,22 @@ Hint Resolve (f_equal2 mult): core.
 
 Lemma mult_n_O : forall n:nat, 0 = n * 0.
 Proof.
-  induction n; simpl in |- *; auto.
+  induction n; simpl; auto.
 Qed.
 Hint Resolve mult_n_O: core.
 
 Lemma mult_n_Sm : forall n m:nat, n * m + n = n * S m.
 Proof.
-  intros; induction n as [| p H]; simpl in |- *; auto.
-  destruct H; rewrite <- plus_n_Sm; apply (f_equal S).
-  pattern m at 1 3 in |- *; elim m; simpl in |- *; auto.
+  intros; induction n as [| p H]; simpl; auto.
+  destruct H; rewrite <- plus_n_Sm; apply eq_S.
+  pattern m at 1 3; elim m; simpl; auto.
 Qed.
 Hint Resolve mult_n_Sm: core.
 
 (** Standard associated names *)
 
-Notation mult_0_r_reverse := mult_n_O (only parsing).
-Notation mult_succ_r_reverse := mult_n_Sm (only parsing).
+Notation mult_0_r_reverse := mult_n_O (compat "8.2").
+Notation mult_succ_r_reverse := mult_n_Sm (compat "8.2").
 
 (** Truncated subtraction: [m-n] is [0] if [n>=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 :
@@ -218,5 +219,78 @@ Theorem nat_double_ind :
    (forall n m:nat, R n m -> R (S n) (S m)) -> forall n m:nat, R n m.
 Proof.
   induction n; auto.
-  destruct m as [| n0]; auto.
+  destruct m; 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..e723cadf 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-2012     *)
 (*   \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,11 @@ 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..d1610f0a 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-2012     *)
 (*   \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.
@@ -62,7 +60,7 @@ Add Printing Let sigT2.
 
 (** Projections of [sig]
 
-    An element [y] of a subset [{x:A & (P x)}] is the pair of an [a]
+    An element [y] of a subset [{x:A | (P x)}] is the pair of an [a]
     of type [A] and of a proof [h] that [a] satisfies [P].  Then
     [(proj1_sig y)] is the witness [a] and [(proj2_sig y)] is the
     proof of [(P a)] *)
@@ -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,34 +208,34 @@ 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.
 
 (* Compatibility *)
 
-Notation sigS := sigT (only parsing).
-Notation existS := existT (only parsing).
-Notation sigS_rect := sigT_rect (only parsing).
-Notation sigS_rec := sigT_rec (only parsing).
-Notation sigS_ind := sigT_ind (only parsing).
-Notation projS1 := projT1 (only parsing).
-Notation projS2 := projT2 (only parsing).
-
-Notation sigS2 := sigT2 (only parsing).
-Notation existS2 := existT2 (only parsing).
-Notation sigS2_rect := sigT2_rect (only parsing).
-Notation sigS2_rec := sigT2_rec (only parsing).
-Notation sigS2_ind := sigT2_ind (only parsing).
+Notation sigS := sigT (compat "8.2").
+Notation existS := existT (compat "8.2").
+Notation sigS_rect := sigT_rect (compat "8.2").
+Notation sigS_rec := sigT_rec (compat "8.2").
+Notation sigS_ind := sigT_ind (compat "8.2").
+Notation projS1 := projT1 (compat "8.2").
+Notation projS2 := projT2 (compat "8.2").
+
+Notation sigS2 := sigT2 (compat "8.2").
+Notation existS2 := existT2 (compat "8.2").
+Notation sigS2_rect := sigT2_rect (compat "8.2").
+Notation sigS2_rec := sigT2_rec (compat "8.2").
+Notation sigS2_ind := sigT2_ind (compat "8.2").
diff --git a/theories/Init/Tactics.v b/theories/Init/Tactics.v
index 1fa4a77f..23d9d10e 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-2012     *)
 (*   \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.
@@ -77,18 +75,22 @@ Ltac false_hyp H G :=
 
 (* A case with no loss of information. *)
 
-Ltac case_eq x := generalize (refl_equal x); pattern x at -1; case x.
+Ltac case_eq x := generalize (eq_refl x); pattern x at -1; case x.
+
+(* use either discriminate or injection on a hypothesis *)
+
+Ltac destr_eq H := discriminate H || (try (injection H; clear H; intro H)).
 
 (* Similar variants of destruct *)
 
 Tactic Notation "destruct_with_eqn" constr(x) :=
-  destruct x as []_eqn.
+  destruct x eqn:?.
 Tactic Notation "destruct_with_eqn" ident(n) :=
-  try intros until n; destruct n as []_eqn.
+  try intros until n; destruct n eqn:?.
 Tactic Notation "destruct_with_eqn" ":" ident(H) constr(x) :=
-  destruct x as []_eqn:H.
+  destruct x eqn:H.
 Tactic Notation "destruct_with_eqn" ":" ident(H) ident(n) :=
-  try intros until n; destruct n as []_eqn:H.
+  try intros until n; destruct n eqn:H.
 
 (** Break every hypothesis of a certain type *)
 
@@ -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..c9fcb570 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-2012     *)
 (*   \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
@@ -105,7 +103,7 @@ Section Well_founded.
 
   Lemma Fix_eq : forall x:A, Fix x = F (fun (y:A) (p:R y x) => Fix y).
   Proof.
-   intro x; unfold Fix in |- *.
+   intro x; unfold Fix.
    rewrite <- Fix_F_eq.
    apply F_ext; intros.
    apply Fix_F_inv.
diff --git a/theories/Lists/List.v b/theories/Lists/List.v
index 4c14008c..69475a6f 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-2012     *)
 (*   \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 Setoid.
 
 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.
@@ -541,30 +546,21 @@ Section Elts.
     end.
 
   (** Compatibility of count_occ with operations on list *)
-  Theorem count_occ_In : forall (l : list A) (x : A), In x l <-> count_occ l x > 0.
+  Theorem count_occ_In (l : list A) (x : A) : In x l <-> count_occ l x > 0.
   Proof.
-    induction l as [|y l].
-    simpl; intros; split; [destruct 1 | apply gt_irrefl].
-    simpl. intro x; destruct (eq_dec y x) as [Heq|Hneq].
-    rewrite Heq; intuition.
-    pose (IHl x). intuition.
+    induction l as [|y l]; simpl.
+    - split; [destruct 1 | apply gt_irrefl].
+    - destruct eq_dec as [->|Hneq]; rewrite IHl; intuition.
   Qed.
 
-  Theorem count_occ_inv_nil : forall (l : list A), (forall x:A, count_occ l x = 0) <-> l = [].
+  Theorem count_occ_inv_nil (l : list A) :
+    (forall x:A, count_occ l x = 0) <-> l = [].
   Proof.
     split.
-    (* Case -> *)
-    induction l as [|x l].
-    trivial.
-    intro H.
-    elim (O_S (count_occ l x)).
-    apply sym_eq.
-    generalize (H x).
-    simpl. destruct (eq_dec x x) as [|HF].
-    trivial.
-    elim HF; reflexivity.
-    (* Case <- *)
-    intro H; rewrite H; simpl; reflexivity.
+    - induction l as [|x l]; trivial.
+      intros H. specialize (H x). simpl in H.
+      destruct eq_dec as [_|NEQ]; [discriminate|now elim NEQ].
+    - now intros ->.
   Qed.
 
   Lemma count_occ_nil : forall (x : A), count_occ [] x = 0.
@@ -749,22 +745,11 @@ Section ListOps.
 
   Hypothesis eq_dec : forall (x y : A), {x = y}+{x <> y}.
 
-  Lemma list_eq_dec :
-    forall l l':list A, {l = l'} + {l <> l'}.
-  Proof.
-    induction l as [| x l IHl]; destruct l' as [| y l'].
-    left; trivial.
-    right; apply nil_cons.
-    right; unfold not; intro HF; apply (nil_cons (sym_eq HF)).
-    destruct (eq_dec x y) as [xeqy|xneqy]; destruct (IHl l') as [leql'|lneql'];
-      try (right; unfold not; intro HF; injection HF; intros; contradiction).
-    rewrite xeqy; rewrite leql'; left; trivial.
-  Qed.
-
+  Lemma list_eq_dec : forall l l':list A, {l = l'} + {l <> l'}.
+  Proof. decide equality. Defined.
 
 End ListOps.
 
-
 (***************************************************)
 (** * Applying functions to the elements of a list *)
 (***************************************************)
@@ -1643,7 +1628,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 +1639,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..b846c48d 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-2012     *)
 (*   \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.
@@ -87,15 +85,15 @@ Section first_definitions.
   Lemma set_In_dec : forall (a:A) (x:set), {set_In a x} + {~ set_In a x}.
 
   Proof.
-    unfold set_In in |- *.
+    unfold set_In.
     (*** Realizer set_mem. Program_all. ***)
     simple induction x.
     auto.
     intros a0 x0 Ha0. case (Aeq_dec a a0); intro eq.
-    rewrite eq; simpl in |- *; auto with datatypes.
+    rewrite eq; simpl; auto with datatypes.
     elim Ha0.
     auto with datatypes.
-    right; simpl in |- *; unfold not in |- *; intros [Hc1| Hc2];
+    right; simpl; unfold not; intros [Hc1| Hc2];
      auto with datatypes.
   Qed.
 
@@ -104,7 +102,7 @@ Section first_definitions.
      (set_In a x -> P y) -> P z -> P (if set_mem a x then y else z).
 
   Proof.
-    simple induction x; simpl in |- *; intros.
+    simple induction x; simpl; intros.
     assumption.
     elim (Aeq_dec a a0); auto with datatypes.
   Qed.
@@ -115,11 +113,11 @@ Section first_definitions.
      (~ set_In a x -> P z) -> P (if set_mem a x then y else z).
 
   Proof.
-    simple induction x; simpl in |- *; intros.
-    apply H0; red in |- *; trivial.
+    simple induction x; simpl; intros.
+    apply H0; red; trivial.
     case (Aeq_dec a a0); auto with datatypes.
     intro; apply H; intros; auto.
-    apply H1; red in |- *; intro.
+    apply H1; red; intro.
     case H3; auto.
   Qed.
 
@@ -127,7 +125,7 @@ Section first_definitions.
   Lemma set_mem_correct1 :
    forall (a:A) (x:set), set_mem a x = true -> set_In a x.
   Proof.
-    simple induction x; simpl in |- *.
+    simple induction x; simpl.
     discriminate.
     intros a0 l; elim (Aeq_dec a a0); auto with datatypes.
   Qed.
@@ -135,7 +133,7 @@ Section first_definitions.
   Lemma set_mem_correct2 :
    forall (a:A) (x:set), set_In a x -> set_mem a x = true.
   Proof.
-    simple induction x; simpl in |- *.
+    simple induction x; simpl.
     intro Ha; elim Ha.
     intros a0 l; elim (Aeq_dec a a0); auto with datatypes.
     intros H1 H2 [H3| H4].
@@ -146,17 +144,17 @@ Section first_definitions.
   Lemma set_mem_complete1 :
    forall (a:A) (x:set), set_mem a x = false -> ~ set_In a x.
   Proof.
-    simple induction x; simpl in |- *.
+    simple induction x; simpl.
     tauto.
     intros a0 l; elim (Aeq_dec a a0).
     intros; discriminate H0.
-    unfold not in |- *; intros; elim H1; auto with datatypes.
+    unfold not; intros; elim H1; auto with datatypes.
   Qed.
 
   Lemma set_mem_complete2 :
    forall (a:A) (x:set), ~ set_In a x -> set_mem a x = false.
   Proof.
-    simple induction x; simpl in |- *.
+    simple induction x; simpl.
     tauto.
     intros a0 l; elim (Aeq_dec a a0).
     intros; elim H0; auto with datatypes.
@@ -167,7 +165,7 @@ Section first_definitions.
    forall (a b:A) (x:set), set_In a x -> set_In a (set_add b x).
 
   Proof.
-    unfold set_In in |- *; simple induction x; simpl in |- *.
+    unfold set_In; simple induction x; simpl.
     auto with datatypes.
     intros a0 l H [Ha0a| Hal].
     elim (Aeq_dec b a0); left; assumption.
@@ -178,11 +176,11 @@ Section first_definitions.
    forall (a b:A) (x:set), a = b -> set_In a (set_add b x).
 
   Proof.
-    unfold set_In in |- *; simple induction x; simpl in |- *.
+    unfold set_In; simple induction x; simpl.
     auto with datatypes.
     intros a0 l H Hab.
     elim (Aeq_dec b a0);
-     [ rewrite Hab; intro Hba0; rewrite Hba0; simpl in |- *;
+     [ rewrite Hab; intro Hba0; rewrite Hba0; simpl;
         auto with datatypes
      | auto with datatypes ].
   Qed.
@@ -200,13 +198,13 @@ Section first_definitions.
    forall (a b:A) (x:set), set_In a (set_add b x) -> a = b \/ set_In a x.
 
   Proof.
-    unfold set_In in |- *.
+    unfold set_In.
     simple induction x.
-    simpl in |- *; intros [H1| H2]; auto with datatypes.
-    simpl in |- *; do 3 intro.
+    simpl; intros [H1| H2]; auto with datatypes.
+    simpl; do 3 intro.
     elim (Aeq_dec b a0).
-    simpl in |- *; tauto.
-    simpl in |- *; intros; elim H0.
+    simpl; tauto.
+    simpl; intros; elim H0.
     trivial with datatypes.
     tauto.
     tauto.
@@ -222,7 +220,7 @@ Section first_definitions.
 
   Lemma set_add_not_empty : forall (a:A) (x:set), set_add a x <> empty_set.
   Proof.
-    simple induction x; simpl in |- *.
+    simple induction x; simpl.
     discriminate.
     intros; elim (Aeq_dec a a0); intros; discriminate.
   Qed.
@@ -231,13 +229,13 @@ Section first_definitions.
   Lemma set_union_intro1 :
    forall (a:A) (x y:set), set_In a x -> set_In a (set_union x y).
   Proof.
-    simple induction y; simpl in |- *; auto with datatypes.
+    simple induction y; simpl; auto with datatypes.
   Qed.
 
   Lemma set_union_intro2 :
    forall (a:A) (x y:set), set_In a y -> set_In a (set_union x y).
   Proof.
-    simple induction y; simpl in |- *.
+    simple induction y; simpl.
     tauto.
     intros; elim H0; auto with datatypes.
   Qed.
@@ -255,7 +253,7 @@ Section first_definitions.
    forall (a:A) (x y:set),
      set_In a (set_union x y) -> set_In a x \/ set_In a y.
   Proof.
-    simple induction y; simpl in |- *.
+    simple induction y; simpl.
     auto with datatypes.
     intros.
     generalize (set_add_elim _ _ _ H0).
@@ -282,11 +280,11 @@ Section first_definitions.
   Proof.
     simple induction x.
     auto with datatypes.
-    simpl in |- *; intros a0 l Hrec y [Ha0a| Hal] Hy.
-    simpl in |- *; rewrite Ha0a.
+    simpl; intros a0 l Hrec y [Ha0a| Hal] Hy.
+    simpl; rewrite Ha0a.
     generalize (set_mem_correct1 a y).
     generalize (set_mem_complete1 a y).
-    elim (set_mem a y); simpl in |- *; intros.
+    elim (set_mem a y); simpl; intros.
     auto with datatypes.
     absurd (set_In a y); auto with datatypes.
     elim (set_mem a0 y); [ right; auto with datatypes | auto with datatypes ].
@@ -297,9 +295,9 @@ Section first_definitions.
   Proof.
     simple induction x.
     auto with datatypes.
-    simpl in |- *; intros a0 l Hrec y.
+    simpl; intros a0 l Hrec y.
     generalize (set_mem_correct1 a0 y).
-    elim (set_mem a0 y); simpl in |- *; intros.
+    elim (set_mem a0 y); simpl; intros.
     elim H0; eauto with datatypes.
     eauto with datatypes.
   Qed.
@@ -308,10 +306,10 @@ Section first_definitions.
    forall (a:A) (x y:set), set_In a (set_inter x y) -> set_In a y.
   Proof.
     simple induction x.
-    simpl in |- *; tauto.
-    simpl in |- *; intros a0 l Hrec y.
+    simpl; tauto.
+    simpl; intros a0 l Hrec y.
     generalize (set_mem_correct1 a0 y).
-    elim (set_mem a0 y); simpl in |- *; intros.
+    elim (set_mem a0 y); simpl; intros.
     elim H0;
      [ intro Hr; rewrite <- Hr; eauto with datatypes | eauto with datatypes ].
     eauto with datatypes.
@@ -331,8 +329,8 @@ Section first_definitions.
      set_In a x -> ~ set_In a y -> set_In a (set_diff x y).
   Proof.
     simple induction x.
-    simpl in |- *; tauto.
-    simpl in |- *; intros a0 l Hrec y [Ha0a| Hal] Hay.
+    simpl; tauto.
+    simpl; intros a0 l Hrec y [Ha0a| Hal] Hay.
     rewrite Ha0a; generalize (set_mem_complete2 _ _ Hay).
     elim (set_mem a y);
      [ intro Habs; discriminate Habs | auto with datatypes ].
@@ -343,8 +341,8 @@ Section first_definitions.
    forall (a:A) (x y:set), set_In a (set_diff x y) -> set_In a x.
   Proof.
     simple induction x.
-    simpl in |- *; tauto.
-    simpl in |- *; intros a0 l Hrec y; elim (set_mem a0 y).
+    simpl; tauto.
+    simpl; intros a0 l Hrec y; elim (set_mem a0 y).
     eauto with datatypes.
     intro; generalize (set_add_elim _ _ _ H).
     intros [H1| H2]; eauto with datatypes.
@@ -352,7 +350,7 @@ Section first_definitions.
 
   Lemma set_diff_elim2 :
    forall (a:A) (x y:set), set_In a (set_diff x y) -> ~ set_In a y.
-  intros a x y; elim x; simpl in |- *.
+  intros a x y; elim x; simpl.
   intros; contradiction.
   intros a0 l Hrec.
   apply set_mem_ind2; auto.
@@ -361,7 +359,7 @@ Section first_definitions.
   Qed.
 
   Lemma set_diff_trivial : forall (a:A) (x:set), ~ set_In a (set_diff x x).
-  red in |- *; intros a x H.
+  red; intros a x H.
   apply (set_diff_elim2 _ _ _ H).
   apply (set_diff_elim1 _ _ _ H).
   Qed.
diff --git a/theories/Lists/ListTactics.v b/theories/Lists/ListTactics.v
index 08669499..74336555 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-2012     *)
 (*   \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.
 
@@ -62,7 +60,7 @@ Ltac Find_at a l :=
    match l with
    | nil     => fail 100 "anomaly: Find_at"
    | a :: _  => eval compute in n
-   | _ :: ?l => find (Psucc n) l
+   | _ :: ?l => find (Pos.succ n) l
    end
  in find 1%positive l.
 
diff --git a/theories/Lists/SetoidList.v b/theories/Lists/SetoidList.v
index ec31f37d..0fd1693e 100644
--- a/theories/Lists/SetoidList.v
+++ b/theories/Lists/SetoidList.v
@@ -6,10 +6,8 @@
 (*         *       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 Sorted.
 Require Export Setoid Basics Morphisms.
 Set Implicit Arguments.
 Unset Strict Implicit.
@@ -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.
@@ -198,7 +199,29 @@ Proof.
  rewrite <- In_rev; auto.
 Qed.
 
+(** Some more facts about InA *)
+
+Lemma InA_singleton x y : InA x (y::nil) <-> eqA x y.
+Proof.
+ rewrite InA_cons, InA_nil; tauto.
+Qed.
+
+Lemma InA_double_head x y l :
+ InA x (y :: y :: l) <-> InA x (y :: l).
+Proof.
+ rewrite !InA_cons; tauto.
+Qed.
+
+Lemma InA_permute_heads x y z l :
+ InA x (y :: z :: l) <-> InA x (z :: y :: l).
+Proof.
+ rewrite !InA_cons; tauto.
+Qed.
 
+Lemma InA_app_idem x l : InA x (l ++ l) <-> InA x l.
+Proof.
+ rewrite InA_app_iff; tauto.
+Qed.
 
 Section NoDupA.
 
@@ -269,7 +292,56 @@ Proof.
  eapply NoDupA_split; eauto.
 Qed.
 
-Lemma equivlistA_NoDupA_split : forall l l1 l2 x y, eqA x y ->
+Lemma NoDupA_singleton x : NoDupA (x::nil).
+Proof.
+ repeat constructor. inversion 1.
+Qed.
+
+End NoDupA.
+
+Section EquivlistA.
+
+Global Instance equivlistA_cons_proper:
+ Proper (eqA ==> equivlistA ==> equivlistA) (@cons A).
+Proof.
+ intros ? ? E1 ? ? E2 ?; now rewrite !InA_cons, E1, E2.
+Qed.
+
+Global Instance equivlistA_app_proper:
+ Proper (equivlistA ==> equivlistA ==> equivlistA) (@app A).
+Proof.
+ intros ? ? E1 ? ? E2 ?. now rewrite !InA_app_iff, E1, E2.
+Qed.
+
+Lemma equivlistA_cons_nil x l : ~ equivlistA (x :: l) nil.
+Proof.
+ intros E. now eapply InA_nil, E, InA_cons_hd.
+Qed.
+
+Lemma equivlistA_nil_eq l : equivlistA l nil -> l = nil.
+Proof.
+ destruct l.
+ - trivial.
+ - intros H. now apply equivlistA_cons_nil in H.
+Qed.
+
+Lemma equivlistA_double_head x l : equivlistA (x :: x :: l) (x :: l).
+Proof.
+ intro. apply InA_double_head.
+Qed.
+
+Lemma equivlistA_permute_heads x y l :
+ equivlistA (x :: y :: l) (y :: x :: l).
+Proof.
+ intro. apply InA_permute_heads.
+Qed.
+
+Lemma equivlistA_app_idem l : equivlistA (l ++ l) l.
+Proof.
+ intro. apply InA_app_idem.
+Qed.
+
+Lemma equivlistA_NoDupA_split l l1 l2 x y : eqA x y ->
  NoDupA (x::l) -> NoDupA (l1++y::l2) ->
  equivlistA (x::l) (l1++y::l2) -> equivlistA l (l1++l2).
 Proof.
@@ -289,9 +361,7 @@ Proof.
  rewrite <-H,<-EQN; auto.
 Qed.
 
-End NoDupA.
-
-
+End EquivlistA.
 
 Section Fold.
 
@@ -587,10 +657,9 @@ Proof.
 Qed.
 
 (** For compatibility, can be deduced from [InfA_compat] *)
-Lemma InfA_eqA :
- forall l x y, eqA x y -> InfA y l -> InfA x l.
+Lemma InfA_eqA l x y : eqA x y -> InfA y l -> InfA x l.
 Proof.
- intros l x y H; rewrite H; auto.
+ intros H; now rewrite H.
 Qed.
 Hint Immediate InfA_ltA InfA_eqA.
 
@@ -747,7 +816,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.
@@ -784,9 +853,11 @@ Qed.
 End Filter.
 End Type_with_equality.
 
-
 Hint Constructors InA eqlistA NoDupA sort lelistA.
 
+Arguments equivlistA_cons_nil {A} eqA {eqA_equiv} x l _.
+Arguments equivlistA_nil_eq {A} eqA {eqA_equiv} l _.
+
 Section Find.
 
 Variable A B : Type.
@@ -837,7 +908,6 @@ Qed.
 
 End Find.
 
-
 (** Compatibility aliases. [Proper] is rather to be used directly now.*)
 
 Definition compat_bool {A} (eqA:A->A->Prop)(f:A->bool) :=
@@ -851,4 +921,3 @@ Definition compat_P {A} (eqA:A->A->Prop)(P:A->Prop) :=
 
 Definition compat_op {A B} (eqA:A->A->Prop)(eqB:B->B->Prop)(f:A->B->B) :=
  Proper (eqA==>eqB==>eqB) f.
-
diff --git a/theories/Lists/SetoidPermutation.v b/theories/Lists/SetoidPermutation.v
new file mode 100644
index 00000000..b0657b63
--- /dev/null
+++ b/theories/Lists/SetoidPermutation.v
@@ -0,0 +1,125 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+Require Import SetoidList.
+
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+(** Permutations of list modulo a setoid equality. *)
+
+(** Contribution by Robbert Krebbers (Nijmegen University). *)
+
+Section Permutation.
+Context {A : Type} (eqA : relation A) (e : Equivalence eqA).
+
+Inductive PermutationA : list A -> list A -> Prop :=
+  | permA_nil: PermutationA nil nil
+  | permA_skip x� x₂ l� l₂ :
+     eqA x� x₂ -> PermutationA l� l₂ -> PermutationA (x� :: l�) (x₂ :: l₂)
+  | permA_swap x y l : PermutationA (y :: x :: l) (x :: y :: l)
+  | permA_trans l� l₂ l₃ :
+     PermutationA l� l₂ -> PermutationA l₂ l₃ -> PermutationA l� l₃.
+Local Hint Constructors PermutationA.
+
+Global Instance: Equivalence PermutationA.
+Proof.
+ constructor.
+ - intro l. induction l; intuition.
+ - intros l� l₂. induction 1; eauto. apply permA_skip; intuition.
+ - exact permA_trans.
+Qed.
+
+Global Instance PermutationA_cons :
+  Proper (eqA ==> PermutationA ==> PermutationA) (@cons A).
+Proof.
+ repeat intro. now apply permA_skip.
+Qed.
+
+Lemma PermutationA_app_head l� l₂ l :
+  PermutationA l� l₂ -> PermutationA (l ++ l�) (l ++ l₂).
+Proof.
+ induction l; trivial; intros. apply permA_skip; intuition.
+Qed.
+
+Global Instance PermutationA_app :
+  Proper (PermutationA ==> PermutationA ==> PermutationA) (@app A).
+Proof.
+ intros l� l₂ Pl k� k₂ Pk.
+ induction Pl.
+ - easy.
+ - now apply permA_skip.
+ - etransitivity.
+   * rewrite <-!app_comm_cons. now apply permA_swap.
+   * rewrite !app_comm_cons. now apply PermutationA_app_head.
+ - do 2 (etransitivity; try eassumption).
+   apply PermutationA_app_head. now symmetry.
+Qed.
+
+Lemma PermutationA_app_tail l� l₂ l :
+  PermutationA l� l₂ -> PermutationA (l� ++ l) (l₂ ++ l).
+Proof.
+ intros E. now rewrite E.
+Qed.
+
+Lemma PermutationA_cons_append l x :
+  PermutationA (x :: l) (l ++ x :: nil).
+Proof.
+ induction l.
+ - easy.
+ - simpl. rewrite <-IHl. intuition.
+Qed.
+
+Lemma PermutationA_app_comm l� l₂ :
+  PermutationA (l� ++ l₂) (l₂ ++ l�).
+Proof.
+ induction l�.
+ - now rewrite app_nil_r.
+ - rewrite <-app_comm_cons, IHl�, app_comm_cons.
+   now rewrite PermutationA_cons_append, <-app_assoc.
+Qed.
+
+Lemma PermutationA_cons_app l l� l₂ x :
+  PermutationA l (l� ++ l₂) -> PermutationA (x :: l) (l� ++ x :: l₂).
+Proof.
+ intros E. rewrite E.
+ now rewrite app_comm_cons, PermutationA_cons_append, <-app_assoc.
+Qed.
+
+Lemma PermutationA_middle l� l₂ x :
+  PermutationA (x :: l� ++ l₂) (l� ++ x :: l₂).
+Proof.
+ now apply PermutationA_cons_app.
+Qed.
+
+Lemma PermutationA_equivlistA l� l₂ :
+  PermutationA l� l₂ -> equivlistA eqA l� l₂.
+Proof.
+ induction 1.
+ - reflexivity.
+ - now apply equivlistA_cons_proper.
+ - now apply equivlistA_permute_heads.
+ - etransitivity; eassumption.
+Qed.
+
+Lemma NoDupA_equivlistA_PermutationA l� l₂ :
+  NoDupA eqA l� -> NoDupA eqA l₂ ->
+   equivlistA eqA l� l₂ -> PermutationA l� l₂.
+Proof.
+  intros Pl�. revert l₂. induction Pl� as [|x l� E1].
+  - intros lâ‚‚ _ Hâ‚‚. symmetry in Hâ‚‚. now rewrite (equivlistA_nil_eq eqA).
+  - intros lâ‚‚ Plâ‚‚ E2.
+    destruct (@InA_split _ eqA lâ‚‚ x) as [lâ‚‚h [y [lâ‚‚t [E3 ?]]]].
+    { rewrite <-E2. intuition. }
+    subst. transitivity (y :: l�); [intuition |].
+    apply PermutationA_cons_app, IHPl�.
+    now apply NoDupA_split with y.
+    apply equivlistA_NoDupA_split with x y; intuition.
+Qed.
+
+End Permutation.
diff --git a/theories/Lists/StreamMemo.v b/theories/Lists/StreamMemo.v
index 1ab4fa9d..67882cde 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -32,10 +32,10 @@ Fixpoint memo_get (n:nat) (l:Stream A) : A :=
 Theorem memo_get_correct: forall n, memo_get n memo_list = f n.
 Proof.
 assert (F1: forall n m, memo_get n (memo_make m) = f (n + m)).
-  induction n as [| n Hrec]; try (intros m; refine (refl_equal _)).
+{ induction n as [| n Hrec]; try (intros m; reflexivity).
   intros m; simpl; rewrite Hrec.
-  rewrite plus_n_Sm; auto.
-intros n; apply trans_equal with (f (n + 0)); try exact (F1 n 0).
+  rewrite plus_n_Sm; auto. }
+intros n; transitivity (f (n + 0)); try exact (F1 n 0).
 rewrite <- plus_n_O; auto.
 Qed.
 
@@ -57,11 +57,10 @@ Definition imemo_list := let f0 := f 0 in
 
 Theorem imemo_get_correct: forall n, memo_get n imemo_list = f n.
 Proof.
-assert (F1: forall n m,
-    memo_get n (imemo_make (f m)) = f (S (n + m))).
-  induction n as [| n Hrec]; try (intros m; exact (sym_equal (Hg_correct m))).
-  simpl; intros m; rewrite <- Hg_correct; rewrite Hrec; rewrite <- plus_n_Sm; auto.
-destruct n as [| n]; try apply refl_equal.
+assert (F1: forall n m, memo_get n (imemo_make (f m)) = f (S (n + m))).
+{ induction n as [| n Hrec]; try (intros m; exact (eq_sym (Hg_correct m))).
+  simpl; intros m; rewrite <- Hg_correct, Hrec, <- plus_n_Sm; auto. }
+destruct n as [| n]; try reflexivity.
 unfold imemo_list; simpl; rewrite F1.
 rewrite <- plus_n_O; auto.
 Qed.
@@ -82,7 +81,7 @@ Inductive memo_val: Type :=
 
 Fixpoint is_eq (n m : nat) : {n = m} + {True} :=
   match n, m return {n = m} + {True} with
-  | 0, 0 =>left True (refl_equal 0)
+  | 0, 0 =>left True (eq_refl 0)
   | 0, S m1 => right (0 = S m1) I
   | S n1, 0 => right (S n1 = 0) I
   | S n1, S m1 =>
@@ -98,7 +97,7 @@ match v with
     match is_eq n m with
     | left H =>
        match H in (eq _ y) return (A y -> A n) with
-        | refl_equal => fun v1 : A n => v1
+        | eq_refl => fun v1 : A n => v1
        end
     | right _ => fun _ : A m => f n
     end x
@@ -115,7 +114,7 @@ Proof.
 intros n; unfold dmemo_get, dmemo_list.
 rewrite (memo_get_correct memo_val mf n); simpl.
 case (is_eq n n); simpl; auto; intros e.
-assert (e = refl_equal n).
+assert (e = eq_refl n).
  apply eq_proofs_unicity.
  induction x as [| x Hx]; destruct y as [| y].
  left; auto.
@@ -144,7 +143,7 @@ Proof.
 intros n; unfold dmemo_get, dimemo_list.
 rewrite (imemo_get_correct memo_val mf mg); simpl.
 case (is_eq n n); simpl; auto; intros e.
-assert (e = refl_equal n).
+assert (e = eq_refl n).
  apply eq_proofs_unicity.
  induction x as [| x Hx]; destruct y as [| y].
  left; auto.
@@ -169,11 +168,11 @@ Open Scope Z_scope.
 Fixpoint tfact (n: nat) :=
   match n with
    | O => 1
-   | S n1 => Z_of_nat n * tfact n1
+   | S n1 => Z.of_nat n * tfact n1
   end.
 
 Definition lfact_list :=
-  dimemo_list _ tfact (fun n z => (Z_of_nat (S  n) * z)).
+  dimemo_list _ tfact (fun n z => (Z.of_nat (S  n) * z)).
 
 Definition lfact n := dmemo_get _ tfact n lfact_list.
 
diff --git a/theories/Lists/Streams.v b/theories/Lists/Streams.v
index 02d17211..e1122cf9 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-2012     *)
 (*   \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 *)
@@ -51,21 +49,21 @@ Qed.
 Lemma tl_nth_tl :
  forall (n:nat) (s:Stream), tl (Str_nth_tl n s) = Str_nth_tl n (tl s).
 Proof.
-  simple induction n; simpl in |- *; auto.
+  simple induction n; simpl; auto.
 Qed.
 Hint Resolve tl_nth_tl: datatypes v62.
 
 Lemma Str_nth_tl_plus :
  forall (n m:nat) (s:Stream),
    Str_nth_tl n (Str_nth_tl m s) = Str_nth_tl (n + m) s.
-simple induction n; simpl in |- *; intros; auto with datatypes.
+simple induction n; simpl; intros; auto with datatypes.
 rewrite <- H.
 rewrite tl_nth_tl; trivial with datatypes.
 Qed.
 
 Lemma Str_nth_plus :
  forall (n m:nat) (s:Stream), Str_nth n (Str_nth_tl m s) = Str_nth (n + m) s.
-intros; unfold Str_nth in |- *; rewrite Str_nth_tl_plus;
+intros; unfold Str_nth; rewrite Str_nth_tl_plus;
  trivial with datatypes.
 Qed.
 
@@ -91,7 +89,7 @@ Qed.
 
 Theorem sym_EqSt : forall s1 s2:Stream, EqSt s1 s2 -> EqSt s2 s1.
 coinduction Eq_sym.
-case H; intros; symmetry  in |- *; assumption.
+case H; intros; symmetry ; assumption.
 case H; intros; assumption.
 Qed.
 
@@ -112,10 +110,10 @@ Qed.
 
 Theorem eqst_ntheq :
  forall (n:nat) (s1 s2:Stream), EqSt s1 s2 -> Str_nth n s1 = Str_nth n s2.
-unfold Str_nth in |- *; simple induction n.
+unfold Str_nth; simple induction n.
 intros s1 s2 H; case H; trivial with datatypes.
 intros m hypind.
-simpl in |- *.
+simpl.
 intros s1 s2 H.
 apply hypind.
 case H; trivial with datatypes.
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..d372de8e 100755
--- a/theories/Lists/intro.tex
+++ b/theories/Lists/intro.tex
@@ -13,12 +13,8 @@ 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
+  co-inductive type. Basic facts are stated and proved. The streams are
   also polymorphic.
 
 \end{itemize}
diff --git a/theories/Lists/vo.itarget b/theories/Lists/vo.itarget
index d2a31367..04994f59 100644
--- a/theories/Lists/vo.itarget
+++ b/theories/Lists/vo.itarget
@@ -2,6 +2,6 @@ ListSet.vo
 ListTactics.vo
 List.vo
 SetoidList.vo
+SetoidPermutation.vo
 StreamMemo.vo
 Streams.vo
-TheoryList.vo
diff --git a/theories/Logic/Berardi.v b/theories/Logic/Berardi.v
index d954f40c..38377573 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-2012     *)
 (*   \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).
@@ -47,7 +45,7 @@ Lemma AC_IF :
    (B -> Q e1) -> (~ B -> Q e2) -> Q (IFProp B e1 e2).
 Proof.
 intros P B e1 e2 Q p1 p2.
-unfold IFProp in |- *.
+unfold IFProp.
 case (EM B); assumption.
 Qed.
 
@@ -78,7 +76,7 @@ Record retract_cond : Prop :=
 Lemma AC : forall r:retract_cond, retract -> forall a:A, j2 r (i2 r a) = a.
 Proof.
 intros r.
-case r; simpl in |- *.
+case r; simpl.
 trivial.
 Qed.
 
@@ -115,7 +113,7 @@ Lemma retract_pow_U_U : retract (pow U) U.
 Proof.
 exists g f.
 intro a.
-unfold f, g in |- *; simpl in |- *.
+unfold f, g; simpl.
 apply AC.
 exists (fun x:pow U => x) (fun x:pow U => x).
 trivial.
@@ -132,8 +130,8 @@ Definition R : U := g (fun u:U => Not_b (u U u)).
 
 Lemma not_has_fixpoint : R R = Not_b (R R).
 Proof.
-unfold R at 1 in |- *.
-unfold g in |- *.
+unfold R at 1.
+unfold g.
 rewrite AC with (r := L1 U U) (a := fun u:U => Not_b (u U u)).
 trivial.
 exists (fun x:pow U => x) (fun x:pow U => x); trivial.
@@ -143,7 +141,7 @@ Qed.
 Theorem classical_proof_irrelevence : T = F.
 Proof.
 generalize not_has_fixpoint.
-unfold Not_b in |- *.
+unfold Not_b.
 apply AC_IF.
 intros is_true is_false.
 elim is_true; elim is_false; trivial.
diff --git a/theories/Logic/ChoiceFacts.v b/theories/Logic/ChoiceFacts.v
index 60dbf3ea..1a32d518 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-2012     *)
 (*   \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.
 
@@ -346,7 +344,7 @@ Lemma rel_choice_and_proof_irrel_imp_guarded_rel_choice :
   RelationalChoice -> ProofIrrelevance -> GuardedRelationalChoice.
 Proof.
   intros rel_choice proof_irrel.
-  red in |- *; intros A B P R H.
+  red; intros A B P R H.
   destruct (rel_choice _ _ (fun (x:sigT P) (y:B) => R (projT1 x) y)) as (R',(HR'R,H0)).
   intros (x,HPx).
   destruct (H x HPx) as (y,HRxy).
@@ -387,7 +385,7 @@ Qed.
 Lemma subset_types_imp_guarded_rel_choice_iff_rel_choice :
   ProofIrrelevance -> (GuardedRelationalChoice <-> RelationalChoice).
 Proof.
-  auto decomp using
+  intuition auto using
     guarded_rel_choice_imp_rel_choice,
     rel_choice_and_proof_irrel_imp_guarded_rel_choice.
 Qed.
@@ -441,7 +439,7 @@ Corollary fun_choice_and_indep_general_prem_iff_guarded_fun_choice :
   FunctionalChoiceOnInhabitedSet /\ IndependenceOfGeneralPremises
   <-> GuardedFunctionalChoice.
 Proof.
-  auto decomp using
+  intuition auto using
     guarded_fun_choice_imp_indep_of_general_premises,
     guarded_fun_choice_imp_fun_choice,
     fun_choice_and_indep_general_prem_imp_guarded_fun_choice.
@@ -482,7 +480,7 @@ Corollary fun_choice_and_small_drinker_iff_omniscient_fun_choice :
   FunctionalChoiceOnInhabitedSet /\ SmallDrinker'sParadox
   <-> OmniscientFunctionalChoice.
 Proof.
-  auto decomp using
+  intuition auto using
     omniscient_fun_choice_imp_small_drinker,
     omniscient_fun_choice_imp_fun_choice,
     fun_choice_and_small_drinker_imp_omniscient_fun_choice.
@@ -549,7 +547,7 @@ Theorem constructive_indefinite_description_and_small_drinker_iff_epsilon :
   (EpsilonStatement ->
    SmallDrinker'sParadox * ConstructiveIndefiniteDescription).
 Proof.
-  auto decomp using
+  intuition auto using
     epsilon_imp_constructive_indefinite_description,
     constructive_indefinite_description_and_small_drinker_imp_epsilon,
     epsilon_imp_small_drinker.
@@ -582,7 +580,7 @@ Lemma classical_denumerable_description_imp_fun_choice :
       (forall x y, decidable (R x y)) -> FunctionalChoice_on_rel R.
 Proof.
   intros A Descr.
-  red in |- *; intros R Rdec H.
+  red; intros R Rdec H.
   set (R':= fun x y => R x y /\ forall y', R x y' -> y <= y').
   destruct (Descr R') as (f,Hf).
   intro x.
@@ -691,7 +689,7 @@ Qed.
 Corollary dep_iff_non_dep_functional_rel_reification :
   FunctionalRelReification <-> DependentFunctionalRelReification.
 Proof.
-  auto decomp using
+  intuition auto using
     non_dep_dep_functional_rel_reification,
     dep_non_dep_functional_rel_reification.
 Qed.
@@ -816,9 +814,9 @@ Corollary fun_reification_descr_computational_excluded_middle_in_prop_context :
   (forall P:Prop, P \/ ~ P) ->
   forall C:Prop, ((forall P:Prop, {P} + {~ P}) -> C) -> C.
 Proof.
-  intros FunReify EM C; auto decomp using
-    constructive_definite_descr_excluded_middle,
-    (relative_non_contradiction_of_definite_descr (C:=C)).
+  intros FunReify EM C H.
+  apply relative_non_contradiction_of_definite_descr; trivial.
+  auto using constructive_definite_descr_excluded_middle.
 Qed.
 
 (**********************************************************************)
diff --git a/theories/Logic/Classical.v b/theories/Logic/Classical.v
index 3f36ff38..d25e0e21 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-2012     *)
 (*   \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..479056c9 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-2012     *)
 (*   \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..2fd6e68e 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-2012     *)
 (*   \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,13 +16,11 @@
 
 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 }.
+Local Notation inhabited A := A (only parsing).
 
 (** The idea for the following proof comes from [ChicliPottierSimpson02] *)
 
diff --git a/theories/Logic/ClassicalEpsilon.v b/theories/Logic/ClassicalEpsilon.v
index 52ecadaf..7ab991f8 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-2012     *)
 (*   \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..34ae1cd5 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-2012     *)
 (*   \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:
@@ -119,7 +117,7 @@ Qed.
 
 *)
 
-Notation Local inhabited A := A (only parsing).
+Local Notation inhabited A := A (only parsing).
 
 Lemma prop_ext_A_eq_A_imp_A :
   prop_extensionality -> forall A:Prop, inhabited A -> (A -> A) = A.
@@ -150,7 +148,7 @@ Proof.
   case (prop_ext_retract_A_A_imp_A Ext A a); intros g1 g2 g1_o_g2.
   exists (fun f => (fun x:A => f (g1 x x)) (g2 (fun x => f (g1 x x)))).
   intro f.
-  pattern (g1 (g2 (fun x:A => f (g1 x x)))) at 1 in |- *.
+  pattern (g1 (g2 (fun x:A => f (g1 x x)))) at 1.
   rewrite (g1_o_g2 (fun x:A => f (g1 x x))).
   reflexivity.
 Qed.
@@ -193,13 +191,13 @@ Section Proof_irrelevance_gen.
     intros Ext Ind.
     case (ext_prop_fixpoint Ext bool true); intros G Gfix.
     set (neg := fun b:bool => bool_elim bool false true b).
-    generalize (refl_equal (G neg)).
-    pattern (G neg) at 1 in |- *.
+    generalize (eq_refl (G neg)).
+    pattern (G neg) at 1.
     apply Ind with (b := G neg); intro Heq.
     rewrite (bool_elim_redl bool false true).
-    change (true = neg true) in |- *; rewrite Heq; apply Gfix.
+    change (true = neg true); rewrite Heq; apply Gfix.
     rewrite (bool_elim_redr bool false true).
-    change (neg false = false) in |- *; rewrite Heq; symmetry  in |- *;
+    change (neg false = false); rewrite Heq; symmetry ;
       apply Gfix.
   Qed.
 
@@ -209,9 +207,9 @@ Section Proof_irrelevance_gen.
     intros Ext Ind A a1 a2.
     set (f := fun b:bool => bool_elim A a1 a2 b).
     rewrite (bool_elim_redl A a1 a2).
-    change (f true = a2) in |- *.
+    change (f true = a2).
     rewrite (bool_elim_redr A a1 a2).
-    change (f true = f false) in |- *.
+    change (f true = f false).
     rewrite (aux Ext Ind).
     reflexivity.
   Qed.
@@ -230,9 +228,9 @@ Section Proof_irrelevance_Prop_Ext_CC.
   Definition FalseP : BoolP := fun C c1 c2 => c2.
   Definition BoolP_elim C c1 c2 (b:BoolP) := b C c1 c2.
   Definition BoolP_elim_redl (C:Prop) (c1 c2:C) :
-    c1 = BoolP_elim C c1 c2 TrueP := refl_equal c1.
+    c1 = BoolP_elim C c1 c2 TrueP := eq_refl c1.
   Definition BoolP_elim_redr (C:Prop) (c1 c2:C) :
-    c2 = BoolP_elim C c1 c2 FalseP := refl_equal c2.
+    c2 = BoolP_elim C c1 c2 FalseP := eq_refl c2.
 
   Definition BoolP_dep_induction :=
     forall P:BoolP -> Prop, P TrueP -> P FalseP -> forall b:BoolP, P b.
@@ -265,9 +263,9 @@ Section Proof_irrelevance_CIC.
     | trueP : boolP
     | falseP : boolP.
   Definition boolP_elim_redl (C:Prop) (c1 c2:C) :
-    c1 = boolP_ind C c1 c2 trueP := refl_equal c1.
+    c1 = boolP_ind C c1 c2 trueP := eq_refl c1.
   Definition boolP_elim_redr (C:Prop) (c1 c2:C) :
-    c2 = boolP_ind C c1 c2 falseP := refl_equal c2.
+    c2 = boolP_ind C c1 c2 falseP := eq_refl c2.
   Scheme boolP_indd := Induction for boolP Sort Prop.
 
   Lemma ext_prop_dep_proof_irrel_cic : prop_extensionality -> proof_irrelevance.
@@ -346,8 +344,8 @@ Section Proof_irrelevance_EM_CC.
 
   Lemma p2p1 : forall A:Prop, A -> b2p (p2b A).
   Proof.
-    unfold p2b in |- *; intro A; apply or_dep_elim with (b := em A);
-      unfold b2p in |- *; intros.
+    unfold p2b; intro A; apply or_dep_elim with (b := em A);
+      unfold b2p; intros.
     apply (or_elim_redl A (~ A) B (fun _ => b1) (fun _ => b2)).
     destruct (b H).
   Qed.
@@ -355,8 +353,8 @@ Section Proof_irrelevance_EM_CC.
   Lemma p2p2 : b1 <> b2 -> forall A:Prop, b2p (p2b A) -> A.
   Proof.
     intro not_eq_b1_b2.
-    unfold p2b in |- *; intro A; apply or_dep_elim with (b := em A);
-      unfold b2p in |- *; intros.
+    unfold p2b; intro A; apply or_dep_elim with (b := em A);
+      unfold b2p; intros.
     assumption.
     destruct not_eq_b1_b2.
     rewrite <- (or_elim_redr A (~ A) B (fun _ => b1) (fun _ => b2)) in H.
@@ -394,9 +392,9 @@ Section Proof_irrelevance_CCI.
   Hypothesis em : forall A:Prop, A \/ ~ A.
 
   Definition or_elim_redl (A B C:Prop) (f:A -> C) (g:B -> C)
-    (a:A) : f a = or_ind f g (or_introl B a) := refl_equal (f a).
+    (a:A) : f a = or_ind f g (or_introl B a) := eq_refl (f a).
   Definition or_elim_redr (A B C:Prop) (f:A -> C) (g:B -> C)
-    (b:B) : g b = or_ind f g (or_intror A b) := refl_equal (g b).
+    (b:B) : g b = or_ind f g (or_intror A b) := eq_refl (g b).
   Scheme or_indd := Induction for or Sort Prop.
 
   Theorem proof_irrelevance_cci : forall (B:Prop) (b1 b2:B), b1 = b2.
diff --git a/theories/Logic/ClassicalUniqueChoice.v b/theories/Logic/ClassicalUniqueChoice.v
index fafa0b94..4a4fc23f 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-2012     *)
 (*   \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..cda9d22c 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-2012     *)
 (*   \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..7e1a4096 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-2012     *)
 (*   \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 *)
 
@@ -41,7 +42,7 @@ Qed.
 Lemma not_ex_all_not :
  forall P:U -> Prop, ~ (exists n : U, P n) -> forall n:U, ~ P n.
 Proof. (* Intuitionistic *)
-unfold not in |- *; intros P notex n abs.
+unfold not; intros P notex n abs.
 apply notex.
 exists n; trivial.
 Qed.
@@ -51,20 +52,20 @@ Lemma not_ex_not_all :
 Proof.
 intros P H n.
 apply NNPP.
-red in |- *; intro K; apply H; exists n; trivial.
+red; intro K; apply H; exists n; trivial.
 Qed.
 
 Lemma ex_not_not_all :
  forall P:U -> Prop, (exists n : U, ~ P n) -> ~ (forall n:U, P n).
 Proof. (* Intuitionistic *)
-unfold not in |- *; intros P exnot allP.
+unfold not; intros P exnot allP.
 elim exnot; auto.
 Qed.
 
 Lemma all_not_not_ex :
  forall P:U -> Prop, (forall n:U, ~ P n) -> ~ (exists n : U, P n).
 Proof. (* Intuitionistic *)
-unfold not in |- *; intros P allnot exP; elim exP; intros n p.
+unfold not; intros P allnot exP; elim exP; intros n p.
 apply allnot with n; auto.
 Qed.
 
diff --git a/theories/Logic/Classical_Prop.v b/theories/Logic/Classical_Prop.v
index c51050d5..1f6b05f5 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-2012     *)
 (*   \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 *)
 
@@ -18,7 +20,7 @@ Axiom classic : forall P:Prop, P \/ ~ P.
 
 Lemma NNPP : forall p:Prop, ~ ~ p -> p.
 Proof.
-unfold not in |- *; intros; elim (classic p); auto.
+unfold not; intros; elim (classic p); auto.
 intro NP; elim (H NP).
 Qed.
 
@@ -33,7 +35,7 @@ Qed.
 
 Lemma not_imply_elim : forall P Q:Prop, ~ (P -> Q) -> P.
 Proof.
-intros; apply NNPP; red in |- *.
+intros; apply NNPP; red.
 intro; apply H; intro; absurd P; trivial.
 Qed.
 
@@ -66,7 +68,7 @@ Qed.
 
 Lemma or_not_and : forall P Q:Prop, ~ P \/ ~ Q -> ~ (P /\ Q).
 Proof.
-simple induction 1; red in |- *; simple induction 2; auto.
+simple induction 1; red; simple induction 2; auto.
 Qed.
 
 Lemma not_or_and : forall P Q:Prop, ~ (P \/ Q) -> ~ P /\ ~ Q.
@@ -110,7 +112,7 @@ Module Eq_rect_eq.
 Lemma eq_rect_eq :
   forall (U:Type) (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h.
 Proof.
-intros; rewrite proof_irrelevance with (p1:=h) (p2:=refl_equal p); reflexivity.
+intros; rewrite proof_irrelevance with (p1:=h) (p2:=eq_refl p); reflexivity.
 Qed.
 
 End Eq_rect_eq.
diff --git a/theories/Logic/Classical_Type.v b/theories/Logic/Classical_Type.v
index 94e623bd..86fdd69f 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-2012     *)
 (*   \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..89d3eebc 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-2012     *)
 (*   \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 15714 2012-08-08 18:54:37Z 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.
 
@@ -113,7 +112,7 @@ of our searching algorithm. *)
 
 Let R (x y : nat) : Prop := x = S y /\ ~ P y.
 
-Notation Local acc x := (Acc R x).
+Local Notation acc x := (Acc R x).
 
 Lemma P_implies_acc : forall x : nat, P x -> acc x.
 Proof.
@@ -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..aaf1813b 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-2012     *)
 (*   \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..3e5d4ef0 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-2012     *)
 (*   \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..87b27987 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-2012     *)
 (*   \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
@@ -63,7 +61,7 @@ Variable pred_extensionality : PredicateExtensionality.
 Lemma prop_ext : forall A B:Prop, (A <-> B) -> A = B.
 Proof.
   intros A B H.
-  change ((fun _ => A) true = (fun _ => B) true) in |- *.
+  change ((fun _ => A) true = (fun _ => B) true).
   rewrite
    pred_extensionality with (P := fun _:bool => A) (Q := fun _:bool => B).
     reflexivity.
@@ -136,8 +134,8 @@ right.
 intro HP.
 assert (Hequiv : forall b:bool, class_of_true b <-> class_of_false b).
 intro b; split.
-unfold class_of_false in |- *; right; assumption.
-unfold class_of_true in |- *; right; assumption.
+unfold class_of_false; right; assumption.
+unfold class_of_true; right; assumption.
 assert (Heq : class_of_true = class_of_false).
 apply pred_extensionality with (1 := Hequiv).
 apply diff_true_false.
@@ -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.
 
@@ -190,8 +188,8 @@ Lemma projT1_injective : a1=a2 -> a1'=a2'.
 Proof.
   intro Heq ; unfold a1', a2', A'.
   rewrite Heq.
-  replace (or_introl (a2=a2) (refl_equal a2))
-     with (or_intror (a2=a2) (refl_equal a2)).
+  replace (or_introl (a2=a2) (eq_refl a2))
+     with (or_intror (a2=a2) (eq_refl a2)).
   reflexivity.
   apply proof_irrelevance.
 Qed.
@@ -267,7 +265,7 @@ End ProofIrrel_RelChoice_imp_EqEM.
 
 (** Proof sketch from Bell [Bell93] (with thanks to P. Castéran) *)
 
-Notation Local inhabited A := A (only parsing).
+Local Notation inhabited A := A (only parsing).
 
 Section ExtensionalEpsilon_imp_EM.
 
@@ -281,7 +279,7 @@ Hypothesis epsilon_extensionality :
   forall (A:Type) (i:inhabited A) (P Q:A->Prop),
   (forall a, P a <-> Q a) -> epsilon A i P = epsilon A i Q.
 
-Notation Local eps := (epsilon bool true) (only parsing).
+Local Notation eps := (epsilon bool true) (only parsing).
 
 Theorem extensional_epsilon_imp_EM : forall P:Prop, P \/ ~ P.
 Proof.
diff --git a/theories/Logic/Epsilon.v b/theories/Logic/Epsilon.v
index 9134b3aa..da3e5b08 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-2012     *)
 (*   \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..6841334f 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-2012     *)
 (*   \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..a22f286e 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-2012     *)
 (*   \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.
@@ -94,14 +101,14 @@ Section Dependent_Equality.
     forall (p q:U) (x:P p) (y:P q), eq_dep p x q y -> eq_dep1 p x q y.
   Proof.
     destruct 1.
-    apply eq_dep1_intro with (refl_equal p).
-    simpl in |- *; trivial.
+    apply eq_dep1_intro with (eq_refl p).
+    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 *)
 
@@ -114,26 +121,105 @@ Proof.
   apply eq_dep_intro.
 Qed.
 
-Notation eq_sigS_eq_dep := eq_sigT_eq_dep (only parsing). (* Compatibility *)
+Notation eq_sigS_eq_dep := eq_sigT_eq_dep (compat "8.2"). (* 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.
@@ -164,12 +250,12 @@ Section Equivalences.
   (** Uniqueness of Reflexive Identity Proofs *)
 
   Definition UIP_refl_ :=
-    forall (x:U) (p:x = x), p = refl_equal x.
+    forall (x:U) (p:x = x), p = eq_refl x.
 
   (** Streicher's axiom K *)
 
   Definition Streicher_K_ :=
-    forall (x:U) (P:x = x -> Prop), P (refl_equal x) -> forall p:x = x, P p.
+    forall (x:U) (P:x = x -> Prop), P (eq_refl x) -> forall p:x = x, P p.
 
   (** Injectivity of Dependent Equality is a consequence of *)
   (** Invariance by Substitution of Reflexive Equality Proof *)
@@ -303,14 +389,14 @@ Proof (eq_dep_eq__UIP U eq_dep_eq).
 
 (** Uniqueness of Reflexive Identity Proofs is a direct instance of UIP *)
 
-Lemma UIP_refl : forall (x:U) (p:x = x), p = refl_equal x.
+Lemma UIP_refl : forall (x:U) (p:x = x), p = eq_refl x.
 Proof (UIP__UIP_refl U UIP).
 
 (** Streicher's axiom K is a direct consequence of Uniqueness of
     Reflexive Identity Proofs *)
 
 Lemma Streicher_K :
-  forall (x:U) (P:x = x -> Prop), P (refl_equal x) -> forall p:x = x, P p.
+  forall (x:U) (P:x = x -> Prop), P (eq_refl x) -> forall p:x = x, P p.
 Proof (UIP_refl__Streicher_K U UIP_refl).
 
 End Axioms.
@@ -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..3a6f6a23 100644
--- a/theories/Logic/Eqdep_dec.v
+++ b/theories/Logic/Eqdep_dec.v
@@ -1,14 +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-2012     *)
 (*   \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].
+(** We prove that there is only one proof of [x=x], i.e [eq_refl x].
     This holds if the equality upon the set of [x] is decidable.
     A corollary of this theorem is the equality of the right projections
     of two equal dependent pairs.
@@ -42,7 +43,7 @@ Section EqdepDec.
   Let comp (x y y':A) (eq1:x = y) (eq2:x = y') : y = y' :=
     eq_ind _ (fun a => a = y') eq2 _ eq1.
 
-  Remark trans_sym_eq : forall (x y:A) (u:x = y), comp u u = refl_equal y.
+  Remark trans_sym_eq : forall (x y:A) (u:x = y), comp u u = eq_refl y.
   Proof.
     intros.
     case u; trivial.
@@ -60,7 +61,7 @@ Section EqdepDec.
 
   Let nu_constant : forall (y:A) (u v:x = y), nu u = nu v.
     intros.
-    unfold nu in |- *.
+    unfold nu.
     case (eq_dec x y); intros.
     reflexivity.
 
@@ -68,13 +69,13 @@ Section EqdepDec.
   Qed.
 
 
-  Let nu_inv (y:A) (v:x = y) : x = y := comp (nu (refl_equal x)) v.
+  Let nu_inv (y:A) (v:x = y) : x = y := comp (nu (eq_refl x)) v.
 
 
   Remark nu_left_inv : forall (y:A) (u:x = y), nu_inv (nu u) = u.
   Proof.
     intros.
-    case u; unfold nu_inv in |- *.
+    case u; unfold nu_inv.
     apply trans_sym_eq.
   Qed.
 
@@ -89,10 +90,10 @@ Section EqdepDec.
   Qed.
 
   Theorem K_dec :
-    forall P:x = x -> Prop, P (refl_equal x) -> forall p:x = x, P p.
+    forall P:x = x -> Prop, P (eq_refl x) -> forall p:x = x, P p.
   Proof.
     intros.
-    elim eq_proofs_unicity with x (refl_equal x) p.
+    elim eq_proofs_unicity with x (eq_refl x) p.
     trivial.
   Qed.
 
@@ -114,7 +115,7 @@ Section EqdepDec.
   Proof.
     intros.
     cut (proj (ex_intro P x y) y = proj (ex_intro P x y') y).
-    simpl in |- *.
+    simpl.
     case (eq_dec x x).
     intro e.
     elim e using K_dec; trivial.
@@ -134,7 +135,7 @@ Require Import EqdepFacts.
 Theorem K_dec_type :
   forall A:Type,
     (forall x y:A, {x = y} + {x <> y}) ->
-    forall (x:A) (P:x = x -> Prop), P (refl_equal x) -> forall p:x = x, P p.
+    forall (x:A) (P:x = x -> Prop), P (eq_refl x) -> forall p:x = x, P p.
 Proof.
   intros A eq_dec x P H p.
   elim p using K_dec; intros.
@@ -145,7 +146,7 @@ Qed.
 Theorem K_dec_set :
   forall A:Set,
     (forall x y:A, {x = y} + {x <> y}) ->
-    forall (x:A) (P:x = x -> Prop), P (refl_equal x) -> forall p:x = x, P p.
+    forall (x:A) (P:x = x -> Prop), P (eq_refl x) -> forall p:x = x, P p.
 Proof fun A => K_dec_type (A:=A).
 
 (** We deduce the [eq_rect_eq] axiom for (decidable) types *)
@@ -211,13 +212,13 @@ Module DecidableEqDep (M:DecidableType).
 
   (** Uniqueness of Reflexive Identity Proofs *)
 
-  Lemma UIP_refl : forall (x:U) (p:x = x), p = refl_equal x.
+  Lemma UIP_refl : forall (x:U) (p:x = x), p = eq_refl x.
   Proof (UIP__UIP_refl U UIP).
 
   (** Streicher's axiom K *)
 
   Lemma Streicher_K :
-    forall (x:U) (P:x = x -> Prop), P (refl_equal x) -> forall p:x = x, P p.
+    forall (x:U) (P:x = x -> Prop), P (eq_refl x) -> forall p:x = x, P p.
   Proof (K_dec_type eq_dec).
 
   (** Injectivity of equality on dependent pairs in [Type] *)
@@ -280,13 +281,13 @@ Module DecidableEqDepSet (M:DecidableSet).
 
   (** Uniqueness of Reflexive Identity Proofs *)
 
-  Lemma UIP_refl : forall (x:U) (p:x = x), p = refl_equal x.
+  Lemma UIP_refl : forall (x:U) (p:x = x), p = eq_refl x.
   Proof N.UIP_refl.
 
   (** Streicher's axiom K *)
 
   Lemma Streicher_K :
-    forall (x:U) (P:x = x -> Prop), P (refl_equal x) -> forall p:x = x, P p.
+    forall (x:U) (P:x = x -> Prop), P (eq_refl x) -> forall p:x = x, P p.
   Proof N.Streicher_K.
 
   (** Proof-irrelevance on subsets of decidable sets *)
@@ -300,7 +301,7 @@ Module DecidableEqDepSet (M:DecidableSet).
 
   Lemma inj_pair2 :
     forall (P:U -> Type) (p:U) (x y:P p),
-      existS P p x = existS P p y -> x = y.
+      existT P p x = existT P p y -> x = y.
   Proof eq_dep_eq__inj_pair2 U N.eq_dep_eq.
 
   (** Injectivity of equality on dependent pairs with second component
diff --git a/theories/Logic/ExtensionalityFacts.v b/theories/Logic/ExtensionalityFacts.v
new file mode 100644
index 00000000..9cbf756d
--- /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-2012     *)
+(*   \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..ecb7428e 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-2012     *)
 (*   \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..1dce51b2 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -46,7 +46,7 @@ Lemma Omega : forall i:U -> bool, induct i -> b2p (i WF).
 Proof.
 intros i y.
 apply y.
-unfold le, WF, induct in |- *.
+unfold le, WF, induct.
 apply p2p2.
 intros x H0.
 apply y.
@@ -55,7 +55,7 @@ Qed.
 
 Lemma lemma1 : induct (fun u => p2b (I u)).
 Proof.
-unfold induct in |- *.
+unfold induct.
 intros x p.
 apply (p2p2 (I x)).
 intro q.
diff --git a/theories/Logic/IndefiniteDescription.v b/theories/Logic/IndefiniteDescription.v
index afca2ee1..5424eea8 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-2012     *)
 (*   \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..530e0555 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-2012     *)
 (*   \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..7d6d0cf8 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-2012     *)
 (*   \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..2e9f0c19 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -25,7 +25,7 @@ Module ProofIrrelevanceTheory (M:ProofIrrelevance).
       forall (U:Type) (p:U) (Q:U -> Type) (x:Q p) (h:p = p),
         x = eq_rect p Q x p h.
     Proof.
-      intros; rewrite M.proof_irrelevance with (p1:=h) (p2:=refl_equal p).
+      intros; rewrite M.proof_irrelevance with (p1:=h) (p2:=eq_refl p).
       reflexivity.
     Qed.
   End Eq_rect_eq.
diff --git a/theories/Logic/RelationalChoice.v b/theories/Logic/RelationalChoice.v
index 25d07fc9..efec03d4 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-2012     *)
 (*   \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..c0a6f9ed 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-2012     *)
 (*   \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..db12ee31 100644
--- a/theories/MSets/MSetAVL.v
+++ b/theories/MSets/MSetAVL.v
@@ -7,15 +7,13 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id$ *)
-
 (** * MSetAVL : Implementation of MSetInterface via AVL trees *)
 
 (** This module implements finite sets using AVL trees.
     It follows the implementation from Ocaml's standard library,
 
     All operations given here expect and produce well-balanced trees
-    (in the ocaml sense: heigths of subtrees shouldn't differ by more
+    (in the ocaml sense: heights of subtrees shouldn't differ by more
     than 2), and hence has low complexities (e.g. add is logarithmic
     in the size of the set). But proving these balancing preservations
     is in fact not necessary for ensuring correct operational behavior
@@ -33,73 +31,42 @@
     code after extraction.
 *)
 
-Require Import MSetInterface ZArith Int.
+Require Import MSetInterface MSetGenTree ZArith Int.
 
 Set Implicit Arguments.
 Unset Strict Implicit.
-(* for nicer extraction, we create only logical inductive principles *)
+(* for nicer extraction, we create inductive principles
+   only when needed *)
 Local Unset Elimination Schemes.
 Local Unset Case Analysis Schemes.
 
 (** * Ops : the pure functions *)
 
-Module Ops (Import I:Int)(X:OrderedType) <: WOps X.
+Module Ops (Import I:Int)(X:OrderedType) <: MSetInterface.Ops X.
 Local Open Scope Int_scope.
-Local Open Scope lazy_bool_scope.
-
-Definition elt := X.t.
+Local Notation int := I.t.
 
-(** ** Trees
+(** ** Generic trees instantiated with integer height *)
 
-   The fourth field of [Node] is the height of the tree *)
+(** We reuse a generic definition of trees where the information
+    parameter is a [Int.t]. Functions like mem or fold are also
+    provided by this generic functor. *)
 
-Inductive tree :=
-  | Leaf : tree
-  | Node : tree -> X.t -> tree -> int -> tree.
+Include MSetGenTree.Ops X I.
 
 Definition t := tree.
 
-(** ** Basic functions on trees: height and cardinal *)
+(** ** Height of trees *)
 
 Definition height (s : t) : int :=
   match s with
   | Leaf => 0
-  | Node _ _ _ h => h
-  end.
-
-Fixpoint cardinal (s : t) : nat :=
-  match s with
-   | Leaf => 0%nat
-   | Node l _ r _ => S (cardinal l + cardinal r)
+  | Node h _ _ _ => h
   end.
 
-(** ** Empty Set *)
-
-Definition empty := Leaf.
-
-(** ** Emptyness test *)
-
-Definition is_empty s :=
-  match s with Leaf => true | _ => false end.
-
-(** ** Membership *)
-
-(** The [mem] function is deciding membership. It exploits the
-    binary search tree invariant to achieve logarithmic complexity. *)
-
-Fixpoint mem x s :=
-   match s with
-     |  Leaf => false
-     |  Node l y r _ => match X.compare x y with
-             | Lt => mem x l
-             | Eq => true
-             | Gt => mem x r
-         end
-   end.
-
 (** ** Singleton set *)
 
-Definition singleton x := Node Leaf x Leaf 1.
+Definition singleton x := Node 1 Leaf x Leaf.
 
 (** ** Helper functions *)
 
@@ -107,7 +74,7 @@ Definition singleton x := Node Leaf x Leaf 1.
     to be balanced and [|height l - height r| <= 2]. *)
 
 Definition create l x r :=
-   Node l x r (max (height l) (height r) + 1).
+   Node (max (height l) (height r) + 1) l x r.
 
 (** [bal l x r] acts as [create], but performs one step of
     rebalancing if necessary, i.e. assumes [|height l - height r| <= 3]. *)
@@ -120,13 +87,13 @@ Definition bal l x r :=
   if gt_le_dec hl (hr+2) then
     match l with
      | Leaf => assert_false l x r
-     | Node ll lx lr _ =>
+     | Node _ ll lx lr =>
        if ge_lt_dec (height ll) (height lr) then
          create ll lx (create lr x r)
        else
          match lr with
           | Leaf => assert_false l x r
-          | Node lrl lrx lrr _ =>
+          | Node _ lrl lrx lrr =>
               create (create ll lx lrl) lrx (create lrr x r)
          end
     end
@@ -134,13 +101,13 @@ Definition bal l x r :=
     if gt_le_dec hr (hl+2) then
       match r with
        | Leaf => assert_false l x r
-       | Node rl rx rr _ =>
+       | Node _ rl rx rr =>
          if ge_lt_dec (height rr) (height rl) then
             create (create l x rl) rx rr
          else
            match rl with
             | Leaf => assert_false l x r
-            | Node rll rlx rlr _ =>
+            | Node _ rll rlx rlr =>
                 create (create l x rll) rlx (create rlr rx rr)
            end
       end
@@ -150,11 +117,11 @@ Definition bal l x r :=
 (** ** Insertion *)
 
 Fixpoint add x s := match s with
-   | Leaf => Node Leaf x Leaf 1
-   | Node l y r h =>
+   | Leaf => Node 1 Leaf x Leaf
+   | Node h l y r =>
       match X.compare x y with
          | Lt => bal (add x l) y r
-         | Eq => Node l y r h
+         | Eq => Node h l y r
          | Gt => bal l y (add x r)
       end
   end.
@@ -168,10 +135,10 @@ Fixpoint add x s := match s with
 Fixpoint join l : elt -> t -> t :=
   match l with
     | Leaf => add
-    | Node ll lx lr lh => fun x =>
+    | Node lh ll lx lr => fun x =>
        fix join_aux (r:t) : t := match r with
-          | Leaf =>  add x l
-          | Node rl rx rr rh =>
+          | Leaf => add x l
+          | Node rh rl rx rr =>
                if gt_le_dec lh (rh+2) then bal ll lx (join lr x r)
                else if gt_le_dec rh (lh+2) then bal (join_aux rl) rx rr
                else create l x r
@@ -181,14 +148,14 @@ Fixpoint join l : elt -> t -> t :=
 (** ** Extraction of minimum element
 
   Morally, [remove_min] is to be applied to a non-empty tree
-  [t = Node l x r h]. Since we can't deal here with [assert false]
+  [t = Node h l x r]. Since we can't deal here with [assert false]
   for [t=Leaf], we pre-unpack [t] (and forget about [h]).
 *)
 
 Fixpoint remove_min l x r : t*elt :=
   match l with
     | Leaf => (r,x)
-    | Node ll lx lr lh =>
+    | Node lh ll lx lr =>
        let (l',m) := remove_min ll lx lr in (bal l' x r, m)
   end.
 
@@ -202,7 +169,7 @@ Fixpoint remove_min l x r : t*elt :=
 Definition merge s1 s2 :=  match s1,s2 with
   | Leaf, _ => s2
   | _, Leaf => s1
-  | _, Node l2 x2 r2 h2 =>
+  | _, Node _ l2 x2 r2 =>
         let (s2',m) := remove_min l2 x2 r2 in bal s1 m s2'
 end.
 
@@ -210,34 +177,14 @@ end.
 
 Fixpoint remove x s := match s with
   | Leaf => Leaf
-  | Node l y r h =>
+  | Node _ l y r =>
       match X.compare x y with
          | Lt => bal (remove x l) y r
          | Eq => merge l r
-         | Gt => bal l  y (remove x r)
+         | Gt => bal l y (remove x r)
       end
    end.
 
-(** ** Minimum element *)
-
-Fixpoint min_elt s := match s with
-   | Leaf => None
-   | Node Leaf y _  _ => Some y
-   | Node l _ _ _ => min_elt l
-end.
-
-(** ** Maximum element *)
-
-Fixpoint max_elt s := match s with
-   | Leaf => None
-   | Node _ y Leaf  _ => Some y
-   | Node _ _ r _ => max_elt r
-end.
-
-(** ** Any element *)
-
-Definition choose := min_elt.
-
 (** ** Concatenation
 
     Same as [merge] but does not assume anything about heights.
@@ -247,7 +194,7 @@ Definition concat s1 s2 :=
    match s1, s2 with
       | Leaf, _ => s2
       | _, Leaf => s1
-      | _, Node l2 x2 r2 _ =>
+      | _, Node _ l2 x2 r2 =>
             let (s2',m) := remove_min l2 x2 r2 in
             join s1 m s2'
    end.
@@ -265,7 +212,7 @@ Notation "<< l , b , r >>" := (mktriple l b r) (at level 9).
 
 Fixpoint split x s : triple := match s with
   | Leaf => << Leaf, false, Leaf >>
-  | Node l y r h =>
+  | Node _ l y r =>
      match X.compare x y with
       | Lt => let (ll,b,rl) := split x l in << ll, b, join rl y r >>
       | Eq => << l, true, r >>
@@ -278,7 +225,7 @@ Fixpoint split x s : triple := match s with
 Fixpoint inter s1 s2 := match s1, s2 with
     | Leaf, _ => Leaf
     | _, Leaf => Leaf
-    | Node l1 x1 r1 h1, _ =>
+    | Node _ l1 x1 r1, _ =>
             let (l2',pres,r2') := split x1 s2 in
             if pres then join (inter l1 l2') x1 (inter r1 r2')
             else concat (inter l1 l2') (inter r1 r2')
@@ -289,7 +236,7 @@ Fixpoint inter s1 s2 := match s1, s2 with
 Fixpoint diff s1 s2 := match s1, s2 with
  | Leaf, _ => Leaf
  | _, Leaf => s1
- | Node l1 x1 r1 h1, _ =>
+ | Node _ l1 x1 r1, _ =>
     let (l2',pres,r2') := split x1 s2 in
     if pres then concat (diff l1 l2') (diff r1 r2')
     else join (diff l1 l2') x1 (diff r1 r2')
@@ -312,187 +259,36 @@ Fixpoint union s1 s2 :=
  match s1, s2 with
   | Leaf, _ => s2
   | _, Leaf => s1
-  | Node l1 x1 r1 h1, _ =>
+  | Node _ l1 x1 r1, _ =>
      let (l2',_,r2') := split x1 s2 in
      join (union l1 l2') x1 (union r1 r2')
  end.
 
-(** ** Elements *)
-
-(** [elements_tree_aux acc t] catenates the elements of [t] in infix
-    order to the list [acc] *)
-
-Fixpoint elements_aux (acc : list X.t) (s : t) : list X.t :=
-  match s with
-   | Leaf => acc
-   | Node l x r _ => elements_aux (x :: elements_aux acc r) l
-  end.
-
-(** then [elements] is an instanciation with an empty [acc] *)
-
-Definition elements := elements_aux nil.
-
 (** ** Filter *)
 
-Fixpoint filter_acc (f:elt->bool) acc s := match s with
-  | Leaf => acc
-  | Node l x r h =>
-     filter_acc f (filter_acc f (if f x then add x acc else acc) l) r
+Fixpoint filter (f:elt->bool) s := match s with
+  | Leaf => Leaf
+  | Node _ l x r =>
+    let l' := filter f l in
+    let r' := filter f r in
+    if f x then join l' x r' else concat l' r'
  end.
 
-Definition filter f := filter_acc f Leaf.
-
-
 (** ** Partition *)
 
-Fixpoint partition_acc (f:elt->bool)(acc : t*t)(s : t) : t*t :=
+Fixpoint partition (f:elt->bool)(s : t) : t*t :=
   match s with
-   | Leaf => acc
-   | Node l x r _ =>
-      let (acct,accf) := acc in
-      partition_acc f
-        (partition_acc f
-           (if f x then (add x acct, accf) else (acct, add x accf)) l) r
+   | Leaf => (Leaf, Leaf)
+   | Node _ l x r =>
+      let (l1,l2) := partition f l in
+      let (r1,r2) := partition f r in
+      if f x then (join l1 x r1, concat l2 r2)
+      else (concat l1 r1, join l2 x r2)
   end.
 
-Definition partition f := partition_acc f (Leaf,Leaf).
-
-(** ** [for_all] and [exists] *)
-
-Fixpoint for_all (f:elt->bool) s := match s with
-  | Leaf => true
-  | Node l x r _ => f x &&& for_all f l &&& for_all f r
-end.
-
-Fixpoint exists_ (f:elt->bool) s := match s with
-  | Leaf => false
-  | Node l x r _ => f x ||| exists_ f l ||| exists_ f r
-end.
-
-(** ** Fold *)
-
-Fixpoint fold (A : Type) (f : elt -> A -> A)(s : t) : A -> A :=
- fun a => match s with
-  | Leaf => a
-  | Node l x r _ => fold f r (f x (fold f l a))
- end.
-Implicit Arguments fold [A].
-
-
-(** ** Subset *)
-
-(** In ocaml, recursive calls are made on "half-trees" such as
-   (Node l1 x1 Leaf _) and (Node Leaf x1 r1 _). Instead of these
-   non-structural calls, we propose here two specialized functions for
-   these situations. This version should be almost as efficient as
-   the one of ocaml (closures as arguments may slow things a bit),
-   it is simply less compact. The exact ocaml version has also been
-   formalized (thanks to Function+measure), see [ocaml_subset] in
-   [MSetFullAVL].
- *)
-
-Fixpoint subsetl (subset_l1:t->bool) x1 s2 : bool :=
- match s2 with
-  | Leaf => false
-  | Node l2 x2 r2 h2 =>
-     match X.compare x1 x2 with
-      | Eq => subset_l1 l2
-      | Lt => subsetl subset_l1 x1 l2
-      | Gt => mem x1 r2 &&& subset_l1 s2
-     end
- end.
-
-Fixpoint subsetr (subset_r1:t->bool) x1 s2 : bool :=
- match s2 with
-  | Leaf => false
-  | Node l2 x2 r2 h2 =>
-     match X.compare x1 x2 with
-      | Eq => subset_r1 r2
-      | Lt => mem x1 l2 &&& subset_r1 s2
-      | Gt => subsetr subset_r1 x1 r2
-     end
- end.
-
-Fixpoint subset s1 s2 : bool := match s1, s2 with
-  | Leaf, _ => true
-  | Node _ _ _ _, Leaf => false
-  | Node l1 x1 r1 h1, Node l2 x2 r2 h2 =>
-     match X.compare x1 x2 with
-      | Eq => subset l1 l2 &&& subset r1 r2
-      | Lt => subsetl (subset l1) x1 l2 &&& subset r1 s2
-      | Gt => subsetr (subset r1) x1 r2 &&& subset l1 s2
-     end
- end.
-
-(** ** A new comparison algorithm suggested by Xavier Leroy
-
-    Transformation in C.P.S. suggested by Benjamin Grégoire.
-    The original ocaml code (with non-structural recursive calls)
-    has also been formalized (thanks to Function+measure), see
-    [ocaml_compare] in [MSetFullAVL]. The following code with
-    continuations computes dramatically faster in Coq, and
-    should be almost as efficient after extraction.
-*)
-
-(** Enumeration of the elements of a tree *)
-
-Inductive enumeration :=
- | End : enumeration
- | More : elt -> t -> enumeration -> enumeration.
-
-
-(** [cons t e] adds the elements of tree [t] on the head of
-    enumeration [e]. *)
-
-Fixpoint cons s e : enumeration :=
- match s with
-  | Leaf => e
-  | Node l x r h => cons l (More x r e)
- end.
-
-(** One step of comparison of elements *)
-
-Definition compare_more x1 (cont:enumeration->comparison) e2 :=
- match e2 with
- | End => Gt
- | More x2 r2 e2 =>
-     match X.compare x1 x2 with
-      | Eq => cont (cons r2 e2)
-      | Lt => Lt
-      | Gt => Gt
-     end
- end.
-
-(** Comparison of left tree, middle element, then right tree *)
-
-Fixpoint compare_cont s1 (cont:enumeration->comparison) e2 :=
- match s1 with
-  | Leaf => cont e2
-  | Node l1 x1 r1 _ =>
-     compare_cont l1 (compare_more x1 (compare_cont r1 cont)) e2
-  end.
-
-(** Initial continuation *)
-
-Definition compare_end e2 :=
- match e2 with End => Eq | _ => Lt end.
-
-(** The complete comparison *)
-
-Definition compare s1 s2 := compare_cont s1 compare_end (cons s2 End).
-
-(** ** Equality test *)
-
-Definition equal s1 s2 : bool :=
- match compare s1 s2 with
-  | Eq => true
-  | _ => false
- end.
-
 End Ops.
 
 
-
 (** * MakeRaw
 
    Functor of pure functions + a posteriori proofs of invariant
@@ -501,265 +297,47 @@ End Ops.
 Module MakeRaw (Import I:Int)(X:OrderedType) <: RawSets X.
 Include Ops I X.
 
-(** * Invariants *)
-
-(** ** Occurrence in a tree *)
-
-Inductive InT (x : elt) : tree -> Prop :=
-  | IsRoot : forall l r h y, X.eq x y -> InT x (Node l y r h)
-  | InLeft : forall l r h y, InT x l -> InT x (Node l y r h)
-  | InRight : forall l r h y, InT x r -> InT x (Node l y r h).
-
-Definition In := InT.
-
-(** ** Some shortcuts *)
-
-Definition Equal s s' := forall a : elt, InT a s <-> InT a s'.
-Definition Subset s s' := forall a : elt, InT a s -> InT a s'.
-Definition Empty s := forall a : elt, ~ InT a s.
-Definition For_all (P : elt -> Prop) s := forall x, InT x s -> P x.
-Definition Exists (P : elt -> Prop) s := exists x, InT x s /\ P x.
-
-(** ** Binary search trees *)
-
-(** [lt_tree x s]: all elements in [s] are smaller than [x]
-   (resp. greater for [gt_tree]) *)
-
-Definition lt_tree x s := forall y, InT y s -> X.lt y x.
-Definition gt_tree x s := forall y, InT y s -> X.lt x y.
-
-(** [bst t] : [t] is a binary search tree *)
-
-Inductive bst : tree -> Prop :=
-  | BSLeaf : bst Leaf
-  | BSNode : forall x l r h, bst l -> bst r ->
-     lt_tree x l -> gt_tree x r -> bst (Node l x r h).
-
-(** [bst] is the (decidable) invariant our trees will have to satisfy. *)
-
-Definition IsOk := bst.
-
-Class Ok (s:t) : Prop := ok : bst s.
-
-Instance bst_Ok s (Hs : bst s) : Ok s := { ok := Hs }.
-
-Fixpoint ltb_tree x s :=
- match s with
-  | Leaf => true
-  | Node l y r _ =>
-     match X.compare x y with
-      | Gt => ltb_tree x l && ltb_tree x r
-      | _ => false
-     end
- end.
-
-Fixpoint gtb_tree x s :=
- match s with
-  | Leaf => true
-  | Node l y r _ =>
-     match X.compare x y with
-      | Lt => gtb_tree x l && gtb_tree x r
-      | _ => false
-     end
- end.
-
-Fixpoint isok s :=
- match s with
-  | Leaf => true
-  | Node l x r _ => isok l && isok r && ltb_tree x l && gtb_tree x r
- end.
-
+(** Generic definition of binary-search-trees and proofs of
+    specifications for generic functions such as mem or fold. *)
 
-(** * Correctness proofs *)
+Include MSetGenTree.Props X I.
 
-Module Import MX := OrderedTypeFacts X.
+(** Automation and dedicated tactics *)
 
-(** * Automation and dedicated tactics *)
-
-Scheme tree_ind := Induction for tree Sort Prop.
-
-Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans @ok.
 Local Hint Immediate MX.eq_sym.
-Local Hint Unfold In lt_tree gt_tree.
+Local Hint Unfold In lt_tree gt_tree Ok.
 Local Hint Constructors InT bst.
-Local Hint Unfold Ok.
-
-Tactic Notation "factornode" ident(l) ident(x) ident(r) ident(h)
- "as" ident(s) :=
- set (s:=Node l x r h) in *; clearbody s; clear l x r h.
-
-(** Automatic treatment of [Ok] hypothesis *)
-
-Ltac inv_ok := match goal with
- | H:Ok (Node _ _ _ _) |- _ => inversion_clear H; inv_ok
- | H:Ok Leaf |- _ => clear H; inv_ok
- | H:bst ?x |- _ => change (Ok x) in H; inv_ok
- | _ => idtac
-end.
-
-(** A tactic to repeat [inversion_clear] on all hyps of the
-    form [(f (Node _ _ _ _))] *)
-
-Ltac is_tree_constr c :=
-  match c with
-   | Leaf => idtac
-   | Node _ _ _ _ => idtac
-   | _ => fail
-  end.
-
-Ltac invtree f :=
-  match goal with
-     | H:f ?s |- _ => is_tree_constr s; inversion_clear H; invtree f
-     | H:f _ ?s |- _ => is_tree_constr s; inversion_clear H; invtree f
-     | H:f _ _ ?s |- _ => is_tree_constr s; inversion_clear H; invtree f
-     | _ => idtac
-  end.
-
-Ltac inv := inv_ok; invtree InT.
-
-Ltac intuition_in := repeat progress (intuition; inv).
-
-(** Helper tactic concerning order of elements. *)
-
-Ltac order := match goal with
- | U: lt_tree _ ?s, V: InT _ ?s |- _ => generalize (U _ V); clear U; order
- | U: gt_tree _ ?s, V: InT _ ?s |- _ => generalize (U _ V); clear U; order
- | _ => MX.order
-end.
-
-
-(** [isok] is indeed a decision procedure for [Ok] *)
-
-Lemma ltb_tree_iff : forall x s, lt_tree x s <-> ltb_tree x s = true.
-Proof.
- induction s as [|l IHl y r IHr h]; simpl.
- unfold lt_tree; intuition_in.
- elim_compare x y.
- split; intros; try discriminate. assert (X.lt y x) by auto. order.
- split; intros; try discriminate. assert (X.lt y x) by auto. order.
- rewrite !andb_true_iff, <-IHl, <-IHr.
-  unfold lt_tree; intuition_in; order.
-Qed.
-
-Lemma gtb_tree_iff : forall x s, gt_tree x s <-> gtb_tree x s = true.
-Proof.
- induction s as [|l IHl y r IHr h]; simpl.
- unfold gt_tree; intuition_in.
- elim_compare x y.
- split; intros; try discriminate. assert (X.lt x y) by auto. order.
- rewrite !andb_true_iff, <-IHl, <-IHr.
-  unfold gt_tree; intuition_in; order.
- split; intros; try discriminate. assert (X.lt x y) by auto. order.
-Qed.
-
-Lemma isok_iff : forall s, Ok s <-> isok s = true.
-Proof.
- induction s as [|l IHl y r IHr h]; simpl.
- intuition_in.
- rewrite !andb_true_iff, <- IHl, <-IHr, <- ltb_tree_iff, <- gtb_tree_iff.
- intuition_in.
-Qed.
-
-Instance isok_Ok s : isok s = true -> Ok s | 10.
-Proof. intros; apply <- isok_iff; auto. Qed.
-
-
-(** * Basic results about [In], [lt_tree], [gt_tree], [height] *)
-
-(** [In] is compatible with [X.eq] *)
-
-Lemma In_1 :
- forall s x y, X.eq x y -> InT x s -> InT y s.
-Proof.
- induction s; simpl; intuition_in; eauto.
-Qed.
-Local Hint Immediate In_1.
-
-Instance In_compat : Proper (X.eq==>eq==>iff) InT.
-Proof.
-apply proper_sym_impl_iff_2; auto with *.
-repeat red; intros; subst. apply In_1 with x; auto.
-Qed.
-
-Lemma In_node_iff :
- forall l x r h y,
-  InT y (Node l x r h) <-> InT y l \/ X.eq y x \/ InT y r.
-Proof.
- intuition_in.
-Qed.
-
-(** Results about [lt_tree] and [gt_tree] *)
-
-Lemma lt_leaf : forall x : elt, lt_tree x Leaf.
-Proof.
- red; inversion 1.
-Qed.
-
-Lemma gt_leaf : forall x : elt, gt_tree x Leaf.
-Proof.
- red; inversion 1.
-Qed.
-
-Lemma lt_tree_node :
- forall (x y : elt) (l r : tree) (h : int),
- lt_tree x l -> lt_tree x r -> X.lt y x -> lt_tree x (Node l y r h).
-Proof.
- unfold lt_tree; intuition_in; order.
-Qed.
-
-Lemma gt_tree_node :
- forall (x y : elt) (l r : tree) (h : int),
- gt_tree x l -> gt_tree x r -> X.lt x y -> gt_tree x (Node l y r h).
-Proof.
- unfold gt_tree; intuition_in; order.
-Qed.
-
+Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans @ok.
 Local Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node.
+Local Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans.
+Local Hint Resolve elements_spec2.
 
-Lemma lt_tree_not_in :
- forall (x : elt) (t : tree), lt_tree x t -> ~ InT x t.
-Proof.
- intros; intro; order.
-Qed.
-
-Lemma lt_tree_trans :
- forall x y, X.lt x y -> forall t, lt_tree x t -> lt_tree y t.
-Proof.
- eauto.
-Qed.
+(* Sometimes functional induction will expose too much of
+   a tree structure. The following tactic allows to factor back
+   a Node whose internal parts occurs nowhere else. *)
 
-Lemma gt_tree_not_in :
- forall (x : elt) (t : tree), gt_tree x t -> ~ InT x t.
-Proof.
- intros; intro; order.
-Qed.
+(* TODO: why Ltac instead of Tactic Notation don't work ? why clear ? *)
 
-Lemma gt_tree_trans :
- forall x y, X.lt y x -> forall t, gt_tree x t -> gt_tree y t.
-Proof.
- eauto.
-Qed.
-
-Local Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans.
+Tactic Notation "factornode" ident(s) :=
+ try clear s;
+ match goal with
+   | |- context [Node ?l ?x ?r ?h] =>
+       set (s:=Node l x r h) in *; clearbody s; clear l x r h
+   | _ : context [Node ?l ?x ?r ?h] |- _ =>
+       set (s:=Node l x r h) in *; clearbody s; clear l x r h
+ end.
 
-(** * Inductions principles for some of the set operators *)
+(** Inductions principles for some of the set operators *)
 
 Functional Scheme bal_ind := Induction for bal Sort Prop.
 Functional Scheme remove_min_ind := Induction for remove_min Sort Prop.
 Functional Scheme merge_ind := Induction for merge Sort Prop.
-Functional Scheme min_elt_ind := Induction for min_elt Sort Prop.
-Functional Scheme max_elt_ind := Induction for max_elt Sort Prop.
 Functional Scheme concat_ind := Induction for concat Sort Prop.
 Functional Scheme inter_ind := Induction for inter Sort Prop.
 Functional Scheme diff_ind := Induction for diff Sort Prop.
 Functional Scheme union_ind := Induction for union Sort Prop.
 
-Ltac induct s x :=
- induction s as [|l IHl x' r IHr h]; simpl; intros;
- [|elim_compare x x'; intros; inv].
-
-
-(** * Notations and helper lemma about pairs and triples *)
+(** Notations and helper lemma about pairs and triples *)
 
 Notation "s #1" := (fst s) (at level 9, format "s '#1'") : pair_scope.
 Notation "s #2" := (snd s) (at level 9, format "s '#2'") : pair_scope.
@@ -767,42 +345,9 @@ Notation "t #l" := (t_left t) (at level 9, format "t '#l'") : pair_scope.
 Notation "t #b" := (t_in t) (at level 9, format "t '#b'") : pair_scope.
 Notation "t #r" := (t_right t) (at level 9, format "t '#r'") : pair_scope.
 
-Open Local Scope pair_scope.
-
-
-(** * Empty set *)
-
-Lemma empty_spec : Empty empty.
-Proof.
- intro; intro.
- inversion H.
-Qed.
-
-Instance empty_ok : Ok empty.
-Proof.
- auto.
-Qed.
-
-(** * Emptyness test *)
-
-Lemma is_empty_spec : forall s, is_empty s = true <-> Empty s.
-Proof.
- destruct s as [|r x l h]; simpl; auto.
- split; auto. red; red; intros; inv.
- split; auto. try discriminate. intro H; elim (H x); auto.
-Qed.
-
-(** * Membership *)
-
-Lemma mem_spec : forall s x `{Ok s}, mem x s = true <-> InT x s.
-Proof.
- split.
- induct s x; auto; try discriminate.
- induct s x; intuition_in; order.
-Qed.
-
+Local Open Scope pair_scope.
 
-(** * Singleton set *)
+(** ** Singleton set *)
 
 Lemma singleton_spec : forall x y, InT y (singleton x) <-> X.eq y x.
 Proof.
@@ -814,9 +359,7 @@ Proof.
  unfold singleton; auto.
 Qed.
 
-
-
-(** * Helper functions *)
+(** ** Helper functions *)
 
 Lemma create_spec :
  forall l x r y,  InT y (create l x r) <-> X.eq y x \/ InT y l \/ InT y r.
@@ -847,7 +390,7 @@ Proof.
 Qed.
 
 
-(** * Insertion *)
+(** ** Insertion *)
 
 Lemma add_spec' : forall s x y,
  InT y (add x s) <-> X.eq y x \/ InT y s.
@@ -867,25 +410,25 @@ Proof.
 Qed.
 
 
-Open Scope Int_scope.
+Local Open Scope Int_scope.
 
-(** * Join *)
+(** ** Join *)
 
-(* Function/Functional Scheme can't deal with internal fix.
-   Let's do its job by hand: *)
+(** Function/Functional Scheme can't deal with internal fix.
+    Let's do its job by hand: *)
 
 Ltac join_tac :=
- intro l; induction l as [| ll _ lx lr Hlr lh];
-   [ | intros x r; induction r as [| rl Hrl rx rr _ rh]; unfold join;
-     [ | destruct (gt_le_dec lh (rh+2));
+ intro l; induction l as [| lh ll _ lx lr Hlr];
+   [ | intros x r; induction r as [| rh rl Hrl rx rr _]; unfold join;
+     [ | 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]
+           with (bal ll lx (join lr x (Node rh rl rx rr))); [ | 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]
+             with (bal (join (Node lh ll lx lr) x rl) rx rr); [ | auto]
            end
          | ] ] ] ]; intros.
 
@@ -905,16 +448,16 @@ 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.
 
 
-(** * Extraction of minimum element *)
+(** ** Extraction of minimum element *)
 
-Lemma remove_min_spec : forall l x r h y,
- InT y (Node l x r h) <->
+Lemma remove_min_spec : forall l x r y h,
+ InT y (Node h l x r) <->
   X.eq y (remove_min l x r)#2 \/ InT y (remove_min l x r)#1.
 Proof.
  intros l x r; functional induction (remove_min l x r); simpl in *; intros.
@@ -922,13 +465,13 @@ Proof.
  rewrite bal_spec, In_node_iff, IHp, e0; simpl; intuition.
 Qed.
 
-Instance remove_min_ok l x r : forall h `(Ok (Node l x r h)),
+Instance remove_min_ok l x r : forall h `(Ok (Node h l x r)),
  Ok (remove_min l x r)#1.
 Proof.
  functional induction (remove_min l x r); simpl; intros.
  inv; auto.
- assert (O : Ok (Node ll lx lr _x)) by (inv; auto).
- assert (L : lt_tree x (Node ll lx lr _x)) by (inv; auto).
+ assert (O : Ok (Node _x ll lx lr)) by (inv; auto).
+ assert (L : lt_tree x (Node _x ll lx lr)) by (inv; auto).
  specialize IHp with (1:=O); rewrite e0 in IHp; auto; simpl in *.
  apply bal_ok; auto.
  inv; auto.
@@ -937,13 +480,13 @@ Proof.
  inv; auto.
 Qed.
 
-Lemma remove_min_gt_tree : forall l x r h `{Ok (Node l x r h)},
+Lemma remove_min_gt_tree : forall l x r h `{Ok (Node h l x r)},
  gt_tree (remove_min l x r)#2 (remove_min l x r)#1.
 Proof.
  intros l x r; functional induction (remove_min l x r); simpl; intros.
  inv; auto.
- assert (O : Ok (Node ll lx lr _x)) by (inv; auto).
- assert (L : lt_tree x (Node ll lx lr _x)) by (inv; auto).
+ assert (O : Ok (Node _x ll lx lr)) by (inv; auto).
+ assert (L : lt_tree x (Node _x ll lx lr)) by (inv; auto).
  specialize IHp with (1:=O); rewrite e0 in IHp; simpl in IHp.
  intro y; rewrite bal_spec; intuition;
   specialize (L m); rewrite remove_min_spec, e0 in L; simpl in L;
@@ -952,14 +495,13 @@ Qed.
 Local Hint Resolve remove_min_gt_tree.
 
 
-
-(** * Merging two trees *)
+(** ** Merging two trees *)
 
 Lemma merge_spec : forall s1 s2 y,
  InT y (merge s1 s2) <-> InT y s1 \/ InT y s2.
 Proof.
  intros s1 s2; functional induction (merge s1 s2); intros;
- try factornode _x _x0 _x1 _x2 as s1.
+  try factornode s1.
  intuition_in.
  intuition_in.
  rewrite bal_spec, remove_min_spec, e1; simpl; intuition.
@@ -970,7 +512,7 @@ Instance merge_ok s1 s2 : forall `(Ok s1, Ok s2)
  Ok (merge s1 s2).
 Proof.
  functional induction (merge s1 s2); intros; auto;
- try factornode _x _x0 _x1 _x2 as s1.
+  try factornode s1.
  apply bal_ok; auto.
  change s2' with ((s2',m)#1); rewrite <-e1; eauto with *.
  intros y Hy.
@@ -981,7 +523,7 @@ Qed.
 
 
 
-(** * Deletion *)
+(** ** Deletion *)
 
 Lemma remove_spec : forall s x y `{Ok s},
  (InT y (remove x s) <-> InT y s /\ ~ X.eq y x).
@@ -989,7 +531,7 @@ Proof.
  induct s x.
  intuition_in.
  rewrite merge_spec; intuition; [order|order|intuition_in].
- elim H6; eauto.
+ elim H2; eauto.
  rewrite bal_spec, IHl; clear IHl IHr; intuition; [order|order|intuition_in].
  rewrite bal_spec, IHr; clear IHl IHr; intuition; [order|order|intuition_in].
 Qed.
@@ -1009,109 +551,13 @@ Proof.
 Qed.
 
 
-(** * Minimum element *)
-
-Lemma min_elt_spec1 : forall s x, min_elt s = Some x -> InT x s.
-Proof.
- intro s; functional induction (min_elt s); auto; inversion 1; auto.
-Qed.
-
-Lemma min_elt_spec2 : forall s x y `{Ok s},
- min_elt s = Some x -> InT y s -> ~ X.lt y x.
-Proof.
- intro s; functional induction (min_elt s);
- try rename _x1 into l1, _x2 into x1, _x3 into r1, _x4 into h1.
- discriminate.
- intros x y0 U V W.
- inversion V; clear V; subst.
- inv; order.
- intros; inv; auto.
- assert (X.lt x y) by (apply H4; apply min_elt_spec1; auto).
- order.
- assert (X.lt x1 y) by auto.
- assert (~X.lt x1 x) by auto.
- order.
-Qed.
-
-Lemma min_elt_spec3 : forall s, min_elt s = None -> Empty s.
-Proof.
- intro s; functional induction (min_elt s).
- red; red; inversion 2.
- inversion 1.
- intro H0.
- destruct (IHo H0 _x2); auto.
-Qed.
-
-
-
-(** * Maximum element *)
-
-Lemma max_elt_spec1 : forall s x, max_elt s = Some x -> InT x s.
-Proof.
- intro s; functional induction (max_elt s); auto; inversion 1; auto.
-Qed.
-
-Lemma max_elt_spec2 : forall s x y `{Ok s},
- max_elt s = Some x -> InT y s -> ~ X.lt x y.
-Proof.
- intro s; functional induction (max_elt s);
- try rename _x1 into l1, _x2 into x1, _x3 into r1, _x4 into h1.
- discriminate.
- intros x y0 U V W.
- inversion V; clear V; subst.
- inv; order.
- intros; inv; auto.
- assert (X.lt y x1) by auto.
- assert (~ X.lt x x1) by auto.
- order.
- assert (X.lt y x) by (apply H5; apply max_elt_spec1; auto).
- order.
-Qed.
-
-Lemma max_elt_spec3 : forall s, max_elt s = None -> Empty s.
-Proof.
- intro s; functional induction (max_elt s).
- red; auto.
- inversion 1.
- intros H0; destruct (IHo H0 _x2); auto.
-Qed.
-
-
-
-(** * Any element *)
-
-Lemma choose_spec1 : forall s x, choose s = Some x -> InT x s.
-Proof.
- exact min_elt_spec1.
-Qed.
-
-Lemma choose_spec2 : forall s, choose s = None -> Empty s.
-Proof.
- exact min_elt_spec3.
-Qed.
-
-Lemma choose_spec3 : forall s s' x x' `{Ok s, Ok s'},
-  choose s = Some x -> choose s' = Some x' ->
-  Equal s s' -> X.eq x x'.
-Proof.
- unfold choose, Equal; intros s s' x x' Hb Hb' Hx Hx' H.
- assert (~X.lt x x').
-  apply min_elt_spec2 with s'; auto.
-  rewrite <-H; auto using min_elt_spec1.
- assert (~X.lt x' x).
-  apply min_elt_spec2 with s; auto.
-  rewrite H; auto using min_elt_spec1.
- elim_compare x x'; intuition.
-Qed.
-
-
-(** * Concatenation *)
+(** ** Concatenation *)
 
 Lemma concat_spec : forall s1 s2 y,
  InT y (concat s1 s2) <-> InT y s1 \/ InT y s2.
 Proof.
  intros s1 s2; functional induction (concat s1 s2); intros;
- try factornode _x _x0 _x1 _x2 as s1.
+  try factornode s1.
  intuition_in.
  intuition_in.
  rewrite join_spec, remove_min_spec, e1; simpl; intuition.
@@ -1122,7 +568,7 @@ Instance concat_ok s1 s2 : forall `(Ok s1, Ok s2)
  Ok (concat s1 s2).
 Proof.
  functional induction (concat s1 s2); intros; auto;
- try factornode _x _x0 _x1 _x2 as s1.
+  try factornode s1.
  apply join_ok; auto.
  change (Ok (s2',m)#1); rewrite <-e1; eauto with *.
  intros y Hy.
@@ -1133,7 +579,7 @@ Qed.
 
 
 
-(** * Splitting *)
+(** ** Splitting *)
 
 Lemma split_spec1 : forall s x y `{Ok s},
  (InT y (split x s)#l <-> InT y s /\ X.lt y x).
@@ -1175,11 +621,11 @@ Lemma split_ok : forall s x `{Ok s}, Ok (split x s)#l /\ Ok (split x s)#r.
 Proof.
  induct s x; simpl; auto.
  specialize (IHl x).
- generalize (fun y => @split_spec2 _ x y H1).
+ generalize (fun y => @split_spec2 l x y _).
  destruct (split x l); simpl in *; intuition. apply join_ok; auto.
  intros y; rewrite H; intuition.
  specialize (IHr x).
- generalize (fun y => @split_spec1 _ x y H2).
+ generalize (fun y => @split_spec1 r x y _).
  destruct (split x r); simpl in *; intuition. apply join_ok; auto.
  intros y; rewrite H; intuition.
 Qed.
@@ -1191,7 +637,7 @@ Instance split_ok2 s x `(Ok s) : Ok (split x s)#r.
 Proof. intros; destruct (@split_ok s x); auto. Qed.
 
 
-(** * Intersection *)
+(** ** Intersection *)
 
 Ltac destruct_split := match goal with
  | H : split ?x ?s = << ?u, ?v, ?w >> |- _ =>
@@ -1205,23 +651,24 @@ Lemma inter_spec_ok : forall s1 s2 `{Ok s1, Ok s2},
  Ok (inter s1 s2) /\ (forall y, InT y (inter s1 s2) <-> InT y s1 /\ InT y s2).
 Proof.
  intros s1 s2; functional induction inter s1 s2; intros B1 B2;
- [intuition_in|intuition_in | | ];
- factornode _x0 _x1 _x2 _x3 as s2; destruct_split; inv;
+ [intuition_in|intuition_in | | ]; factornode s2;
+ destruct_split; inv;
  destruct IHt0 as (IHo1,IHi1), IHt1 as (IHo2,IHi2); auto with *;
  split; intros.
- (* Ok join *)
- apply join_ok; auto with *; intro y; rewrite ?IHi1, ?IHi2; intuition.
- (* InT join *)
- rewrite join_spec, IHi1, IHi2, split_spec1, split_spec2; intuition_in.
- setoid_replace y with x1; auto. rewrite <- split_spec3; auto.
- (* Ok concat *)
- apply concat_ok; auto with *; intros y1 y2; rewrite IHi1, IHi2; intuition; order.
- (* InT concat *)
- rewrite concat_spec, IHi1, IHi2, split_spec1, split_spec2; auto.
- intuition_in.
- absurd (InT x1 s2).
-  rewrite <- split_spec3; auto; congruence.
-  setoid_replace x1 with y; auto.
+ - (* Ok join *)
+   apply join_ok; auto with *; intro y; rewrite ?IHi1, ?IHi2; intuition.
+ - (* InT join *)
+   rewrite join_spec, IHi1, IHi2, split_spec1, split_spec2; intuition_in.
+   setoid_replace y with x1; auto. rewrite <- split_spec3; auto.
+ - (* Ok concat *)
+   apply concat_ok; auto with *; intros y1 y2; rewrite IHi1, IHi2;
+   intuition; order.
+ - (* InT concat *)
+   rewrite concat_spec, IHi1, IHi2, split_spec1, split_spec2; auto.
+   intuition_in.
+   absurd (InT x1 s2).
+   rewrite <- split_spec3; auto; congruence.
+   setoid_replace x1 with y; auto.
 Qed.
 
 Lemma inter_spec : forall s1 s2 y `{Ok s1, Ok s2},
@@ -1232,31 +679,31 @@ Instance inter_ok s1 s2 `(Ok s1, Ok s2) : Ok (inter s1 s2).
 Proof. intros; destruct (@inter_spec_ok s1 s2); auto. Qed.
 
 
-(** * Difference *)
+(** ** Difference *)
 
 Lemma diff_spec_ok : forall s1 s2 `{Ok s1, Ok s2},
  Ok (diff s1 s2) /\ (forall y, InT y (diff s1 s2) <-> InT y s1 /\ ~InT y s2).
 Proof.
  intros s1 s2; functional induction diff s1 s2; intros B1 B2;
- [intuition_in|intuition_in | | ];
- factornode _x0 _x1 _x2 _x3 as s2; destruct_split; inv;
+ [intuition_in|intuition_in | | ]; factornode s2;
+ destruct_split; inv;
  destruct IHt0 as (IHb1,IHi1), IHt1 as (IHb2,IHi2); auto with *;
  split; intros.
- (* Ok concat *)
- apply concat_ok; auto; intros y1 y2; rewrite IHi1, IHi2; intuition; order.
- (* InT concat *)
- rewrite concat_spec, IHi1, IHi2, split_spec1, split_spec2; intuition_in.
- absurd (InT x1 s2).
-  setoid_replace x1 with y; auto.
-  rewrite <- split_spec3; auto; congruence.
- (* Ok join *)
- apply join_ok; auto; intro y; rewrite ?IHi1, ?IHi2; intuition.
- (* InT join *)
- rewrite join_spec, IHi1, IHi2, split_spec1, split_spec2; auto with *.
- intuition_in.
- absurd (InT x1 s2); auto.
-  rewrite <- split_spec3; auto; congruence.
-  setoid_replace x1 with y; auto.
+ - (* Ok concat *)
+   apply concat_ok; auto; intros y1 y2; rewrite IHi1, IHi2; intuition; order.
+ - (* InT concat *)
+   rewrite concat_spec, IHi1, IHi2, split_spec1, split_spec2; intuition_in.
+   absurd (InT x1 s2).
+   + setoid_replace x1 with y; auto.
+   + rewrite <- split_spec3; auto; congruence.
+ - (* Ok join *)
+   apply join_ok; auto; intro y; rewrite ?IHi1, ?IHi2; intuition.
+ - (* InT join *)
+   rewrite join_spec, IHi1, IHi2, split_spec1, split_spec2; auto with *.
+   intuition_in.
+   absurd (InT x1 s2); auto.
+   * rewrite <- split_spec3; auto; congruence.
+   * setoid_replace x1 with y; auto.
 Qed.
 
 Lemma diff_spec : forall s1 s2 y `{Ok s1, Ok s2},
@@ -1267,7 +714,7 @@ Instance diff_ok s1 s2 `(Ok s1, Ok s2) : Ok (diff s1 s2).
 Proof. intros; destruct (@diff_spec_ok s1 s2); auto. Qed.
 
 
-(** * Union *)
+(** ** Union *)
 
 Lemma union_spec : forall s1 s2 y `{Ok s1, Ok s2},
  (InT y (union s1 s2) <-> InT y s1 \/ InT y s2).
@@ -1275,548 +722,90 @@ Proof.
  intros s1 s2; functional induction union s1 s2; intros y B1 B2.
  intuition_in.
  intuition_in.
- factornode _x0 _x1 _x2 _x3 as s2; destruct_split; inv.
+ factornode s2; destruct_split; inv.
  rewrite join_spec, IHt0, IHt1, split_spec1, split_spec2; auto with *.
- elim_compare y x1; intuition_in.
+ destruct (X.compare_spec y x1); intuition_in.
 Qed.
 
 Instance union_ok s1 s2 : forall `(Ok s1, Ok s2), Ok (union s1 s2).
 Proof.
  functional induction union s1 s2; intros B1 B2; auto.
- factornode _x0 _x1 _x2 _x3 as s2; destruct_split; inv.
+ factornode s2; destruct_split; inv.
  apply join_ok; auto with *.
  intro y; rewrite union_spec, split_spec1; intuition_in.
  intro y; rewrite union_spec, split_spec2; intuition_in.
 Qed.
 
-
-(** * Elements *)
-
-Lemma elements_spec1' : forall s acc x,
- InA X.eq x (elements_aux acc s) <-> InT x s \/ InA X.eq x acc.
-Proof.
- induction s as [ | l Hl x r Hr h ]; simpl; auto.
- intuition.
- inversion H0.
- intros.
- rewrite Hl.
- destruct (Hr acc x0); clear Hl Hr.
- intuition; inversion_clear H3; intuition.
-Qed.
-
-Lemma elements_spec1 : forall s x, InA X.eq x (elements s) <-> InT x s.
-Proof.
- intros; generalize (elements_spec1' s nil x); intuition.
- inversion_clear H0.
-Qed.
-
-Lemma elements_spec2' : forall s acc `{Ok s}, sort X.lt acc ->
- (forall x y : elt, InA X.eq x acc -> InT y s -> X.lt y x) ->
- sort X.lt (elements_aux acc s).
-Proof.
- induction s as [ | l Hl y r Hr h]; simpl; intuition.
- inv.
- apply Hl; auto.
- constructor.
- apply Hr; auto.
- eapply InA_InfA; eauto with *.
- intros.
- destruct (elements_spec1' r acc y0); intuition.
- intros.
- inversion_clear H.
- order.
- destruct (elements_spec1' r acc x); intuition eauto.
-Qed.
-
-Lemma elements_spec2 : forall s `(Ok s), sort X.lt (elements s).
-Proof.
- intros; unfold elements; apply elements_spec2'; auto.
- intros; inversion H0.
-Qed.
-Local Hint Resolve elements_spec2.
-
-Lemma elements_spec2w : forall s `(Ok s), NoDupA X.eq (elements s).
-Proof.
- intros. eapply SortA_NoDupA; eauto with *.
-Qed.
-
-Lemma elements_aux_cardinal :
- forall s acc, (length acc + cardinal s)%nat = length (elements_aux acc s).
-Proof.
- simple induction s; simpl in |- *; intuition.
- rewrite <- H.
- simpl in |- *.
- rewrite <- H0; omega.
-Qed.
-
-Lemma elements_cardinal : forall s : tree, cardinal s = length (elements s).
-Proof.
- exact (fun s => elements_aux_cardinal s nil).
-Qed.
-
-Definition cardinal_spec (s:t)(Hs:Ok s) := elements_cardinal s.
-
-Lemma elements_app :
- forall s acc, elements_aux acc s = elements s ++ acc.
-Proof.
- induction s; simpl; intros; auto.
- rewrite IHs1, IHs2.
- unfold elements; simpl.
- rewrite 2 IHs1, IHs2, <- !app_nil_end, !app_ass; auto.
-Qed.
-
-Lemma elements_node :
- forall l x r h acc,
- elements l ++ x :: elements r ++ acc =
- elements (Node l x r h) ++ acc.
-Proof.
- unfold elements; simpl; intros; auto.
- rewrite !elements_app, <- !app_nil_end, !app_ass; auto.
-Qed.
-
-
 (** * Filter *)
 
-Lemma filter_spec' : forall s x acc f,
- Proper (X.eq==>eq) f ->
- (InT x (filter_acc f acc s) <-> InT x acc \/ InT x s /\ f x = true).
-Proof.
- induction s; simpl; intros.
- intuition_in.
- rewrite IHs2, IHs1 by (destruct (f t0); auto).
- case_eq (f t0); intros.
- rewrite add_spec'; auto.
- intuition_in.
- rewrite (H _ _ H2).
- intuition.
- intuition_in.
- rewrite (H _ _ H2) in H3.
- rewrite H0 in H3; discriminate.
-Qed.
-
-Instance filter_ok' : forall s acc f `(Ok s, Ok acc),
- Ok (filter_acc f acc s).
+Lemma filter_spec : forall s x f,
+ Proper (X.eq==>Logic.eq) f ->
+ (InT x (filter f s) <-> InT x s /\ f x = true).
 Proof.
- induction s; simpl; auto.
- intros. inv.
- destruct (f t0); auto with *.
+ induction s as [ |h l Hl x0 r Hr]; intros x f Hf; simpl.
+ - intuition_in.
+ - case_eq (f x0); intros Hx0.
+   * rewrite join_spec, Hl, Hr; intuition_in.
+     now setoid_replace x with x0.
+   * rewrite concat_spec, Hl, Hr; intuition_in.
+     assert (f x = f x0) by auto. congruence.
 Qed.
 
-Lemma filter_spec : forall s x f,
- Proper (X.eq==>eq) f ->
- (InT x (filter f s) <-> InT x s /\ f x = true).
+Lemma filter_weak_spec : forall s x f,
+ InT x (filter f s) -> InT x s.
 Proof.
- unfold filter; intros; rewrite filter_spec'; intuition_in.
+ induction s as [ |h l Hl x0 r Hr]; intros x f; simpl.
+ - trivial.
+ - destruct (f x0).
+   * rewrite join_spec; intuition_in; eauto.
+   * rewrite concat_spec; intuition_in; eauto.
 Qed.
 
-Instance filter_ok s f `(Ok s) : Ok (filter f s).
+Instance filter_ok s f `(H : Ok s) : Ok (filter f s).
 Proof.
- unfold filter; intros; apply filter_ok'; auto.
+ induction H as [ | h x l r Hl Hfl Hr Hfr Hlt Hgt ].
+ - constructor.
+ - simpl.
+   assert (lt_tree x (filter f l)) by (eauto using filter_weak_spec).
+   assert (gt_tree x (filter f r)) by (eauto using filter_weak_spec).
+   destruct (f x); eauto using concat_ok, join_ok.
 Qed.
 
 
 (** * Partition *)
 
-Lemma partition_spec1' : forall s acc f,
- Proper (X.eq==>eq) f -> forall x : elt,
- InT x (partition_acc f acc s)#1 <->
- InT x acc#1 \/ InT x s /\ f x = true.
+Lemma partition_spec1' s f : (partition f s)#1 = filter f s.
 Proof.
- induction s; simpl; intros.
- intuition_in.
- destruct acc as [acct accf]; simpl in *.
- rewrite IHs2 by
-  (destruct (f t0); auto; apply partition_acc_avl_1; simpl; auto).
- rewrite IHs1 by (destruct (f t0); simpl; auto).
- case_eq (f t0); simpl; intros.
- rewrite add_spec'; auto.
- intuition_in.
- rewrite (H _ _ H2).
- intuition.
- intuition_in.
- rewrite (H _ _ H2) in H3.
- rewrite H0 in H3; discriminate.
+ induction s as [ | h l Hl x r Hr ]; simpl.
+ - trivial.
+ - rewrite <- Hl, <- Hr.
+   now destruct (partition f l), (partition f r), (f x).
 Qed.
 
-Lemma partition_spec2' : forall s acc f,
- Proper (X.eq==>eq) f -> forall x : elt,
- InT x (partition_acc f acc s)#2 <->
- InT x acc#2 \/ InT x s /\ f x = false.
+Lemma partition_spec2' s f :
+ (partition f s)#2 = filter (fun x => negb (f x)) s.
 Proof.
- induction s; simpl; intros.
- intuition_in.
- destruct acc as [acct accf]; simpl in *.
- rewrite IHs2 by
-  (destruct (f t0); auto; apply partition_acc_avl_2; simpl; auto).
- rewrite IHs1 by (destruct (f t0); simpl; auto).
- case_eq (f t0); simpl; intros.
- intuition.
- intuition_in.
- rewrite (H _ _ H2) in H3.
- rewrite H0 in H3; discriminate.
- rewrite add_spec'; auto.
- intuition_in.
- rewrite (H _ _ H2).
- intuition.
+ induction s as [ | h l Hl x r Hr ]; simpl.
+ - trivial.
+ - rewrite <- Hl, <- Hr.
+   now destruct (partition f l), (partition f r), (f x).
 Qed.
 
-Lemma partition_spec1 : forall s f,
- Proper (X.eq==>eq) f ->
+Lemma partition_spec1 s f :
+ Proper (X.eq==>Logic.eq) f ->
  Equal (partition f s)#1 (filter f s).
-Proof.
- unfold partition; intros s f P x.
- rewrite partition_spec1', filter_spec; simpl; intuition_in.
-Qed.
+Proof. now rewrite partition_spec1'. Qed.
 
-Lemma partition_spec2 : forall s f,
- Proper (X.eq==>eq) f ->
+Lemma partition_spec2 s f :
+ Proper (X.eq==>Logic.eq) f ->
  Equal (partition f s)#2 (filter (fun x => negb (f x)) s).
-Proof.
- unfold partition; intros s f P x.
- rewrite partition_spec2', filter_spec; simpl; intuition_in.
- rewrite H1; auto.
- right; split; auto.
- rewrite negb_true_iff in H1; auto.
- intros u v H; rewrite H; auto.
-Qed.
-
-Instance partition_ok1' : forall s acc f `(Ok s, Ok acc#1),
- Ok (partition_acc f acc s)#1.
-Proof.
- induction s; simpl; auto.
- destruct acc as [acct accf]; simpl in *.
- intros. inv.
- destruct (f t0); auto.
- apply IHs2; simpl; auto.
- apply IHs1; simpl; auto with *.
-Qed.
-
-Instance partition_ok2' : forall s acc f `(Ok s, Ok acc#2),
- Ok (partition_acc f acc s)#2.
-Proof.
- induction s; simpl; auto.
- destruct acc as [acct accf]; simpl in *.
- intros. inv.
- destruct (f t0); auto.
- apply IHs2; simpl; auto.
- apply IHs1; simpl; auto with *.
-Qed.
+Proof. now rewrite partition_spec2'. Qed.
 
 Instance partition_ok1 s f `(Ok s) : Ok (partition f s)#1.
-Proof. apply partition_ok1'; auto. Qed.
+Proof. rewrite partition_spec1'; now apply filter_ok. Qed.
 
 Instance partition_ok2 s f `(Ok s) : Ok (partition f s)#2.
-Proof. apply partition_ok2'; auto. Qed.
-
-
-
-(** * [for_all] and [exists] *)
-
-Lemma for_all_spec : forall s f, Proper (X.eq==>eq) f ->
- (for_all f s = true <-> For_all (fun x => f x = true) s).
-Proof.
- split.
- induction s; simpl; auto; intros; red; intros; inv.
- destruct (andb_prop _ _ H0); auto.
- destruct (andb_prop _ _ H1); eauto.
- apply IHs1; auto.
- destruct (andb_prop _ _ H0); auto.
- destruct (andb_prop _ _ H1); auto.
- apply IHs2; auto.
- destruct (andb_prop _ _ H0); auto.
- (* <- *)
- induction s; simpl; auto.
- intros. red in H0.
- rewrite IHs1; try red; auto.
- rewrite IHs2; try red; auto.
- generalize (H0 t0).
- destruct (f t0); simpl; auto.
-Qed.
-
-Lemma exists_spec : forall s f, Proper (X.eq==>eq) f ->
- (exists_ f s = true <-> Exists (fun x => f x = true) s).
-Proof.
- split.
- induction s; simpl; intros; rewrite <- ?orb_lazy_alt in *.
- discriminate.
- destruct (orb_true_elim _ _ H0) as [H1|H1].
- destruct (orb_true_elim _ _ H1) as [H2|H2].
- exists t0; auto.
- destruct (IHs1 H2); auto; exists x; intuition.
- destruct (IHs2 H1); auto; exists x; intuition.
- (* <- *)
- induction s; simpl; destruct 1 as (x,(U,V)); inv; rewrite <- ?orb_lazy_alt.
- rewrite (H _ _ (MX.eq_sym H0)); rewrite V; auto.
- apply orb_true_intro; left.
- apply orb_true_intro; right; apply IHs1; auto; exists x; auto.
- apply orb_true_intro; right; apply IHs2; auto; exists x; auto.
-Qed.
-
-
-(** * Fold *)
-
-Lemma fold_spec' :
- forall (A : Type) (f : elt -> A -> A) (s : tree) (i : A) (acc : list elt),
- fold_left (flip f) (elements_aux acc s) i = fold_left (flip f) acc (fold f s i).
-Proof.
- induction s as [|l IHl x r IHr h]; simpl; intros; auto.
- rewrite IHl.
- simpl. unfold flip at 2.
- apply IHr.
-Qed.
-
-Lemma fold_spec :
- forall (s:t) (A : Type) (i : A) (f : elt -> A -> A),
- fold f s i = fold_left (flip f) (elements s) i.
-Proof.
- unfold elements.
- induction s as [|l IHl x r IHr h]; simpl; intros; auto.
- rewrite fold_spec'.
- rewrite IHr.
- simpl; auto.
-Qed.
-
-
-(** * Subset *)
-
-Lemma subsetl_spec : forall subset_l1 l1 x1 h1 s2
- `{Ok (Node l1 x1 Leaf h1), Ok s2},
- (forall s `{Ok s}, (subset_l1 s = true <-> Subset l1 s)) ->
- (subsetl subset_l1 x1 s2 = true <-> Subset (Node l1 x1 Leaf h1) s2 ).
-Proof.
- induction s2 as [|l2 IHl2 x2 r2 IHr2 h2]; simpl; intros.
- unfold Subset; intuition; try discriminate.
- assert (H': InT x1 Leaf) by auto; inversion H'.
- specialize (IHl2 H).
- specialize (IHr2 H).
- inv.
- elim_compare x1 x2.
-
- rewrite H1 by auto; clear H1 IHl2 IHr2.
- unfold Subset. intuition_in.
- assert (X.eq a x2) by order; intuition_in.
- assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
-
- rewrite IHl2 by auto; clear H1 IHl2 IHr2.
- unfold Subset. intuition_in.
- assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
- assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
-
- rewrite <-andb_lazy_alt, andb_true_iff, H1 by auto; clear H1 IHl2 IHr2.
- unfold Subset. intuition_in.
- constructor 3. setoid_replace a with x1; auto. rewrite <- mem_spec; auto.
- rewrite mem_spec; auto.
- assert (InT x1 (Node l2 x2 r2 h2)) by auto; intuition_in; order.
-Qed.
-
-
-Lemma subsetr_spec : forall subset_r1 r1 x1 h1 s2,
- bst (Node Leaf x1 r1 h1) -> bst s2 ->
- (forall s, bst s -> (subset_r1 s = true <-> Subset r1 s)) ->
- (subsetr subset_r1 x1 s2 = true <-> Subset (Node Leaf x1 r1 h1) s2).
-Proof.
- induction s2 as [|l2 IHl2 x2 r2 IHr2 h2]; simpl; intros.
- unfold Subset; intuition; try discriminate.
- assert (H': InT x1 Leaf) by auto; inversion H'.
- specialize (IHl2 H).
- specialize (IHr2 H).
- inv.
- elim_compare x1 x2.
-
- rewrite H1 by auto; clear H1 IHl2 IHr2.
- unfold Subset. intuition_in.
- assert (X.eq a x2) by order; intuition_in.
- assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
-
- rewrite <-andb_lazy_alt, andb_true_iff, H1 by auto;  clear H1 IHl2 IHr2.
- unfold Subset. intuition_in.
- constructor 2. setoid_replace a with x1; auto. rewrite <- mem_spec; auto.
- rewrite mem_spec; auto.
- assert (InT x1 (Node l2 x2 r2 h2)) by auto; intuition_in; order.
-
- rewrite IHr2 by auto; clear H1 IHl2 IHr2.
- unfold Subset. intuition_in.
- assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
- assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
-Qed.
-
-Lemma subset_spec : forall s1 s2 `{Ok s1, Ok s2},
- (subset s1 s2 = true <-> Subset s1 s2).
-Proof.
- induction s1 as [|l1 IHl1 x1 r1 IHr1 h1]; simpl; intros.
- unfold Subset; intuition_in.
- destruct s2 as [|l2 x2 r2 h2]; simpl; intros.
- unfold Subset; intuition_in; try discriminate.
- assert (H': InT x1 Leaf) by auto; inversion H'.
- inv.
- elim_compare x1 x2.
-
- rewrite <-andb_lazy_alt, andb_true_iff, IHl1, IHr1 by auto.
- clear IHl1 IHr1.
- unfold Subset; intuition_in.
- assert (X.eq a x2) by order; intuition_in.
- assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
- assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
-
- rewrite <-andb_lazy_alt, andb_true_iff, IHr1 by auto.
- rewrite (@subsetl_spec (subset l1) l1 x1 h1) by auto.
- clear IHl1 IHr1.
- unfold Subset; intuition_in.
- assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
- assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
-
- rewrite <-andb_lazy_alt, andb_true_iff, IHl1 by auto.
- rewrite (@subsetr_spec (subset r1) r1 x1 h1) by auto.
- clear IHl1 IHr1.
- unfold Subset; intuition_in.
- assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
- assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
-Qed.
-
-
-(** * Comparison *)
-
-(** ** Relations [eq] and [lt] over trees *)
-
-Module L := MakeListOrdering X.
-
-Definition eq := Equal.
-Instance eq_equiv : Equivalence eq.
-Proof. firstorder. Qed.
-
-Lemma eq_Leq : forall s s', eq s s' <-> L.eq (elements s) (elements s').
-Proof.
- unfold eq, Equal, L.eq; intros.
- setoid_rewrite elements_spec1; firstorder.
-Qed.
-
-Definition lt (s1 s2 : t) : Prop :=
- exists s1', exists s2', Ok s1' /\ Ok s2' /\ eq s1 s1' /\ eq s2 s2'
-   /\ L.lt (elements s1') (elements s2').
-
-Instance lt_strorder : StrictOrder lt.
-Proof.
- split.
- intros s (s1 & s2 & B1 & B2 & E1 & E2 & L).
- assert (eqlistA X.eq (elements s1) (elements s2)).
-  apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto with *.
-  rewrite <- eq_Leq. transitivity s; auto. symmetry; auto.
- rewrite H in L.
- apply (StrictOrder_Irreflexive (elements s2)); auto.
- intros s1 s2 s3 (s1' & s2' & B1 & B2 & E1 & E2 & L12)
-                 (s2'' & s3' & B2' & B3 & E2' & E3 & L23).
- exists s1', s3'; do 4 (split; trivial).
- assert (eqlistA X.eq (elements s2') (elements s2'')).
-  apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto with *.
-  rewrite <- eq_Leq. transitivity s2; auto. symmetry; auto.
- transitivity (elements s2'); auto.
- rewrite H; auto.
-Qed.
-
-Instance lt_compat : Proper (eq==>eq==>iff) lt.
-Proof.
- intros s1 s2 E12 s3 s4 E34. split.
- intros (s1' & s3' & B1 & B3 & E1 & E3 & LT).
- exists s1', s3'; do 2 (split; trivial).
-  split. transitivity s1; auto. symmetry; auto.
-  split; auto. transitivity s3; auto. symmetry; auto.
- intros (s1' & s3' & B1 & B3 & E1 & E3 & LT).
- exists s1', s3'; do 2 (split; trivial).
-  split. transitivity s2; auto.
-  split; auto. transitivity s4; auto.
-Qed.
-
-
-(** * Proof of the comparison algorithm *)
-
-(** [flatten_e e] returns the list of elements of [e] i.e. the list
-    of elements actually compared *)
-
-Fixpoint flatten_e (e : enumeration) : list elt := match e with
-  | End => nil
-  | More x t r => x :: elements t ++ flatten_e r
- end.
-
-Lemma flatten_e_elements :
- forall l x r h e,
- elements l ++ flatten_e (More x r e) = elements (Node l x r h) ++ flatten_e e.
-Proof.
- intros; simpl; apply elements_node.
-Qed.
-
-Lemma cons_1 : forall s e,
-  flatten_e (cons s e) = elements s ++ flatten_e e.
-Proof.
- induction s; simpl; auto; intros.
- rewrite IHs1; apply flatten_e_elements.
-Qed.
-
-(** Correctness of this comparison *)
-
-Definition Cmp c x y := CompSpec L.eq L.lt x y c.
-
-Local Hint Unfold Cmp flip.
-
-Lemma compare_end_Cmp :
- forall e2, Cmp (compare_end e2) nil (flatten_e e2).
-Proof.
- destruct e2; simpl; constructor; auto. reflexivity.
-Qed.
-
-Lemma compare_more_Cmp : forall x1 cont x2 r2 e2 l,
-  Cmp (cont (cons r2 e2)) l (elements r2 ++ flatten_e e2) ->
-   Cmp (compare_more x1 cont (More x2 r2 e2)) (x1::l)
-      (flatten_e (More x2 r2 e2)).
-Proof.
- simpl; intros; elim_compare x1 x2; simpl; auto.
-Qed.
-
-Lemma compare_cont_Cmp : forall s1 cont e2 l,
- (forall e, Cmp (cont e) l (flatten_e e)) ->
- Cmp (compare_cont s1 cont e2) (elements s1 ++ l) (flatten_e e2).
-Proof.
- induction s1 as [|l1 Hl1 x1 r1 Hr1 h1]; simpl; intros; auto.
- rewrite <- elements_node; simpl.
- apply Hl1; auto. clear e2. intros [|x2 r2 e2].
- simpl; auto.
- apply compare_more_Cmp.
- rewrite <- cons_1; auto.
-Qed.
-
-Lemma compare_Cmp : forall s1 s2,
- Cmp (compare s1 s2) (elements s1) (elements s2).
-Proof.
- intros; unfold compare.
- rewrite (app_nil_end (elements s1)).
- replace (elements s2) with (flatten_e (cons s2 End)) by
-  (rewrite cons_1; simpl; rewrite <- app_nil_end; auto).
- apply compare_cont_Cmp; auto.
- intros.
- apply compare_end_Cmp; auto.
-Qed.
-
-Lemma compare_spec : forall s1 s2 `{Ok s1, Ok s2},
- CompSpec eq lt s1 s2 (compare s1 s2).
-Proof.
- intros.
- destruct (compare_Cmp s1 s2); constructor.
- rewrite eq_Leq; auto.
- intros; exists s1, s2; repeat split; auto.
- intros; exists s2, s1; repeat split; auto.
-Qed.
-
-
-(** * Equality test *)
-
-Lemma equal_spec : forall s1 s2 `{Ok s1, Ok s2},
- equal s1 s2 = true <-> eq s1 s2.
-Proof.
-unfold equal; intros s1 s2 B1 B2.
-destruct (@compare_spec s1 s2 B1 B2) as [H|H|H];
- split; intros H'; auto; try discriminate.
-rewrite H' in H. elim (StrictOrder_Irreflexive s2); auto.
-rewrite H' in H. elim (StrictOrder_Irreflexive s2); auto.
-Qed.
+Proof. rewrite partition_spec2'; now apply filter_ok. Qed.
 
 End MakeRaw.
 
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..4f0d93fb 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
@@ -208,7 +206,7 @@ intros.
 generalize (@choose_1 s) (@choose_2 s).
 destruct (choose s);intros.
 exists e;auto with set.
-generalize (H1 (refl_equal None)); clear H1.
+generalize (H1 (eq_refl None)); clear H1.
 intros; rewrite (is_empty_1 H1) in H; discriminate.
 Qed.
 
@@ -633,7 +631,7 @@ destruct (choose (filter f s)).
 intros H0 _; apply exists_1; auto.
 exists e; generalize (H0 e); rewrite filter_iff; auto.
 intros _ H0.
-rewrite (is_empty_1 (H0 (refl_equal None))) in H; auto; discriminate.
+rewrite (is_empty_1 (H0 (eq_refl None))) in H; auto; discriminate.
 Qed.
 
 Lemma partition_filter_1:
@@ -881,8 +879,8 @@ generalize (@add_filter_1 f Hf s0 (add x s0) x) (@add_filter_2 f Hf s0 (add x s0
 assert (~ In x (filter f s0)).
  intro H1; rewrite (mem_1 (filter_1 Hf H1)) in H; discriminate H.
 case (f x); simpl; intros.
-rewrite (MP.cardinal_2 H1 (H2 (refl_equal true) (MP.Add_add s0 x))); auto.
-rewrite <- (MP.Equal_cardinal (H3 (refl_equal false) (MP.Add_add s0 x))); auto.
+rewrite (MP.cardinal_2 H1 (H2 (eq_refl true) (MP.Add_add s0 x))); auto.
+rewrite <- (MP.Equal_cardinal (H3 (eq_refl false) (MP.Add_add s0 x))); auto.
 intros; rewrite fold_empty;auto.
 rewrite MP.cardinal_1; auto.
 unfold Empty; intros.
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/MSetGenTree.v b/theories/MSets/MSetGenTree.v
new file mode 100644
index 00000000..704ff31b
--- /dev/null
+++ b/theories/MSets/MSetGenTree.v
@@ -0,0 +1,1145 @@
+(***********************************************************************)
+(*  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       *)
+(***********************************************************************)
+
+(** * MSetGenTree : sets via generic trees
+
+    This module factorizes common parts in implementations
+    of finite sets as AVL trees and as Red-Black trees. The nodes
+    of the trees defined here include an generic information
+    parameter, that will be the heigth in AVL trees and the color
+    in Red-Black trees. Without more details here about these
+    information parameters, trees here are not known to be
+    well-balanced, but simply binary-search-trees.
+
+    The operations we could define and prove correct here are the
+    one that do not build non-empty trees, but only analyze them :
+
+     - empty is_empty
+     - mem
+     - compare equal subset
+     - fold cardinal elements
+     - for_all exists_
+     - min_elt max_elt choose
+*)
+
+Require Import Orders OrdersFacts MSetInterface NPeano.
+Local Open Scope list_scope.
+Local Open Scope lazy_bool_scope.
+
+(* For nicer extraction, we create induction principles
+   only when needed *)
+Local Unset Elimination Schemes.
+Local Unset Case Analysis Schemes.
+
+Module Type InfoTyp.
+ Parameter t : Set.
+End InfoTyp.
+
+(** * Ops : the pure functions *)
+
+Module Type Ops (X:OrderedType)(Info:InfoTyp).
+
+Definition elt := X.t.
+Hint Transparent elt.
+
+Inductive tree  : Type :=
+| Leaf : tree
+| Node : Info.t -> tree -> X.t -> tree -> tree.
+
+(** ** The empty set and emptyness test *)
+
+Definition empty := Leaf.
+
+Definition is_empty t :=
+ match t with
+ | Leaf => true
+ | _ => false
+ end.
+
+(** ** Membership test *)
+
+(** The [mem] function is deciding membership. It exploits the
+    binary search tree invariant to achieve logarithmic complexity. *)
+
+Fixpoint mem x t :=
+ match t with
+ | Leaf => false
+ | Node _ l k r =>
+   match X.compare x k with
+     | Lt => mem x l
+     | Eq => true
+     | Gt => mem x r
+   end
+ end.
+
+(** ** Minimal, maximal, arbitrary elements *)
+
+Fixpoint min_elt (t : tree) : option elt :=
+ match t with
+ | Leaf => None
+ | Node _ Leaf x r => Some x
+ | Node _ l x r => min_elt l
+ end.
+
+Fixpoint max_elt (t : tree) : option elt :=
+  match t with
+  | Leaf => None
+  | Node _ l x Leaf => Some x
+  | Node _ l x r => max_elt r
+  end.
+
+Definition choose := min_elt.
+
+(** ** Iteration on elements *)
+
+Fixpoint fold {A: Type} (f: elt -> A -> A) (t: tree) (base: A) : A :=
+  match t with
+  | Leaf => base
+  | Node _ l x r => fold f r (f x (fold f l base))
+ end.
+
+Fixpoint elements_aux acc s :=
+  match s with
+   | Leaf => acc
+   | Node _ l x r => elements_aux (x :: elements_aux acc r) l
+  end.
+
+Definition elements := elements_aux nil.
+
+Fixpoint rev_elements_aux acc s :=
+  match s with
+   | Leaf => acc
+   | Node _ l x r => rev_elements_aux (x :: rev_elements_aux acc l) r
+  end.
+
+Definition rev_elements := rev_elements_aux nil.
+
+Fixpoint cardinal (s : tree) : nat :=
+  match s with
+   | Leaf => 0
+   | Node _ l _ r => S (cardinal l + cardinal r)
+  end.
+
+Fixpoint maxdepth s :=
+ match s with
+ | Leaf => 0
+ | Node _ l _ r => S (max (maxdepth l) (maxdepth r))
+ end.
+
+Fixpoint mindepth s :=
+ match s with
+ | Leaf => 0
+ | Node _ l _ r => S (min (mindepth l) (mindepth r))
+ end.
+
+(** ** Testing universal or existential properties. *)
+
+(** We do not use the standard boolean operators of Coq,
+    but lazy ones. *)
+
+Fixpoint for_all (f:elt->bool) s := match s with
+  | Leaf => true
+  | Node _ l x r => f x &&& for_all f l &&& for_all f r
+end.
+
+Fixpoint exists_ (f:elt->bool) s := match s with
+  | Leaf => false
+  | Node _ l x r => f x ||| exists_ f l ||| exists_ f r
+end.
+
+(** ** Comparison of trees *)
+
+(** The algorithm here has been suggested by Xavier Leroy,
+    and transformed into c.p.s. by Benjamin Grégoire.
+    The original ocaml code (with non-structural recursive calls)
+    has also been formalized (thanks to Function+measure), see
+    [ocaml_compare] in [MSetFullAVL]. The following code with
+    continuations computes dramatically faster in Coq, and
+    should be almost as efficient after extraction.
+*)
+
+(** Enumeration of the elements of a tree. This corresponds
+    to the "samefringe" notion in the litterature. *)
+
+Inductive enumeration :=
+ | End : enumeration
+ | More : elt -> tree -> enumeration -> enumeration.
+
+
+(** [cons t e] adds the elements of tree [t] on the head of
+    enumeration [e]. *)
+
+Fixpoint cons s e : enumeration :=
+ match s with
+  | Leaf => e
+  | Node _ l x r => cons l (More x r e)
+ end.
+
+(** One step of comparison of elements *)
+
+Definition compare_more x1 (cont:enumeration->comparison) e2 :=
+ match e2 with
+ | End => Gt
+ | More x2 r2 e2 =>
+     match X.compare x1 x2 with
+      | Eq => cont (cons r2 e2)
+      | Lt => Lt
+      | Gt => Gt
+     end
+ end.
+
+(** Comparison of left tree, middle element, then right tree *)
+
+Fixpoint compare_cont s1 (cont:enumeration->comparison) e2 :=
+ match s1 with
+  | Leaf => cont e2
+  | Node _ l1 x1 r1 =>
+     compare_cont l1 (compare_more x1 (compare_cont r1 cont)) e2
+  end.
+
+(** Initial continuation *)
+
+Definition compare_end e2 :=
+ match e2 with End => Eq | _ => Lt end.
+
+(** The complete comparison *)
+
+Definition compare s1 s2 := compare_cont s1 compare_end (cons s2 End).
+
+Definition equal s1 s2 :=
+ match compare s1 s2 with Eq => true | _ => false end.
+
+(** ** Subset test *)
+
+(** In ocaml, recursive calls are made on "half-trees" such as
+   (Node _ l1 x1 Leaf) and (Node _ Leaf x1 r1). Instead of these
+   non-structural calls, we propose here two specialized functions
+   for these situations. This version should be almost as efficient
+   as the one of ocaml (closures as arguments may slow things a bit),
+   it is simply less compact. The exact ocaml version has also been
+   formalized (thanks to Function+measure), see [ocaml_subset] in
+   [MSetFullAVL].
+*)
+
+Fixpoint subsetl (subset_l1 : tree -> bool) x1 s2 : bool :=
+ match s2 with
+  | Leaf => false
+  | Node _ l2 x2 r2 =>
+     match X.compare x1 x2 with
+      | Eq => subset_l1 l2
+      | Lt => subsetl subset_l1 x1 l2
+      | Gt => mem x1 r2 &&& subset_l1 s2
+     end
+ end.
+
+Fixpoint subsetr (subset_r1 : tree -> bool) x1 s2 : bool :=
+ match s2 with
+  | Leaf => false
+  | Node _ l2 x2 r2 =>
+     match X.compare x1 x2 with
+      | Eq => subset_r1 r2
+      | Lt => mem x1 l2 &&& subset_r1 s2
+      | Gt => subsetr subset_r1 x1 r2
+     end
+ end.
+
+Fixpoint subset s1 s2 : bool := match s1, s2 with
+  | Leaf, _ => true
+  | Node _ _ _ _, Leaf => false
+  | Node _ l1 x1 r1, Node _ l2 x2 r2 =>
+     match X.compare x1 x2 with
+      | Eq => subset l1 l2 &&& subset r1 r2
+      | Lt => subsetl (subset l1) x1 l2 &&& subset r1 s2
+      | Gt => subsetr (subset r1) x1 r2 &&& subset l1 s2
+     end
+ end.
+
+End Ops.
+
+(** * Props : correctness proofs of these generic operations *)
+
+Module Type Props (X:OrderedType)(Info:InfoTyp)(Import M:Ops X Info).
+
+(** ** Occurrence in a tree *)
+
+Inductive InT (x : elt) : tree -> Prop :=
+  | IsRoot : forall c l r y, X.eq x y -> InT x (Node c l y r)
+  | InLeft : forall c l r y, InT x l -> InT x (Node c l y r)
+  | InRight : forall c l r y, InT x r -> InT x (Node c l y r).
+
+Definition In := InT.
+
+(** ** Some shortcuts *)
+
+Definition Equal s s' := forall a : elt, InT a s <-> InT a s'.
+Definition Subset s s' := forall a : elt, InT a s -> InT a s'.
+Definition Empty s := forall a : elt, ~ InT a s.
+Definition For_all (P : elt -> Prop) s := forall x, InT x s -> P x.
+Definition Exists (P : elt -> Prop) s := exists x, InT x s /\ P x.
+
+(** ** Binary search trees *)
+
+(** [lt_tree x s]: all elements in [s] are smaller than [x]
+   (resp. greater for [gt_tree]) *)
+
+Definition lt_tree x s := forall y, InT y s -> X.lt y x.
+Definition gt_tree x s := forall y, InT y s -> X.lt x y.
+
+(** [bst t] : [t] is a binary search tree *)
+
+Inductive bst : tree -> Prop :=
+  | BSLeaf : bst Leaf
+  | BSNode : forall c x l r, bst l -> bst r ->
+     lt_tree x l -> gt_tree x r -> bst (Node c l x r).
+
+(** [bst] is the (decidable) invariant our trees will have to satisfy. *)
+
+Definition IsOk := bst.
+
+Class Ok (s:tree) : Prop := ok : bst s.
+
+Instance bst_Ok s (Hs : bst s) : Ok s := { ok := Hs }.
+
+Fixpoint ltb_tree x s :=
+ match s with
+  | Leaf => true
+  | Node _ l y r =>
+     match X.compare x y with
+      | Gt => ltb_tree x l && ltb_tree x r
+      | _ => false
+     end
+ end.
+
+Fixpoint gtb_tree x s :=
+ match s with
+  | Leaf => true
+  | Node _ l y r =>
+     match X.compare x y with
+      | Lt => gtb_tree x l && gtb_tree x r
+      | _ => false
+     end
+ end.
+
+Fixpoint isok s :=
+ match s with
+  | Leaf => true
+  | Node _  l x r => isok l && isok r && ltb_tree x l && gtb_tree x r
+ end.
+
+
+(** ** Known facts about ordered types *)
+
+Module Import MX := OrderedTypeFacts X.
+
+(** ** Automation and dedicated tactics *)
+
+Scheme tree_ind := Induction for tree Sort Prop.
+Scheme bst_ind := Induction for bst Sort Prop.
+
+Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans @ok.
+Local Hint Immediate MX.eq_sym.
+Local Hint Unfold In lt_tree gt_tree.
+Local Hint Constructors InT bst.
+Local Hint Unfold Ok.
+
+(** Automatic treatment of [Ok] hypothesis *)
+
+Ltac clear_inversion H := inversion H; clear H; subst.
+
+Ltac inv_ok := match goal with
+ | H:Ok (Node _ _ _ _) |- _ => clear_inversion H; inv_ok
+ | H:Ok Leaf |- _ => clear H; inv_ok
+ | H:bst ?x |- _ => change (Ok x) in H; inv_ok
+ | _ => idtac
+end.
+
+(** A tactic to repeat [inversion_clear] on all hyps of the
+    form [(f (Node _ _ _ _))] *)
+
+Ltac is_tree_constr c :=
+  match c with
+   | Leaf => idtac
+   | Node _ _ _ _ => idtac
+   | _ => fail
+  end.
+
+Ltac invtree f :=
+  match goal with
+     | H:f ?s |- _ => is_tree_constr s; clear_inversion H; invtree f
+     | H:f _ ?s |- _ => is_tree_constr s; clear_inversion H; invtree f
+     | H:f _ _ ?s |- _ => is_tree_constr s; clear_inversion H; invtree f
+     | _ => idtac
+  end.
+
+Ltac inv := inv_ok; invtree InT.
+
+Ltac intuition_in := repeat progress (intuition; inv).
+
+(** Helper tactic concerning order of elements. *)
+
+Ltac order := match goal with
+ | U: lt_tree _ ?s, V: InT _ ?s |- _ => generalize (U _ V); clear U; order
+ | U: gt_tree _ ?s, V: InT _ ?s |- _ => generalize (U _ V); clear U; order
+ | _ => MX.order
+end.
+
+
+(** [isok] is indeed a decision procedure for [Ok] *)
+
+Lemma ltb_tree_iff : forall x s, lt_tree x s <-> ltb_tree x s = true.
+Proof.
+ induction s as [|c l IHl y r IHr]; simpl.
+ unfold lt_tree; intuition_in.
+ elim_compare x y.
+ split; intros; try discriminate. assert (X.lt y x) by auto. order.
+ split; intros; try discriminate. assert (X.lt y x) by auto. order.
+ rewrite !andb_true_iff, <-IHl, <-IHr.
+  unfold lt_tree; intuition_in; order.
+Qed.
+
+Lemma gtb_tree_iff : forall x s, gt_tree x s <-> gtb_tree x s = true.
+Proof.
+ induction s as [|c l IHl y r IHr]; simpl.
+ unfold gt_tree; intuition_in.
+ elim_compare x y.
+ split; intros; try discriminate. assert (X.lt x y) by auto. order.
+ rewrite !andb_true_iff, <-IHl, <-IHr.
+  unfold gt_tree; intuition_in; order.
+ split; intros; try discriminate. assert (X.lt x y) by auto. order.
+Qed.
+
+Lemma isok_iff : forall s, Ok s <-> isok s = true.
+Proof.
+ induction s as [|c l IHl y r IHr]; simpl.
+ intuition_in.
+ rewrite !andb_true_iff, <- IHl, <-IHr, <- ltb_tree_iff, <- gtb_tree_iff.
+ intuition_in.
+Qed.
+
+Instance isok_Ok s : isok s = true -> Ok s | 10.
+Proof. intros; apply <- isok_iff; auto. Qed.
+
+(** ** Basic results about [In] *)
+
+Lemma In_1 :
+ forall s x y, X.eq x y -> InT x s -> InT y s.
+Proof.
+ induction s; simpl; intuition_in; eauto.
+Qed.
+Local Hint Immediate In_1.
+
+Instance In_compat : Proper (X.eq==>eq==>iff) InT.
+Proof.
+apply proper_sym_impl_iff_2; auto with *.
+repeat red; intros; subst. apply In_1 with x; auto.
+Qed.
+
+Lemma In_node_iff :
+ forall c l x r y,
+  InT y (Node c l x r) <-> InT y l \/ X.eq y x \/ InT y r.
+Proof.
+ intuition_in.
+Qed.
+
+Lemma In_leaf_iff : forall x, InT x Leaf <-> False.
+Proof.
+ intuition_in.
+Qed.
+
+(** Results about [lt_tree] and [gt_tree] *)
+
+Lemma lt_leaf : forall x : elt, lt_tree x Leaf.
+Proof.
+ red; inversion 1.
+Qed.
+
+Lemma gt_leaf : forall x : elt, gt_tree x Leaf.
+Proof.
+ red; inversion 1.
+Qed.
+
+Lemma lt_tree_node :
+ forall (x y : elt) (l r : tree) (i : Info.t),
+ lt_tree x l -> lt_tree x r -> X.lt y x -> lt_tree x (Node i l y r).
+Proof.
+ unfold lt_tree; intuition_in; order.
+Qed.
+
+Lemma gt_tree_node :
+ forall (x y : elt) (l r : tree) (i : Info.t),
+ gt_tree x l -> gt_tree x r -> X.lt x y -> gt_tree x (Node i l y r).
+Proof.
+ unfold gt_tree; intuition_in; order.
+Qed.
+
+Local Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node.
+
+Lemma lt_tree_not_in :
+ forall (x : elt) (t : tree), lt_tree x t -> ~ InT x t.
+Proof.
+ intros; intro; order.
+Qed.
+
+Lemma lt_tree_trans :
+ forall x y, X.lt x y -> forall t, lt_tree x t -> lt_tree y t.
+Proof.
+ eauto.
+Qed.
+
+Lemma gt_tree_not_in :
+ forall (x : elt) (t : tree), gt_tree x t -> ~ InT x t.
+Proof.
+ intros; intro; order.
+Qed.
+
+Lemma gt_tree_trans :
+ forall x y, X.lt y x -> forall t, gt_tree x t -> gt_tree y t.
+Proof.
+ eauto.
+Qed.
+
+Instance lt_tree_compat : Proper (X.eq ==> Logic.eq ==> iff) lt_tree.
+Proof.
+ apply proper_sym_impl_iff_2; auto.
+ intros x x' Hx s s' Hs H y Hy. subst. setoid_rewrite <- Hx; auto.
+Qed.
+
+Instance gt_tree_compat : Proper (X.eq ==> Logic.eq ==> iff) gt_tree.
+Proof.
+ apply proper_sym_impl_iff_2; auto.
+ intros x x' Hx s s' Hs H y Hy. subst. setoid_rewrite <- Hx; auto.
+Qed.
+
+Local Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans.
+
+Ltac induct s x :=
+ induction s as [|i l IHl x' r IHr]; simpl; intros;
+ [|elim_compare x x'; intros; inv].
+
+Ltac auto_tc := auto with typeclass_instances.
+
+Ltac ok :=
+ inv; change bst with Ok in *;
+ match goal with
+   | |- Ok (Node _ _ _ _) => constructor; auto_tc; ok
+   | |- lt_tree _ (Node _ _ _ _) => apply lt_tree_node; ok
+   | |- gt_tree _ (Node _ _ _ _) => apply gt_tree_node; ok
+   | _ => eauto with typeclass_instances
+ end.
+
+(** ** Empty set *)
+
+Lemma empty_spec : Empty empty.
+Proof.
+ intros x H. inversion H.
+Qed.
+
+Instance empty_ok : Ok empty.
+Proof.
+ auto.
+Qed.
+
+(** ** Emptyness test *)
+
+Lemma is_empty_spec : forall s, is_empty s = true <-> Empty s.
+Proof.
+ destruct s as [|c r x l]; simpl; auto.
+ - split; auto. intros _ x H. inv.
+ - split; auto. try discriminate. intro H; elim (H x); auto.
+Qed.
+
+(** ** Membership *)
+
+Lemma mem_spec : forall s x `{Ok s}, mem x s = true <-> InT x s.
+Proof.
+ split.
+ - induct s x; now auto.
+ - induct s x; intuition_in; order.
+Qed.
+
+(** ** Minimal and maximal elements *)
+
+Functional Scheme min_elt_ind := Induction for min_elt Sort Prop.
+Functional Scheme max_elt_ind := Induction for max_elt Sort Prop.
+
+Lemma min_elt_spec1 s x : min_elt s = Some x -> InT x s.
+Proof.
+ functional induction (min_elt s); auto; inversion 1; auto.
+Qed.
+
+Lemma min_elt_spec2 s x y `{Ok s} :
+ min_elt s = Some x -> InT y s -> ~ X.lt y x.
+Proof.
+ revert y.
+ functional induction (min_elt s);
+ try rename _x0 into r; try rename _x2 into l1, _x3 into x1, _x4 into r1.
+ - discriminate.
+ - intros y V W.
+   inversion V; clear V; subst.
+   inv; order.
+ - intros; inv; auto.
+   * assert (X.lt x x0) by (apply H8; apply min_elt_spec1; auto).
+     order.
+   * assert (X.lt x1 x0) by auto.
+     assert (~X.lt x1 x) by auto.
+     order.
+Qed.
+
+Lemma min_elt_spec3 s : min_elt s = None -> Empty s.
+Proof.
+ functional induction (min_elt s).
+ red; red; inversion 2.
+ inversion 1.
+ intro H0.
+ destruct (IHo H0 _x3); auto.
+Qed.
+
+Lemma max_elt_spec1 s x : max_elt s = Some x -> InT x s.
+Proof.
+ functional induction (max_elt s); auto; inversion 1; auto.
+Qed.
+
+Lemma max_elt_spec2 s x y `{Ok s} :
+ max_elt s = Some x -> InT y s -> ~ X.lt x y.
+Proof.
+ revert y.
+ functional induction (max_elt s);
+ try rename _x0 into r; try rename _x2 into l1, _x3 into x1, _x4 into r1.
+ - discriminate.
+ - intros y V W.
+   inversion V; clear V; subst.
+   inv; order.
+ - intros; inv; auto.
+   * assert (X.lt x0 x) by (apply H9; apply max_elt_spec1; auto).
+     order.
+   * assert (X.lt x0 x1) by auto.
+     assert (~X.lt x x1) by auto.
+     order.
+Qed.
+
+Lemma max_elt_spec3 s : max_elt s = None -> Empty s.
+Proof.
+ functional induction (max_elt s).
+ red; red; inversion 2.
+ inversion 1.
+ intro H0.
+ destruct (IHo H0 _x3); auto.
+Qed.
+
+Lemma choose_spec1 : forall s x, choose s = Some x -> InT x s.
+Proof.
+ exact min_elt_spec1.
+Qed.
+
+Lemma choose_spec2 : forall s, choose s = None -> Empty s.
+Proof.
+ exact min_elt_spec3.
+Qed.
+
+Lemma choose_spec3 : forall s s' x x' `{Ok s, Ok s'},
+  choose s = Some x -> choose s' = Some x' ->
+  Equal s s' -> X.eq x x'.
+Proof.
+ unfold choose, Equal; intros s s' x x' Hb Hb' Hx Hx' H.
+ assert (~X.lt x x').
+  apply min_elt_spec2 with s'; auto.
+  rewrite <-H; auto using min_elt_spec1.
+ assert (~X.lt x' x).
+  apply min_elt_spec2 with s; auto.
+  rewrite H; auto using min_elt_spec1.
+ elim_compare x x'; intuition.
+Qed.
+
+(** ** Elements *)
+
+Lemma elements_spec1' : forall s acc x,
+ InA X.eq x (elements_aux acc s) <-> InT x s \/ InA X.eq x acc.
+Proof.
+ induction s as [ | c l Hl x r Hr ]; simpl; auto.
+ intuition.
+ inversion H0.
+ intros.
+ rewrite Hl.
+ destruct (Hr acc x0); clear Hl Hr.
+ intuition; inversion_clear H3; intuition.
+Qed.
+
+Lemma elements_spec1 : forall s x, InA X.eq x (elements s) <-> InT x s.
+Proof.
+ intros; generalize (elements_spec1' s nil x); intuition.
+ inversion_clear H0.
+Qed.
+
+Lemma elements_spec2' : forall s acc `{Ok s}, sort X.lt acc ->
+ (forall x y : elt, InA X.eq x acc -> InT y s -> X.lt y x) ->
+ sort X.lt (elements_aux acc s).
+Proof.
+ induction s as [ | c l Hl y r Hr]; simpl; intuition.
+ inv.
+ apply Hl; auto.
+ constructor.
+ apply Hr; auto.
+ eapply InA_InfA; eauto with *.
+ intros.
+ destruct (elements_spec1' r acc y0); intuition.
+ intros.
+ inversion_clear H.
+ order.
+ destruct (elements_spec1' r acc x); intuition eauto.
+Qed.
+
+Lemma elements_spec2 : forall s `(Ok s), sort X.lt (elements s).
+Proof.
+ intros; unfold elements; apply elements_spec2'; auto.
+ intros; inversion H0.
+Qed.
+Local Hint Resolve elements_spec2.
+
+Lemma elements_spec2w : forall s `(Ok s), NoDupA X.eq (elements s).
+Proof.
+ intros. eapply SortA_NoDupA; eauto with *.
+Qed.
+
+Lemma elements_aux_cardinal :
+ forall s acc, (length acc + cardinal s)%nat = length (elements_aux acc s).
+Proof.
+ simple induction s; simpl; intuition.
+ rewrite <- H.
+ simpl.
+ rewrite <- H0. rewrite (Nat.add_comm (cardinal t0)).
+ now rewrite <- Nat.add_succ_r, Nat.add_assoc.
+Qed.
+
+Lemma elements_cardinal : forall s : tree, cardinal s = length (elements s).
+Proof.
+ exact (fun s => elements_aux_cardinal s nil).
+Qed.
+
+Definition cardinal_spec (s:tree)(Hs:Ok s) := elements_cardinal s.
+
+Lemma elements_app :
+ forall s acc, elements_aux acc s = elements s ++ acc.
+Proof.
+ induction s; simpl; intros; auto.
+ rewrite IHs1, IHs2.
+ unfold elements; simpl.
+ rewrite 2 IHs1, IHs2, !app_nil_r, !app_ass; auto.
+Qed.
+
+Lemma elements_node c l x r :
+ elements (Node c l x r) = elements l ++ x :: elements r.
+Proof.
+ unfold elements; simpl.
+ now rewrite !elements_app, !app_nil_r.
+Qed.
+
+Lemma rev_elements_app :
+ forall s acc, rev_elements_aux acc s = rev_elements s ++ acc.
+Proof.
+ induction s; simpl; intros; auto.
+ rewrite IHs1, IHs2.
+ unfold rev_elements; simpl.
+ rewrite IHs1, 2 IHs2, !app_nil_r, !app_ass; auto.
+Qed.
+
+Lemma rev_elements_node c l x r :
+ rev_elements (Node c l x r) = rev_elements r ++ x :: rev_elements l.
+Proof.
+ unfold rev_elements; simpl.
+ now rewrite !rev_elements_app, !app_nil_r.
+Qed.
+
+Lemma rev_elements_rev s : rev_elements s = rev (elements s).
+Proof.
+ induction s as [|c l IHl x r IHr]; trivial.
+ rewrite elements_node, rev_elements_node, IHl, IHr, rev_app_distr.
+ simpl. now rewrite !app_ass.
+Qed.
+
+(** The converse of [elements_spec2], used in MSetRBT *)
+
+(* TODO: TO MIGRATE ELSEWHERE... *)
+
+Lemma sorted_app_inv l1 l2 :
+ sort X.lt (l1++l2) ->
+ sort X.lt l1 /\ sort X.lt l2 /\
+ forall x1 x2, InA X.eq x1 l1 -> InA X.eq x2 l2 -> X.lt x1 x2.
+Proof.
+ induction l1 as [|a1 l1 IHl1].
+ - simpl; repeat split; auto.
+   intros. now rewrite InA_nil in *.
+ - simpl. inversion_clear 1 as [ | ? ? Hs Hhd ].
+   destruct (IHl1 Hs) as (H1 & H2 & H3).
+   repeat split.
+   * constructor; auto.
+     destruct l1; simpl in *; auto; inversion_clear Hhd; auto.
+   * trivial.
+   * intros x1 x2 Hx1 Hx2. rewrite InA_cons in Hx1. destruct Hx1.
+     + rewrite H.
+       apply SortA_InfA_InA with (eqA:=X.eq)(l:=l1++l2); auto_tc.
+       rewrite InA_app_iff; auto_tc.
+     + auto.
+Qed.
+
+Lemma elements_sort_ok s : sort X.lt (elements s) -> Ok s.
+Proof.
+ induction s as [|c l IHl x r IHr].
+ - auto.
+ - rewrite elements_node.
+   intros H. destruct (sorted_app_inv _ _ H) as (H1 & H2 & H3).
+   inversion_clear H2.
+   constructor; ok.
+   * intros y Hy. apply H3.
+     + now rewrite elements_spec1.
+     + rewrite InA_cons. now left.
+   * intros y Hy.
+     apply SortA_InfA_InA with (eqA:=X.eq)(l:=elements r); auto_tc.
+     now rewrite elements_spec1.
+Qed.
+
+(** ** [for_all] and [exists] *)
+
+Lemma for_all_spec s f : Proper (X.eq==>eq) f ->
+ (for_all f s = true <-> For_all (fun x => f x = true) s).
+Proof.
+ intros Hf; unfold For_all.
+ induction s as [|i l IHl x r IHr]; simpl; auto.
+ - split; intros; inv; auto.
+ - rewrite <- !andb_lazy_alt, !andb_true_iff, IHl, IHr. clear IHl IHr.
+   intuition_in. eauto.
+Qed.
+
+Lemma exists_spec s f : Proper (X.eq==>eq) f ->
+ (exists_ f s = true <-> Exists (fun x => f x = true) s).
+Proof.
+ intros Hf; unfold Exists.
+ induction s as [|i l IHl x r IHr]; simpl; auto.
+ - split.
+   * discriminate.
+   * intros (y,(H,_)); inv.
+ - rewrite <- !orb_lazy_alt, !orb_true_iff, IHl, IHr. clear IHl IHr.
+   split; [intros [[H|(y,(H,H'))]|(y,(H,H'))]|intros (y,(H,H'))].
+   * exists x; auto.
+   * exists y; auto.
+   * exists y; auto.
+   * inv; [left;left|left;right|right]; try (exists y); eauto.
+Qed.
+
+(** ** Fold *)
+
+Lemma fold_spec' {A} (f : elt -> A -> A) (s : tree) (i : A) (acc : list elt) :
+ fold_left (flip f) (elements_aux acc s) i = fold_left (flip f) acc (fold f s i).
+Proof.
+ revert i acc.
+ induction s as [|c l IHl x r IHr]; simpl; intros; auto.
+ rewrite IHl.
+ simpl. unfold flip at 2.
+ apply IHr.
+Qed.
+
+Lemma fold_spec (s:tree) {A} (i : A) (f : elt -> A -> A) :
+ fold f s i = fold_left (flip f) (elements s) i.
+Proof.
+ revert i. unfold elements.
+ induction s as [|c l IHl x r IHr]; simpl; intros; auto.
+ rewrite fold_spec'.
+ rewrite IHr.
+ simpl; auto.
+Qed.
+
+
+(** ** Subset *)
+
+Lemma subsetl_spec : forall subset_l1 l1 x1 c1 s2
+ `{Ok (Node c1 l1 x1 Leaf), Ok s2},
+ (forall s `{Ok s}, (subset_l1 s = true <-> Subset l1 s)) ->
+ (subsetl subset_l1 x1 s2 = true <-> Subset (Node c1 l1 x1 Leaf) s2 ).
+Proof.
+ induction s2 as [|c2 l2 IHl2 x2 r2 IHr2]; simpl; intros.
+ unfold Subset; intuition; try discriminate.
+ assert (H': InT x1 Leaf) by auto; inversion H'.
+ specialize (IHl2 H).
+ specialize (IHr2 H).
+ inv.
+ elim_compare x1 x2.
+
+ rewrite H1 by auto; clear H1 IHl2 IHr2.
+ unfold Subset. intuition_in.
+ assert (X.eq a x2) by order; intuition_in.
+ assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.
+
+ rewrite IHl2 by auto; clear H1 IHl2 IHr2.
+ unfold Subset. intuition_in.
+ assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.
+ assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.
+
+ rewrite <-andb_lazy_alt, andb_true_iff, H1 by auto; clear H1 IHl2 IHr2.
+ unfold Subset. intuition_in.
+ constructor 3. setoid_replace a with x1; auto. rewrite <- mem_spec; auto.
+ rewrite mem_spec; auto.
+ assert (InT x1 (Node c2 l2 x2 r2)) by auto; intuition_in; order.
+Qed.
+
+
+Lemma subsetr_spec : forall subset_r1 r1 x1 c1 s2,
+ bst (Node c1 Leaf x1 r1) -> bst s2 ->
+ (forall s, bst s -> (subset_r1 s = true <-> Subset r1 s)) ->
+ (subsetr subset_r1 x1 s2 = true <-> Subset (Node c1 Leaf x1 r1) s2).
+Proof.
+ induction s2 as [|c2 l2 IHl2 x2 r2 IHr2]; simpl; intros.
+ unfold Subset; intuition; try discriminate.
+ assert (H': InT x1 Leaf) by auto; inversion H'.
+ specialize (IHl2 H).
+ specialize (IHr2 H).
+ inv.
+ elim_compare x1 x2.
+
+ rewrite H1 by auto; clear H1 IHl2 IHr2.
+ unfold Subset. intuition_in.
+ assert (X.eq a x2) by order; intuition_in.
+ assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.
+
+ rewrite <-andb_lazy_alt, andb_true_iff, H1 by auto;  clear H1 IHl2 IHr2.
+ unfold Subset. intuition_in.
+ constructor 2. setoid_replace a with x1; auto. rewrite <- mem_spec; auto.
+ rewrite mem_spec; auto.
+ assert (InT x1 (Node c2 l2 x2 r2)) by auto; intuition_in; order.
+
+ rewrite IHr2 by auto; clear H1 IHl2 IHr2.
+ unfold Subset. intuition_in.
+ assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.
+ assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.
+Qed.
+
+Lemma subset_spec : forall s1 s2 `{Ok s1, Ok s2},
+ (subset s1 s2 = true <-> Subset s1 s2).
+Proof.
+ induction s1 as [|c1 l1 IHl1 x1 r1 IHr1]; simpl; intros.
+ unfold Subset; intuition_in.
+ destruct s2 as [|c2 l2 x2 r2]; simpl; intros.
+ unfold Subset; intuition_in; try discriminate.
+ assert (H': InT x1 Leaf) by auto; inversion H'.
+ inv.
+ elim_compare x1 x2.
+
+ rewrite <-andb_lazy_alt, andb_true_iff, IHl1, IHr1 by auto.
+ clear IHl1 IHr1.
+ unfold Subset; intuition_in.
+ assert (X.eq a x2) by order; intuition_in.
+ assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.
+ assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.
+
+ rewrite <-andb_lazy_alt, andb_true_iff, IHr1 by auto.
+ rewrite (@subsetl_spec (subset l1) l1 x1 c1) by auto.
+ clear IHl1 IHr1.
+ unfold Subset; intuition_in.
+ assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.
+ assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.
+
+ rewrite <-andb_lazy_alt, andb_true_iff, IHl1 by auto.
+ rewrite (@subsetr_spec (subset r1) r1 x1 c1) by auto.
+ clear IHl1 IHr1.
+ unfold Subset; intuition_in.
+ assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.
+ assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.
+Qed.
+
+
+(** ** Comparison *)
+
+(** Relations [eq] and [lt] over trees *)
+
+Module L := MSetInterface.MakeListOrdering X.
+
+Definition eq := Equal.
+Instance eq_equiv : Equivalence eq.
+Proof. firstorder. Qed.
+
+Lemma eq_Leq : forall s s', eq s s' <-> L.eq (elements s) (elements s').
+Proof.
+ unfold eq, Equal, L.eq; intros.
+ setoid_rewrite elements_spec1; firstorder.
+Qed.
+
+Definition lt (s1 s2 : tree) : Prop :=
+ exists s1' s2', Ok s1' /\ Ok s2' /\ eq s1 s1' /\ eq s2 s2'
+   /\ L.lt (elements s1') (elements s2').
+
+Instance lt_strorder : StrictOrder lt.
+Proof.
+ split.
+ intros s (s1 & s2 & B1 & B2 & E1 & E2 & L).
+ assert (eqlistA X.eq (elements s1) (elements s2)).
+  apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto with *.
+  rewrite <- eq_Leq. transitivity s; auto. symmetry; auto.
+ rewrite H in L.
+ apply (StrictOrder_Irreflexive (elements s2)); auto.
+ intros s1 s2 s3 (s1' & s2' & B1 & B2 & E1 & E2 & L12)
+                 (s2'' & s3' & B2' & B3 & E2' & E3 & L23).
+ exists s1', s3'; do 4 (split; trivial).
+ assert (eqlistA X.eq (elements s2') (elements s2'')).
+  apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto with *.
+  rewrite <- eq_Leq. transitivity s2; auto. symmetry; auto.
+ transitivity (elements s2'); auto.
+ rewrite H; auto.
+Qed.
+
+Instance lt_compat : Proper (eq==>eq==>iff) lt.
+Proof.
+ intros s1 s2 E12 s3 s4 E34. split.
+ intros (s1' & s3' & B1 & B3 & E1 & E3 & LT).
+ exists s1', s3'; do 2 (split; trivial).
+  split. transitivity s1; auto. symmetry; auto.
+  split; auto. transitivity s3; auto. symmetry; auto.
+ intros (s1' & s3' & B1 & B3 & E1 & E3 & LT).
+ exists s1', s3'; do 2 (split; trivial).
+  split. transitivity s2; auto.
+  split; auto. transitivity s4; auto.
+Qed.
+
+
+(** Proof of the comparison algorithm *)
+
+(** [flatten_e e] returns the list of elements of [e] i.e. the list
+    of elements actually compared *)
+
+Fixpoint flatten_e (e : enumeration) : list elt := match e with
+  | End => nil
+  | More x t r => x :: elements t ++ flatten_e r
+ end.
+
+Lemma flatten_e_elements :
+ forall l x r c e,
+ elements l ++ flatten_e (More x r e) = elements (Node c l x r) ++ flatten_e e.
+Proof.
+ intros; simpl. now rewrite elements_node, app_ass.
+Qed.
+
+Lemma cons_1 : forall s e,
+  flatten_e (cons s e) = elements s ++ flatten_e e.
+Proof.
+ induction s; simpl; auto; intros.
+ rewrite IHs1; apply flatten_e_elements.
+Qed.
+
+(** Correctness of this comparison *)
+
+Definition Cmp c x y := CompSpec L.eq L.lt x y c.
+
+Local Hint Unfold Cmp flip.
+
+Lemma compare_end_Cmp :
+ forall e2, Cmp (compare_end e2) nil (flatten_e e2).
+Proof.
+ destruct e2; simpl; constructor; auto. reflexivity.
+Qed.
+
+Lemma compare_more_Cmp : forall x1 cont x2 r2 e2 l,
+  Cmp (cont (cons r2 e2)) l (elements r2 ++ flatten_e e2) ->
+   Cmp (compare_more x1 cont (More x2 r2 e2)) (x1::l)
+      (flatten_e (More x2 r2 e2)).
+Proof.
+ simpl; intros; elim_compare x1 x2; simpl; red; auto.
+Qed.
+
+Lemma compare_cont_Cmp : forall s1 cont e2 l,
+ (forall e, Cmp (cont e) l (flatten_e e)) ->
+ Cmp (compare_cont s1 cont e2) (elements s1 ++ l) (flatten_e e2).
+Proof.
+ induction s1 as [|c1 l1 Hl1 x1 r1 Hr1]; simpl; intros; auto.
+ rewrite elements_node, app_ass; simpl.
+ apply Hl1; auto. clear e2. intros [|x2 r2 e2].
+ simpl; auto.
+ apply compare_more_Cmp.
+ rewrite <- cons_1; auto.
+Qed.
+
+Lemma compare_Cmp : forall s1 s2,
+ Cmp (compare s1 s2) (elements s1) (elements s2).
+Proof.
+ intros; unfold compare.
+ rewrite (app_nil_end (elements s1)).
+ replace (elements s2) with (flatten_e (cons s2 End)) by
+  (rewrite cons_1; simpl; rewrite <- app_nil_end; auto).
+ apply compare_cont_Cmp; auto.
+ intros.
+ apply compare_end_Cmp; auto.
+Qed.
+
+Lemma compare_spec : forall s1 s2 `{Ok s1, Ok s2},
+ CompSpec eq lt s1 s2 (compare s1 s2).
+Proof.
+ intros.
+ destruct (compare_Cmp s1 s2); constructor.
+ rewrite eq_Leq; auto.
+ intros; exists s1, s2; repeat split; auto.
+ intros; exists s2, s1; repeat split; auto.
+Qed.
+
+
+(** ** Equality test *)
+
+Lemma equal_spec : forall s1 s2 `{Ok s1, Ok s2},
+ equal s1 s2 = true <-> eq s1 s2.
+Proof.
+unfold equal; intros s1 s2 B1 B2.
+destruct (@compare_spec s1 s2 B1 B2) as [H|H|H];
+ split; intros H'; auto; try discriminate.
+rewrite H' in H. elim (StrictOrder_Irreflexive s2); auto.
+rewrite H' in H. elim (StrictOrder_Irreflexive s2); auto.
+Qed.
+
+(** ** A few results about [mindepth] and [maxdepth] *)
+
+Lemma mindepth_maxdepth s : mindepth s <= maxdepth s.
+Proof.
+ induction s; simpl; auto.
+ rewrite <- Nat.succ_le_mono.
+ transitivity (mindepth s1). apply Nat.le_min_l.
+ transitivity (maxdepth s1). trivial. apply Nat.le_max_l.
+Qed.
+
+Lemma maxdepth_cardinal s : cardinal s < 2^(maxdepth s).
+Proof.
+ unfold Peano.lt.
+ induction s as [|c l IHl x r IHr].
+ - auto.
+ - simpl. rewrite <- Nat.add_succ_r, <- Nat.add_succ_l, Nat.add_0_r.
+   apply Nat.add_le_mono; etransitivity;
+   try apply IHl; try apply IHr; apply Nat.pow_le_mono; auto.
+   * apply Nat.le_max_l.
+   * apply Nat.le_max_r.
+Qed.
+
+Lemma mindepth_cardinal s : 2^(mindepth s) <= S (cardinal s).
+Proof.
+ unfold Peano.lt.
+ induction s as [|c l IHl x r IHr].
+ - auto.
+ - simpl. rewrite <- Nat.add_succ_r, <- Nat.add_succ_l, Nat.add_0_r.
+   apply Nat.add_le_mono; etransitivity;
+   try apply IHl; try apply IHr; apply Nat.pow_le_mono; auto.
+   * apply Nat.le_min_l.
+   * apply Nat.le_min_r.
+Qed.
+
+Lemma maxdepth_log_cardinal s : s <> Leaf ->
+ log2 (cardinal s) < maxdepth s.
+Proof.
+ intros H.
+ apply Nat.log2_lt_pow2. destruct s; simpl; intuition.
+ apply maxdepth_cardinal.
+Qed.
+
+Lemma mindepth_log_cardinal s : mindepth s <= log2 (S (cardinal s)).
+Proof.
+ apply Nat.log2_le_pow2. auto with arith.
+ apply mindepth_cardinal.
+Qed.
+
+End Props.
\ No newline at end of file
diff --git a/theories/MSets/MSetInterface.v b/theories/MSets/MSetInterface.v
index 194cb904..6778deff 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).
@@ -482,7 +480,7 @@ Module WRaw2SetsOn (E:DecidableType)(M:WRawSets E) <: WSetsOn E.
  Proof.
   intros (s,Hs) (s',Hs').
   change ({M.Equal s s'}+{~M.Equal s s'}).
-  destruct (M.equal s s') as [ ]_eqn:H; [left|right];
+  destruct (M.equal s s') eqn:H; [left|right];
    rewrite <- M.equal_spec; congruence.
  Defined.
 
@@ -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..d9b1fd9b 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
@@ -664,7 +662,7 @@ Module MakeRaw (X: OrderedType) <: RawSets X.
   Proof.
   induction s; simpl; intros.
   split; intuition; inv.
-  destruct (f a) as [ ]_eqn:F; rewrite !InA_cons, ?IHs; intuition.
+  destruct (f a) eqn:F; rewrite !InA_cons, ?IHs; intuition.
   setoid_replace x with a; auto.
   setoid_replace a with x in F; auto; congruence.
   Qed.
@@ -676,7 +674,7 @@ Module MakeRaw (X: OrderedType) <: RawSets X.
   Proof.
   unfold For_all; induction s; simpl; intros.
   split; intros; auto. inv.
-  destruct (f a) as [ ]_eqn:F.
+  destruct (f a) eqn:F.
   rewrite IHs; auto. firstorder. inv; auto.
   setoid_replace x with a; auto.
   split; intros H'. discriminate.
@@ -690,7 +688,7 @@ Module MakeRaw (X: OrderedType) <: RawSets X.
   Proof.
   unfold Exists; induction s; simpl; intros.
   firstorder. discriminate. inv.
-  destruct (f a) as [ ]_eqn:F.
+  destruct (f a) eqn:F.
   firstorder.
   rewrite IHs; auto.
   firstorder.
@@ -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/MSetPositive.v b/theories/MSets/MSetPositive.v
index e83ac27d..e500602f 100644
--- a/theories/MSets/MSetPositive.v
+++ b/theories/MSets/MSetPositive.v
@@ -36,8 +36,8 @@ Local Unset Boolean Equality Schemes.
 Module PositiveOrderedTypeBits <: UsualOrderedType.
   Definition t:=positive.
   Include HasUsualEq <+ UsualIsEq.
-  Definition eqb := Peqb.
-  Definition eqb_eq := Peqb_eq.
+  Definition eqb := Pos.eqb.
+  Definition eqb_eq := Pos.eqb_eq.
   Include HasEqBool2Dec.
 
   Fixpoint bits_lt (p q:positive) : Prop :=
diff --git a/theories/MSets/MSetProperties.v b/theories/MSets/MSetProperties.v
index c0038a4f..396067b5 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
@@ -828,7 +831,7 @@ Module WPropertiesOn (Import E : DecidableType)(M : WSetsOn E).
   rewrite (inter_subset_equal H).
   generalize (@cardinal_inv_1 (diff s' s)).
   destruct (cardinal (diff s' s)).
-  intro H2; destruct (H2 (refl_equal _) x).
+  intro H2; destruct (H2 (eq_refl _) x).
   set_iff; auto.
   intros _.
   change (0 + cardinal s < S n + cardinal s).
@@ -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/MSetRBT.v b/theories/MSets/MSetRBT.v
new file mode 100644
index 00000000..b838495f
--- /dev/null
+++ b/theories/MSets/MSetRBT.v
@@ -0,0 +1,1965 @@
+(***********************************************************************)
+(*  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       *)
+(***********************************************************************)
+
+(** * MSetRBT : Implementation of MSetInterface via Red-Black trees *)
+
+(** Initial author: Andrew W. Appel, 2011.
+    Extra modifications by: Pierre Letouzey
+
+The design decisions behind this implementation are described here:
+
+ - Efficient Verified Red-Black Trees, by Andrew W. Appel, September 2011.
+   http://www.cs.princeton.edu/~appel/papers/redblack.pdf
+
+Additional suggested reading:
+
+ - Red-Black Trees in a Functional Setting by Chris Okasaki.
+   Journal of Functional Programming, 9(4):471-477, July 1999.
+   http://www.eecs.usma.edu/webs/people/okasaki/jfp99redblack.pdf
+
+ - Red-black trees with types, by Stefan Kahrs.
+   Journal of Functional Programming, 11(4), 425-432, 2001.
+
+ - Functors for Proofs and Programs, by J.-C. Filliatre and P. Letouzey.
+   ESOP'04: European Symposium on Programming, pp. 370-384, 2004.
+   http://www.lri.fr/~filliatr/ftp/publis/fpp.ps.gz
+*)
+
+Require MSetGenTree.
+Require Import Bool List BinPos Pnat Setoid SetoidList NPeano.
+Local Open Scope list_scope.
+
+(* For nicer extraction, we create induction principles
+   only when needed *)
+Local Unset Elimination Schemes.
+Local Unset Case Analysis Schemes.
+
+(** An extra function not (yet?) in MSetInterface.S *)
+
+Module Type MSetRemoveMin (Import M:MSetInterface.S).
+
+ Parameter remove_min : t -> option (elt * t).
+
+ Axiom remove_min_spec1 : forall s k s',
+  remove_min s = Some (k,s') ->
+   min_elt s = Some k /\ remove k s [=] s'.
+
+ Axiom remove_min_spec2 : forall s, remove_min s = None -> Empty s.
+
+End MSetRemoveMin.
+
+(** The type of color annotation. *)
+
+Inductive color := Red | Black.
+
+Module Color.
+ Definition t := color.
+End Color.
+
+(** * Ops : the pure functions *)
+
+Module Ops (X:Orders.OrderedType) <: MSetInterface.Ops X.
+
+(** ** Generic trees instantiated with color *)
+
+(** We reuse a generic definition of trees where the information
+    parameter is a color. Functions like mem or fold are also
+    provided by this generic functor. *)
+
+Include MSetGenTree.Ops X Color.
+
+Definition t := tree.
+Local Notation Rd := (Node Red).
+Local Notation Bk := (Node Black).
+
+(** ** Basic tree *)
+
+Definition singleton (k: elt) : tree := Bk Leaf k Leaf.
+
+(** ** Changing root color *)
+
+Definition makeBlack t :=
+ match t with
+ | Leaf => Leaf
+ | Node _ a x b => Bk a x b
+ end.
+
+Definition makeRed t :=
+ match t with
+ | Leaf => Leaf
+ | Node _ a x b => Rd a x b
+ end.
+
+(** ** Balancing *)
+
+(** We adapt when one side is not a true red-black tree.
+    Both sides have the same black depth. *)
+
+Definition lbal l k r :=
+ match l with
+ | Rd (Rd a x b) y c => Rd (Bk a x b) y (Bk c k r)
+ | Rd a x (Rd b y c) => Rd (Bk a x b) y (Bk c k r)
+ | _ => Bk l k r
+ end.
+
+Definition rbal l k r :=
+ match r with
+ | Rd (Rd b y c) z d => Rd (Bk l k b) y (Bk c z d)
+ | Rd b y (Rd c z d) => Rd (Bk l k b) y (Bk c z d)
+ | _ => Bk l k r
+ end.
+
+(** A variant of [rbal], with reverse pattern order.
+    Is it really useful ? Should we always use it ? *)
+
+Definition rbal' l k r :=
+ match r with
+ | Rd b y (Rd c z d) => Rd (Bk l k b) y (Bk c z d)
+ | Rd (Rd b y c) z d => Rd (Bk l k b) y (Bk c z d)
+ | _ => Bk l k r
+ end.
+
+(** Balancing with different black depth.
+    One side is almost a red-black tree, while the other is
+    a true red-black tree, but with black depth + 1.
+    Used in deletion. *)
+
+Definition lbalS l k r :=
+ match l with
+ | Rd a x b => Rd (Bk a x b) k r
+ | _ =>
+   match r with
+   | Bk a y b => rbal' l k (Rd a y b)
+   | Rd (Bk a y b) z c => Rd (Bk l k a) y (rbal' b z (makeRed c))
+   | _ => Rd l k r (* impossible *)
+   end
+ end.
+
+Definition rbalS l k r :=
+ match r with
+ | Rd b y c => Rd l k (Bk b y c)
+ | _ =>
+   match l with
+   | Bk a x b => lbal (Rd a x b) k r
+   | Rd a x (Bk b y c) => Rd (lbal (makeRed a) x b) y (Bk c k r)
+   | _ => Rd l k r (* impossible *)
+   end
+ end.
+
+(** ** Insertion *)
+
+Fixpoint ins x s :=
+ match s with
+ | Leaf => Rd Leaf x Leaf
+ | Node c l y r =>
+   match X.compare x y with
+   | Eq => s
+   | Lt =>
+     match c with
+     | Red => Rd (ins x l) y r
+     | Black => lbal (ins x l) y r
+     end
+   | Gt =>
+     match c with
+     | Red => Rd l y (ins x r)
+     | Black => rbal l y (ins x r)
+     end
+   end
+ end.
+
+Definition add x s := makeBlack (ins x s).
+
+(** ** Deletion *)
+
+Fixpoint append (l:tree) : tree -> tree :=
+ match l with
+ | Leaf => fun r => r
+ | Node lc ll lx lr =>
+   fix append_l (r:tree) : tree :=
+   match r with
+   | Leaf => l
+   | Node rc rl rx rr =>
+     match lc, rc with
+     | Red, Red =>
+       let lrl := append lr rl in
+       match lrl with
+       | Rd lr' x rl' => Rd (Rd ll lx lr') x (Rd rl' rx rr)
+       | _ => Rd ll lx (Rd lrl rx rr)
+       end
+     | Black, Black =>
+       let lrl := append lr rl in
+       match lrl with
+       | Rd lr' x rl' => Rd (Bk ll lx lr') x (Bk rl' rx rr)
+       | _ => lbalS ll lx (Bk lrl rx rr)
+       end
+     | Black, Red => Rd (append_l rl) rx rr
+     | Red, Black => Rd ll lx (append lr r)
+     end
+   end
+ end.
+
+Fixpoint del x t :=
+ match t with
+ | Leaf => Leaf
+ | Node _ a y b =>
+   match X.compare x y with
+   | Eq => append a b
+   | Lt =>
+     match a with
+     | Bk _ _ _ => lbalS (del x a) y b
+     | _ => Rd (del x a) y b
+     end
+   | Gt =>
+     match b with
+     | Bk _ _ _ => rbalS a y (del x b)
+     | _ => Rd a y (del x b)
+     end
+   end
+ end.
+
+Definition remove x t := makeBlack (del x t).
+
+(** ** Removing minimal element *)
+
+Fixpoint delmin l x r : (elt * tree) :=
+ match l with
+ | Leaf => (x,r)
+ | Node lc ll lx lr =>
+   let (k,l') := delmin ll lx lr in
+   match lc with
+   | Black => (k, lbalS l' x r)
+   | Red => (k, Rd l' x r)
+   end
+ end.
+
+Definition remove_min t : option (elt * tree) :=
+ match t with
+ | Leaf => None
+ | Node _ l x r =>
+   let (k,t) := delmin l x r in
+   Some (k, makeBlack t)
+ end.
+
+(** ** Tree-ification
+
+    We rebuild a tree of size [if pred then n-1 else n] as soon
+    as the list [l] has enough elements *)
+
+Definition bogus : tree * list elt := (Leaf, nil).
+
+Notation treeify_t := (list elt -> tree * list elt).
+
+Definition treeify_zero : treeify_t :=
+ fun acc => (Leaf,acc).
+
+Definition treeify_one : treeify_t :=
+ fun acc => match acc with
+ | x::acc => (Rd Leaf x Leaf, acc)
+ | _ => bogus
+ end.
+
+Definition treeify_cont (f g : treeify_t) : treeify_t :=
+ fun acc =>
+ match f acc with
+ | (l, x::acc) =>
+   match g acc with
+   | (r, acc) => (Bk l x r, acc)
+   end
+ | _ => bogus
+ end.
+
+Fixpoint treeify_aux (pred:bool)(n: positive) : treeify_t :=
+ match n with
+ | xH => if pred then treeify_zero else treeify_one
+ | xO n => treeify_cont (treeify_aux pred n) (treeify_aux true n)
+ | xI n => treeify_cont (treeify_aux false n) (treeify_aux pred n)
+ end.
+
+Fixpoint plength_aux (l:list elt)(p:positive) := match l with
+ | nil => p
+ | _::l => plength_aux l (Pos.succ p)
+end.
+
+Definition plength l := plength_aux l 1.
+
+Definition treeify (l:list elt) :=
+ fst (treeify_aux true (plength l) l).
+
+(** ** Filtering *)
+
+Fixpoint filter_aux (f: elt -> bool) s acc :=
+ match s with
+ | Leaf => acc
+ | Node _ l k r =>
+   let acc := filter_aux f r acc in
+   if f k then filter_aux f l (k::acc)
+   else filter_aux f l acc
+ end.
+
+Definition filter (f: elt -> bool) (s: t) : t :=
+ treeify (filter_aux f s nil).
+
+Fixpoint partition_aux (f: elt -> bool) s acc1 acc2 :=
+ match s with
+ | Leaf => (acc1,acc2)
+ | Node _ sl k sr =>
+   let (acc1, acc2) := partition_aux f sr acc1 acc2 in
+   if f k then partition_aux f sl (k::acc1) acc2
+   else partition_aux f sl acc1 (k::acc2)
+ end.
+
+Definition partition (f: elt -> bool) (s:t) : t*t :=
+  let (ok,ko) := partition_aux f s nil nil in
+  (treeify ok, treeify ko).
+
+(** ** Union, intersection, difference *)
+
+(** union of the elements of [l1] and [l2] into a third [acc] list. *)
+
+Fixpoint union_list l1 : list elt -> list elt -> list elt :=
+ match l1 with
+ | nil => @rev_append _
+ | x::l1' =>
+    fix union_l1 l2 acc :=
+    match l2 with
+    | nil => rev_append l1 acc
+    | y::l2' =>
+       match X.compare x y with
+       | Eq => union_list l1' l2' (x::acc)
+       | Lt => union_l1 l2' (y::acc)
+       | Gt => union_list l1' l2 (x::acc)
+       end
+    end
+ end.
+
+Definition linear_union s1 s2 :=
+  treeify (union_list (rev_elements s1) (rev_elements s2) nil).
+
+Fixpoint inter_list l1 : list elt -> list elt -> list elt :=
+ match l1 with
+ | nil => fun _ acc => acc
+ | x::l1' =>
+    fix inter_l1 l2 acc :=
+    match l2 with
+    | nil => acc
+    | y::l2' =>
+       match X.compare x y with
+       | Eq => inter_list l1' l2' (x::acc)
+       | Lt => inter_l1 l2' acc
+       | Gt => inter_list l1' l2 acc
+       end
+    end
+ end.
+
+Definition linear_inter s1 s2 :=
+  treeify (inter_list (rev_elements s1) (rev_elements s2) nil).
+
+Fixpoint diff_list l1 : list elt -> list elt -> list elt :=
+ match l1 with
+ | nil => fun _ acc => acc
+ | x::l1' =>
+    fix diff_l1 l2 acc :=
+    match l2 with
+    | nil => rev_append l1 acc
+    | y::l2' =>
+       match X.compare x y with
+       | Eq => diff_list l1' l2' acc
+       | Lt => diff_l1 l2' acc
+       | Gt => diff_list l1' l2 (x::acc)
+       end
+    end
+ end.
+
+Definition linear_diff s1 s2 :=
+  treeify (diff_list (rev_elements s1) (rev_elements s2) nil).
+
+(** [compare_height] returns:
+  - [Lt] if [height s2] is at least twice [height s1];
+  - [Gt] if [height s1] is at least twice [height s2];
+  - [Eq] if heights are approximately equal.
+  Warning: this is not an equivalence relation! but who cares.... *)
+
+Definition skip_red t :=
+ match t with
+ | Rd t' _ _ => t'
+ | _ => t
+ end.
+
+Definition skip_black t :=
+ match skip_red t with
+ | Bk t' _ _ => t'
+ | t' => t'
+ end.
+
+Fixpoint compare_height (s1x s1 s2 s2x: tree) : comparison :=
+ match skip_red s1x, skip_red s1, skip_red s2, skip_red s2x with
+ | Node _ s1x' _ _, Node _ s1' _ _, Node _ s2' _ _, Node _ s2x' _ _ =>
+   compare_height (skip_black s2x') s1' s2' (skip_black s2x')
+ | _, Leaf, _, Node _ _ _ _ => Lt
+ | Node _ _ _ _, _, Leaf, _ => Gt
+ | Node _ s1x' _ _, Node _ s1' _ _, Node _ s2' _ _, Leaf =>
+   compare_height (skip_black s1x') s1' s2' Leaf
+ | Leaf, Node _ s1' _ _, Node _ s2' _ _, Node _ s2x' _ _ =>
+   compare_height Leaf s1'  s2'  (skip_black s2x')
+ | _, _, _, _ => Eq
+ end.
+
+(** When one tree is quite smaller than the other, we simply
+    adds repeatively all its elements in the big one.
+    For trees of comparable height, we rather use [linear_union]. *)
+
+Definition union (t1 t2: t) : t :=
+ match compare_height t1 t1 t2 t2 with
+ | Lt => fold add t1 t2
+ | Gt => fold add t2 t1
+ | Eq => linear_union t1 t2
+ end.
+
+Definition diff (t1 t2: t) : t :=
+ match compare_height t1 t1 t2 t2 with
+ | Lt => filter (fun k => negb (mem k t2)) t1
+ | Gt => fold remove t2 t1
+ | Eq => linear_diff t1 t2
+ end.
+
+Definition inter (t1 t2: t) : t :=
+ match compare_height t1 t1 t2 t2 with
+ | Lt => filter (fun k => mem k t2) t1
+ | Gt => filter (fun k => mem k t1) t2
+ | Eq => linear_inter t1 t2
+ end.
+
+End Ops.
+
+(** * MakeRaw : the pure functions and their specifications *)
+
+Module Type MakeRaw (X:Orders.OrderedType) <: MSetInterface.RawSets X.
+Include Ops X.
+
+(** Generic definition of binary-search-trees and proofs of
+    specifications for generic functions such as mem or fold. *)
+
+Include MSetGenTree.Props X Color.
+
+Local Notation Rd := (Node Red).
+Local Notation Bk := (Node Black).
+
+Local Hint Immediate MX.eq_sym.
+Local Hint Unfold In lt_tree gt_tree Ok.
+Local Hint Constructors InT bst.
+Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans @ok.
+Local Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node.
+Local Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans.
+Local Hint Resolve elements_spec2.
+
+(** ** Singleton set *)
+
+Lemma singleton_spec x y : InT y (singleton x) <-> X.eq y x.
+Proof.
+ unfold singleton; intuition_in.
+Qed.
+
+Instance singleton_ok x : Ok (singleton x).
+Proof.
+ unfold singleton; auto.
+Qed.
+
+(** ** makeBlack, MakeRed *)
+
+Lemma makeBlack_spec s x : InT x (makeBlack s) <-> InT x s.
+Proof.
+ destruct s; simpl; intuition_in.
+Qed.
+
+Lemma makeRed_spec s x : InT x (makeRed s) <-> InT x s.
+Proof.
+ destruct s; simpl; intuition_in.
+Qed.
+
+Instance makeBlack_ok s `{Ok s} : Ok (makeBlack s).
+Proof.
+ destruct s; simpl; ok.
+Qed.
+
+Instance makeRed_ok s `{Ok s} : Ok (makeRed s).
+Proof.
+ destruct s; simpl; ok.
+Qed.
+
+(** ** Generic handling for red-matching and red-red-matching *)
+
+Definition isblack t :=
+ match t with Bk _ _ _ => True | _ => False end.
+
+Definition notblack t :=
+ match t with Bk _ _ _ => False | _ => True end.
+
+Definition notred t :=
+ match t with Rd _ _ _ => False | _ => True end.
+
+Definition rcase {A} f g t : A :=
+ match t with
+ | Rd a x b => f a x b
+ | _ => g t
+ end.
+
+Inductive rspec {A} f g : tree -> A -> Prop :=
+ | rred a x b : rspec f g (Rd a x b) (f a x b)
+ | relse t : notred t -> rspec f g t (g t).
+
+Fact rmatch {A} f g t : rspec (A:=A) f g t (rcase f g t).
+Proof.
+destruct t as [|[|] l x r]; simpl; now constructor.
+Qed.
+
+Definition rrcase {A} f g t : A :=
+ match t with
+ | Rd (Rd a x b) y c => f a x b y c
+ | Rd a x (Rd b y c) => f a x b y c
+ | _ => g t
+ end.
+
+Notation notredred := (rrcase (fun _ _ _ _ _ => False) (fun _ => True)).
+
+Inductive rrspec {A} f g : tree -> A -> Prop :=
+ | rrleft a x b y c : rrspec f g (Rd (Rd a x b) y c) (f a x b y c)
+ | rrright a x b y c : rrspec f g (Rd a x (Rd b y c)) (f a x b y c)
+ | rrelse t : notredred t -> rrspec f g t (g t).
+
+Fact rrmatch {A} f g t : rrspec (A:=A) f g t (rrcase f g t).
+Proof.
+destruct t as [|[|] l x r]; simpl; try now constructor.
+destruct l as [|[|] ll lx lr], r as [|[|] rl rx rr]; now constructor.
+Qed.
+
+Definition rrcase' {A} f g t : A :=
+ match t with
+ | Rd a x (Rd b y c) => f a x b y c
+ | Rd (Rd a x b) y c => f a x b y c
+ | _ => g t
+ end.
+
+Fact rrmatch' {A} f g t : rrspec (A:=A) f g t (rrcase' f g t).
+Proof.
+destruct t as [|[|] l x r]; simpl; try now constructor.
+destruct l as [|[|] ll lx lr], r as [|[|] rl rx rr]; now constructor.
+Qed.
+
+(** Balancing operations are instances of generic match *)
+
+Fact lbal_match l k r :
+ rrspec
+   (fun a x b y c => Rd (Bk a x b) y (Bk c k r))
+   (fun l => Bk l k r)
+   l
+   (lbal l k r).
+Proof.
+ exact (rrmatch _ _ _).
+Qed.
+
+Fact rbal_match l k r :
+ rrspec
+   (fun a x b y c => Rd (Bk l k a) x (Bk b y c))
+   (fun r => Bk l k r)
+   r
+   (rbal l k r).
+Proof.
+ exact (rrmatch _ _ _).
+Qed.
+
+Fact rbal'_match l k r :
+ rrspec
+   (fun a x b y c => Rd (Bk l k a) x (Bk b y c))
+   (fun r => Bk l k r)
+   r
+   (rbal' l k r).
+Proof.
+ exact (rrmatch' _ _ _).
+Qed.
+
+Fact lbalS_match l x r :
+ rspec
+  (fun a y b => Rd (Bk a y b) x r)
+  (fun l =>
+    match r with
+    | Bk a y b => rbal' l x (Rd a y b)
+    | Rd (Bk a y b) z c => Rd (Bk l x a) y (rbal' b z (makeRed c))
+    | _ => Rd l x r
+    end)
+  l
+  (lbalS l x r).
+Proof.
+ exact (rmatch _ _ _).
+Qed.
+
+Fact rbalS_match l x r :
+ rspec
+  (fun a y b => Rd l x (Bk a y b))
+  (fun r =>
+    match l with
+    | Bk a y b => lbal (Rd a y b) x r
+    | Rd a y (Bk b z c) => Rd (lbal (makeRed a) y b) z (Bk c x r)
+    | _ => Rd l x r
+    end)
+  r
+  (rbalS l x r).
+Proof.
+ exact (rmatch _ _ _).
+Qed.
+
+(** ** Balancing for insertion *)
+
+Lemma lbal_spec l x r y :
+   InT y (lbal l x r) <-> X.eq y x \/ InT y l \/ InT y r.
+Proof.
+ case lbal_match; intuition_in.
+Qed.
+
+Instance lbal_ok l x r `(Ok l, Ok r, lt_tree x l, gt_tree x r) :
+ Ok (lbal l x r).
+Proof.
+ destruct (lbal_match l x r); ok.
+Qed.
+
+Lemma rbal_spec l x r y :
+   InT y (rbal l x r) <-> X.eq y x \/ InT y l \/ InT y r.
+Proof.
+ case rbal_match; intuition_in.
+Qed.
+
+Instance rbal_ok l x r `(Ok l, Ok r, lt_tree x l, gt_tree x r) :
+ Ok (rbal l x r).
+Proof.
+ destruct (rbal_match l x r); ok.
+Qed.
+
+Lemma rbal'_spec l x r y :
+   InT y (rbal' l x r) <-> X.eq y x \/ InT y l \/ InT y r.
+Proof.
+ case rbal'_match; intuition_in.
+Qed.
+
+Instance rbal'_ok l x r `(Ok l, Ok r, lt_tree x l, gt_tree x r) :
+ Ok (rbal' l x r).
+Proof.
+ destruct (rbal'_match l x r); ok.
+Qed.
+
+Hint Rewrite In_node_iff In_leaf_iff
+ makeRed_spec makeBlack_spec lbal_spec rbal_spec rbal'_spec : rb.
+
+Ltac descolor := destruct_all Color.t.
+Ltac destree t := destruct t as [|[|] ? ? ?].
+Ltac autorew := autorewrite with rb.
+Tactic Notation "autorew" "in" ident(H) := autorewrite with rb in H.
+
+(** ** Insertion *)
+
+Lemma ins_spec : forall s x y,
+ InT y (ins x s) <-> X.eq y x \/ InT y s.
+Proof.
+ induct s x.
+ - intuition_in.
+ - intuition_in. setoid_replace y with x; eauto.
+ - descolor; autorew; rewrite IHl; intuition_in.
+ - descolor; autorew; rewrite IHr; intuition_in.
+Qed.
+Hint Rewrite ins_spec : rb.
+
+Instance ins_ok s x `{Ok s} : Ok (ins x s).
+Proof.
+ induct s x; auto; descolor;
+ (apply lbal_ok || apply rbal_ok || ok); auto;
+ intros y; autorew; intuition; order.
+Qed.
+
+Lemma add_spec' s x y :
+ InT y (add x s) <-> X.eq y x \/ InT y s.
+Proof.
+ unfold add. now autorew.
+Qed.
+
+Hint Rewrite add_spec' : rb.
+
+Lemma add_spec s x y `{Ok s} :
+ InT y (add x s) <-> X.eq y x \/ InT y s.
+Proof.
+ apply add_spec'.
+Qed.
+
+Instance add_ok s x `{Ok s} : Ok (add x s).
+Proof.
+ unfold add; auto_tc.
+Qed.
+
+(** ** Balancing for deletion *)
+
+Lemma lbalS_spec l x r y :
+  InT y (lbalS l x r) <-> X.eq y x \/ InT y l \/ InT y r.
+Proof.
+ case lbalS_match.
+ - intros; autorew; intuition_in.
+ - clear l. intros l _.
+   destruct r as [|[|] rl rx rr].
+   * autorew. intuition_in.
+   * destree rl; autorew; intuition_in.
+   * autorew. intuition_in.
+Qed.
+
+Instance lbalS_ok l x r :
+ forall `(Ok l, Ok r, lt_tree x l, gt_tree x r), Ok (lbalS l x r).
+Proof.
+ case lbalS_match; intros.
+ - ok.
+ - destruct r as [|[|] rl rx rr].
+   * ok.
+   * destruct rl as [|[|] rll rlx rlr]; intros; ok.
+     + apply rbal'_ok; ok.
+       intros w; autorew; auto.
+     + intros w; autorew.
+       destruct 1 as [Hw|[Hw|Hw]]; try rewrite Hw; eauto.
+   * ok. autorew. apply rbal'_ok; ok.
+Qed.
+
+Lemma rbalS_spec l x r y :
+  InT y (rbalS l x r) <-> X.eq y x \/ InT y l \/ InT y r.
+Proof.
+ case rbalS_match.
+ - intros; autorew; intuition_in.
+ - intros t _.
+   destruct l as [|[|] ll lx lr].
+   * autorew. intuition_in.
+   * destruct lr as [|[|] lrl lrx lrr]; autorew; intuition_in.
+   * autorew. intuition_in.
+Qed.
+
+Instance rbalS_ok l x r :
+ forall `(Ok l, Ok r, lt_tree x l, gt_tree x r), Ok (rbalS l x r).
+Proof.
+ case rbalS_match; intros.
+ - ok.
+ - destruct l as [|[|] ll lx lr].
+   * ok.
+   * destruct lr as [|[|] lrl lrx lrr]; intros; ok.
+     + apply lbal_ok; ok.
+       intros w; autorew; auto.
+     + intros w; autorew.
+       destruct 1 as [Hw|[Hw|Hw]]; try rewrite Hw; eauto.
+   * ok. apply lbal_ok; ok.
+Qed.
+
+Hint Rewrite lbalS_spec rbalS_spec : rb.
+
+(** ** Append for deletion *)
+
+Ltac append_tac l r :=
+ induction l as [| lc ll _ lx lr IHlr];
+ [intro r; simpl
+ |induction r as [| rc rl IHrl rx rr _];
+   [simpl
+   |destruct lc, rc;
+     [specialize (IHlr rl); clear IHrl
+     |simpl;
+      assert (Hr:notred (Bk rl rx rr)) by (simpl; trivial);
+      set (r:=Bk rl rx rr) in *; clearbody r; clear IHrl rl rx rr;
+      specialize (IHlr r)
+     |change (append _ _) with (Rd (append (Bk ll lx lr) rl) rx rr);
+      assert (Hl:notred (Bk ll lx lr)) by (simpl; trivial);
+      set (l:=Bk ll lx lr) in *; clearbody l; clear IHlr ll lx lr
+     |specialize (IHlr rl); clear IHrl]]].
+
+Fact append_rr_match ll lx lr rl rx rr :
+ rspec
+  (fun a x b => Rd (Rd ll lx a) x (Rd b rx rr))
+  (fun t => Rd ll lx (Rd t rx rr))
+  (append lr rl)
+  (append (Rd ll lx lr) (Rd rl rx rr)).
+Proof.
+ exact (rmatch _ _ _).
+Qed.
+
+Fact append_bb_match ll lx lr rl rx rr :
+ rspec
+  (fun a x b => Rd (Bk ll lx a) x (Bk b rx rr))
+  (fun t => lbalS ll lx (Bk t rx rr))
+  (append lr rl)
+  (append (Bk ll lx lr) (Bk rl rx rr)).
+Proof.
+ exact (rmatch _ _ _).
+Qed.
+
+Lemma append_spec l r x :
+ InT x (append l r) <-> InT x l \/ InT x r.
+Proof.
+ revert r.
+ append_tac l r; autorew; try tauto.
+ - (* Red / Red *)
+   revert IHlr; case append_rr_match;
+    [intros a y b | intros t Ht]; autorew; tauto.
+ - (* Black / Black *)
+   revert IHlr; case append_bb_match;
+    [intros a y b | intros t Ht]; autorew; tauto.
+Qed.
+
+Hint Rewrite append_spec : rb.
+
+Lemma append_ok : forall x l r `{Ok l, Ok r},
+ lt_tree x l -> gt_tree x r -> Ok (append l r).
+Proof.
+ append_tac l r.
+ - (* Leaf / _ *)
+   trivial.
+ - (* _ / Leaf *)
+   trivial.
+ - (* Red / Red *)
+   intros; inv.
+   assert (IH : Ok (append lr rl)) by (apply IHlr; eauto). clear IHlr.
+   assert (X.lt lx rx) by (transitivity x; eauto).
+   assert (G : gt_tree lx (append lr rl)).
+    { intros w. autorew. destruct 1; [|transitivity x]; eauto. }
+   assert (L : lt_tree rx (append lr rl)).
+    { intros w. autorew. destruct 1; [transitivity x|]; eauto. }
+   revert IH G L; case append_rr_match; intros; ok.
+ - (* Red / Black *)
+   intros; ok.
+   intros w; autorew; destruct 1; eauto.
+ - (* Black / Red *)
+   intros; ok.
+   intros w; autorew; destruct 1; eauto.
+ - (* Black / Black *)
+   intros; inv.
+   assert (IH : Ok (append lr rl)) by (apply IHlr; eauto). clear IHlr.
+   assert (X.lt lx rx) by (transitivity x; eauto).
+   assert (G : gt_tree lx (append lr rl)).
+    { intros w. autorew. destruct 1; [|transitivity x]; eauto. }
+   assert (L : lt_tree rx (append lr rl)).
+    { intros w. autorew. destruct 1; [transitivity x|]; eauto. }
+   revert IH G L; case append_bb_match; intros; ok.
+    apply lbalS_ok; ok.
+Qed.
+
+(** ** Deletion *)
+
+Lemma del_spec : forall s x y `{Ok s},
+ InT y (del x s) <-> InT y s /\ ~X.eq y x.
+Proof.
+induct s x.
+- intuition_in.
+- autorew; intuition_in.
+  assert (X.lt y x') by eauto. order.
+  assert (X.lt x' y) by eauto. order.
+  order.
+- destruct l as [|[|] ll lx lr]; autorew;
+  rewrite ?IHl by trivial; intuition_in; order.
+- destruct r as [|[|] rl rx rr]; autorew;
+  rewrite ?IHr by trivial; intuition_in; order.
+Qed.
+
+Hint Rewrite del_spec : rb.
+
+Instance del_ok s x `{Ok s} : Ok (del x s).
+Proof.
+induct s x.
+- trivial.
+- eapply append_ok; eauto.
+- assert (lt_tree x' (del x l)).
+  { intro w. autorew; trivial. destruct 1. eauto. }
+  destruct l as [|[|] ll lx lr]; auto_tc.
+- assert (gt_tree x' (del x r)).
+  { intro w. autorew; trivial. destruct 1. eauto. }
+  destruct r as [|[|] rl rx rr]; auto_tc.
+Qed.
+
+Lemma remove_spec s x y `{Ok s} :
+ InT y (remove x s) <-> InT y s /\ ~X.eq y x.
+Proof.
+unfold remove. now autorew.
+Qed.
+
+Hint Rewrite remove_spec : rb.
+
+Instance remove_ok s x `{Ok s} : Ok (remove x s).
+Proof.
+unfold remove; auto_tc.
+Qed.
+
+(** ** Removing the minimal element *)
+
+Lemma delmin_spec l y r c x s' `{O : Ok (Node c l y r)} :
+ delmin l y r = (x,s') ->
+  min_elt (Node c l y r) = Some x /\ del x (Node c l y r) = s'.
+Proof.
+ revert y r c x s' O.
+ induction l as [|lc ll IH ly lr _].
+ - simpl. intros y r _ x s' _. injection 1; intros; subst.
+   now rewrite MX.compare_refl.
+ - intros y r c x s' O.
+   simpl delmin.
+   specialize (IH ly lr). destruct delmin as (x0,s0).
+   destruct (IH lc x0 s0); clear IH; [ok|trivial|].
+   remember (Node lc ll ly lr) as l.
+   simpl min_elt in *.
+   intros E.
+   replace x0 with x in * by (destruct lc; now injection E).
+   split.
+   * subst l; intuition.
+   * assert (X.lt x y).
+     { inversion_clear O.
+       assert (InT x l) by now apply min_elt_spec1. auto. }
+     simpl. case X.compare_spec; try order.
+     destruct lc; injection E; clear E; intros; subst l s0; auto.
+Qed.
+
+Lemma remove_min_spec1 s x s' `{Ok s}:
+ remove_min s = Some (x,s') ->
+  min_elt s = Some x /\ remove x s = s'.
+Proof.
+ unfold remove_min.
+ destruct s as [|c l y r]; try easy.
+ generalize (delmin_spec l y r c).
+ destruct delmin as (x0,s0). intros D.
+ destruct (D x0 s0) as (->,<-); auto.
+ fold (remove x0 (Node c l y r)).
+ inversion_clear 1; auto.
+Qed.
+
+Lemma remove_min_spec2 s : remove_min s = None -> Empty s.
+Proof.
+ unfold remove_min.
+ destruct s as [|c l y r].
+ - easy.
+ - now destruct delmin.
+Qed.
+
+Lemma remove_min_ok (s:t) `{Ok s}:
+ match remove_min s with
+ | Some (_,s') => Ok s'
+ | None => True
+ end.
+Proof.
+ generalize (remove_min_spec1 s).
+ destruct remove_min as [(x0,s0)|]; auto.
+ intros R. destruct (R x0 s0); auto. subst s0. auto_tc.
+Qed.
+
+(** ** Treeify *)
+
+Notation ifpred p n := (if p then pred n else n%nat).
+
+Definition treeify_invariant size (f:treeify_t) :=
+ forall acc,
+ size <= length acc ->
+ let (t,acc') := f acc in
+ cardinal t = size /\ acc = elements t ++ acc'.
+
+Lemma treeify_zero_spec : treeify_invariant 0 treeify_zero.
+Proof.
+ intro. simpl. auto.
+Qed.
+
+Lemma treeify_one_spec : treeify_invariant 1 treeify_one.
+Proof.
+ intros [|x acc]; simpl; auto; inversion 1.
+Qed.
+
+Lemma treeify_cont_spec f g size1 size2 size :
+ treeify_invariant size1 f ->
+ treeify_invariant size2 g ->
+ size = S (size1 + size2) ->
+ treeify_invariant size (treeify_cont f g).
+Proof.
+ intros Hf Hg EQ acc LE. unfold treeify_cont.
+ specialize (Hf acc).
+ destruct (f acc) as (t1,acc1).
+ destruct Hf as (Hf1,Hf2).
+  { transitivity size; trivial. subst. auto with arith. }
+ destruct acc1 as [|x acc1].
+  { exfalso. revert LE. apply Nat.lt_nge. subst.
+    rewrite <- app_nil_end, <- elements_cardinal; auto with arith. }
+ specialize (Hg acc1).
+ destruct (g acc1) as (t2,acc2).
+ destruct Hg as (Hg1,Hg2).
+  { revert LE. subst.
+    rewrite app_length, <- elements_cardinal. simpl.
+    rewrite Nat.add_succ_r, <- Nat.succ_le_mono.
+    apply Nat.add_le_mono_l. }
+ simpl. rewrite elements_node, app_ass. now subst.
+Qed.
+
+Lemma treeify_aux_spec n (p:bool) :
+ treeify_invariant (ifpred p (Pos.to_nat n)) (treeify_aux p n).
+Proof.
+ revert p.
+ induction n as [n|n|]; intros p; simpl treeify_aux.
+ - eapply treeify_cont_spec; [ apply (IHn false) | apply (IHn p) | ].
+   rewrite Pos2Nat.inj_xI.
+   assert (H := Pos2Nat.is_pos n). apply Nat.neq_0_lt_0 in H.
+   destruct p; simpl; intros; rewrite Nat.add_0_r; trivial.
+   now rewrite <- Nat.add_succ_r, Nat.succ_pred; trivial.
+ - eapply treeify_cont_spec; [ apply (IHn p) | apply (IHn true) | ].
+   rewrite Pos2Nat.inj_xO.
+   assert (H := Pos2Nat.is_pos n). apply Nat.neq_0_lt_0 in H.
+   rewrite <- Nat.add_succ_r, Nat.succ_pred by trivial.
+   destruct p; simpl; intros; rewrite Nat.add_0_r; trivial.
+   symmetry. now apply Nat.add_pred_l.
+ - destruct p; [ apply treeify_zero_spec | apply treeify_one_spec ].
+Qed.
+
+Lemma plength_aux_spec l p :
+  Pos.to_nat (plength_aux l p) = length l + Pos.to_nat p.
+Proof.
+ revert p. induction l; simpl; trivial.
+ intros. now rewrite IHl, Pos2Nat.inj_succ, Nat.add_succ_r.
+Qed.
+
+Lemma plength_spec l : Pos.to_nat (plength l) = S (length l).
+Proof.
+ unfold plength. rewrite plength_aux_spec. apply Nat.add_1_r.
+Qed.
+
+Lemma treeify_elements l : elements (treeify l) = l.
+Proof.
+ assert (H := treeify_aux_spec (plength l) true l).
+ unfold treeify. destruct treeify_aux as (t,acc); simpl in *.
+ destruct H as (H,H'). { now rewrite plength_spec. }
+ subst l. rewrite plength_spec, app_length, <- elements_cardinal in *.
+ destruct acc.
+ * now rewrite app_nil_r.
+ * exfalso. revert H. simpl.
+   rewrite Nat.add_succ_r, Nat.add_comm.
+   apply Nat.succ_add_discr.
+Qed.
+
+Lemma treeify_spec x l : InT x (treeify l) <-> InA X.eq x l.
+Proof.
+ intros. now rewrite <- elements_spec1, treeify_elements.
+Qed.
+
+Lemma treeify_ok l : sort X.lt l -> Ok (treeify l).
+Proof.
+ intros. apply elements_sort_ok. rewrite treeify_elements; auto.
+Qed.
+
+
+(** ** Filter *)
+
+Lemma filter_app A f (l l':list A) :
+ List.filter f (l ++ l') = List.filter f l ++ List.filter f l'.
+Proof.
+ induction l as [|x l IH]; simpl; trivial.
+ destruct (f x); simpl; now rewrite IH.
+Qed.
+
+Lemma filter_aux_elements s f acc :
+ filter_aux f s acc = List.filter f (elements s) ++ acc.
+Proof.
+ revert acc.
+ induction s as [|c l IHl x r IHr]; simpl; trivial.
+ intros acc.
+ rewrite elements_node, filter_app. simpl.
+ destruct (f x); now rewrite IHl, IHr, app_ass.
+Qed.
+
+Lemma filter_elements s f :
+ elements (filter f s) = List.filter f (elements s).
+Proof.
+ unfold filter.
+ now rewrite treeify_elements, filter_aux_elements, app_nil_r.
+Qed.
+
+Lemma filter_spec s x f :
+ Proper (X.eq==>Logic.eq) f ->
+ (InT x (filter f s) <-> InT x s /\ f x = true).
+Proof.
+ intros Hf.
+ rewrite <- elements_spec1, filter_elements, filter_InA, elements_spec1;
+  now auto_tc.
+Qed.
+
+Instance filter_ok s f `(Ok s) : Ok (filter f s).
+Proof.
+ apply elements_sort_ok.
+ rewrite filter_elements.
+ apply filter_sort with X.eq; auto_tc.
+Qed.
+
+(** ** Partition *)
+
+Lemma partition_aux_spec s f acc1 acc2 :
+ partition_aux f s acc1 acc2 =
+  (filter_aux f s acc1, filter_aux (fun x => negb (f x)) s acc2).
+Proof.
+ revert acc1 acc2.
+ induction s as [ | c l Hl x r Hr ]; simpl.
+ - trivial.
+ - intros acc1 acc2.
+   destruct (f x); simpl; now rewrite Hr, Hl.
+Qed.
+
+Lemma partition_spec s f :
+ partition f s = (filter f s, filter (fun x => negb (f x)) s).
+Proof.
+ unfold partition, filter. now rewrite partition_aux_spec.
+Qed.
+
+Lemma partition_spec1 s f :
+ Proper (X.eq==>Logic.eq) f ->
+ Equal (fst (partition f s)) (filter f s).
+Proof. now rewrite partition_spec. Qed.
+
+Lemma partition_spec2 s f :
+ Proper (X.eq==>Logic.eq) f ->
+ Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
+Proof. now rewrite partition_spec. Qed.
+
+Instance partition_ok1 s f `(Ok s) : Ok (fst (partition f s)).
+Proof. rewrite partition_spec; now apply filter_ok. Qed.
+
+Instance partition_ok2 s f `(Ok s) : Ok (snd (partition f s)).
+Proof. rewrite partition_spec; now apply filter_ok. Qed.
+
+
+(** ** An invariant for binary list functions with accumulator. *)
+
+Ltac inA :=
+ rewrite ?InA_app_iff, ?InA_cons, ?InA_nil, ?InA_rev in *; auto_tc.
+
+Record INV l1 l2 acc : Prop := {
+ l1_sorted : sort X.lt (rev l1);
+ l2_sorted : sort X.lt (rev l2);
+ acc_sorted : sort X.lt acc;
+ l1_lt_acc x y : InA X.eq x l1 -> InA X.eq y acc -> X.lt x y;
+ l2_lt_acc x y : InA X.eq x l2 -> InA X.eq y acc -> X.lt x y}.
+Local Hint Resolve l1_sorted l2_sorted acc_sorted.
+
+Lemma INV_init s1 s2 `(Ok s1, Ok s2) :
+ INV (rev_elements s1) (rev_elements s2) nil.
+Proof.
+ rewrite !rev_elements_rev.
+ split; rewrite ?rev_involutive; auto; intros; now inA.
+Qed.
+
+Lemma INV_sym l1 l2 acc : INV l1 l2 acc -> INV l2 l1 acc.
+Proof.
+ destruct 1; now split.
+Qed.
+
+Lemma INV_drop x1 l1 l2 acc :
+  INV (x1 :: l1) l2 acc -> INV l1 l2 acc.
+Proof.
+ intros (l1s,l2s,accs,l1a,l2a). simpl in *.
+ destruct (sorted_app_inv _ _ l1s) as (U & V & W); auto.
+ split; auto.
+Qed.
+
+Lemma INV_eq x1 x2 l1 l2 acc :
+  INV (x1 :: l1) (x2 :: l2) acc -> X.eq x1 x2 ->
+  INV l1 l2 (x1 :: acc).
+Proof.
+ intros (U,V,W,X,Y) EQ. simpl in *.
+ destruct (sorted_app_inv _ _ U) as (U1 & U2 & U3); auto.
+ destruct (sorted_app_inv _ _ V) as (V1 & V2 & V3); auto.
+ split; auto.
+ - constructor; auto. apply InA_InfA with X.eq; auto_tc.
+ - intros x y; inA; intros Hx [Hy|Hy].
+   + apply U3; inA.
+   + apply X; inA.
+ - intros x y; inA; intros Hx [Hy|Hy].
+   + rewrite Hy, EQ; apply V3; inA.
+   + apply Y; inA.
+Qed.
+
+Lemma INV_lt x1 x2 l1 l2 acc :
+  INV (x1 :: l1) (x2 :: l2) acc -> X.lt x1 x2 ->
+  INV (x1 :: l1) l2 (x2 :: acc).
+Proof.
+ intros (U,V,W,X,Y) EQ. simpl in *.
+ destruct (sorted_app_inv _ _ U) as (U1 & U2 & U3); auto.
+ destruct (sorted_app_inv _ _ V) as (V1 & V2 & V3); auto.
+ split; auto.
+ - constructor; auto. apply InA_InfA with X.eq; auto_tc.
+ - intros x y; inA; intros Hx [Hy|Hy].
+   + rewrite Hy; clear Hy. destruct Hx; [order|].
+     transitivity x1; auto. apply U3; inA.
+   + apply X; inA.
+ - intros x y; inA; intros Hx [Hy|Hy].
+   + rewrite Hy. apply V3; inA.
+   + apply Y; inA.
+Qed.
+
+Lemma INV_rev l1 l2 acc :
+ INV l1 l2 acc -> Sorted X.lt (rev_append l1 acc).
+Proof.
+ intros. rewrite rev_append_rev.
+ apply SortA_app with X.eq; eauto with *.
+ intros x y. inA. eapply l1_lt_acc; eauto.
+Qed.
+
+(** ** union *)
+
+Lemma union_list_ok l1 l2 acc :
+ INV l1 l2 acc -> sort X.lt (union_list l1 l2 acc).
+Proof.
+ revert l2 acc.
+ induction l1 as [|x1 l1 IH1];
+  [intro l2|induction l2 as [|x2 l2 IH2]];
+   intros acc inv.
+ - eapply INV_rev, INV_sym; eauto.
+ - eapply INV_rev; eauto.
+ - simpl. case X.compare_spec; intro C.
+   * apply IH1. eapply INV_eq; eauto.
+   * apply (IH2 (x2::acc)). eapply INV_lt; eauto.
+   * apply IH1. eapply INV_sym, INV_lt; eauto. now apply INV_sym.
+Qed.
+
+Instance linear_union_ok s1 s2 `(Ok s1, Ok s2) :
+ Ok (linear_union s1 s2).
+Proof.
+ unfold linear_union. now apply treeify_ok, union_list_ok, INV_init.
+Qed.
+
+Instance fold_add_ok s1 s2 `(Ok s1, Ok s2) :
+ Ok (fold add s1 s2).
+Proof.
+ rewrite fold_spec, <- fold_left_rev_right.
+ unfold elt in *.
+ induction (rev (elements s1)); simpl; unfold flip in *; auto_tc.
+Qed.
+
+Instance union_ok s1 s2 `(Ok s1, Ok s2) : Ok (union s1 s2).
+Proof.
+ unfold union. destruct compare_height; auto_tc.
+Qed.
+
+Lemma union_list_spec x l1 l2 acc :
+ InA X.eq x (union_list l1 l2 acc) <->
+  InA X.eq x l1 \/ InA X.eq x l2 \/ InA X.eq x acc.
+Proof.
+ revert l2 acc.
+ induction l1 as [|x1 l1 IH1].
+ - intros l2 acc; simpl. rewrite rev_append_rev. inA. tauto.
+ - induction l2 as [|x2 l2 IH2]; intros acc; simpl.
+   * rewrite rev_append_rev. inA. tauto.
+   * case X.compare_spec; intro C.
+     + rewrite IH1, !InA_cons, C; tauto.
+     + rewrite (IH2 (x2::acc)), !InA_cons. tauto.
+     + rewrite IH1, !InA_cons; tauto.
+Qed.
+
+Lemma linear_union_spec s1 s2 x :
+ InT x (linear_union s1 s2) <-> InT x s1 \/ InT x s2.
+Proof.
+ unfold linear_union.
+ rewrite treeify_spec, union_list_spec, !rev_elements_rev.
+ rewrite !InA_rev, InA_nil, !elements_spec1 by auto_tc.
+ tauto.
+Qed.
+
+Lemma fold_add_spec s1 s2 x :
+ InT x (fold add s1 s2) <-> InT x s1 \/ InT x s2.
+Proof.
+ rewrite fold_spec, <- fold_left_rev_right.
+ rewrite <- (elements_spec1 s1), <- InA_rev by auto_tc.
+ unfold elt in *.
+ induction (rev (elements s1)); simpl.
+ - rewrite InA_nil. tauto.
+ - unfold flip. rewrite add_spec', IHl, InA_cons. tauto.
+Qed.
+
+Lemma union_spec' s1 s2 x :
+ InT x (union s1 s2) <-> InT x s1 \/ InT x s2.
+Proof.
+ unfold union. destruct compare_height.
+ - apply linear_union_spec.
+ - apply fold_add_spec.
+ - rewrite fold_add_spec. tauto.
+Qed.
+
+Lemma union_spec : forall s1 s2 y `{Ok s1, Ok s2},
+ (InT y (union s1 s2) <-> InT y s1 \/ InT y s2).
+Proof.
+ intros; apply union_spec'.
+Qed.
+
+(** ** inter *)
+
+Lemma inter_list_ok l1 l2 acc :
+ INV l1 l2 acc -> sort X.lt (inter_list l1 l2 acc).
+Proof.
+ revert l2 acc.
+ induction l1 as [|x1 l1 IH1]; [|induction l2 as [|x2 l2 IH2]]; simpl.
+ - eauto.
+ - eauto.
+ - intros acc inv.
+   case X.compare_spec; intro C.
+   * apply IH1. eapply INV_eq; eauto.
+   * apply (IH2 acc). eapply INV_sym, INV_drop, INV_sym; eauto.
+   * apply IH1. eapply INV_drop; eauto.
+Qed.
+
+Instance linear_inter_ok s1 s2 `(Ok s1, Ok s2) :
+ Ok (linear_inter s1 s2).
+Proof.
+ unfold linear_inter. now apply treeify_ok, inter_list_ok, INV_init.
+Qed.
+
+Instance inter_ok s1 s2 `(Ok s1, Ok s2) : Ok (inter s1 s2).
+Proof.
+ unfold inter. destruct compare_height; auto_tc.
+Qed.
+
+Lemma inter_list_spec x l1 l2 acc :
+ sort X.lt (rev l1) ->
+ sort X.lt (rev l2) ->
+ (InA X.eq x (inter_list l1 l2 acc) <->
+   (InA X.eq x l1 /\ InA X.eq x l2) \/ InA X.eq x acc).
+Proof.
+ revert l2 acc.
+ induction l1 as [|x1 l1 IH1].
+ - intros l2 acc; simpl. inA. tauto.
+ - induction l2 as [|x2 l2 IH2]; intros acc.
+   * simpl. inA. tauto.
+   * simpl. intros U V.
+     destruct (sorted_app_inv _ _ U) as (U1 & U2 & U3); auto.
+     destruct (sorted_app_inv _ _ V) as (V1 & V2 & V3); auto.
+     case X.compare_spec; intro C.
+     + rewrite IH1, !InA_cons, C; tauto.
+     + rewrite (IH2 acc); auto. inA. intuition; try order.
+       assert (X.lt x x1) by (apply U3; inA). order.
+     + rewrite IH1; auto. inA. intuition; try order.
+       assert (X.lt x x2) by (apply V3; inA). order.
+Qed.
+
+Lemma linear_inter_spec s1 s2 x `(Ok s1, Ok s2) :
+ InT x (linear_inter s1 s2) <-> InT x s1 /\ InT x s2.
+Proof.
+ unfold linear_inter.
+ rewrite !rev_elements_rev, treeify_spec, inter_list_spec
+  by (rewrite rev_involutive; auto_tc).
+ rewrite !InA_rev, InA_nil, !elements_spec1 by auto_tc. tauto.
+Qed.
+
+Local Instance mem_proper s `(Ok s) :
+ Proper (X.eq ==> Logic.eq) (fun k => mem k s).
+Proof.
+ intros x y EQ. apply Bool.eq_iff_eq_true; rewrite !mem_spec; auto.
+ now rewrite EQ.
+Qed.
+
+Lemma inter_spec s1 s2 y `{Ok s1, Ok s2} :
+ InT y (inter s1 s2) <-> InT y s1 /\ InT y s2.
+Proof.
+ unfold inter. destruct compare_height.
+ - now apply linear_inter_spec.
+ - rewrite filter_spec, mem_spec by auto_tc; tauto.
+ - rewrite filter_spec, mem_spec by auto_tc; tauto.
+Qed.
+
+(** ** difference *)
+
+Lemma diff_list_ok l1 l2 acc :
+ INV l1 l2 acc -> sort X.lt (diff_list l1 l2 acc).
+Proof.
+ revert l2 acc.
+ induction l1 as [|x1 l1 IH1];
+  [intro l2|induction l2 as [|x2 l2 IH2]];
+    intros acc inv.
+ - eauto.
+ - unfold diff_list. eapply INV_rev; eauto.
+ - simpl. case X.compare_spec; intro C.
+   * apply IH1. eapply INV_drop, INV_sym, INV_drop, INV_sym; eauto.
+   * apply (IH2 acc). eapply INV_sym, INV_drop, INV_sym; eauto.
+   * apply IH1. eapply INV_sym, INV_lt; eauto. now apply INV_sym.
+Qed.
+
+Instance diff_inter_ok s1 s2 `(Ok s1, Ok s2) :
+ Ok (linear_diff s1 s2).
+Proof.
+ unfold linear_inter. now apply treeify_ok, diff_list_ok, INV_init.
+Qed.
+
+Instance fold_remove_ok s1 s2 `(Ok s2) :
+ Ok (fold remove s1 s2).
+Proof.
+ rewrite fold_spec, <- fold_left_rev_right.
+ unfold elt in *.
+ induction (rev (elements s1)); simpl; unfold flip in *; auto_tc.
+Qed.
+
+Instance diff_ok s1 s2 `(Ok s1, Ok s2) : Ok (diff s1 s2).
+Proof.
+ unfold diff. destruct compare_height; auto_tc.
+Qed.
+
+Lemma diff_list_spec x l1 l2 acc :
+ sort X.lt (rev l1) ->
+ sort X.lt (rev l2) ->
+ (InA X.eq x (diff_list l1 l2 acc) <->
+   (InA X.eq x l1 /\ ~InA X.eq x l2) \/ InA X.eq x acc).
+Proof.
+ revert l2 acc.
+ induction l1 as [|x1 l1 IH1].
+ - intros l2 acc; simpl. inA. tauto.
+ - induction l2 as [|x2 l2 IH2]; intros acc.
+   * intros; simpl. rewrite rev_append_rev. inA. tauto.
+   * simpl. intros U V.
+     destruct (sorted_app_inv _ _ U) as (U1 & U2 & U3); auto.
+     destruct (sorted_app_inv _ _ V) as (V1 & V2 & V3); auto.
+     case X.compare_spec; intro C.
+     + rewrite IH1; auto. f_equiv. inA. intuition; try order.
+       assert (X.lt x x1) by (apply U3; inA). order.
+     + rewrite (IH2 acc); auto. f_equiv. inA. intuition; try order.
+       assert (X.lt x x1) by (apply U3; inA). order.
+     + rewrite IH1; auto. inA. intuition; try order.
+       left; split; auto. destruct 1. order.
+       assert (X.lt x x2) by (apply V3; inA). order.
+Qed.
+
+Lemma linear_diff_spec s1 s2 x `(Ok s1, Ok s2) :
+ InT x (linear_diff s1 s2) <-> InT x s1 /\ ~InT x s2.
+Proof.
+ unfold linear_diff.
+ rewrite !rev_elements_rev, treeify_spec, diff_list_spec
+  by (rewrite rev_involutive; auto_tc).
+ rewrite !InA_rev, InA_nil, !elements_spec1 by auto_tc. tauto.
+Qed.
+
+Lemma fold_remove_spec s1 s2 x `(Ok s2) :
+  InT x (fold remove s1 s2) <-> InT x s2 /\ ~InT x s1.
+Proof.
+ rewrite fold_spec, <- fold_left_rev_right.
+ rewrite <- (elements_spec1 s1), <- InA_rev by auto_tc.
+ unfold elt in *.
+ induction (rev (elements s1)); simpl; intros.
+ - rewrite InA_nil. intuition.
+ - unfold flip in *. rewrite remove_spec, IHl, InA_cons. tauto.
+   clear IHl. induction l; simpl; auto_tc.
+Qed.
+
+Lemma diff_spec s1 s2 y `{Ok s1, Ok s2} :
+ InT y (diff s1 s2) <-> InT y s1 /\ ~InT y s2.
+Proof.
+ unfold diff. destruct compare_height.
+ - now apply linear_diff_spec.
+ - rewrite filter_spec, Bool.negb_true_iff,
+     <- Bool.not_true_iff_false, mem_spec;
+    intuition.
+    intros x1 x2 EQ. f_equal. now apply mem_proper.
+ - now apply fold_remove_spec.
+Qed.
+
+End MakeRaw.
+
+(** * Balancing properties
+
+    We now prove that all operations preserve a red-black invariant,
+    and that trees have hence a logarithmic depth.
+*)
+
+Module BalanceProps(X:Orders.OrderedType)(Import M : MakeRaw X).
+
+Local Notation Rd := (Node Red).
+Local Notation Bk := (Node Black).
+Import M.MX.
+
+(** ** Red-Black invariants *)
+
+(** In a red-black tree :
+    - a red node has no red children
+    - the black depth at each node is the same along all paths.
+    The black depth is here an argument of the predicate. *)
+
+Inductive rbt : nat -> tree -> Prop :=
+ | RB_Leaf : rbt 0 Leaf
+ | RB_Rd n l k r :
+   notred l -> notred r -> rbt n l -> rbt n r -> rbt n (Rd l k r)
+ | RB_Bk n l k r : rbt n l -> rbt n r -> rbt (S n) (Bk l k r).
+
+(** A red-red tree is almost a red-black tree, except that it has
+    a _red_ root node which _may_ have red children. Note that a
+    red-red tree is hence non-empty, and all its strict subtrees
+    are red-black. *)
+
+Inductive rrt (n:nat) : tree -> Prop :=
+ | RR_Rd l k r : rbt n l -> rbt n r -> rrt n (Rd l k r).
+
+(** An almost-red-black tree is almost a red-black tree, except that
+    it's permitted to have two red nodes in a row at the very root (only).
+    We implement this notion by saying that a quasi-red-black tree
+    is either a red-black tree or a red-red tree. *)
+
+Inductive arbt (n:nat)(t:tree) : Prop :=
+ | ARB_RB : rbt n t -> arbt n t
+ | ARB_RR : rrt n t -> arbt n t.
+
+(** The main exported invariant : being a red-black tree for some
+    black depth. *)
+
+Class Rbt (t:tree) :=  RBT : exists d, rbt d t.
+
+(** ** Basic tactics and results about red-black *)
+
+Scheme rbt_ind := Induction for rbt Sort Prop.
+Local Hint Constructors rbt rrt arbt.
+Local Hint Extern 0 (notred _) => (exact I).
+Ltac invrb := intros; invtree rrt; invtree rbt; try contradiction.
+Ltac desarb := match goal with H:arbt _ _ |- _ => destruct H end.
+Ltac nonzero n := destruct n as [|n]; [try split; invrb|].
+
+Lemma rr_nrr_rb n t :
+ rrt n t -> notredred t -> rbt n t.
+Proof.
+ destruct 1 as [l x r Hl Hr].
+ destruct l, r; descolor; invrb; auto.
+Qed.
+
+Local Hint Resolve rr_nrr_rb.
+
+Lemma arb_nrr_rb n t :
+ arbt n t -> notredred t -> rbt n t.
+Proof.
+ destruct 1; auto.
+Qed.
+
+Lemma arb_nr_rb n t :
+ arbt n t -> notred t -> rbt n t.
+Proof.
+ destruct 1; destruct t; descolor; invrb; auto.
+Qed.
+
+Local Hint Resolve arb_nrr_rb arb_nr_rb.
+
+(** ** A Red-Black tree has indeed a logarithmic depth *)
+
+Definition redcarac s := rcase (fun _ _ _ => 1) (fun _ => 0) s.
+
+Lemma rb_maxdepth s n : rbt n s -> maxdepth s <= 2*n + redcarac s.
+Proof.
+ induction 1.
+ - simpl; auto.
+ - replace (redcarac l) with 0 in * by now destree l.
+   replace (redcarac r) with 0 in * by now destree r.
+   simpl maxdepth. simpl redcarac.
+   rewrite Nat.add_succ_r, <- Nat.succ_le_mono.
+   now apply Nat.max_lub.
+ - simpl. rewrite <- Nat.succ_le_mono.
+   apply Nat.max_lub; eapply Nat.le_trans; eauto;
+   [destree l | destree r]; simpl;
+   rewrite !Nat.add_0_r, ?Nat.add_1_r; auto with arith.
+Qed.
+
+Lemma rb_mindepth s n : rbt n s -> n + redcarac s <= mindepth s.
+Proof.
+ induction 1; simpl.
+ - trivial.
+ - rewrite Nat.add_succ_r.
+   apply -> Nat.succ_le_mono.
+   replace (redcarac l) with 0 in * by now destree l.
+   replace (redcarac r) with 0 in * by now destree r.
+   now apply Nat.min_glb.
+ - apply -> Nat.succ_le_mono. rewrite Nat.add_0_r.
+   apply Nat.min_glb; eauto with arith.
+Qed.
+
+Lemma maxdepth_upperbound s : Rbt s ->
+ maxdepth s <= 2 * log2 (S (cardinal s)).
+Proof.
+ intros (n,H).
+ eapply Nat.le_trans; [eapply rb_maxdepth; eauto|].
+ transitivity (2*(n+redcarac s)).
+ - rewrite Nat.mul_add_distr_l. apply Nat.add_le_mono_l.
+   rewrite <- Nat.mul_1_l at 1. apply Nat.mul_le_mono_r.
+   auto with arith.
+ - apply Nat.mul_le_mono_l.
+   transitivity (mindepth s).
+   + now apply rb_mindepth.
+   + apply mindepth_log_cardinal.
+Qed.
+
+Lemma maxdepth_lowerbound s : s<>Leaf ->
+ log2 (cardinal s) < maxdepth s.
+Proof.
+ apply maxdepth_log_cardinal.
+Qed.
+
+
+(** ** Singleton *)
+
+Lemma singleton_rb x : Rbt (singleton x).
+Proof.
+ unfold singleton. exists 1; auto.
+Qed.
+
+(** ** [makeBlack] and [makeRed] *)
+
+Lemma makeBlack_rb n t : arbt n t -> Rbt (makeBlack t).
+Proof.
+ destruct t as [|[|] l x r].
+ - exists 0; auto.
+ - destruct 1; invrb; exists (S n); simpl; auto.
+ - exists n; auto.
+Qed.
+
+Lemma makeRed_rr t n :
+ rbt (S n) t -> notred t -> rrt n (makeRed t).
+Proof.
+ destruct t as [|[|] l x r]; invrb; simpl; auto.
+Qed.
+
+(** ** Balancing *)
+
+Lemma lbal_rb n l k r :
+ arbt n l -> rbt n r -> rbt (S n) (lbal l k r).
+Proof.
+case lbal_match; intros; desarb; invrb; auto.
+Qed.
+
+Lemma rbal_rb n l k r :
+ rbt n l -> arbt n r -> rbt (S n) (rbal l k r).
+Proof.
+case rbal_match; intros; desarb; invrb; auto.
+Qed.
+
+Lemma rbal'_rb n l k r :
+ rbt n l -> arbt n r -> rbt (S n) (rbal' l k r).
+Proof.
+case rbal'_match; intros; desarb; invrb; auto.
+Qed.
+
+Lemma lbalS_rb n l x r :
+ arbt n l -> rbt (S n) r -> notred r -> rbt (S n) (lbalS l x r).
+Proof.
+ intros Hl Hr Hr'.
+ destruct r as [|[|] rl rx rr]; invrb. clear Hr'.
+ revert Hl.
+ case lbalS_match.
+ - destruct 1; invrb; auto.
+ - intros. apply rbal'_rb; auto.
+Qed.
+
+Lemma lbalS_arb n l x r :
+ arbt n l -> rbt (S n) r -> arbt (S n) (lbalS l x r).
+Proof.
+ case lbalS_match.
+ - destruct 1; invrb; auto.
+ - clear l. intros l Hl Hl' Hr.
+   destruct r as [|[|] rl rx rr]; invrb.
+   * destruct rl as [|[|] rll rlx rlr]; invrb.
+     right; auto using rbal'_rb, makeRed_rr.
+   * left; apply rbal'_rb; auto.
+Qed.
+
+Lemma rbalS_rb n l x r :
+ rbt (S n) l -> notred l -> arbt n r -> rbt (S n) (rbalS l x r).
+Proof.
+ intros Hl Hl' Hr.
+ destruct l as [|[|] ll lx lr]; invrb. clear Hl'.
+ revert Hr.
+ case rbalS_match.
+ - destruct 1; invrb; auto.
+ - intros. apply lbal_rb; auto.
+Qed.
+
+Lemma rbalS_arb n l x r :
+ rbt (S n) l -> arbt n r -> arbt (S n) (rbalS l x r).
+Proof.
+ case rbalS_match.
+ - destruct 2; invrb; auto.
+ - clear r. intros r Hr Hr' Hl.
+   destruct l as [|[|] ll lx lr]; invrb.
+   * destruct lr as [|[|] lrl lrx lrr]; invrb.
+     right; auto using lbal_rb, makeRed_rr.
+   * left; apply lbal_rb; auto.
+Qed.
+
+
+(** ** Insertion *)
+
+(** The next lemmas combine simultaneous results about rbt and arbt.
+    A first solution here: statement with [if ... then ... else] *)
+
+Definition ifred s (A B:Prop) := rcase (fun _ _ _ => A) (fun _ => B) s.
+
+Lemma ifred_notred s A B : notred s -> (ifred s A B <-> B).
+Proof.
+ destruct s; descolor; simpl; intuition.
+Qed.
+
+Lemma ifred_or s A B : ifred s A B -> A\/B.
+Proof.
+ destruct s; descolor; simpl; intuition.
+Qed.
+
+Lemma ins_rr_rb x s n : rbt n s ->
+ ifred s (rrt n (ins x s)) (rbt n (ins x s)).
+Proof.
+induction 1 as [ | n l k r | n l k r Hl IHl Hr IHr ].
+- simpl; auto.
+- simpl. rewrite ifred_notred in * by trivial.
+  elim_compare x k; auto.
+- rewrite ifred_notred by trivial.
+  unfold ins; fold ins. (* simpl is too much here ... *)
+  elim_compare x k.
+  * auto.
+  * apply lbal_rb; trivial. apply ifred_or in IHl; intuition.
+  * apply rbal_rb; trivial. apply ifred_or in IHr; intuition.
+Qed.
+
+Lemma ins_arb x s n : rbt n s -> arbt n (ins x s).
+Proof.
+ intros H. apply (ins_rr_rb x), ifred_or in H. intuition.
+Qed.
+
+Instance add_rb x s : Rbt s -> Rbt (add x s).
+Proof.
+ intros (n,H). unfold add. now apply (makeBlack_rb n), ins_arb.
+Qed.
+
+(** ** Deletion *)
+
+(** A second approach here: statement with ... /\ ... *)
+
+Lemma append_arb_rb n l r : rbt n l -> rbt n r ->
+ (arbt n (append l r)) /\
+ (notred l -> notred r -> rbt n (append l r)).
+Proof.
+revert r n.
+append_tac l r.
+- split; auto.
+- split; auto.
+- (* Red / Red *)
+  intros n. invrb.
+  case (IHlr n); auto; clear IHlr.
+  case append_rr_match.
+  + intros a x b _ H; split; invrb.
+    assert (rbt n (Rd a x b)) by auto. invrb. auto.
+  + split; invrb; auto.
+- (* Red / Black *)
+  split; invrb. destruct (IHlr n) as (_,IH); auto.
+- (* Black / Red *)
+  split; invrb. destruct (IHrl n) as (_,IH); auto.
+- (* Black / Black *)
+  nonzero n.
+  invrb.
+  destruct (IHlr n) as (IH,_); auto; clear IHlr.
+  revert IH.
+  case append_bb_match.
+  + intros a x b IH; split; destruct IH; invrb; auto.
+  + split; [left | invrb]; auto using lbalS_rb.
+Qed.
+
+(** A third approach : Lemma ... with ... *)
+
+Lemma del_arb s x n : rbt (S n) s -> isblack s -> arbt n (del x s)
+with del_rb s x n : rbt n s -> notblack s -> rbt n (del x s).
+Proof.
+{ revert n.
+  induct s x; try destruct c; try contradiction; invrb.
+  - apply append_arb_rb; assumption.
+  - assert (IHl' := del_rb l x). clear IHr del_arb del_rb.
+    destruct l as [|[|] ll lx lr]; auto.
+    nonzero n. apply lbalS_arb; auto.
+  - assert (IHr' := del_rb r x). clear IHl del_arb del_rb.
+    destruct r as [|[|] rl rx rr]; auto.
+    nonzero n. apply rbalS_arb; auto. }
+{ revert n.
+  induct s x; try assumption; try destruct c; try contradiction; invrb.
+  - apply append_arb_rb; assumption.
+  - assert (IHl' := del_arb l x). clear IHr del_arb del_rb.
+    destruct l as [|[|] ll lx lr]; auto.
+    nonzero n. destruct n as [|n]; [invrb|]; apply lbalS_rb; auto.
+  - assert (IHr' := del_arb r x). clear IHl del_arb del_rb.
+    destruct r as [|[|] rl rx rr]; auto.
+    nonzero n. apply rbalS_rb; auto. }
+Qed.
+
+Instance remove_rb s x : Rbt s -> Rbt (remove x s).
+Proof.
+ intros (n,H). unfold remove.
+ destruct s as [|[|] l y r].
+ - apply (makeBlack_rb n). auto.
+ - apply (makeBlack_rb n). left. apply del_rb; simpl; auto.
+ - nonzero n. apply (makeBlack_rb n). apply del_arb; simpl; auto.
+Qed.
+
+(** ** Treeify *)
+
+Definition treeify_rb_invariant size depth (f:treeify_t) :=
+ forall acc,
+ size <= length acc ->
+  rbt depth (fst (f acc)) /\
+  size + length (snd (f acc)) = length acc.
+
+Lemma treeify_zero_rb : treeify_rb_invariant 0 0 treeify_zero.
+Proof.
+ intros acc _; simpl; auto.
+Qed.
+
+Lemma treeify_one_rb : treeify_rb_invariant 1 0 treeify_one.
+Proof.
+ intros [|x acc]; simpl; auto; inversion 1.
+Qed.
+
+Lemma treeify_cont_rb f g size1 size2 size d :
+ treeify_rb_invariant size1 d f ->
+ treeify_rb_invariant size2 d g ->
+ size = S (size1 + size2) ->
+ treeify_rb_invariant size (S d) (treeify_cont f g).
+Proof.
+ intros Hf Hg H acc Hacc.
+ unfold treeify_cont.
+ specialize (Hf acc).
+ destruct (f acc) as (l, acc1). simpl in *.
+ destruct Hf as (Hf1, Hf2). { subst. eauto with arith. }
+ destruct acc1 as [|x acc2]; simpl in *.
+ - exfalso. revert Hacc. apply Nat.lt_nge. rewrite H, <- Hf2.
+   auto with arith.
+ - specialize (Hg acc2).
+   destruct (g acc2) as (r, acc3). simpl in *.
+   destruct Hg as (Hg1, Hg2).
+   { revert Hacc.
+     rewrite H, <- Hf2, Nat.add_succ_r, <- Nat.succ_le_mono.
+     apply Nat.add_le_mono_l. }
+   split; auto.
+   now rewrite H, <- Hf2, <- Hg2, Nat.add_succ_r, Nat.add_assoc.
+Qed.
+
+Lemma treeify_aux_rb n :
+ exists d, forall (b:bool),
+  treeify_rb_invariant (ifpred b (Pos.to_nat n)) d (treeify_aux b n).
+Proof.
+ induction n as [n (d,IHn)|n (d,IHn)| ].
+ - exists (S d). intros b.
+   eapply treeify_cont_rb; [ apply (IHn false) | apply (IHn b) | ].
+   rewrite Pos2Nat.inj_xI.
+   assert (H := Pos2Nat.is_pos n). apply Nat.neq_0_lt_0 in H.
+   destruct b; simpl; intros; rewrite Nat.add_0_r; trivial.
+   now rewrite <- Nat.add_succ_r, Nat.succ_pred; trivial.
+ - exists (S d). intros b.
+   eapply treeify_cont_rb; [ apply (IHn b) | apply (IHn true) | ].
+   rewrite Pos2Nat.inj_xO.
+   assert (H := Pos2Nat.is_pos n). apply Nat.neq_0_lt_0 in H.
+   rewrite <- Nat.add_succ_r, Nat.succ_pred by trivial.
+   destruct b; simpl; intros; rewrite Nat.add_0_r; trivial.
+   symmetry. now apply Nat.add_pred_l.
+ - exists 0; destruct b;
+    [ apply treeify_zero_rb | apply treeify_one_rb ].
+Qed.
+
+(** The black depth of [treeify l] is actually a log2, but
+    we don't need to mention that. *)
+
+Instance treeify_rb l : Rbt (treeify l).
+Proof.
+ unfold treeify.
+ destruct (treeify_aux_rb (plength l)) as (d,H).
+ exists d.
+ apply H.
+ now rewrite plength_spec.
+Qed.
+
+(** ** Filtering *)
+
+Instance filter_rb f s : Rbt (filter f s).
+Proof.
+ unfold filter; auto_tc.
+Qed.
+
+Instance partition_rb1 f s : Rbt (fst (partition f s)).
+Proof.
+ unfold partition. destruct partition_aux. simpl. auto_tc.
+Qed.
+
+Instance partition_rb2 f s : Rbt (snd (partition f s)).
+Proof.
+ unfold partition. destruct partition_aux. simpl. auto_tc.
+Qed.
+
+(** ** Union, intersection, difference *)
+
+Instance fold_add_rb s1 s2 : Rbt s2 -> Rbt (fold add s1 s2).
+Proof.
+ intros. rewrite fold_spec, <- fold_left_rev_right. unfold elt in *.
+ induction (rev (elements s1)); simpl; unfold flip in *; auto_tc.
+Qed.
+
+Instance fold_remove_rb s1 s2 : Rbt s2 -> Rbt (fold remove s1 s2).
+Proof.
+ intros. rewrite fold_spec, <- fold_left_rev_right. unfold elt in *.
+ induction (rev (elements s1)); simpl; unfold flip in *; auto_tc.
+Qed.
+
+Lemma union_rb s1 s2 : Rbt s1 -> Rbt s2 -> Rbt (union s1 s2).
+Proof.
+ intros. unfold union, linear_union. destruct compare_height; auto_tc.
+Qed.
+
+Lemma inter_rb s1 s2 : Rbt s1 -> Rbt s2 -> Rbt (inter s1 s2).
+Proof.
+ intros. unfold inter, linear_inter. destruct compare_height; auto_tc.
+Qed.
+
+Lemma diff_rb s1 s2 : Rbt s1 -> Rbt s2 -> Rbt (diff s1 s2).
+Proof.
+ intros. unfold diff, linear_diff. destruct compare_height; auto_tc.
+Qed.
+
+End BalanceProps.
+
+(** * Final Encapsulation
+
+   Now, in order to really provide a functor implementing [S], we
+   need to encapsulate everything into a type of binary search trees.
+   They also happen to be well-balanced, but this has no influence
+   on the correctness of operations, so we won't state this here,
+   see [BalanceProps] if you need more than just the MSet interface.
+*)
+
+Module Type MSetInterface_S_Ext := MSetInterface.S <+ MSetRemoveMin.
+
+Module Make (X: Orders.OrderedType) <:
+ MSetInterface_S_Ext with Module E := X.
+ Module Raw. Include MakeRaw X. End Raw.
+ Include MSetInterface.Raw2Sets X Raw.
+
+ Definition opt_ok (x:option (elt * Raw.t)) :=
+  match x with Some (_,s) => Raw.Ok s | None => True end.
+
+ Definition mk_opt_t (x: option (elt * Raw.t))(P: opt_ok x) :
+   option (elt * t) :=
+ match x as o return opt_ok o -> option (elt * t) with
+ | Some (k,s') => fun P : Raw.Ok s' => Some (k, Mkt s')
+ | None => fun _ => None
+ end P.
+
+ Definition remove_min s : option (elt * t) :=
+  mk_opt_t (Raw.remove_min (this s)) (Raw.remove_min_ok s).
+
+ Lemma remove_min_spec1 s x s' :
+  remove_min s = Some (x,s') ->
+   min_elt s = Some x /\ Equal (remove x s) s'.
+ Proof.
+ destruct s as (s,Hs).
+ unfold remove_min, mk_opt_t, min_elt, remove, Equal, In; simpl.
+ generalize (fun x s' => @Raw.remove_min_spec1 s x s' Hs).
+ set (P := Raw.remove_min_ok s). clearbody P.
+ destruct (Raw.remove_min s) as [(x0,s0)|]; try easy.
+ intros H U. injection U. clear U; intros; subst. simpl.
+ destruct (H x s0); auto. subst; intuition.
+ Qed.
+
+ Lemma remove_min_spec2 s : remove_min s = None -> Empty s.
+ Proof.
+ destruct s as (s,Hs).
+ unfold remove_min, mk_opt_t, Empty, In; simpl.
+ generalize (Raw.remove_min_spec2 s).
+ set (P := Raw.remove_min_ok s). clearbody P.
+ destruct (Raw.remove_min s) as [(x0,s0)|]; now intuition.
+ Qed.
+
+End Make.
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..fd4114cd 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
@@ -398,7 +396,7 @@ Module MakeRaw (X:DecidableType) <: WRawSets X.
   induction s; simpl.
   intuition; inv.
   intros.
-  destruct (f a) as [ ]_eqn:E; rewrite ?InA_cons, IHs; intuition.
+  destruct (f a) eqn:E; rewrite ?InA_cons, IHs; intuition.
   setoid_replace x with a; auto.
   setoid_replace a with x in E; auto. congruence.
   Qed.
@@ -422,7 +420,7 @@ Module MakeRaw (X:DecidableType) <: WRawSets X.
   unfold For_all; induction s; simpl.
   intuition. inv.
   intros; inv.
-  destruct (f a) as [ ]_eqn:F.
+  destruct (f a) eqn:F.
   rewrite IHs; intuition. inv; auto.
   setoid_replace x with a; auto.
   split; intros H'; try discriminate.
@@ -438,7 +436,7 @@ Module MakeRaw (X:DecidableType) <: WRawSets X.
   unfold Exists; induction s; simpl.
   split; [discriminate| intros (x & Hx & _); inv].
   intros.
-  destruct (f a) as [ ]_eqn:F.
+  destruct (f a) eqn:F.
   split; auto.
   exists a; auto.
   rewrite IHs; firstorder.
@@ -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/MSets/vo.itarget b/theories/MSets/vo.itarget
index 14429b81..7c5b6899 100644
--- a/theories/MSets/vo.itarget
+++ b/theories/MSets/vo.itarget
@@ -1,4 +1,6 @@
+MSetGenTree.vo
 MSetAVL.vo
+MSetRBT.vo
 MSetDecide.vo
 MSetEqProperties.vo
 MSetFacts.vo
diff --git a/theories/NArith/BinNat.v b/theories/NArith/BinNat.v
index 8695acca..5b1e83e6 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-2012     *)
 (*   \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 = pos p } + { n = 0 }.
+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 (pos p) in
+ let f2' p := f2 (pos p) in
+ let fS2' p := fS2 (pos p) in
+ match n with
+ | 0 => f0
+ | pos 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 (pos p) in
+let f' p := f (pos p) in
+match n with
+| 0 => f0
+| pos 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 (pos 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 : pos (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) = pos 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 sub_0_r n : n - 0 = n.
+Proof.
+now destruct n.
+Qed.
 
-Theorem Nrect_base : forall P a f, Nrect P a f N0 = a.
+Theorem sub_succ_r n m : n - succ m = pred (n - m).
 Proof.
-intros P a f; simpl; 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.
 
-Theorem Nrect_step : forall P a f n, Nrect P a f (Nsucc n) = f n (Nrect P a f n).
+(** Specification of multiplication *)
+
+Theorem mul_0_l n : 0 * n = 0.
 Proof.
-intros P a f; destruct n as [| p]; simpl;
-[rewrite Prect_base | rewrite Prect_succ]; reflexivity.
+reflexivity.
 Qed.
 
-Definition Nind (P : N -> Prop) := Nrect P.
+Theorem mul_succ_l n m : (succ n) * m = n * m + m.
+Proof.
+destruct n, m; simpl; trivial. f_equal. rewrite Pos.add_comm.
+apply Pos.mul_succ_l.
+Qed.
 
-Definition Nrec (P : N -> Set) := Nrect P.
+(** Specification of boolean comparisons. *)
 
-Theorem Nrec_base : forall P a f, Nrec P a f N0 = a.
+Lemma eqb_eq n m : eqb n m = true <-> n=m.
 Proof.
-intros P a f; unfold Nrec; apply Nrect_base.
+destruct n as [|n], m as [|m]; simpl; try easy'.
+rewrite Pos.eqb_eq. split; intro H. now subst. now destr_eq H.
 Qed.
 
-Theorem Nrec_step : forall P a f n, Nrec P a f (Nsucc n) = f n (Nrec P a f n).
+Lemma ltb_lt n m : (n <? m) = true <-> n < m.
 Proof.
-intros P a f; unfold Nrec; apply Nrect_step.
+  unfold ltb, lt. destruct compare; easy'.
 Qed.
 
-(** Properties of successor and predecessor *)
+Lemma leb_le n m : (n <=? m) = true <-> n <= m.
+Proof.
+  unfold leb, le. destruct compare; easy'.
+Qed.
 
-Theorem Npred_succ : forall n : N, Npred (Nsucc n) = n.
+(** Basic properties of comparison *)
+
+Theorem compare_eq_iff n m : (n ?= m) = Eq <-> 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.
+destruct n, m; simpl; rewrite ?Pos.compare_eq_iff; split; congruence.
 Qed.
 
-(** Properties of addition *)
+Theorem compare_lt_iff n m : (n ?= m) = Lt <-> n < m.
+Proof.
+reflexivity.
+Qed.
 
-Theorem Nplus_0_l : forall n:N, N0 + n = n.
+Theorem compare_le_iff n m : (n ?= m) <> Gt <-> n <= m.
 Proof.
 reflexivity.
 Qed.
 
-Theorem Nplus_0_r : forall n:N, n + N0 = n.
+Theorem compare_antisym n m : (m ?= n) = CompOpp (n ?= m).
 Proof.
-destruct n; reflexivity.
+destruct n, m; simpl; trivial. apply Pos.compare_antisym.
 Qed.
 
-Theorem Nplus_comm : forall n m:N, n + m = m + n.
+(** 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.
-intros.
-destruct n; destruct m; simpl in |- *; try reflexivity.
-rewrite Pplus_comm; reflexivity.
+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 (pos 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 (pos 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 (pos 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 pos 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 (pos a~1) with (succ_double (pos 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 (pos a~0) with (double (pos 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 (pos 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.
+ 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 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 (pos 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 testbit_odd_0 a : testbit (2*a+1) 0 = true.
+Proof.
+ now destruct a.
+Qed.
+
+Lemma testbit_succ_r_div2 a n : 0<=n ->
+ testbit a (succ n) = testbit (div2 a) n.
+Proof.
+ intros _. destruct a as [|[a|a| ]], n as [|n]; simpl; trivial;
+  f_equal; apply Pos.pred_N_succ.
+Qed.
+
+Lemma testbit_odd_succ a n : 0<=n ->
+ testbit (2*a+1) (succ n) = testbit a n.
+Proof.
+ intros H. rewrite testbit_succ_r_div2 by trivial. f_equal. now destruct a.
+Qed.
+
+Lemma testbit_even_succ a n : 0<=n ->
+ testbit (2*a) (succ n) = testbit a n.
+Proof.
+ 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 0 -> (forall n, A n <-> A (succ n)) -> forall n : N, A n.
 Proof.
-destruct n; discriminate.
+intros A A_wd A0 AS. apply peano_rect. assumption. intros; now apply -> AS.
 Qed.
 
-(** Dividing by 2 *)
+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.
 
-Definition Ndiv2 (n:N) :=
-  match n with
-  | N0 => N0
-  | Npos 1 => N0
-  | Npos (xO p) => Npos p
-  | Npos (xI p) => Npos p
-  end.
+Theorem recursion_0 {A} (a:A) (f:N->A->A) : recursion a f 0 = a.
+Proof. reflexivity. Qed.
 
-Lemma Ndouble_div2 : forall n:N, Ndiv2 (Ndouble n) = n.
+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.
-  destruct n; trivial.
+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.
 
-Lemma Ndouble_plus_one_div2 :
- forall n:N, Ndiv2 (Ndouble_plus_one n) = n.
+(** Instantiation of generic properties of natural numbers *)
+
+(** The Bind Scope prevents N to stay associated with abstract_scope.
+    (TODO FIX) *)
+
+Include NProp. Bind Scope N_scope with N.
+Include UsualMinMaxLogicalProperties <+ UsualMinMaxDecProperties.
+
+(** 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.
-  destruct n; trivial.
+ unfold lt, gt. now rewrite compare_antisym, CompOpp_iff.
 Qed.
 
-Lemma Ndouble_inj : forall n m, Ndouble n = Ndouble m -> n = m.
+Lemma gt_lt n m : n > m -> m < n.
 Proof.
-  intros. rewrite <- (Ndouble_div2 n). rewrite H. apply Ndouble_div2.
+ apply gt_lt_iff.
 Qed.
 
-Lemma Ndouble_plus_one_inj :
- forall n m, Ndouble_plus_one n = Ndouble_plus_one m -> n = m.
+Lemma lt_gt n m : n < m -> m > n.
 Proof.
-  intros. rewrite <- (Ndouble_plus_one_div2 n). rewrite H. apply Ndouble_plus_one_div2.
+ 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 (compat "8.3").*) (*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 := N.pos (only parsing).
+
+Notation Ndiscr := N.discr (compat "8.3").
+Notation Ndouble_plus_one := N.succ_double (compat "8.3").
+Notation Ndouble := N.double (compat "8.3").
+Notation Nsucc := N.succ (compat "8.3").
+Notation Npred := N.pred (compat "8.3").
+Notation Nsucc_pos := N.succ_pos (compat "8.3").
+Notation Ppred_N := Pos.pred_N (compat "8.3").
+Notation Nplus := N.add (compat "8.3").
+Notation Nminus := N.sub (compat "8.3").
+Notation Nmult := N.mul (compat "8.3").
+Notation Neqb := N.eqb (compat "8.3").
+Notation Ncompare := N.compare (compat "8.3").
+Notation Nlt := N.lt (compat "8.3").
+Notation Ngt := N.gt (compat "8.3").
+Notation Nle := N.le (compat "8.3").
+Notation Nge := N.ge (compat "8.3").
+Notation Nmin := N.min (compat "8.3").
+Notation Nmax := N.max (compat "8.3").
+Notation Ndiv2 := N.div2 (compat "8.3").
+Notation Neven := N.even (compat "8.3").
+Notation Nodd := N.odd (compat "8.3").
+Notation Npow := N.pow (compat "8.3").
+Notation Nlog2 := N.log2 (compat "8.3").
+
+Notation nat_of_N := N.to_nat (compat "8.3").
+Notation N_of_nat := N.of_nat (compat "8.3").
+Notation N_eq_dec := N.eq_dec (compat "8.3").
+Notation Nrect := N.peano_rect (compat "8.3").
+Notation Nrect_base := N.peano_rect_base (compat "8.3").
+Notation Nrect_step := N.peano_rect_succ (compat "8.3").
+Notation Nind := N.peano_ind (compat "8.3").
+Notation Nrec := N.peano_rec (compat "8.3").
+Notation Nrec_base := N.peano_rec_base (compat "8.3").
+Notation Nrec_succ := N.peano_rec_succ (compat "8.3").
+
+Notation Npred_succ := N.pred_succ (compat "8.3").
+Notation Npred_minus := N.pred_sub (compat "8.3").
+Notation Nsucc_pred := N.succ_pred (compat "8.3").
+Notation Ppred_N_spec := N.pos_pred_spec (compat "8.3").
+Notation Nsucc_pos_spec := N.succ_pos_spec (compat "8.3").
+Notation Ppred_Nsucc := N.pos_pred_succ (compat "8.3").
+Notation Nplus_0_l := N.add_0_l (compat "8.3").
+Notation Nplus_0_r := N.add_0_r (compat "8.3").
+Notation Nplus_comm := N.add_comm (compat "8.3").
+Notation Nplus_assoc := N.add_assoc (compat "8.3").
+Notation Nplus_succ := N.add_succ_l (compat "8.3").
+Notation Nsucc_0 := N.succ_0_discr (compat "8.3").
+Notation Nsucc_inj := N.succ_inj (compat "8.3").
+Notation Nminus_N0_Nle := N.sub_0_le (compat "8.3").
+Notation Nminus_0_r := N.sub_0_r (compat "8.3").
+Notation Nminus_succ_r:= N.sub_succ_r (compat "8.3").
+Notation Nmult_0_l := N.mul_0_l (compat "8.3").
+Notation Nmult_1_l := N.mul_1_l (compat "8.3").
+Notation Nmult_1_r := N.mul_1_r (compat "8.3").
+Notation Nmult_comm := N.mul_comm (compat "8.3").
+Notation Nmult_assoc := N.mul_assoc (compat "8.3").
+Notation Nmult_plus_distr_r := N.mul_add_distr_r (compat "8.3").
+Notation Neqb_eq := N.eqb_eq (compat "8.3").
+Notation Nle_0 := N.le_0_l (compat "8.3").
+Notation Ncompare_refl := N.compare_refl (compat "8.3").
+Notation Ncompare_Eq_eq := N.compare_eq (compat "8.3").
+Notation Ncompare_eq_correct := N.compare_eq_iff (compat "8.3").
+Notation Nlt_irrefl := N.lt_irrefl (compat "8.3").
+Notation Nlt_trans := N.lt_trans (compat "8.3").
+Notation Nle_lteq := N.lt_eq_cases (compat "8.3").
+Notation Nlt_succ_r := N.lt_succ_r (compat "8.3").
+Notation Nle_trans := N.le_trans (compat "8.3").
+Notation Nle_succ_l := N.le_succ_l (compat "8.3").
+Notation Ncompare_spec := N.compare_spec (compat "8.3").
+Notation Ncompare_0 := N.compare_0_r (compat "8.3").
+Notation Ndouble_div2 := N.div2_double (compat "8.3").
+Notation Ndouble_plus_one_div2 := N.div2_succ_double (compat "8.3").
+Notation Ndouble_inj := N.double_inj (compat "8.3").
+Notation Ndouble_plus_one_inj := N.succ_double_inj (compat "8.3").
+Notation Npow_0_r := N.pow_0_r (compat "8.3").
+Notation Npow_succ_r := N.pow_succ_r (compat "8.3").
+Notation Nlog2_spec := N.log2_spec (compat "8.3").
+Notation Nlog2_nonpos := N.log2_nonpos (compat "8.3").
+Notation Neven_spec := N.even_spec (compat "8.3").
+Notation Nodd_spec := N.odd_spec (compat "8.3").
+Notation Nlt_not_eq := N.lt_neq (compat "8.3").
+Notation Ngt_Nlt := N.gt_lt (compat "8.3").
+
+(** 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..08e1138f
--- /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-2012     *)
+(*   \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.
+
+(** ** Nicer name [N.pos] for contructor [Npos] *)
+
+Notation pos := Npos.
+
+(** ** Constants *)
+
+Definition zero := 0.
+Definition one := 1.
+Definition two := 2.
+
+(** ** Operation [x -> 2*x+1] *)
+
+Definition succ_double x :=
+  match x with
+  | 0 => 1
+  | pos p => pos p~1
+  end.
+
+(** ** Operation [x -> 2*x] *)
+
+Definition double n :=
+  match n with
+  | 0 => 0
+  | pos p => pos p~0
+  end.
+
+(** ** Successor *)
+
+Definition succ n :=
+  match n with
+  | 0 => 1
+  | pos p => pos (Pos.succ p)
+  end.
+
+(** ** Predecessor *)
+
+Definition pred n :=
+  match n with
+  | 0 => 0
+  | pos 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
+   | 0 => 1%positive
+   | pos p => Pos.succ p
+ end.
+
+(** ** Addition *)
+
+Definition add n m :=
+  match n, m with
+  | 0, _ => m
+  | _, 0 => n
+  | pos p, pos q => pos (p + q)
+  end.
+
+Infix "+" := add : N_scope.
+
+(** Subtraction *)
+
+Definition sub n m :=
+match n, m with
+| 0, _ => 0
+| n, 0 => n
+| pos n', pos m' =>
+  match Pos.sub_mask n' m' with
+  | IsPos p => pos p
+  | _ => 0
+  end
+end.
+
+Infix "-" := sub : N_scope.
+
+(** Multiplication *)
+
+Definition mul n m :=
+  match n, m with
+  | 0, _ => 0
+  | _, 0 => 0
+  | pos p, pos q => pos (p * q)
+  end.
+
+Infix "*" := mul : N_scope.
+
+(** Order *)
+
+Definition compare n m :=
+  match n, m with
+  | 0, 0 => Eq
+  | 0, pos m' => Lt
+  | pos n', 0 => Gt
+  | pos n', pos m' => (n' ?= m')%positive
+  end.
+
+Infix "?=" := compare (at level 70, no associativity) : N_scope.
+
+(** Boolean equality and comparison *)
+
+Fixpoint eqb n m :=
+  match n, m with
+    | 0, 0 => true
+    | pos p, pos 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
+  | pos (p~0) => pos p
+  | pos (p~1) => pos p
+  end.
+
+(** Parity *)
+
+Definition even n :=
+  match n with
+    | 0 => true
+    | pos (xO _) => true
+    | _ => false
+  end.
+
+Definition odd n := negb (even n).
+
+(** Power *)
+
+Definition pow n p :=
+  match p, n with
+    | 0, _ => 1
+    | _, 0 => 0
+    | pos p, pos q => pos (q^p)
+  end.
+
+Infix "^" := pow : N_scope.
+
+(** Square *)
+
+Definition square n :=
+  match n with
+    | 0 => 0
+    | pos p => pos (Pos.square p)
+  end.
+
+(** Base-2 logarithm *)
+
+Definition log2 n :=
+ match n with
+   | 0 => 0
+   | 1 => 0
+   | pos (p~0) => pos (Pos.size p)
+   | pos (p~1) => pos (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
+  | pos p => pos (Pos.size p)
+ end.
+
+Definition size_nat n :=
+ match n with
+  | 0 => O
+  | pos 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)
+   | pos 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
+  | pos p, pos q => pos (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))
+  | pos p, pos q =>
+     let '(g,(aa,bb)) := Pos.ggcd p q in
+     (pos g, (pos aa, pos bb))
+ end.
+
+(** Square root *)
+
+Definition sqrtrem n :=
+ match n with
+  | 0 => (0, 0)
+  | pos p =>
+    match Pos.sqrtrem p with
+     | (s, IsPos r) => (pos s, pos r)
+     | (s, _) => (pos s, 0)
+    end
+ end.
+
+Definition sqrt n :=
+ match n with
+  | 0 => 0
+  | pos p => pos (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
+   | pos p, pos q => pos (Pos.lor p q)
+ end.
+
+(** Logical [and] *)
+
+Definition land n m :=
+ match n, m with
+  | 0, _ => 0
+  | _, 0 => 0
+  | pos p, pos q => Pos.land p q
+ end.
+
+(** Logical [diff] *)
+
+Fixpoint ldiff n m :=
+ match n, m with
+  | 0, _ => 0
+  | _, 0 => n
+  | pos p, pos q => Pos.ldiff p q
+ end.
+
+(** [xor] *)
+
+Definition lxor n m :=
+  match n, m with
+    | 0, _ => m
+    | _, 0 => n
+    | pos p, pos 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
+    | pos a => pos (Pos.shiftl a n)
+  end.
+
+Definition shiftr a n :=
+  match n with
+    | 0 => a
+    | pos 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
+    | pos p => Pos.testbit_nat p
+  end.
+
+(** Same, but with index in N *)
+
+Definition testbit a n :=
+  match a with
+    | 0 => false
+    | pos p => Pos.testbit p n
+  end.
+
+(** Translation from [N] to [nat] and back. *)
+
+Definition to_nat (a:N) :=
+  match a with
+    | 0 => O
+    | pos p => Pos.to_nat p
+  end.
+
+Definition of_nat (n:nat) :=
+  match n with
+    | O => 0
+    | S n' => pos (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
+    | pos 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..d0664d37 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-2012     *)
 (*   \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..f8db7548 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-2012     *)
 (*   \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.
@@ -17,315 +15,238 @@ Require Import Pnat.
 Require Import Nnat.
 Require Import Ndigits.
 
-(** A boolean equality over [N] *)
+Local Open Scope N_scope.
 
-Notation Peqb := Peqb (only parsing). (* Now in [BinPos] *)
-Notation Neqb := Neqb (only parsing). (* Now in [BinNat] *)
+(** Obsolete results about boolean comparisons over [N],
+    kept for compatibility with IntMap and SMC. *)
 
-Notation Peqb_correct := Peqb_refl (only parsing).
+Notation Peqb := Pos.eqb (compat "8.3").
+Notation Neqb := N.eqb (compat "8.3").
+Notation Peqb_correct := Pos.eqb_refl (compat "8.3").
+Notation Neqb_correct := N.eqb_refl (compat "8.3").
+Notation Neqb_comm := N.eqb_sym (compat "8.3").
 
-Lemma Peqb_complete : forall p p', Peqb p p' = true -> p = p'.
-Proof.
-  intros. now apply (Peqb_eq p p').
-Qed.
+Lemma Peqb_complete p p' : Pos.eqb p p' = true -> p = p'.
+Proof. now apply Pos.eqb_eq. Qed.
 
-Lemma Peqb_Pcompare : forall p p', Peqb p p' = true -> Pcompare p p' Eq = Eq.
-Proof.
-  intros. now rewrite Pcompare_eq_iff, <- Peqb_eq.
-Qed.
-
-Lemma Pcompare_Peqb : forall p p', Pcompare p p' Eq = Eq -> Peqb p p' = true.
-Proof.
-  intros; now rewrite Peqb_eq, <- Pcompare_eq_iff.
-Qed.
+Lemma Peqb_Pcompare p p' : Pos.eqb p p' = true -> Pos.compare p p' = Eq.
+Proof. now rewrite Pos.compare_eq_iff, <- Pos.eqb_eq. Qed.
 
-Lemma Neqb_correct : forall n, Neqb n n = true.
-Proof.
-  intros; now rewrite Neqb_eq.
-Qed.
+Lemma Pcompare_Peqb p p' : Pos.compare p p' = Eq -> Pos.eqb p p' = true.
+Proof. now rewrite Pos.eqb_eq, <- Pos.compare_eq_iff. Qed.
 
-Lemma Neqb_Ncompare : forall n n', Neqb n n' = true -> Ncompare n n' = Eq.
-Proof.
-  intros; now rewrite Ncompare_eq_correct, <- Neqb_eq.
-Qed.
+Lemma Neqb_Ncompare n n' : N.eqb n n' = true -> N.compare n n' = Eq.
+Proof. now rewrite N.compare_eq_iff, <- N.eqb_eq. Qed.
 
-Lemma Ncompare_Neqb : forall n n', Ncompare n n' = Eq -> Neqb n n' = true.
-Proof.
-  intros; now rewrite Neqb_eq, <- Ncompare_eq_correct.
-Qed.
+Lemma Ncompare_Neqb n n' : N.compare n n' = Eq -> N.eqb n n' = true.
+Proof. now rewrite N.eqb_eq, <- N.compare_eq_iff. Qed.
 
-Lemma Neqb_complete : forall a a', Neqb a a' = true -> a = a'.
-Proof.
-  intros; now rewrite <- Neqb_eq.
-Qed.
+Lemma Neqb_complete n n' : N.eqb n n' = true -> n = n'.
+Proof. now apply N.eqb_eq. Qed.
 
-Lemma Neqb_comm : forall a a', Neqb a a' = Neqb a' a.
+Lemma Nxor_eq_true n n' : N.lxor n n' = 0 -> N.eqb n n' = true.
 Proof.
-  intros; apply eq_true_iff_eq. rewrite 2 Neqb_eq; auto with *.
+  intro H. apply N.lxor_eq in H. subst. apply N.eqb_refl.
 Qed.
 
-Lemma Nxor_eq_true :
- forall a a', Nxor a a' = N0 -> Neqb a a' = true.
-Proof.
-  intros. rewrite (Nxor_eq a a' H). apply Neqb_correct.
-Qed.
+Ltac eqb2eq := rewrite <- ?not_true_iff_false in *; rewrite ?N.eqb_eq in *.
 
-Lemma Nxor_eq_false :
- forall a a' p, Nxor a a' = Npos p -> Neqb a a' = false.
+Lemma Nxor_eq_false n n' p :
+  N.lxor n n' = N.pos p -> N.eqb n n' = false.
 Proof.
-  intros. elim (sumbool_of_bool (Neqb a a')). intro H0.
-  rewrite (Neqb_complete a a' H0) in H.
-  rewrite (Nxor_nilpotent a') in H. discriminate H.
-  trivial.
+  intros. eqb2eq. intro. subst. now rewrite N.lxor_nilpotent in *.
 Qed.
 
-Lemma Nodd_not_double :
- forall a,
-   Nodd a -> forall a0, Neqb (Ndouble a0) a = false.
+Lemma Nodd_not_double a :
+  Nodd a -> forall a0, N.eqb (N.double a0) a = false.
 Proof.
-  intros. elim (sumbool_of_bool (Neqb (Ndouble a0) a)). intro H0.
-  rewrite <- (Neqb_complete _ _ H0) in H.
-  unfold Nodd in H.
-  rewrite (Ndouble_bit0 a0) in H. discriminate H.
-  trivial.
+  intros. eqb2eq. intros <-.
+  unfold Nodd in *. now rewrite Ndouble_bit0 in *.
 Qed.
 
-Lemma Nnot_div2_not_double :
- forall a a0,
-   Neqb (Ndiv2 a) a0 = false -> Neqb a (Ndouble a0) = false.
+Lemma Nnot_div2_not_double a a0 :
+  N.eqb (N.div2 a) a0 = false -> N.eqb a (N.double a0) = false.
 Proof.
-  intros. elim (sumbool_of_bool (Neqb (Ndouble a0) a)). intro H0.
-  rewrite <- (Neqb_complete _ _ H0) in H. rewrite (Ndouble_div2 a0) in H.
-  rewrite (Neqb_correct a0) in H. discriminate H.
-  intro. rewrite Neqb_comm. assumption.
+  intros H. eqb2eq. contradict H. subst. apply N.div2_double.
 Qed.
 
-Lemma Neven_not_double_plus_one :
- forall a,
-   Neven a -> forall a0, Neqb (Ndouble_plus_one a0) a = false.
+Lemma Neven_not_double_plus_one a :
+  Neven a -> forall a0, N.eqb (N.succ_double a0) a = false.
 Proof.
-  intros. elim (sumbool_of_bool (Neqb (Ndouble_plus_one a0) a)). intro H0.
-  rewrite <- (Neqb_complete _ _ H0) in H.
-  unfold Neven in H.
-  rewrite (Ndouble_plus_one_bit0 a0) in H.
-  discriminate H.
-  trivial.
+  intros. eqb2eq. intros <-.
+  unfold Neven in *. now rewrite Ndouble_plus_one_bit0 in *.
 Qed.
 
-Lemma Nnot_div2_not_double_plus_one :
- forall a a0,
-   Neqb (Ndiv2 a) a0 = false -> Neqb (Ndouble_plus_one a0) a = false.
+Lemma Nnot_div2_not_double_plus_one a a0 :
+  N.eqb (N.div2 a) a0 = false -> N.eqb (N.succ_double a0) a = false.
 Proof.
-  intros. elim (sumbool_of_bool (Neqb a (Ndouble_plus_one a0))). intro H0.
-  rewrite (Neqb_complete _ _ H0) in H. rewrite (Ndouble_plus_one_div2 a0) in H.
-  rewrite (Neqb_correct a0) in H. discriminate H.
-  intro H0. rewrite Neqb_comm. assumption.
+  intros H. eqb2eq. contradict H. subst. apply N.div2_succ_double.
 Qed.
 
-Lemma Nbit0_neq :
- forall a a',
-   Nbit0 a = false -> Nbit0 a' = true -> Neqb a a' = false.
+Lemma Nbit0_neq a a' :
+  N.odd a = false -> N.odd a' = true -> N.eqb a a' = false.
 Proof.
-  intros. elim (sumbool_of_bool (Neqb a a')). intro H1.
-  rewrite (Neqb_complete _ _ H1) in H.
-  rewrite H in H0. discriminate H0.
-  trivial.
+  intros. eqb2eq. now intros <-.
 Qed.
 
-Lemma Ndiv2_eq :
- forall a a', Neqb a a' = true -> Neqb (Ndiv2 a) (Ndiv2 a') = true.
+Lemma Ndiv2_eq a a' :
+  N.eqb a a' = true -> N.eqb (N.div2 a) (N.div2 a') = true.
 Proof.
-  intros. cut (a = a'). intros. rewrite H0. apply Neqb_correct.
-  apply Neqb_complete. exact H.
+  intros. eqb2eq. now subst.
 Qed.
 
-Lemma Ndiv2_neq :
- forall a a',
-   Neqb (Ndiv2 a) (Ndiv2 a') = false -> Neqb a a' = false.
+Lemma Ndiv2_neq a a' :
+  N.eqb (N.div2 a) (N.div2 a') = false -> N.eqb a a' = false.
 Proof.
-  intros. elim (sumbool_of_bool (Neqb a a')). intro H0.
-  rewrite (Neqb_complete _ _ H0) in H.
-  rewrite (Neqb_correct (Ndiv2 a')) in H. discriminate H.
-  trivial.
+  intros H. eqb2eq. contradict H. now subst.
 Qed.
 
-Lemma Ndiv2_bit_eq :
- forall a a',
-   Nbit0 a = Nbit0 a' -> Ndiv2 a = Ndiv2 a' -> a = a'.
+Lemma Ndiv2_bit_eq a a' :
+  N.odd a = N.odd a' -> N.div2 a = N.div2 a' -> a = a'.
 Proof.
-  intros. apply Nbit_faithful. unfold eqf in |- *. destruct n.
-  rewrite Nbit0_correct. rewrite Nbit0_correct. assumption.
-  rewrite <- Ndiv2_correct. rewrite <- Ndiv2_correct.
-  rewrite H0. reflexivity.
+  intros H H'; now rewrite (N.div2_odd a), (N.div2_odd a'), H, H'.
 Qed.
 
-Lemma Ndiv2_bit_neq :
- forall a a',
-   Neqb a a' = false ->
-   Nbit0 a = Nbit0 a' -> Neqb (Ndiv2 a) (Ndiv2 a') = false.
+Lemma Ndiv2_bit_neq a a' :
+  N.eqb a a' = false ->
+   N.odd a = N.odd a' -> N.eqb (N.div2 a) (N.div2 a') = false.
 Proof.
-  intros. elim (sumbool_of_bool (Neqb (Ndiv2 a) (Ndiv2 a'))). intro H1.
-  rewrite (Ndiv2_bit_eq _ _ H0 (Neqb_complete _ _ H1)) in H.
-  rewrite (Neqb_correct a') in H. discriminate H.
-  trivial.
+  intros H H'. eqb2eq. contradict H. now apply Ndiv2_bit_eq.
 Qed.
 
-Lemma Nneq_elim :
- forall a a',
-   Neqb a a' = false ->
-   Nbit0 a = negb (Nbit0 a') \/
-   Neqb (Ndiv2 a) (Ndiv2 a') = false.
+Lemma Nneq_elim a a' :
+   N.eqb a a' = false ->
+   N.odd a = negb (N.odd a') \/
+   N.eqb (N.div2 a) (N.div2 a') = false.
 Proof.
-  intros. cut (Nbit0 a = Nbit0 a' \/ Nbit0 a = negb (Nbit0 a')).
+  intros. cut (N.odd a = N.odd a' \/ N.odd a = negb (N.odd a')).
   intros. elim H0. intro. right. apply Ndiv2_bit_neq. assumption.
   assumption.
   intro. left. assumption.
-  case (Nbit0 a); case (Nbit0 a'); auto.
+  case (N.odd a), (N.odd a'); auto.
 Qed.
 
-Lemma Ndouble_or_double_plus_un :
- forall a,
-   {a0 : N | a = Ndouble a0} + {a1 : N | a = Ndouble_plus_one a1}.
+Lemma Ndouble_or_double_plus_un a :
+   {a0 : N | a = N.double a0} + {a1 : N | a = N.succ_double a1}.
 Proof.
-  intro. elim (sumbool_of_bool (Nbit0 a)). intro H. right. split with (Ndiv2 a).
-  rewrite (Ndiv2_double_plus_one a H). reflexivity.
-  intro H. left. split with (Ndiv2 a). rewrite (Ndiv2_double a H). reflexivity.
+  elim (sumbool_of_bool (N.odd a)); intros H; [right|left];
+    exists (N.div2 a); symmetry;
+    apply Ndiv2_double_plus_one || apply Ndiv2_double; auto.
 Qed.
 
-(** A boolean order on [N] *)
+(** An inefficient boolean order on [N]. Please use [N.leb] instead now. *)
 
-Definition Nleb (a b:N) := leb (nat_of_N a) (nat_of_N b).
+Definition Nleb (a b:N) := leb (N.to_nat a) (N.to_nat b).
 
-Lemma Nleb_Nle : forall a b, Nleb a b = true <-> Nle a b.
+Lemma Nleb_alt a b : Nleb a b = N.leb a b.
 Proof.
- intros; unfold Nle; rewrite nat_of_Ncompare.
- unfold Nleb; apply leb_compare.
+ unfold Nleb.
+ now rewrite eq_iff_eq_true, N.leb_le, leb_compare, <- N2Nat.inj_compare.
 Qed.
 
-Lemma Nleb_refl : forall a, Nleb a a = true.
-Proof.
-  intro. unfold Nleb in |- *. apply leb_correct. apply le_n.
-Qed.
+Lemma Nleb_Nle a b : Nleb a b = true <-> a <= b.
+Proof. now rewrite Nleb_alt, N.leb_le. Qed.
 
-Lemma Nleb_antisym :
- forall a b, Nleb a b = true -> Nleb b a = true -> a = b.
-Proof.
-  unfold Nleb in |- *. intros. rewrite <- (N_of_nat_of_N a). rewrite <- (N_of_nat_of_N b).
-  rewrite (le_antisym _ _ (leb_complete _ _ H) (leb_complete _ _ H0)). reflexivity.
-Qed.
+Lemma Nleb_refl a : Nleb a a = true.
+Proof. rewrite Nleb_Nle; apply N.le_refl. Qed.
 
-Lemma Nleb_trans :
- forall a b c, Nleb a b = true -> Nleb b c = true -> Nleb a c = true.
-Proof.
-  unfold Nleb in |- *. intros. apply leb_correct. apply le_trans with (m := nat_of_N b).
-  apply leb_complete. assumption.
-  apply leb_complete. assumption.
-Qed.
+Lemma Nleb_antisym a b : Nleb a b = true -> Nleb b a = true -> a = b.
+Proof. rewrite !Nleb_Nle. apply N.le_antisymm. Qed.
 
-Lemma Nleb_ltb_trans :
- forall a b c,
-   Nleb a b = true -> Nleb c b = false -> Nleb c a = false.
+Lemma Nleb_trans a b c : Nleb a b = true -> Nleb b c = true -> Nleb a c = true.
+Proof. rewrite !Nleb_Nle. apply N.le_trans. Qed.
+
+Lemma Nleb_ltb_trans a b c :
+  Nleb a b = true -> Nleb c b = false -> Nleb c a = false.
 Proof.
-  unfold Nleb in |- *. intros. apply leb_correct_conv. apply le_lt_trans with (m := nat_of_N b).
+  unfold Nleb. intros. apply leb_correct_conv.
+  apply le_lt_trans with (m := N.to_nat b).
   apply leb_complete. assumption.
   apply leb_complete_conv. assumption.
 Qed.
 
-Lemma Nltb_leb_trans :
- forall a b c,
-   Nleb b a = false -> Nleb b c = true -> Nleb c a = false.
+Lemma Nltb_leb_trans a b c :
+  Nleb b a = false -> Nleb b c = true -> Nleb c a = false.
 Proof.
-  unfold Nleb in |- *. intros. apply leb_correct_conv. apply lt_le_trans with (m := nat_of_N b).
+  unfold Nleb. intros. apply leb_correct_conv.
+  apply lt_le_trans with (m := N.to_nat b).
   apply leb_complete_conv. assumption.
   apply leb_complete. assumption.
 Qed.
 
-Lemma Nltb_trans :
- forall a b c,
-   Nleb b a = false -> Nleb c b = false -> Nleb c a = false.
+Lemma Nltb_trans a b c :
+  Nleb b a = false -> Nleb c b = false -> Nleb c a = false.
 Proof.
-  unfold Nleb in |- *. intros. apply leb_correct_conv. apply lt_trans with (m := nat_of_N b).
+  unfold Nleb. intros. apply leb_correct_conv.
+  apply lt_trans with (m := N.to_nat b).
   apply leb_complete_conv. assumption.
   apply leb_complete_conv. assumption.
 Qed.
 
-Lemma Nltb_leb_weak : forall a b:N, Nleb b a = false -> Nleb a b = true.
+Lemma Nltb_leb_weak a b : Nleb b a = false -> Nleb a b = true.
 Proof.
-  unfold Nleb in |- *. intros. apply leb_correct. apply lt_le_weak.
+  unfold Nleb. intros. apply leb_correct. apply lt_le_weak.
   apply leb_complete_conv. assumption.
 Qed.
 
-Lemma Nleb_double_mono :
- forall a b,
-   Nleb a b = true -> Nleb (Ndouble a) (Ndouble b) = true.
+Lemma Nleb_double_mono a b :
+  Nleb a b = true -> Nleb (N.double a) (N.double b) = true.
 Proof.
-  unfold Nleb in |- *. intros. rewrite nat_of_Ndouble. rewrite nat_of_Ndouble. apply leb_correct.
-  simpl in |- *. apply plus_le_compat. apply leb_complete. assumption.
-  apply plus_le_compat. apply leb_complete. assumption.
-  apply le_n.
+  unfold Nleb. intros. rewrite !N2Nat.inj_double. apply leb_correct.
+  apply mult_le_compat_l. now apply leb_complete.
 Qed.
 
-Lemma Nleb_double_plus_one_mono :
- forall a b,
-   Nleb a b = true ->
-   Nleb (Ndouble_plus_one a) (Ndouble_plus_one b) = true.
+Lemma Nleb_double_plus_one_mono a b :
+  Nleb a b = true ->
+   Nleb (N.succ_double a) (N.succ_double b) = true.
 Proof.
-  unfold Nleb in |- *. intros. rewrite nat_of_Ndouble_plus_one. rewrite nat_of_Ndouble_plus_one.
-  apply leb_correct. apply le_n_S. simpl in |- *. apply plus_le_compat. apply leb_complete.
-  assumption.
-  apply plus_le_compat. apply leb_complete. assumption.
-  apply le_n.
+  unfold Nleb. intros. rewrite !N2Nat.inj_succ_double. apply leb_correct.
+  apply le_n_S, mult_le_compat_l. now apply leb_complete.
 Qed.
 
-Lemma Nleb_double_mono_conv :
- forall a b,
-   Nleb (Ndouble a) (Ndouble b) = true -> Nleb a b = true.
+Lemma Nleb_double_mono_conv a b :
+  Nleb (N.double a) (N.double b) = true -> Nleb a b = true.
 Proof.
-  unfold Nleb in |- *. intros a b. rewrite nat_of_Ndouble. rewrite nat_of_Ndouble. intro.
-  apply leb_correct. apply (mult_S_le_reg_l 1). apply leb_complete. assumption.
+  unfold Nleb. rewrite !N2Nat.inj_double. intro. apply leb_correct.
+  apply (mult_S_le_reg_l 1). now apply leb_complete.
 Qed.
 
-Lemma Nleb_double_plus_one_mono_conv :
- forall a b,
-   Nleb (Ndouble_plus_one a) (Ndouble_plus_one b) = true ->
+Lemma Nleb_double_plus_one_mono_conv a b :
+  Nleb (N.succ_double a) (N.succ_double b) = true ->
    Nleb a b = true.
 Proof.
-  unfold Nleb in |- *. intros a b. rewrite nat_of_Ndouble_plus_one. rewrite nat_of_Ndouble_plus_one.
-  intro. apply leb_correct. apply (mult_S_le_reg_l 1). apply le_S_n. apply leb_complete.
-  assumption.
+  unfold Nleb. rewrite !N2Nat.inj_succ_double. intro. apply leb_correct.
+  apply (mult_S_le_reg_l 1). apply le_S_n. now apply leb_complete.
 Qed.
 
-Lemma Nltb_double_mono :
- forall a b,
-   Nleb a b = false -> Nleb (Ndouble a) (Ndouble b) = false.
+Lemma Nltb_double_mono a b :
+   Nleb a b = false -> Nleb (N.double a) (N.double b) = false.
 Proof.
-  intros. elim (sumbool_of_bool (Nleb (Ndouble a) (Ndouble b))). intro H0.
+  intros. elim (sumbool_of_bool (Nleb (N.double a) (N.double b))). intro H0.
   rewrite (Nleb_double_mono_conv _ _ H0) in H. discriminate H.
   trivial.
 Qed.
 
-Lemma Nltb_double_plus_one_mono :
- forall a b,
-   Nleb a b = false ->
-   Nleb (Ndouble_plus_one a) (Ndouble_plus_one b) = false.
+Lemma Nltb_double_plus_one_mono a b :
+  Nleb a b = false ->
+   Nleb (N.succ_double a) (N.succ_double b) = false.
 Proof.
-  intros. elim (sumbool_of_bool (Nleb (Ndouble_plus_one a) (Ndouble_plus_one b))). intro H0.
+  intros. elim (sumbool_of_bool (Nleb (N.succ_double a) (N.succ_double b))).
+  intro H0.
   rewrite (Nleb_double_plus_one_mono_conv _ _ H0) in H. discriminate H.
   trivial.
 Qed.
 
-Lemma Nltb_double_mono_conv :
- forall a b,
-   Nleb (Ndouble a) (Ndouble b) = false -> Nleb a b = false.
+Lemma Nltb_double_mono_conv a b :
+  Nleb (N.double a) (N.double b) = false -> Nleb a b = false.
 Proof.
-  intros. elim (sumbool_of_bool (Nleb a b)). intro H0. rewrite (Nleb_double_mono _ _ H0) in H.
-  discriminate H.
+  intros. elim (sumbool_of_bool (Nleb a b)). intro H0.
+  rewrite (Nleb_double_mono _ _ H0) in H. discriminate H.
   trivial.
 Qed.
 
-Lemma Nltb_double_plus_one_mono_conv :
- forall a b,
-   Nleb (Ndouble_plus_one a) (Ndouble_plus_one b) = false ->
+Lemma Nltb_double_plus_one_mono_conv a b :
+  Nleb (N.succ_double a) (N.succ_double b) = false ->
    Nleb a b = false.
 Proof.
   intros. elim (sumbool_of_bool (Nleb a b)). intro H0.
@@ -333,110 +254,52 @@ Proof.
   trivial.
 Qed.
 
-(* Nleb and Ncompare *)
+(* Nleb and N.compare *)
 
-(* NB: No need to prove that Nleb a b = true <-> Ncompare a b <> Gt,
+(* NB: No need to prove that Nleb a b = true <-> N.compare a b <> Gt,
    this statement is in fact Nleb_Nle! *)
 
-Lemma Nltb_Ncompare : forall a b,
- Nleb a b = false <-> Ncompare a b = Gt.
+Lemma Nltb_Ncompare a b : Nleb a b = false <-> N.compare a b = Gt.
 Proof.
- intros.
- assert (IFF : forall x:bool, x = false <-> ~ x = true)
-   by (destruct x; intuition).
- rewrite IFF, Nleb_Nle; unfold Nle.
- destruct (Ncompare a b); split; intro H; auto;
-  elim H; discriminate.
+  now rewrite N.compare_nle_iff, <- Nleb_Nle, not_true_iff_false.
 Qed.
 
-Lemma Ncompare_Gt_Nltb : forall a b,
- Ncompare a b = Gt -> Nleb a b = false.
-Proof.
- intros; apply <- Nltb_Ncompare; auto.
-Qed.
+Lemma Ncompare_Gt_Nltb a b : N.compare a b = Gt -> Nleb a b = false.
+Proof. apply <- Nltb_Ncompare; auto. Qed.
 
-Lemma Ncompare_Lt_Nltb : forall a b,
- Ncompare a b = Lt -> Nleb b a = false.
+Lemma Ncompare_Lt_Nltb a b : N.compare a b = Lt -> Nleb b a = false.
 Proof.
- intros a b H.
- rewrite Nltb_Ncompare, <- Ncompare_antisym, H; auto.
+ intros H. rewrite Nltb_Ncompare, N.compare_antisym, H; auto.
 Qed.
 
-(* An alternate [min] function over [N] *)
-
-Definition Nmin' (a b:N) := if Nleb a b then a else b.
-
-Lemma Nmin_Nmin' : forall a b, Nmin a b = Nmin' a b.
-Proof.
- unfold Nmin, Nmin', Nleb; intros.
- rewrite nat_of_Ncompare.
- generalize (leb_compare (nat_of_N a) (nat_of_N b));
- destruct (nat_compare (nat_of_N a) (nat_of_N b));
- destruct (leb (nat_of_N a) (nat_of_N b)); intuition.
- lapply H1; intros; discriminate.
- lapply H1; intros; discriminate.
-Qed.
+(* Old results about [N.min] *)
 
-Lemma Nmin_choice : forall a b, {Nmin a b = a} + {Nmin a b = b}.
-Proof.
-  unfold Nmin in *; intros; destruct (Ncompare a b); auto.
-Qed.
+Notation Nmin_choice := N.min_dec (compat "8.3").
 
-Lemma Nmin_le_1 : forall a b, Nleb (Nmin a b) a = true.
-Proof.
-  intros; rewrite Nmin_Nmin'.
-  unfold Nmin'; elim (sumbool_of_bool (Nleb a b)). intro H. rewrite H.
-  apply Nleb_refl.
-  intro H. rewrite H. apply Nltb_leb_weak. assumption.
-Qed.
+Lemma Nmin_le_1 a b : Nleb (N.min a b) a = true.
+Proof. rewrite Nleb_Nle. apply N.le_min_l. Qed.
 
-Lemma Nmin_le_2 : forall a b, Nleb (Nmin a b) b = true.
-Proof.
-  intros; rewrite Nmin_Nmin'.
-  unfold Nmin'; elim (sumbool_of_bool (Nleb a b)). intro H. rewrite H. assumption.
-  intro H. rewrite H. apply Nleb_refl.
-Qed.
+Lemma Nmin_le_2 a b : Nleb (N.min a b) b = true.
+Proof. rewrite Nleb_Nle. apply N.le_min_r. Qed.
 
-Lemma Nmin_le_3 :
- forall a b c, Nleb a (Nmin b c) = true -> Nleb a b = true.
-Proof.
-  intros; rewrite Nmin_Nmin' in *.
-  unfold Nmin' in *; elim (sumbool_of_bool (Nleb b c)). intro H0. rewrite H0 in H.
-  assumption.
-  intro H0. rewrite H0 in H. apply Nltb_leb_weak. apply Nleb_ltb_trans with (b := c); assumption.
-Qed.
+Lemma Nmin_le_3 a b c : Nleb a (N.min b c) = true -> Nleb a b = true.
+Proof. rewrite !Nleb_Nle. apply N.min_glb_l. Qed.
 
-Lemma Nmin_le_4 :
- forall a b c, Nleb a (Nmin b c) = true -> Nleb a c = true.
-Proof.
-  intros; rewrite Nmin_Nmin' in *.
-  unfold Nmin' in *; elim (sumbool_of_bool (Nleb b c)). intro H0. rewrite H0 in H.
-  apply Nleb_trans with (b := b); assumption.
-  intro H0. rewrite H0 in H. assumption.
-Qed.
+Lemma Nmin_le_4 a b c : Nleb a (N.min b c) = true -> Nleb a c = true.
+Proof. rewrite !Nleb_Nle. apply N.min_glb_r. Qed.
 
-Lemma Nmin_le_5 :
- forall a b c,
-   Nleb a b = true -> Nleb a c = true -> Nleb a (Nmin b c) = true.
-Proof.
-  intros. elim (Nmin_choice b c). intro H1. rewrite H1. assumption.
-  intro H1. rewrite H1. assumption.
-Qed.
+Lemma Nmin_le_5 a b c :
+   Nleb a b = true -> Nleb a c = true -> Nleb a (N.min b c) = true.
+Proof. rewrite !Nleb_Nle. apply N.min_glb. Qed.
 
-Lemma Nmin_lt_3 :
- forall a b c, Nleb (Nmin b c) a = false -> Nleb b a = false.
+Lemma Nmin_lt_3 a b c : Nleb (N.min b c) a = false -> Nleb b a = false.
 Proof.
-  intros; rewrite Nmin_Nmin' in *.
-  unfold Nmin' in *. intros. elim (sumbool_of_bool (Nleb b c)). intro H0. rewrite H0 in H.
-  assumption.
-  intro H0. rewrite H0 in H. apply Nltb_trans with (b := c); assumption.
+  rewrite <- !not_true_iff_false, !Nleb_Nle.
+  rewrite N.min_le_iff; auto.
 Qed.
 
-Lemma Nmin_lt_4 :
- forall a b c, Nleb (Nmin b c) a = false -> Nleb c a = false.
+Lemma Nmin_lt_4 a b c : Nleb (N.min b c) a = false -> Nleb c a = false.
 Proof.
-  intros; rewrite Nmin_Nmin' in *.
-  unfold Nmin' in *. elim (sumbool_of_bool (Nleb b c)). intro H0. rewrite H0 in H.
-  apply Nltb_leb_trans with (b := b); assumption.
-  intro H0. rewrite H0 in H. assumption.
+  rewrite <- !not_true_iff_false, !Nleb_Nle.
+  rewrite N.min_le_iff; auto.
 Qed.
diff --git a/theories/NArith/Ndigits.v b/theories/NArith/Ndigits.v
index 6b490dfc..4ea8e1d4 100644
--- a/theories/NArith/Ndigits.v
+++ b/theories/NArith/Ndigits.v
@@ -1,343 +1,276 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*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 (compat "8.3").
+Notation Nxor := N.lxor (compat "8.3").
+Notation Pbit := Pos.testbit_nat (compat "8.3").
+Notation Nbit := N.testbit_nat (compat "8.3").
 
-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 (compat "8.3").
+Notation Nxor_comm := N.lxor_comm (compat "8.3").
+Notation Nxor_assoc := N.lxor_assoc (compat "8.3").
+Notation Nxor_neutral_left := N.lxor_0_l (compat "8.3").
+Notation Nxor_neutral_right := N.lxor_0_r (compat "8.3").
+Notation Nxor_nilpotent := N.lxor_nilpotent (compat "8.3").
 
-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) = Pos.testbit_nat 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 Nat2N.inj_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) = N.testbit_nat 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, Pos.testbit_nat 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, N.testbit_nat 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 Pos2Nat.inj_iter.
+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,
+  N.testbit_nat (N.shiftr_nat a n) m = N.testbit_nat 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 ->
+  N.testbit_nat (N.shiftl_nat a n) m = N.testbit_nat 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 ->
+ N.testbit_nat (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 [N.testbit_nat] *)
+
+Lemma Pxor_semantics p p' n :
+ N.testbit_nat (Pos.lxor p p') n = xorb (Pos.testbit_nat p n) (Pos.testbit_nat 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 :
+ N.testbit_nat (N.lxor a a') n = xorb (N.testbit_nat a n) (N.testbit_nat 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 :
+ Pos.testbit_nat (Pos.lor p p') n = (Pos.testbit_nat p n) || (Pos.testbit_nat 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 :
+ N.testbit_nat (N.lor a a') n = (N.testbit_nat a n) || (N.testbit_nat 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 :
+ N.testbit_nat (Pos.land p p') n = (Pos.testbit_nat p n) && (Pos.testbit_nat 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 :
+ N.testbit_nat (N.land a a') n = (N.testbit_nat a n) && (N.testbit_nat 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 :
+ N.testbit_nat (Pos.ldiff p p') n = (Pos.testbit_nat p n) && negb (Pos.testbit_nat 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 :
+ N.testbit_nat (N.ldiff a a') n = (N.testbit_nat a n) && negb (N.testbit_nat 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, ~(Pos.testbit_nat 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', Pos.testbit_nat p == Pos.testbit_nat 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', N.testbit_nat n == N.testbit_nat 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', N.testbit_nat n == N.testbit_nat 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 (compat "8.3").
 
-Definition Nodd (n:N) := Nbit0 n = true.
-Definition Neven (n:N) := Nbit0 n = false.
+Definition Nodd (n:N) := N.odd n = true.
+Definition Neven (n:N) := N.odd n = false.
 
-Lemma Nbit0_correct : forall n:N, Nbit n 0 = Nbit0 n.
+Lemma Nbit0_correct : forall n:N, N.testbit_nat n 0 = N.odd n.
 Proof.
   destruct n; trivial.
   destruct p; trivial.
 Qed.
 
-Lemma Ndouble_bit0 : forall n:N, Nbit0 (Ndouble n) = false.
+Lemma Ndouble_bit0 : forall n:N, N.odd (N.double n) = false.
 Proof.
   destruct n; trivial.
 Qed.
 
 Lemma Ndouble_plus_one_bit0 :
- forall n:N, Nbit0 (Ndouble_plus_one n) = true.
+ forall n:N, N.odd (N.succ_double n) = true.
 Proof.
   destruct n; trivial.
 Qed.
 
 Lemma Ndiv2_double :
- forall n:N, Neven n -> Ndouble (Ndiv2 n) = n.
+ forall n:N, Neven n -> N.double (N.div2 n) = n.
 Proof.
   destruct n. trivial. destruct p. intro H. discriminate H.
   intros. reflexivity.
@@ -345,7 +278,7 @@ Proof.
 Qed.
 
 Lemma Ndiv2_double_plus_one :
- forall n:N, Nodd n -> Ndouble_plus_one (Ndiv2 n) = n.
+ forall n:N, Nodd n -> N.succ_double (N.div2 n) = n.
 Proof.
   destruct n. intro. discriminate H.
   destruct p. intros. reflexivity.
@@ -354,134 +287,136 @@ Proof.
 Qed.
 
 Lemma Ndiv2_correct :
- forall (a:N) (n:nat), Nbit (Ndiv2 a) n = Nbit a (S n).
+ forall (a:N) (n:nat), N.testbit_nat (N.div2 a) n = N.testbit_nat a (S n).
 Proof.
   destruct a; trivial.
   destruct p; trivial.
 Qed.
 
 Lemma Nxor_bit0 :
- forall a a':N, Nbit0 (Nxor a a') = xorb (Nbit0 a) (Nbit0 a').
+ forall a a':N, N.odd (N.lxor a a') = xorb (N.odd a) (N.odd 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 :
- forall a a':N, Ndiv2 (Nxor a a') = Nxor (Ndiv2 a) (Ndiv2 a').
+ forall a a':N, N.div2 (N.lxor a a') = N.lxor (N.div2 a) (N.div2 a').
 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 (Nxor_semantics (N.div2 a) (N.div2 a') n), Ndiv2_correct, (Nxor_semantics a a' (S n)).
+  rewrite 2! Ndiv2_correct.
   reflexivity.
 Qed.
 
 Lemma Nneg_bit0 :
  forall a a':N,
-   Nbit0 (Nxor a a') = true -> Nbit0 a = negb (Nbit0 a').
+   N.odd (N.lxor a a') = true -> N.odd a = negb (N.odd 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.
 
 Lemma Nneg_bit0_1 :
- forall a a':N, Nxor a a' = Npos 1 -> Nbit0 a = negb (Nbit0 a').
+ forall a a':N, N.lxor a a' = Npos 1 -> N.odd a = negb (N.odd a').
 Proof.
   intros. apply Nneg_bit0. rewrite H. reflexivity.
 Qed.
 
 Lemma Nneg_bit0_2 :
  forall (a a':N) (p:positive),
-   Nxor a a' = Npos (xI p) -> Nbit0 a = negb (Nbit0 a').
+   N.lxor a a' = Npos (xI p) -> N.odd a = negb (N.odd a').
 Proof.
   intros. apply Nneg_bit0. rewrite H. reflexivity.
 Qed.
 
 Lemma Nsame_bit0 :
  forall (a a':N) (p:positive),
-   Nxor a a' = Npos (xO p) -> Nbit0 a = Nbit0 a'.
+   N.lxor a a' = Npos (xO p) -> N.odd a = N.odd a'.
 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.
+  intros. rewrite <- (xorb_false (N.odd a)).
+  assert (H0: N.odd (Npos (xO p)) = false) by reflexivity.
+  rewrite <- H0, <- H, Nxor_bit0, <- xorb_assoc, xorb_nilpotent, false_xorb.
+    reflexivity.
 Qed.
 
 (** a lexicographic order on bits, starting from the lowest bit *)
 
 Fixpoint Nless_aux (a a':N) (p:positive) : bool :=
   match p with
-  | xO p' => Nless_aux (Ndiv2 a) (Ndiv2 a') p'
-  | _ => andb (negb (Nbit0 a)) (Nbit0 a')
+  | xO p' => Nless_aux (N.div2 a) (N.div2 a') p'
+  | _ => andb (negb (N.odd a)) (N.odd a')
   end.
 
 Definition Nless (a a':N) :=
-  match Nxor a a' with
+  match N.lxor a a' with
   | N0 => false
   | Npos p => Nless_aux a a' p
   end.
 
 Lemma Nbit0_less :
  forall a a',
-   Nbit0 a = false -> Nbit0 a' = true -> Nless a a' = true.
+   N.odd a = false -> N.odd a' = true -> Nless a a' = true.
 Proof.
-  intros. destruct (Ndiscr (Nxor a a')) as [(p,H2)|H1]. unfold Nless.
+  intros. destruct (N.discr (N.lxor a a')) as [(p,H2)|H1]. unfold Nless.
   rewrite H2. destruct p. simpl. rewrite H, H0. reflexivity.
-  assert (H1: Nbit0 (Nxor a a') = false) by (rewrite H2; reflexivity).
+  assert (H1: N.odd (N.lxor a a') = false) by (rewrite H2; reflexivity).
   rewrite (Nxor_bit0 a a'), H, H0 in H1. discriminate H1.
   simpl. rewrite H, H0. reflexivity.
-  assert (H2: Nbit0 (Nxor a a') = false) by (rewrite H1; reflexivity).
+  assert (H2: N.odd (N.lxor a a') = false) by (rewrite H1; reflexivity).
   rewrite (Nxor_bit0 a a'), H, H0 in H2. discriminate H2.
 Qed.
 
 Lemma Nbit0_gt :
  forall a a',
-   Nbit0 a = true -> Nbit0 a' = false -> Nless a a' = false.
+   N.odd a = true -> N.odd a' = false -> Nless a a' = false.
 Proof.
-  intros. destruct (Ndiscr (Nxor a a')) as [(p,H2)|H1]. unfold Nless.
+  intros. destruct (N.discr (N.lxor a a')) as [(p,H2)|H1]. unfold Nless.
   rewrite H2. destruct p. simpl. rewrite H, H0. reflexivity.
-  assert (H1: Nbit0 (Nxor a a') = false) by (rewrite H2; reflexivity).
+  assert (H1: N.odd (N.lxor a a') = false) by (rewrite H2; reflexivity).
   rewrite (Nxor_bit0 a a'), H, H0 in H1. discriminate H1.
   simpl. rewrite H, H0. reflexivity.
-  assert (H2: Nbit0 (Nxor a a') = false) by (rewrite H1; reflexivity).
+  assert (H2: N.odd (N.lxor a a') = false) by (rewrite H1; reflexivity).
   rewrite (Nxor_bit0 a a'), H, H0 in H2. discriminate H2.
 Qed.
 
 Lemma Nless_not_refl : forall a, Nless a a = false.
 Proof.
-  intro. unfold Nless. rewrite (Nxor_nilpotent a). reflexivity.
+  intro. unfold Nless. rewrite (N.lxor_nilpotent a). reflexivity.
 Qed.
 
 Lemma Nless_def_1 :
- forall a a', Nless (Ndouble a) (Ndouble a') = Nless a a'.
+ forall a a', Nless (N.double a) (N.double a') = Nless a a'.
 Proof.
   destruct a; destruct a'. reflexivity.
   trivial.
   unfold Nless. simpl. destruct p; trivial.
-  unfold Nless. simpl. destruct (Pxor p p0). reflexivity.
+  unfold Nless. simpl. destruct (Pos.lxor p p0). reflexivity.
   trivial.
 Qed.
 
 Lemma Nless_def_2 :
  forall a a',
-   Nless (Ndouble_plus_one a) (Ndouble_plus_one a') = Nless a a'.
+   Nless (N.succ_double a) (N.succ_double a') = Nless a a'.
 Proof.
   destruct a; destruct a'. reflexivity.
   trivial.
   unfold Nless. simpl. destruct p; trivial.
-  unfold Nless. simpl. destruct (Pxor p p0). reflexivity.
+  unfold Nless. simpl. destruct (Pos.lxor p p0). reflexivity.
   trivial.
 Qed.
 
 Lemma Nless_def_3 :
- forall a a', Nless (Ndouble a) (Ndouble_plus_one a') = true.
+ forall a a', Nless (N.double a) (N.succ_double a') = true.
 Proof.
   intros. apply Nbit0_less. apply Ndouble_bit0.
   apply Ndouble_plus_one_bit0.
 Qed.
 
 Lemma Nless_def_4 :
- forall a a', Nless (Ndouble_plus_one a) (Ndouble a') = false.
+ forall a a', Nless (N.succ_double a) (N.double a') = false.
 Proof.
   intros. apply Nbit0_gt. apply Ndouble_plus_one_bit0.
   apply Ndouble_bit0.
@@ -490,7 +425,7 @@ Qed.
 Lemma Nless_z : forall a, Nless a N0 = false.
 Proof.
   induction a. reflexivity.
-  unfold Nless. rewrite (Nxor_neutral_right (Npos p)). induction p; trivial.
+  unfold Nless. rewrite (N.lxor_0_r (Npos p)). induction p; trivial.
 Qed.
 
 Lemma N0_less_1 :
@@ -510,26 +445,26 @@ Lemma Nless_trans :
  forall a a' a'',
    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.
-    induction a' as [|a' _|a' _] using N_ind_double.
-      rewrite (Nless_z (Ndouble a)) in H. discriminate H.
+  induction a as [|a IHa|a IHa] using N.binary_ind; intros a' a'' H H0.
+    case_eq (Nless N0 a'') ; intros Heqn. trivial.
+     rewrite (N0_less_2 a'' Heqn), (Nless_z a') in H0. discriminate H0.
+    induction a' as [|a' _|a' _] using N.binary_ind.
+      rewrite (Nless_z (N.double a)) in H. discriminate H.
       rewrite (Nless_def_1 a a') in H.
-       induction a'' using N_ind_double.
-         rewrite (Nless_z (Ndouble a')) in H0. discriminate H0.
+       induction a'' using N.binary_ind.
+         rewrite (Nless_z (N.double a')) in H0. discriminate H0.
          rewrite (Nless_def_1 a' a'') in H0. rewrite (Nless_def_1 a a'').
           exact (IHa _ _ H H0).
          apply Nless_def_3.
-      induction a'' as [|a'' _|a'' _] using N_ind_double.
-        rewrite (Nless_z (Ndouble_plus_one a')) in H0. discriminate H0.
+      induction a'' as [|a'' _|a'' _] using N.binary_ind.
+        rewrite (Nless_z (N.succ_double a')) in H0. discriminate H0.
         rewrite (Nless_def_4 a' a'') in H0. discriminate H0.
         apply Nless_def_3.
-    induction a' as [|a' _|a' _] using N_ind_double.
-      rewrite (Nless_z (Ndouble_plus_one a)) in H. discriminate H.
+    induction a' as [|a' _|a' _] using N.binary_ind.
+      rewrite (Nless_z (N.succ_double a)) in H. discriminate H.
       rewrite (Nless_def_4 a a') in H. discriminate H.
-      induction a'' using N_ind_double.
-        rewrite (Nless_z (Ndouble_plus_one a')) in H0. discriminate H0.
+      induction a'' using N.binary_ind.
+        rewrite (Nless_z (N.succ_double a')) in H0. discriminate H0.
         rewrite (Nless_def_4 a' a'') in H0. discriminate H0.
         rewrite (Nless_def_2 a' a'') in H0. rewrite (Nless_def_2 a a') in H.
           rewrite (Nless_def_2 a a''). exact (IHa _ _ H H0).
@@ -538,17 +473,17 @@ Qed.
 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.
+  induction a using N.binary_rec; intro a'.
+    case_eq (Nless N0 a') ; intros Heqb. left. left. auto.
      right. rewrite (N0_less_2 a' Heqb). reflexivity.
-    induction a' as [|a' _|a' _] using N_rec_double.
-      destruct (Nless N0 (Ndouble a)) as []_eqn:Heqb. left. right. auto.
+    induction a' as [|a' _|a' _] using N.binary_rec.
+      case_eq (Nless N0 (N.double a)) ; intros Heqb. left. right. auto.
        right. exact (N0_less_2 _  Heqb).
       rewrite 2!Nless_def_1. destruct (IHa a') as [ | ->].
         left. assumption.
         right. reflexivity.
     left. left. apply Nless_def_3.
-    induction a' as [|a' _|a' _] using N_rec_double.
+    induction a' as [|a' _|a' _] using N.binary_rec.
       left. right. destruct a; reflexivity.
       left. right. apply Nless_def_3.
       rewrite 2!Nless_def_2. destruct (IHa a') as [ | ->].
@@ -558,32 +493,28 @@ 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 (compat "8.3").
 
 (** conversions between N and bit vectors. *)
 
-Fixpoint P2Bv (p:positive) : Bvector (Psize p) :=
- match p return Bvector (Psize p) with
+Fixpoint P2Bv (p:positive) : Bvector (Pos.size_nat p) :=
+ match p return Bvector (Pos.size_nat p) with
    | xH => Bvect_true 1%nat
-   | xO p => Bcons false (Psize p) (P2Bv p)
-   | xI p => Bcons true (Psize p) (P2Bv p)
+   | xO p => Bcons false (Pos.size_nat p) (P2Bv p)
+   | xI p => Bcons true (Pos.size_nat p) (P2Bv p)
  end.
 
-Definition N2Bv (n:N) : Bvector (Nsize n) :=
-  match n as n0 return Bvector (Nsize n0) with
+Definition N2Bv (n:N) : Bvector (N.size_nat n) :=
+  match n as n0 return Bvector (N.size_nat n0) with
     | N0 => Bnil
     | Npos p => P2Bv p
   end.
 
 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 => N.double (Bv2N n bv)
+    | Vector.cons true n bv => N.succ_double (Bv2N n bv)
   end.
 
 Lemma Bv2N_N2Bv : forall n, Bv2N _ (N2Bv n) = n.
@@ -597,15 +528,14 @@ Qed.
   bit vector has some zeros on its right, they will disappear during
   the return [Bv2N] translation: *)
 
-Lemma Bv2N_Nsize : forall n (bv:Bvector n), Nsize (Bv2N n bv) <= n.
+Lemma Bv2N_Nsize : forall n (bv:Bvector n), N.size_nat (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
@@ -613,17 +543,12 @@ Qed.
 
 Lemma Bv2N_Nsize_1 : forall n (bv:Bvector (S n)),
   Bsign _ bv = true <->
-  Nsize (Bv2N _ bv) = (S n).
+  N.size_nat (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
@@ -642,7 +567,7 @@ Fixpoint N2Bv_gen (n:nat)(a:N) : Bvector n :=
 
 (** The first [N2Bv] is then a special case of [N2Bv_gen] *)
 
-Lemma N2Bv_N2Bv_gen : forall (a:N), N2Bv a = N2Bv_gen (Nsize a) a.
+Lemma N2Bv_N2Bv_gen : forall (a:N), N2Bv a = N2Bv_gen (N.size_nat a) a.
 Proof.
 destruct a; simpl.
 auto.
@@ -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 (N.size_nat a + k) a = Vector.append (N2Bv a) (Bvect_false k).
 Proof.
 destruct a; simpl.
 destruct k; simpl; auto.
@@ -665,49 +590,43 @@ 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.
 
 (** accessing some precise bits. *)
 
 Lemma Nbit0_Blow : forall n, forall (bv:Bvector (S n)),
-  Nbit0 (Bv2N _ bv) = Blow _ bv.
+  N.odd (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 = N.testbit_nat (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.
+Lemma Nbit_Nsize : forall n p, N.size_nat n <= p -> N.testbit_nat n p = false.
 Proof.
 destruct n as [|n].
 simpl; auto.
@@ -716,26 +635,31 @@ 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 < N.size_nat n),
+  N.testbit_nat 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').
+  Bv2N _ (BVxor _ bv bv') = N.lxor (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..ce4f7663 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-2012     *)
 (*   \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.
@@ -35,12 +33,12 @@ Definition Nplength (a:N) :=
 Lemma Nplength_infty : forall a:N, Nplength a = infty -> a = N0.
 Proof.
   simple induction a; trivial.
-  unfold Nplength in |- *; intros; discriminate H.
+  unfold Nplength; intros; discriminate H.
 Qed.
 
 Lemma Nplength_zeros :
  forall (a:N) (n:nat),
-   Nplength a = ni n -> forall k:nat, k < n -> Nbit a k = false.
+   Nplength a = ni n -> forall k:nat, k < n -> N.testbit_nat a k = false.
 Proof.
   simple induction a; trivial.
   simple induction p. simple induction n. intros. inversion H1.
@@ -48,33 +46,33 @@ Proof.
   intros. simpl in H1. discriminate H1.
   simple induction k. trivial.
   generalize H0. case n. intros. inversion H3.
-  intros. simpl in |- *. unfold Nbit in H. apply (H n0). simpl in H1. inversion H1. reflexivity.
+  intros. simpl. unfold N.testbit_nat in H. apply (H n0). simpl in H1. inversion H1. reflexivity.
   exact (lt_S_n n1 n0 H3).
-  simpl in |- *. intros n H. inversion H. intros. inversion H0.
+  simpl. intros n H. inversion H. intros. inversion H0.
 Qed.
 
 Lemma Nplength_one :
- forall (a:N) (n:nat), Nplength a = ni n -> Nbit a n = true.
+ forall (a:N) (n:nat), Nplength a = ni n -> N.testbit_nat a n = true.
 Proof.
   simple induction a. intros. inversion H.
   simple induction p. intros. simpl in H0. inversion H0. reflexivity.
-  intros. simpl in H0. inversion H0. simpl in |- *. unfold Nbit in H. apply H. reflexivity.
+  intros. simpl in H0. inversion H0. simpl. unfold N.testbit_nat in H. apply H. reflexivity.
   intros. simpl in H. inversion H. reflexivity.
 Qed.
 
 Lemma Nplength_first_one :
  forall (a:N) (n:nat),
-   (forall k:nat, k < n -> Nbit a k = false) ->
-   Nbit a n = true -> Nplength a = ni n.
+   (forall k:nat, k < n -> N.testbit_nat a k = false) ->
+   N.testbit_nat a n = true -> Nplength a = ni n.
 Proof.
   simple induction a. intros. simpl in H0. discriminate H0.
   simple induction p. intros. generalize H0. case n. intros. reflexivity.
-  intros. absurd (Nbit (Npos (xI p0)) 0 = false). trivial with bool.
+  intros. absurd (N.testbit_nat (Npos (xI p0)) 0 = false). trivial with bool.
   auto with bool arith.
   intros. generalize H0 H1. case n. intros. simpl in H3. discriminate H3.
-  intros. simpl in |- *. unfold Nplength in H.
+  intros. simpl. unfold Nplength in H.
   cut (ni (Pplength p0) = ni n0). intro. inversion H4. reflexivity.
-  apply H. intros. change (Nbit (Npos (xO p0)) (S k) = false) in |- *. apply H2. apply lt_n_S. exact H4.
+  apply H. intros. change (N.testbit_nat (Npos (xO p0)) (S k) = false). apply H2. apply lt_n_S. exact H4.
   exact H3.
   intro. case n. trivial.
   intros. simpl in H0. discriminate H0.
@@ -92,10 +90,10 @@ Definition ni_min (d d':natinf) :=
 Lemma ni_min_idemp : forall d:natinf, ni_min d d = d.
 Proof.
   simple induction d; trivial.
-  unfold ni_min in |- *.
+  unfold ni_min.
   simple induction n; trivial.
   intros.
-  simpl in |- *.
+  simpl.
   inversion H.
   rewrite H1.
   rewrite H1.
@@ -107,7 +105,7 @@ Proof.
   simple induction d. simple induction d'; trivial.
   simple induction d'; trivial. elim n. simple induction n0; trivial.
   intros. elim n1; trivial. intros. unfold ni_min in H. cut (min n0 n2 = min n2 n0).
-  intro. unfold ni_min in |- *. simpl in |- *. rewrite H1. reflexivity.
+  intro. unfold ni_min. simpl. rewrite H1. reflexivity.
   cut (ni (min n0 n2) = ni (min n2 n0)). intros.
   inversion H1; trivial.
   exact (H n2).
@@ -118,11 +116,11 @@ Lemma ni_min_assoc :
 Proof.
   simple induction d; trivial. simple induction d'; trivial.
   simple induction d''; trivial.
-  unfold ni_min in |- *. intro. cut (min (min n n0) n1 = min n (min n0 n1)).
+  unfold ni_min. intro. cut (min (min n n0) n1 = min n (min n0 n1)).
   intro. rewrite H. reflexivity.
   generalize n0 n1. elim n; trivial.
   simple induction n3; trivial. simple induction n5; trivial.
-  intros. simpl in |- *. auto.
+  intros. simpl. auto.
 Qed.
 
 Lemma ni_min_O_l : forall d:natinf, ni_min (ni 0) d = ni 0.
@@ -154,42 +152,42 @@ Qed.
 
 Lemma ni_le_antisym : forall d d':natinf, ni_le d d' -> ni_le d' d -> d = d'.
 Proof.
-  unfold ni_le in |- *. intros d d'. rewrite ni_min_comm. intro H. rewrite H. trivial.
+  unfold ni_le. intros d d'. rewrite ni_min_comm. intro H. rewrite H. trivial.
 Qed.
 
 Lemma ni_le_trans :
  forall d d' d'':natinf, ni_le d d' -> ni_le d' d'' -> ni_le d d''.
 Proof.
-  unfold ni_le in |- *. intros. rewrite <- H. rewrite ni_min_assoc. rewrite H0. reflexivity.
+  unfold ni_le. intros. rewrite <- H. rewrite ni_min_assoc. rewrite H0. reflexivity.
 Qed.
 
 Lemma ni_le_min_1 : forall d d':natinf, ni_le (ni_min d d') d.
 Proof.
-  unfold ni_le in |- *. intros. rewrite (ni_min_comm d d'). rewrite ni_min_assoc.
+  unfold ni_le. intros. rewrite (ni_min_comm d d'). rewrite ni_min_assoc.
   rewrite ni_min_idemp. reflexivity.
 Qed.
 
 Lemma ni_le_min_2 : forall d d':natinf, ni_le (ni_min d d') d'.
 Proof.
-  unfold ni_le in |- *. intros. rewrite ni_min_assoc. rewrite ni_min_idemp. reflexivity.
+  unfold ni_le. intros. rewrite ni_min_assoc. rewrite ni_min_idemp. reflexivity.
 Qed.
 
 Lemma ni_min_case : forall d d':natinf, ni_min d d' = d \/ ni_min d d' = d'.
 Proof.
   simple induction d. intro. right. exact (ni_min_inf_l d').
   simple induction d'. left. exact (ni_min_inf_r (ni n)).
-  unfold ni_min in |- *. cut (forall n0:nat, min n n0 = n \/ min n n0 = n0).
+  unfold ni_min. cut (forall n0:nat, min n n0 = n \/ min n n0 = n0).
   intros. case (H n0). intro. left. rewrite H0. reflexivity.
   intro. right. rewrite H0. reflexivity.
   elim n. intro. left. reflexivity.
   simple induction n1. right. reflexivity.
-  intros. case (H n2). intro. left. simpl in |- *. rewrite H1. reflexivity.
-  intro. right. simpl in |- *. rewrite H1. reflexivity.
+  intros. case (H n2). intro. left. simpl. rewrite H1. reflexivity.
+  intro. right. simpl. rewrite H1. reflexivity.
 Qed.
 
 Lemma ni_le_total : forall d d':natinf, ni_le d d' \/ ni_le d' d.
 Proof.
-  unfold ni_le in |- *. intros. rewrite (ni_min_comm d' d). apply ni_min_case.
+  unfold ni_le. intros. rewrite (ni_min_comm d' d). apply ni_min_case.
 Qed.
 
 Lemma ni_le_min_induc :
@@ -203,7 +201,7 @@ Proof.
   apply ni_le_antisym. apply H1. apply ni_le_refl.
   exact H2.
   exact H.
-  intro. rewrite H2. apply ni_le_antisym. apply H1. unfold ni_le in |- *. rewrite ni_min_comm. exact H2.
+  intro. rewrite H2. apply ni_le_antisym. apply H1. unfold ni_le. rewrite ni_min_comm. exact H2.
   apply ni_le_refl.
   exact H0.
 Qed.
@@ -211,40 +209,40 @@ Qed.
 Lemma le_ni_le : forall m n:nat, m <= n -> ni_le (ni m) (ni n).
 Proof.
   cut (forall m n:nat, m <= n -> min m n = m).
-  intros. unfold ni_le, ni_min in |- *. rewrite (H m n H0). reflexivity.
+  intros. unfold ni_le, ni_min. rewrite (H m n H0). reflexivity.
   simple induction m. trivial.
   simple induction n0. intro. inversion H0.
-  intros. simpl in |- *. rewrite (H n1 (le_S_n n n1 H1)). reflexivity.
+  intros. simpl. rewrite (H n1 (le_S_n n n1 H1)). reflexivity.
 Qed.
 
 Lemma ni_le_le : forall m n:nat, ni_le (ni m) (ni n) -> m <= n.
 Proof.
-  unfold ni_le in |- *. unfold ni_min in |- *. intros. inversion H. apply le_min_r.
+  unfold ni_le. unfold ni_min. intros. inversion H. apply le_min_r.
 Qed.
 
 Lemma Nplength_lb :
  forall (a:N) (n:nat),
-   (forall k:nat, k < n -> Nbit a k = false) -> ni_le (ni n) (Nplength a).
+   (forall k:nat, k < n -> N.testbit_nat a k = false) -> ni_le (ni n) (Nplength a).
 Proof.
   simple induction a. intros. exact (ni_min_inf_r (ni n)).
-  intros. unfold Nplength in |- *. apply le_ni_le. case (le_or_lt n (Pplength p)). trivial.
-  intro. absurd (Nbit (Npos p) (Pplength p) = false).
+  intros. unfold Nplength. apply le_ni_le. case (le_or_lt n (Pplength p)). trivial.
+  intro. absurd (N.testbit_nat (Npos p) (Pplength p) = false).
   rewrite
    (Nplength_one (Npos p) (Pplength p)
-      (refl_equal (Nplength (Npos p)))).
+      (eq_refl (Nplength (Npos p)))).
   discriminate.
   apply H. exact H0.
 Qed.
 
 Lemma Nplength_ub :
- forall (a:N) (n:nat), Nbit a n = true -> ni_le (Nplength a) (ni n).
+ forall (a:N) (n:nat), N.testbit_nat a n = true -> ni_le (Nplength a) (ni n).
 Proof.
   simple induction a. intros. discriminate H.
-  intros. unfold Nplength in |- *. apply le_ni_le. case (le_or_lt (Pplength p) n). trivial.
-  intro. absurd (Nbit (Npos p) n = true).
+  intros. unfold Nplength. apply le_ni_le. case (le_or_lt (Pplength p) n). trivial.
+  intro. absurd (N.testbit_nat (Npos p) n = true).
   rewrite
    (Nplength_zeros (Npos p) (Pplength p)
-      (refl_equal (Nplength (Npos p))) n H0).
+      (eq_refl (Nplength (Npos p))) n H0).
   discriminate.
   exact H.
 Qed.
@@ -257,26 +255,26 @@ Qed.
     Instead of working with $d$, we work with $pd$, namely
     [Npdist]: *)
 
-Definition Npdist (a a':N) := Nplength (Nxor a a').
+Definition Npdist (a a':N) := Nplength (N.lxor a a').
 
 (** d is a distance, so $d(a,a')=0$ iff $a=a'$; this means that
     $pd(a,a')=infty$ iff $a=a'$: *)
 
 Lemma Npdist_eq_1 : forall a:N, Npdist a a = infty.
 Proof.
-  intros. unfold Npdist in |- *. rewrite Nxor_nilpotent. reflexivity.
+  intros. unfold Npdist. rewrite N.lxor_nilpotent. reflexivity.
 Qed.
 
 Lemma Npdist_eq_2 : forall a a':N, Npdist a a' = infty -> a = a'.
 Proof.
-  intros. apply Nxor_eq. apply Nplength_infty. exact H.
+  intros. apply N.lxor_eq. apply Nplength_infty. exact H.
 Qed.
 
 (** $d$ is a distance, so $d(a,a')=d(a',a)$: *)
 
 Lemma Npdist_comm : forall a a':N, Npdist a a' = Npdist a' a.
 Proof.
-  unfold Npdist in |- *. intros. rewrite Nxor_comm. reflexivity.
+  unfold Npdist. intros. rewrite N.lxor_comm. reflexivity.
 Qed.
 
 (** $d$ is an ultrametric distance, that is, not only $d(a,a')\leq
@@ -294,21 +292,21 @@ Qed.
 Lemma Nplength_ultra_1 :
  forall a a':N,
    ni_le (Nplength a) (Nplength a') ->
-   ni_le (Nplength a) (Nplength (Nxor a a')).
+   ni_le (Nplength a) (Nplength (N.lxor a a')).
 Proof.
   simple induction a. intros. unfold ni_le in H. unfold Nplength at 1 3 in H.
   rewrite (ni_min_inf_l (Nplength a')) in H.
-  rewrite (Nplength_infty a' H). simpl in |- *. apply ni_le_refl.
-  intros. unfold Nplength at 1 in |- *. apply Nplength_lb. intros.
-  cut (forall a'':N, Nxor (Npos p) a' = a'' -> Nbit a'' k = false).
+  rewrite (Nplength_infty a' H). simpl. apply ni_le_refl.
+  intros. unfold Nplength at 1. apply Nplength_lb. intros.
+  cut (forall a'':N, N.lxor (Npos p) a' = a'' -> N.testbit_nat a'' k = false).
   intros. apply H1. reflexivity.
   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).
+      (eq_refl (Nplength (Npos p))) k H0).
   generalize H. case a'. trivial.
-  intros. cut (Nbit (Npos p1) k = false). intros. rewrite H3. reflexivity.
+  intros. cut (N.testbit_nat (Npos p1) k = false). intros. rewrite H3. reflexivity.
   apply Nplength_zeros with (n := Pplength p1). reflexivity.
   apply (lt_le_trans k (Pplength p) (Pplength p1)). exact H0.
   apply ni_le_le. exact H2.
@@ -316,14 +314,14 @@ Qed.
 
 Lemma Nplength_ultra :
  forall a a':N,
-   ni_le (ni_min (Nplength a) (Nplength a')) (Nplength (Nxor a a')).
+   ni_le (ni_min (Nplength a) (Nplength a')) (Nplength (N.lxor a a')).
 Proof.
   intros. case (ni_le_total (Nplength a) (Nplength a')). intro.
   cut (ni_min (Nplength a) (Nplength a') = Nplength a).
   intro. rewrite H0. apply Nplength_ultra_1. exact H.
   exact H.
   intro. cut (ni_min (Nplength a) (Nplength a') = Nplength a').
-  intro. rewrite H0. rewrite Nxor_comm. apply Nplength_ultra_1. exact H.
+  intro. rewrite H0. rewrite N.lxor_comm. apply Nplength_ultra_1. exact H.
   rewrite ni_min_comm. exact H.
 Qed.
 
@@ -331,8 +329,8 @@ Lemma Npdist_ultra :
  forall a a' a'':N,
    ni_le (ni_min (Npdist a a'') (Npdist a'' a')) (Npdist a a').
 Proof.
-  intros. unfold Npdist in |- *. cut (Nxor (Nxor a a'') (Nxor a'' a') = Nxor a a').
+  intros. unfold Npdist. cut (N.lxor (N.lxor a a'') (N.lxor a'' a') = N.lxor a a').
   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
+  rewrite N.lxor_assoc. rewrite <- (N.lxor_assoc a'' a'' a'). rewrite N.lxor_nilpotent.
+  rewrite N.lxor_0_l. reflexivity.
+Qed.
diff --git a/theories/NArith/Ndiv_def.v b/theories/NArith/Ndiv_def.v
new file mode 100644
index 00000000..0b220f5d
--- /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-2012     *)
+(*   \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 (compat "8.3").
+Notation Ndiv := N.div (compat "8.3").
+Notation Nmod := N.modulo (compat "8.3").
+
+Notation Ndiv_eucl_correct := N.div_eucl_spec (compat "8.3").
+Notation Ndiv_mod_eq := N.div_mod' (compat "8.3").
+Notation Nmod_lt := N.mod_lt (compat "8.3").
diff --git a/theories/NArith/Ngcd_def.v b/theories/NArith/Ngcd_def.v
new file mode 100644
index 00000000..737cd450
--- /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-2012     *)
+(*   \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..1b7e2f24 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-2012     *)
 (*   \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 (compat "8.3").
+Notation N_of_nat_of_N := N2Nat.id (compat "8.3").
+Notation nat_of_Ndouble := N2Nat.inj_double (compat "8.3").
+Notation nat_of_Ndouble_plus_one := N2Nat.inj_succ_double (compat "8.3").
+Notation nat_of_Nsucc := N2Nat.inj_succ (compat "8.3").
+Notation nat_of_Nplus := N2Nat.inj_add (compat "8.3").
+Notation nat_of_Nmult := N2Nat.inj_mul (compat "8.3").
+Notation nat_of_Nminus := N2Nat.inj_sub (compat "8.3").
+Notation nat_of_Npred := N2Nat.inj_pred (compat "8.3").
+Notation nat_of_Ndiv2 := N2Nat.inj_div2 (compat "8.3").
+Notation nat_of_Ncompare := N2Nat.inj_compare (compat "8.3").
+Notation nat_of_Nmax := N2Nat.inj_max (compat "8.3").
+Notation nat_of_Nmin := N2Nat.inj_min (compat "8.3").
+
+Notation nat_of_N_of_nat := Nat2N.id (compat "8.3").
+Notation N_of_nat_inj := Nat2N.inj (compat "8.3").
+Notation N_of_double := Nat2N.inj_double (compat "8.3").
+Notation N_of_double_plus_one := Nat2N.inj_succ_double (compat "8.3").
+Notation N_of_S := Nat2N.inj_succ (compat "8.3").
+Notation N_of_pred := Nat2N.inj_pred (compat "8.3").
+Notation N_of_plus := Nat2N.inj_add (compat "8.3").
+Notation N_of_minus := Nat2N.inj_sub (compat "8.3").
+Notation N_of_mult := Nat2N.inj_mul (compat "8.3").
+Notation N_of_div2 := Nat2N.inj_div2 (compat "8.3").
+Notation N_of_nat_compare := Nat2N.inj_compare (compat "8.3").
+Notation N_of_min := Nat2N.inj_min (compat "8.3").
+Notation N_of_max := Nat2N.inj_max (compat "8.3").
diff --git a/lib/bstack.mli b/theories/NArith/Nsqrt_def.v
index 39a5202a..240d7469 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-2012     *)
 (*   \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 (compat "8.3").
+Notation Nsqrt := N.sqrt (compat "8.3").
+Notation Nsqrtrem_spec := N.sqrtrem_spec (compat "8.3").
+Notation Nsqrt_spec := (fun n => N.sqrt_spec n (N.le_0_l n)) (compat "8.3").
+Notation Nsqrtrem_sqrt := N.sqrtrem_sqrt (compat "8.3").
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..56d48eb5 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-2012     *)
 (*   \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
@@ -32,7 +30,7 @@ Declare ML Module "numbers_syntax_plugin".
 
 Local Open Scope Z_scope.
 
-(* For compatibility of scripts, weaker version of some lemmas of Zdiv *)
+(* For compatibility of scripts, weaker version of some lemmas of Z.div *)
 
 Lemma Zlt0_not_eq : forall n, 0<n -> n<>0.
 Proof.
@@ -45,22 +43,22 @@ Definition Z_div_plus_l a b c H := Zdiv.Z_div_plus_full_l a b c (Zlt0_not_eq _ H
 
 (* Automation *)
 
-Hint  Extern 2 (Zle _ _) =>
+Hint  Extern 2 (Z.le _ _) =>
  (match goal with
-   |- Zpos _ <= Zpos _ => exact (refl_equal _)
-|   H: _ <=  ?p |- _ <= ?p => apply Zle_trans with (2 := H)
-|   H: _ <  ?p |- _ <= ?p => apply Zlt_le_weak; apply Zle_lt_trans with (2 := H)
+   |- Zpos _ <= Zpos _ => exact (eq_refl _)
+|   H: _ <=  ?p |- _ <= ?p => apply Z.le_trans with (2 := H)
+|   H: _ <  ?p |- _ <= ?p => apply Z.lt_le_incl; apply Z.le_lt_trans with (2 := H)
   end).
 
-Hint  Extern 2 (Zlt _ _) =>
+Hint  Extern 2 (Z.lt _ _) =>
  (match goal with
-   |- Zpos _ < Zpos _ => exact (refl_equal _)
-|      H: _ <=  ?p |- _ <= ?p => apply Zlt_le_trans with (2 := H)
-|   H: _ <  ?p |- _ <= ?p => apply Zle_lt_trans with (2 := H)
+   |- Zpos _ < Zpos _ => exact (eq_refl _)
+|      H: _ <=  ?p |- _ <= ?p => apply Z.lt_le_trans with (2 := H)
+|   H: _ <  ?p |- _ <= ?p => apply Z.le_lt_trans with (2 := H)
   end).
 
 
-Hint Resolve Zlt_gt Zle_ge Z_div_pos: zarith.
+Hint Resolve Z.lt_gt Z.le_ge Z_div_pos: zarith.
 
 (**************************************
    Properties of order and product
@@ -73,9 +71,9 @@ Hint Resolve Zlt_gt Zle_ge Z_div_pos: zarith.
  Proof.
   intros a b c d beta H1 (H3, H4) (H5, H6).
   assert (a - c < 1); auto with zarith.
-  apply Zmult_lt_reg_r with beta; auto with zarith.
-  apply Zle_lt_trans with (d  - b); auto with zarith.
-  rewrite Zmult_minus_distr_r; auto with zarith.
+  apply Z.mul_lt_mono_pos_r with beta; auto with zarith.
+  apply Z.le_lt_trans with (d  - b); auto with zarith.
+  rewrite Z.mul_sub_distr_r; auto with zarith.
  Qed.
 
  Theorem beta_lex_inv: forall a b c d beta,
@@ -84,15 +82,15 @@ Hint Resolve Zlt_gt Zle_ge Z_div_pos: zarith.
       a * beta + b < c * beta  + d.
  Proof.
   intros a b c d beta H1 (H3, H4) (H5, H6).
-  case (Zle_or_lt (c * beta + d) (a * beta + b)); auto with zarith.
-  intros H7; contradict H1;apply Zle_not_lt;apply beta_lex with (1 := H7);auto.
+  case (Z.le_gt_cases (c * beta + d) (a * beta + b)); auto with zarith.
+  intros H7. contradict H1. apply Z.le_ngt. apply beta_lex with (1 := H7); auto.
  Qed.
 
  Lemma beta_mult : forall h l beta,
    0 <= h < beta -> 0 <= l < beta -> 0 <= h*beta+l < beta^2.
  Proof.
   intros h l beta H1 H2;split. auto with zarith.
-  rewrite <- (Zplus_0_r (beta^2)); rewrite Zpower_2;
+  rewrite <- (Z.add_0_r (beta^2)); rewrite Z.pow_2_r;
    apply beta_lex_inv;auto with zarith.
  Qed.
 
@@ -100,9 +98,9 @@ Hint Resolve Zlt_gt Zle_ge Z_div_pos: zarith.
    forall b x y, 0 <= x < b -> 0 <= y < b -> 0 <= x * y <= b^2 - 2*b + 1.
  Proof.
   intros b x y (Hx1,Hx2) (Hy1,Hy2);split;auto with zarith.
-  apply Zle_trans with ((b-1)*(b-1)).
-  apply Zmult_le_compat;auto with zarith.
-  apply Zeq_le;ring.
+  apply Z.le_trans with ((b-1)*(b-1)).
+  apply Z.mul_le_mono_nonneg;auto with zarith.
+  apply Z.eq_le_incl; ring.
  Qed.
 
  Lemma sum_mul_carry : forall xh xl yh yl wc cc beta,
@@ -131,11 +129,10 @@ Hint Resolve Zlt_gt Zle_ge Z_div_pos: zarith.
  Proof.
   intros x y cross beta HH HH1 HH2.
   split; auto with zarith.
-  apply Zle_lt_trans with  ((beta-1)*(beta-1)+(beta-1)); auto with zarith.
-  apply Zplus_le_compat; auto with zarith.
-  apply Zmult_le_compat; auto with zarith.
-  repeat (rewrite Zmult_minus_distr_l || rewrite Zmult_minus_distr_r);
-  rewrite Zpower_2; auto with zarith.
+  apply Z.le_lt_trans with  ((beta-1)*(beta-1)+(beta-1)); auto with zarith.
+  apply Z.add_le_mono; auto with zarith.
+  apply Z.mul_le_mono_nonneg; auto with zarith.
+  rewrite ?Z.mul_sub_distr_l, ?Z.mul_sub_distr_r, Z.pow_2_r; auto with zarith.
  Qed.
 
  Theorem mult_add_ineq2: forall x y c cross beta,
@@ -146,11 +143,10 @@ Hint Resolve Zlt_gt Zle_ge Z_div_pos: zarith.
  Proof.
   intros x y c cross beta HH HH1 HH2.
   split; auto with zarith.
-  apply Zle_lt_trans with ((beta-1)*(beta-1)+(2*beta-2));auto with zarith.
-  apply Zplus_le_compat; auto with zarith.
-  apply Zmult_le_compat; auto with zarith.
-  repeat (rewrite Zmult_minus_distr_l || rewrite Zmult_minus_distr_r);
-   rewrite Zpower_2; auto with zarith.
+  apply Z.le_lt_trans with ((beta-1)*(beta-1)+(2*beta-2));auto with zarith.
+  apply Z.add_le_mono; auto with zarith.
+  apply Z.mul_le_mono_nonneg; auto with zarith.
+  rewrite ?Z.mul_sub_distr_l, ?Z.mul_sub_distr_r, Z.pow_2_r; auto with zarith.
  Qed.
 
 Theorem mult_add_ineq3: forall x y c cross beta,
@@ -163,20 +159,20 @@ Theorem mult_add_ineq3: forall x y c cross beta,
   intros x y c cross beta HH HH1 HH2 HH3.
   apply mult_add_ineq2;auto with zarith.
   split;auto with zarith.
-  apply Zle_trans with (1*beta+cross);auto with zarith.
+  apply Z.le_trans with (1*beta+cross);auto with zarith.
  Qed.
 
-Hint Rewrite Zmult_1_r Zmult_0_r Zmult_1_l Zmult_0_l Zplus_0_l Zplus_0_r Zminus_0_r: rm10.
+Hint Rewrite Z.mul_1_r Z.mul_0_r Z.mul_1_l Z.mul_0_l Z.add_0_l Z.add_0_r Z.sub_0_r: rm10.
 
 
 (**************************************
- Properties of Zdiv and Zmod
+ Properties of Z.div and Z.modulo
 **************************************)
 
 Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a.
  Proof.
   intros a b H H1;case (Z_mod_lt a b);auto with zarith;intros H2 H3;split;auto.
-  case (Zle_or_lt b a); intros H4; auto with zarith.
+  case (Z.le_gt_cases b a); intros H4; auto with zarith.
   rewrite Zmod_small; auto with zarith.
  Qed.
 
@@ -186,26 +182,26 @@ Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a.
  Proof.
   intros a b r t (H1, H2) H3 (H4, H5).
   assert (t < 2 ^ b).
-  apply Zlt_le_trans with (1:= H5); auto with zarith.
+  apply Z.lt_le_trans with (1:= H5); auto with zarith.
   apply Zpower_le_monotone; auto with zarith.
   rewrite Zplus_mod; auto with zarith.
   rewrite Zmod_small with (a := t); auto with zarith.
   apply Zmod_small; auto with zarith.
   split; auto with zarith.
   assert (0 <= 2 ^a * r); auto with zarith.
-  apply Zplus_le_0_compat; auto with zarith.
+  apply Z.add_nonneg_nonneg; auto with zarith.
   match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end;
    auto with zarith.
   pattern (2 ^ b) at 2; replace (2 ^ b) with ((2 ^ b - 2 ^a) + 2 ^ a);
     try ring.
-  apply Zplus_le_lt_compat; auto with zarith.
+  apply Z.add_le_lt_mono; auto with zarith.
   replace b with ((b - a) + a); try ring.
   rewrite Zpower_exp; auto with zarith.
-  pattern (2 ^a) at 4; rewrite <- (Zmult_1_l (2 ^a));
-   try rewrite <- Zmult_minus_distr_r.
-  rewrite (Zmult_comm (2 ^(b - a))); rewrite  Zmult_mod_distr_l;
+  pattern (2 ^a) at 4; rewrite <- (Z.mul_1_l (2 ^a));
+   try rewrite <- Z.mul_sub_distr_r.
+  rewrite (Z.mul_comm (2 ^(b - a))); rewrite  Zmult_mod_distr_l;
    auto with zarith.
-  rewrite (Zmult_comm (2 ^a)); apply Zmult_le_compat_r; auto with zarith.
+  rewrite (Z.mul_comm (2 ^a)); apply Z.mul_le_mono_nonneg_r; auto with zarith.
   match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end;
    auto with zarith.
  Qed.
@@ -216,25 +212,25 @@ Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a.
  Proof.
   intros a b r t (H1, H2) H3 (H4, H5).
   assert (t < 2 ^ b).
-  apply Zlt_le_trans with (1:= H5); auto with zarith.
+  apply Z.lt_le_trans with (1:= H5); auto with zarith.
   apply Zpower_le_monotone; auto with zarith.
   rewrite Zplus_mod; auto with zarith.
   rewrite Zmod_small with (a := t); auto with zarith.
   apply Zmod_small; auto with zarith.
   split; auto with zarith.
   assert (0 <= 2 ^a * r); auto with zarith.
-  apply Zplus_le_0_compat; auto with zarith.
+  apply Z.add_nonneg_nonneg; auto with zarith.
   match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end;
    auto with zarith.
   pattern (2 ^ b) at 2;replace (2 ^ b) with ((2 ^ b - 2 ^a) + 2 ^ a); try ring.
-  apply Zplus_le_lt_compat; auto with zarith.
+  apply Z.add_le_lt_mono; auto with zarith.
   replace b with ((b - a) + a); try ring.
   rewrite Zpower_exp; auto with zarith.
-  pattern (2 ^a) at 4; rewrite <- (Zmult_1_l (2 ^a));
-   try rewrite <- Zmult_minus_distr_r.
-  repeat rewrite (fun x => Zmult_comm x (2 ^ a)); rewrite Zmult_mod_distr_l;
+  pattern (2 ^a) at 4; rewrite <- (Z.mul_1_l (2 ^a));
+   try rewrite <- Z.mul_sub_distr_r.
+  repeat rewrite (fun x => Z.mul_comm x (2 ^ a)); rewrite Zmult_mod_distr_l;
    auto with zarith.
-  apply Zmult_le_compat_l; auto with zarith.
+  apply Z.mul_le_mono_nonneg_l; auto with zarith.
   match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end;
    auto with zarith.
  Qed.
@@ -245,13 +241,13 @@ Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a.
   Proof.
    intros a b r t (H1, H2) H3 (H4, H5).
    assert (Eq: t < 2 ^ b); auto with zarith.
-   apply Zlt_le_trans with (1 := H5); auto with zarith.
+   apply Z.lt_le_trans with (1 := H5); auto with zarith.
    apply Zpower_le_monotone; auto with zarith.
    pattern (r * 2 ^ a) at 1; rewrite Z_div_mod_eq with (b := 2 ^ b);
     auto with zarith.
-   rewrite <- Zplus_assoc.
+   rewrite <- Z.add_assoc.
    rewrite <- Zmod_shift_r; auto with zarith.
-   rewrite (Zmult_comm (2 ^ b)); rewrite Z_div_plus_full_l; auto with zarith.
+   rewrite (Z.mul_comm (2 ^ b)); rewrite Z_div_plus_full_l; auto with zarith.
    rewrite (fun x y => @Zdiv_small (x mod y)); auto with zarith.
    match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end;
     auto with zarith.
@@ -266,7 +262,7 @@ Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a.
   intros n p a H1 H2.
   pattern (a*2^p) at 1;replace (a*2^p) with
      (a*2^p/2^n * 2^n + a*2^p mod 2^n).
-  2:symmetry;rewrite (Zmult_comm (a*2^p/2^n));apply Z_div_mod_eq.
+  2:symmetry;rewrite (Z.mul_comm (a*2^p/2^n));apply Z_div_mod_eq.
   replace (a * 2 ^ p / 2 ^ n) with (a / 2 ^ (n - p));trivial.
   replace (2^n) with (2^(n-p)*2^p).
   symmetry;apply Zdiv_mult_cancel_r.
@@ -275,7 +271,7 @@ Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a.
   rewrite <- Zpower_exp.
   replace (n-p+p) with n;trivial. ring.
   omega. omega.
-  apply Zlt_gt. apply Zpower_gt_0;auto with zarith.
+  apply Z.lt_gt. apply Z.pow_pos_nonneg;auto with zarith.
  Qed.
 
 
@@ -286,15 +282,15 @@ Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a.
  intros.
  rewrite Zmod_small.
  rewrite Zmod_eq by (auto with zarith).
- unfold Zminus at 1.
+ unfold Z.sub at 1.
  rewrite Z_div_plus_l by (auto with zarith).
  assert (2^n = 2^(n-p)*2^p).
   rewrite <- Zpower_exp by (auto with zarith).
   replace (n-p+p) with n; auto with zarith.
  rewrite H0.
  rewrite <- Zdiv_Zdiv, Z_div_mult by (auto with zarith).
- rewrite (Zmult_comm (2^(n-p))), Zmult_assoc.
- rewrite Zopp_mult_distr_l.
+ rewrite (Z.mul_comm (2^(n-p))), Z.mul_assoc.
+ rewrite <- Z.mul_opp_l.
  rewrite Z_div_mult by (auto with zarith).
  symmetry; apply Zmod_eq; auto with zarith.
 
@@ -303,9 +299,9 @@ Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a.
  split.
  apply Z_div_pos; auto with zarith.
  apply Zdiv_lt_upper_bound; auto with zarith.
- apply Zlt_le_trans with (2^n); auto with zarith.
- rewrite <- (Zmult_1_r (2^n)) at 1.
- apply Zmult_le_compat; auto with zarith.
+ apply Z.lt_le_trans with (2^n); auto with zarith.
+ rewrite <- (Z.mul_1_r (2^n)) at 1.
+ apply Z.mul_le_mono_nonneg; auto with zarith.
  cut (0 < 2 ^ (n-p)); auto with zarith.
  Qed.
 
@@ -315,31 +311,29 @@ 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.
  Proof.
   intros p x y H;destruct (Z_le_gt_dec 0 p).
   apply Zdiv_lt_upper_bound;auto with zarith.
-  apply Zlt_le_trans with y;auto with zarith.
-  rewrite <- (Zmult_1_r y);apply Zmult_le_compat;auto with zarith.
+  apply Z.lt_le_trans with y;auto with zarith.
+  rewrite <- (Z.mul_1_r y);apply Z.mul_le_mono_nonneg;auto with zarith.
   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:
-   0 < b -> 0 < Zgcd a b -> 0 < b / Zgcd a b.
+   0 < b -> 0 < Z.gcd a b -> 0 < b / Z.gcd a b.
  Proof.
- intros Ha Hg.
- case (Zle_lt_or_eq 0 (b/Zgcd a b)); auto.
- apply Z_div_pos; auto with zarith.
- intros H; generalize Ha.
- pattern b at 1; rewrite (Zdivide_Zdiv_eq (Zgcd a b) b); auto.
- rewrite <- H; auto with zarith.
- assert (F := (Zgcd_is_gcd a b)); inversion F; auto.
+ intros Hb Hg.
+ assert (H : 0 <= b / Z.gcd a b) by (apply Z.div_pos; auto with zarith).
+ Z.le_elim H; trivial.
+ rewrite (Zdivide_Zdiv_eq (Z.gcd a b) b), <- H, Z.mul_0_r in Hb;
+  auto using Z.gcd_divide_r with zarith.
  Qed.
 
  Theorem Zdiv_neg a b:
@@ -349,7 +343,7 @@ Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a.
  assert (b > 0) by omega.
  generalize (Z_mult_div_ge a _ H); intros.
  assert (b * (a / b) < 0)%Z.
-  apply Zle_lt_trans with a; auto with zarith.
+  apply Z.le_lt_trans with a; auto with zarith.
  destruct b; try (compute in Hb; discriminate).
  destruct (a/Zpos p)%Z.
  compute in H1; discriminate.
@@ -357,20 +351,20 @@ Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a.
  compute; auto.
  Qed.
 
- Lemma Zdiv_gcd_zero : forall a b, b / Zgcd a b = 0 -> b <> 0 ->
-  Zgcd a b = 0.
+ Lemma Zdiv_gcd_zero : forall a b, b / Z.gcd a b = 0 -> b <> 0 ->
+  Z.gcd a b = 0.
  Proof.
  intros.
  generalize (Zgcd_is_gcd a b); destruct 1.
  destruct H2 as (k,Hk).
  generalize H; rewrite Hk at 1.
- destruct (Z_eq_dec (Zgcd a b) 0) as [H'|H']; auto.
+ destruct (Z.eq_dec (Z.gcd a b) 0) as [H'|H']; auto.
  rewrite Z_div_mult_full; auto.
  intros; subst k; simpl in *; subst b; elim H0; auto.
  Qed.
 
  Lemma Zgcd_mult_rel_prime : forall a b c,
-  Zgcd a c = 1 -> Zgcd b c = 1 -> Zgcd (a*b) c = 1.
+  Z.gcd a c = 1 -> Z.gcd b c = 1 -> Z.gcd (a*b) c = 1.
  Proof.
  intros.
  rewrite Zgcd_1_rel_prime in *.
@@ -398,23 +392,20 @@ intros Q b Q0 QS.
 set (Q' := fun n => (n < b /\ Q n) \/ (b <= n)).
 assert (H : forall n, 0 <= n -> Q' n).
 apply natlike_rec2; unfold Q'.
-destruct (Zle_or_lt b 0) as [H | H]. now right. left; now split.
+destruct (Z.le_gt_cases b 0) as [H | H]. now right. left; now split.
 intros n H IH. destruct IH as [[IH1 IH2] | IH].
-destruct (Zle_or_lt (b - 1) n) as [H1 | H1].
+destruct (Z.le_gt_cases (b - 1) n) as [H1 | H1].
 right; auto with zarith.
 left. split; [auto with zarith | now apply (QS n)].
 right; auto with zarith.
 unfold Q' in *; intros n H1 H2. destruct (H n H1) as [[H3 H4] | H3].
-assumption. apply Zle_not_lt in H3. false_hyp H2 H3.
+assumption. now apply Z.le_ngt in H3.
 Qed.
 
-Lemma Zsquare_le : forall x, x <= x*x.
+Lemma Zsquare_le x : x <= x*x.
 Proof.
-intros.
-destruct (Z_lt_le_dec 0 x).
-pattern x at 1; rewrite <- (Zmult_1_l x).
-apply Zmult_le_compat; auto with zarith.
-apply Zle_trans with 0; auto with zarith.
-rewrite <- Zmult_opp_opp.
-apply Zmult_le_0_compat; auto with zarith.
+destruct (Z.lt_ge_cases 0 x).
+- rewrite <- Z.mul_1_l at 1.
+  rewrite <- Z.mul_le_mono_pos_r; auto with zarith.
+- pose proof (Z.square_nonneg x); auto with zarith.
 Qed.
diff --git a/theories/Numbers/BinNums.v b/theories/Numbers/BinNums.v
new file mode 100644
index 00000000..aab2c14f
--- /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-2012     *)
+(*   \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..9a8a7691 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-2012     *)
 (*   \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).
-
- 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_mul_c       := w_op.(znz_mul_c).
- Let w_mul         := w_op.(znz_mul).
- Let w_square_c    := w_op.(znz_square_c).
-
- Let w_div21       := w_op.(znz_div21).
- Let w_div_gt      := w_op.(znz_div_gt).
- Let w_div         := w_op.(znz_div).
-
- 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).
+    sqrt2       : t -> t -> t * carry t;
+    sqrt        : t -> t  }.
 
- Let w_is_even     := w_op.(znz_is_even).
- Let w_sqrt2       := w_op.(znz_sqrt2).
- Let w_sqrt        := w_op.(znz_sqrt).
+ Section Specs.
+ Context {t : Type}{ops : Ops t}.
 
- Notation "[| x |]" := (w_to_Z x)  (at level 0, x at level 99).
+ Notation "[| x |]" := (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.
 
-(** Generic construction of double words *)
+ Arguments Specs {t} ops.
 
-Section WW.
+ (** Generic construction of double words *)
 
- Variable w : Type.
- Variable w_op : znz_op w.
- Variable op_spec : znz_spec w_op.
+ Section WW.
 
- 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).
+ Context {t : Type}{ops : Ops t}{specs : Specs ops}.
 
- Definition znz_W0 h :=
-  if w_eq0 h then W0 else WW h w_0.
+ Let wB := base digits.
 
- Definition znz_0W l :=
-  if w_eq0 l then W0 else WW w_0 l.
+ Definition WO' (eq0:t->bool) zero h :=
+  if eq0 h then W0 else WW h zero.
 
- Definition znz_WW h l :=
-  if w_eq0 h then znz_0W l else WW h l.
+ Definition WO := Eval lazy beta delta [WO'] in
+   let eq0 := ZnZ.eq0 in
+   let zero := ZnZ.zero in
+   WO' eq0 zero.
 
- Lemma spec_W0 : forall h,
-   zn2z_to_Z wB w_to_Z (znz_W0 h) = (w_to_Z h)*wB.
+ Definition OW' (eq0:t->bool) zero l :=
+  if eq0 l then W0 else WW zero l.
+
+ Definition OW := Eval lazy beta delta [OW'] in
+   let eq0 := ZnZ.eq0 in
+   let zero := ZnZ.zero in
+   OW' eq0 zero.
+
+ 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.
+ End WW.
 
-(** Injecting [Z] numbers into a cyclic structure *)
+ (** Injecting [Z] numbers into a cyclic structure *)
 
-Section znz_of_pos.
+ Section Of_Z.
 
- Variable w : Type.
- Variable w_op : znz_op w.
- Variable op_spec : znz_spec w_op.
+ Context {t : Type}{ops : Ops t}{specs : Specs ops}.
 
- Notation "[| x |]" := (znz_to_Z w_op x)  (at level 0, x at level 99).
+ Notation "[| x |]" := (to_Z x)  (at level 0, x at level 99).
 
- 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.
-
- 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.
+ intros p1 Hp1; contradict Hp; apply Z.le_ngt.
+ replace (base digits) with (1 * base digits + 0) by ring.
+ rewrite Hp1.
+ apply Z.add_le_mono.
+ apply Z.mul_le_mono_nonneg; 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 p1 (H1, _); contradict H1; apply Zlt_not_le; red; simpl; auto.
+ intros; rewrite of_pos_correct; auto with zarith.
+ intros p1 (H1, _); contradict H1; apply Z.lt_nge; 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,87 +325,78 @@ 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).
+intros. zify. rewrite Z.add_0_l.
+apply Zmod_small. apply ZnZ.spec_to_Z.
 Qed.
 
 Lemma add_comm : forall x y, x + y == y + x.
 Proof.
-intros. zify. now rewrite Zplus_comm.
+intros. zify. now rewrite Z.add_comm.
 Qed.
 
 Lemma add_assoc : forall x y z, x + (y + z) == x + y + z.
 Proof.
-intros. zify. now rewrite Zplus_mod_idemp_r, Zplus_mod_idemp_l, Zplus_assoc.
+intros. zify. now rewrite Zplus_mod_idemp_r, Zplus_mod_idemp_l, Z.add_assoc.
 Qed.
 
 Lemma mul_1_l : forall x, 1 * x == x.
 Proof.
-intros. zify. rewrite Zmult_1_l.
-apply Zmod_small. apply w_spec.(spec_to_Z).
+intros. zify. rewrite Z.mul_1_l.
+apply Zmod_small. apply ZnZ.spec_to_Z.
 Qed.
 
 Lemma mul_comm : forall x y, x * y == y * x.
 Proof.
-intros. zify. now rewrite Zmult_comm.
+intros. zify. now rewrite Z.mul_comm.
 Qed.
 
 Lemma mul_assoc : forall x y z, x * (y * z) == x * y * z.
 Proof.
-intros. zify. now rewrite Zmult_mod_idemp_r, Zmult_mod_idemp_l, Zmult_assoc.
+intros. zify. now rewrite Zmult_mod_idemp_r, Zmult_mod_idemp_l, Z.mul_assoc.
 Qed.
 
 Lemma mul_add_distr_r : forall x y z, (x+y)*z == x*z + y*z.
 Proof.
-intros. zify. now rewrite <- Zplus_mod, Zmult_mod_idemp_l, Zmult_plus_distr_l.
+intros. zify. now rewrite <- Zplus_mod, Zmult_mod_idemp_l, Z.mul_add_distr_r.
 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].
-rewrite Z_mod_zero_opp_full, EQ, 2 Zplus_0_r; auto.
+intros. zify. rewrite <- Zminus_mod_idemp_r. unfold Z.sub.
+destruct (Z.eq_dec ([|y|] mod wB) 0) as [EQ|NEQ].
+rewrite Z_mod_zero_opp_full, EQ, 2 Z.add_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.
+intros. red. rewrite add_opp_r. zify. now rewrite Z.sub_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,16 @@ 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. generalize (w_spec.(spec_compare) x y).
- destruct (w_op.(znz_compare) x y); intuition; try discriminate.
+ intros. unfold eqb, eq.
+ rewrite ZnZ.spec_compare.
+ case Z.compare_spec; intuition; try discriminate.
 Qed.
 
 Lemma eqb_correct : forall x y, eqb x y = true -> x==y.
 Proof. now apply eqb_eq. Qed.
 
-End CyclicRing.
\ No newline at end of file
+End CyclicRing.
diff --git a/theories/Numbers/Cyclic/Abstract/NZCyclic.v b/theories/Numbers/Cyclic/Abstract/NZCyclic.v
index 92215ba9..1d5b78ec 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-2012     *)
 (*   \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,45 +47,29 @@ 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.
-unfold base. apply Zpower_gt_1; unfold Zlt; auto with zarith.
+unfold base. apply Zpower_gt_1; unfold Z.lt; auto with zarith.
 Qed.
 
 Theorem gt_wB_0 : 0 < wB.
@@ -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,51 +150,51 @@ 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 Z.add_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.
+rewrite <- (Z.add_assoc ([| n |] mod wB) 1 [| m |]). rewrite Zplus_mod_idemp_l.
+rewrite (Z.add_comm 1 [| m |]); now rewrite Z.add_assoc.
 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 Z.sub_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.
-now rewrite Zmult_plus_distr_l, Zmult_1_l.
+intros n m. zify. rewrite Zplus_mod_idemp_l, Zmult_mod_idemp_l.
+now rewrite Z.mul_add_distr_r, Z.mul_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..35d8b595 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-2012     *)
 (*   \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.
@@ -184,7 +182,7 @@ Section DoubleAdd.
    destruct x as [ |xh xl];simpl. apply spec_ww_1.
    generalize (spec_w_succ_c xl);destruct (w_succ_c xl) as [l|l];
     intro H;unfold interp_carry in H. simpl;rewrite H;ring.
-   rewrite <- Zplus_assoc;rewrite <- H;rewrite Zmult_1_l.
+   rewrite <- Z.add_assoc;rewrite <- H;rewrite Z.mul_1_l.
    assert ([|l|] = 0). generalize (spec_to_Z xl)(spec_to_Z l);omega.
    rewrite H0;generalize (spec_w_succ_c xh);destruct (w_succ_c xh) as [h|h];
     intro H1;unfold interp_carry in H1.
@@ -197,19 +195,19 @@ Section DoubleAdd.
   Lemma spec_ww_add_c  : forall x y, [+[ww_add_c x y]] = [[x]] + [[y]].
   Proof.
    destruct x as [ |xh xl];simpl;trivial.
-   destruct y as [ |yh yl];simpl. rewrite Zplus_0_r;trivial.
+   destruct y as [ |yh yl];simpl. rewrite Z.add_0_r;trivial.
    replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|]))
    with (([|xh|]+[|yh|])*wB + ([|xl|]+[|yl|])). 2:ring.
    generalize (spec_w_add_c xl yl);destruct (w_add_c xl yl) as [l|l];
     intros H;unfold interp_carry in H;rewrite <- H.
    generalize (spec_w_add_c xh yh);destruct (w_add_c xh yh) as [h|h];
     intros H1;unfold interp_carry in *;rewrite <- H1. trivial.
-   repeat rewrite Zmult_1_l;rewrite spec_w_WW;rewrite wwB_wBwB; ring.
-   rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l.
+   repeat rewrite Z.mul_1_l;rewrite spec_w_WW;rewrite wwB_wBwB; ring.
+   rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r.
    generalize (spec_w_add_carry_c xh yh);destruct (w_add_carry_c xh yh)
     as [h|h]; intros H1;unfold interp_carry in *;rewrite <- H1.
    simpl;ring.
-   repeat rewrite Zmult_1_l;rewrite wwB_wBwB;rewrite spec_w_WW;ring.
+   repeat rewrite Z.mul_1_l;rewrite wwB_wBwB;rewrite spec_w_WW;ring.
   Qed.
 
   Section Cont.
@@ -223,23 +221,23 @@ Section DoubleAdd.
     destruct x as [ |xh xl];simpl;trivial.
     apply spec_f0;trivial.
     destruct y as [ |yh yl];simpl.
-    apply spec_f0;simpl;rewrite Zplus_0_r;trivial.
+    apply spec_f0;simpl;rewrite Z.add_0_r;trivial.
     generalize (spec_w_add_c xl yl);destruct (w_add_c xl yl) as [l|l];
      intros H;unfold interp_carry in H.
     generalize (spec_w_add_c xh yh);destruct (w_add_c xh yh) as [h|h];
      intros H1;unfold interp_carry in *.
     apply spec_f0. simpl;rewrite H;rewrite H1;ring.
     apply spec_f1. simpl;rewrite spec_w_WW;rewrite H.
-    rewrite Zplus_assoc;rewrite wwB_wBwB. rewrite Zpower_2; rewrite <- Zmult_plus_distr_l.
-    rewrite Zmult_1_l in H1;rewrite H1;ring.
+    rewrite Z.add_assoc;rewrite wwB_wBwB. rewrite Z.pow_2_r; rewrite <- Z.mul_add_distr_r.
+    rewrite Z.mul_1_l in H1;rewrite H1;ring.
     generalize (spec_w_add_carry_c xh yh);destruct (w_add_carry_c xh yh)
      as [h|h]; intros H1;unfold interp_carry in *.
-    apply spec_f0;simpl;rewrite H1. rewrite Zmult_plus_distr_l.
-    rewrite <- Zplus_assoc;rewrite H;ring.
+    apply spec_f0;simpl;rewrite H1. rewrite Z.mul_add_distr_r.
+    rewrite <- Z.add_assoc;rewrite H;ring.
     apply spec_f1.  simpl;rewrite spec_w_WW;rewrite wwB_wBwB.
-    rewrite Zplus_assoc; rewrite Zpower_2; rewrite <- Zmult_plus_distr_l.
-    rewrite Zmult_1_l in H1;rewrite H1. rewrite Zmult_plus_distr_l.
-    rewrite <- Zplus_assoc;rewrite H;ring.
+    rewrite Z.add_assoc; rewrite Z.pow_2_r; rewrite <- Z.mul_add_distr_r.
+    rewrite Z.mul_1_l in H1;rewrite H1. rewrite Z.mul_add_distr_r.
+    rewrite <- Z.add_assoc;rewrite H;ring.
    Qed.
 
   End Cont.
@@ -250,19 +248,19 @@ Section DoubleAdd.
    destruct x as [ |xh xl];intro y;simpl.
    exact (spec_ww_succ_c y).
    destruct y as [ |yh yl];simpl.
-   rewrite Zplus_0_r;exact (spec_ww_succ_c (WW xh xl)).
+   rewrite Z.add_0_r;exact (spec_ww_succ_c (WW xh xl)).
    replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|]) + 1)
    with (([|xh|]+[|yh|])*wB + ([|xl|]+[|yl|]+1)). 2:ring.
    generalize (spec_w_add_carry_c xl yl);destruct (w_add_carry_c xl yl)
     as [l|l];intros H;unfold interp_carry in H;rewrite <- H.
    generalize (spec_w_add_c xh yh);destruct (w_add_c xh yh) as [h|h];
     intros H1;unfold interp_carry in H1;rewrite <- H1. trivial.
-   unfold interp_carry;repeat rewrite Zmult_1_l;simpl;rewrite wwB_wBwB;ring.
-   rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l.
+   unfold interp_carry;repeat rewrite Z.mul_1_l;simpl;rewrite wwB_wBwB;ring.
+   rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r.
    generalize (spec_w_add_carry_c xh yh);destruct (w_add_carry_c xh yh)
     as [h|h];intros H1;unfold interp_carry in H1;rewrite <- H1. trivial.
    unfold interp_carry;rewrite spec_w_WW;
-   repeat rewrite Zmult_1_l;simpl;rewrite wwB_wBwB;ring.
+   repeat rewrite Z.mul_1_l;simpl;rewrite wwB_wBwB;ring.
   Qed.
 
   Lemma spec_ww_succ : forall x, [[ww_succ x]] = ([[x]] + 1) mod wwB.
@@ -270,14 +268,14 @@ Section DoubleAdd.
    destruct x as [ |xh xl];simpl.
    rewrite spec_ww_1;rewrite Zmod_small;trivial.
    split;[intro;discriminate|apply wwB_pos].
-   rewrite <- Zplus_assoc;generalize (spec_w_succ_c xl);
+   rewrite <- Z.add_assoc;generalize (spec_w_succ_c xl);
    destruct (w_succ_c xl) as[l|l];intro H;unfold interp_carry in H;rewrite <-H.
    rewrite Zmod_small;trivial.
    rewrite wwB_wBwB;apply beta_mult;apply spec_to_Z.
    assert ([|l|] = 0). clear spec_ww_1 spec_w_1 spec_w_0.
     assert (H1:= spec_to_Z l); assert (H2:= spec_to_Z xl); omega.
-   rewrite H0;rewrite Zplus_0_r;rewrite <- Zmult_plus_distr_l;rewrite wwB_wBwB.
-   rewrite Zpower_2; rewrite Zmult_mod_distr_r;try apply lt_0_wB.
+   rewrite H0;rewrite Z.add_0_r;rewrite <- Z.mul_add_distr_r;rewrite wwB_wBwB.
+   rewrite Z.pow_2_r; rewrite Zmult_mod_distr_r;try apply lt_0_wB.
    rewrite spec_w_W0;rewrite spec_w_succ;trivial.
   Qed.
 
@@ -286,7 +284,7 @@ Section DoubleAdd.
    destruct x as [ |xh xl];intros y;simpl.
    rewrite Zmod_small;trivial. apply spec_ww_to_Z;trivial.
    destruct y as [ |yh yl].
-   change [[W0]] with 0;rewrite Zplus_0_r.
+   change [[W0]] with 0;rewrite Z.add_0_r.
    rewrite Zmod_small;trivial.
     exact (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW xh xl)).
    simpl. replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|]))
@@ -294,7 +292,7 @@ Section DoubleAdd.
    generalize (spec_w_add_c xl yl);destruct (w_add_c xl yl) as [l|l];
    unfold interp_carry;intros H;simpl;rewrite <- H.
    rewrite (mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_w_add;trivial.
-   rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l.
+   rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r.
    rewrite(mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_w_add_carry;trivial.
   Qed.
 
@@ -304,13 +302,13 @@ Section DoubleAdd.
    destruct x as [ |xh xl];intros y;simpl.
    exact (spec_ww_succ y).
    destruct y as [ |yh yl].
-   change [[W0]] with 0;rewrite Zplus_0_r. exact (spec_ww_succ (WW xh xl)).
+   change [[W0]] with 0;rewrite Z.add_0_r. exact (spec_ww_succ (WW xh xl)).
    simpl;replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|]) + 1)
    with (([|xh|]+[|yh|])*wB + ([|xl|]+[|yl|]+1)). 2:ring.
    generalize (spec_w_add_carry_c xl yl);destruct (w_add_carry_c xl yl)
    as [l|l];unfold interp_carry;intros H;rewrite <- H;simpl ww_to_Z.
    rewrite(mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_w_add;trivial.
-   rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l.
+   rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r.
    rewrite(mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_w_add_carry;trivial.
   Qed.
 
diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v
index 3d44f96b..ed69a8f5 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-2012     *)
 (*   \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,17 +161,13 @@ 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 = Z.compare [|x|] [|y|].
 
   Lemma wwB_wBwB : wwB = wB^2.
   Proof.
-   unfold base, ww_digits;rewrite Zpower_2; rewrite (Zpos_xO w_digits).
+   unfold base, ww_digits;rewrite Z.pow_2_r; rewrite (Pos2Z.inj_xO w_digits).
    replace (2 * Zpos w_digits) with (Zpos w_digits + Zpos w_digits).
-   apply Zpower_exp; unfold Zge;simpl;intros;discriminate.
+   apply Zpower_exp; unfold Z.ge;simpl;intros;discriminate.
    ring.
   Qed.
 
@@ -189,28 +179,28 @@ Section DoubleBase.
 
   Lemma lt_0_wB : 0 < wB.
   Proof.
-   unfold base;apply Zpower_gt_0. unfold Zlt;reflexivity.
-   unfold Zle;intros H;discriminate H.
+   unfold base;apply Z.pow_pos_nonneg. unfold Z.lt;reflexivity.
+   unfold Z.le;intros H;discriminate H.
   Qed.
 
   Lemma lt_0_wwB : 0 < wwB.
-  Proof. rewrite wwB_wBwB; rewrite Zpower_2; apply Zmult_lt_0_compat;apply lt_0_wB. Qed.
+  Proof. rewrite wwB_wBwB; rewrite Z.pow_2_r; apply Z.mul_pos_pos;apply lt_0_wB. Qed.
 
   Lemma wB_pos: 1 < wB.
   Proof.
-   unfold base;apply Zlt_le_trans with (2^1).  unfold Zlt;reflexivity.
-   apply Zpower_le_monotone.  unfold Zlt;reflexivity.
-   split;unfold Zle;intros H. discriminate H.
+   unfold base;apply Z.lt_le_trans with (2^1).  unfold Z.lt;reflexivity.
+   apply Zpower_le_monotone.  unfold Z.lt;reflexivity.
+   split;unfold Z.le;intros H. discriminate H.
    clear spec_w_0W w_0W spec_w_Bm1 spec_to_Z spec_w_WW w_WW.
    destruct w_digits; discriminate H.
   Qed.
 
   Lemma wwB_pos: 1 < wwB.
   Proof.
-   assert (H:= wB_pos);rewrite wwB_wBwB;rewrite <-(Zmult_1_r 1).
-   rewrite Zpower_2.
-   apply Zmult_lt_compat2;(split;[unfold Zlt;reflexivity|trivial]).
-   apply Zlt_le_weak;trivial.
+   assert (H:= wB_pos);rewrite wwB_wBwB;rewrite <-(Z.mul_1_r 1).
+   rewrite Z.pow_2_r.
+   apply Zmult_lt_compat2;(split;[unfold Z.lt;reflexivity|trivial]).
+   apply Z.lt_le_incl;trivial.
   Qed.
 
   Theorem wB_div_2:  2 * (wB / 2) = wB.
@@ -218,22 +208,22 @@ Section DoubleBase.
    clear spec_w_0 w_0 spec_w_1 w_1 spec_w_Bm1 w_Bm1 spec_w_WW spec_w_0W
     spec_to_Z;unfold base.
    assert (2 ^ Zpos w_digits = 2 * (2 ^ (Zpos w_digits - 1))).
-   pattern 2 at 2; rewrite <- Zpower_1_r.
+   pattern 2 at 2; rewrite <- Z.pow_1_r.
    rewrite <- Zpower_exp; auto with zarith.
    f_equal; auto with zarith.
    case w_digits; compute; intros; discriminate.
    rewrite H; f_equal; auto with zarith.
-   rewrite Zmult_comm; apply Z_div_mult; auto with zarith.
+   rewrite Z.mul_comm; apply Z_div_mult; auto with zarith.
   Qed.
 
   Theorem wwB_div_2 : wwB / 2 = wB / 2 * wB.
   Proof.
    clear spec_w_0 w_0 spec_w_1 w_1 spec_w_Bm1 w_Bm1 spec_w_WW spec_w_0W
     spec_to_Z.
-   rewrite wwB_wBwB; rewrite Zpower_2.
+   rewrite wwB_wBwB; rewrite Z.pow_2_r.
    pattern wB at 1; rewrite <- wB_div_2; auto.
-   rewrite <- Zmult_assoc.
-   repeat (rewrite (Zmult_comm 2); rewrite Z_div_mult); auto with zarith.
+   rewrite <- Z.mul_assoc.
+   repeat (rewrite (Z.mul_comm 2); rewrite Z_div_mult); auto with zarith.
   Qed.
 
   Lemma mod_wwB : forall z x,
@@ -241,15 +231,15 @@ Section DoubleBase.
   Proof.
    intros z x.
    rewrite Zplus_mod.
-   pattern wwB at 1;rewrite wwB_wBwB; rewrite Zpower_2.
+   pattern wwB at 1;rewrite wwB_wBwB; rewrite Z.pow_2_r.
    rewrite Zmult_mod_distr_r;try apply lt_0_wB.
    rewrite (Zmod_small [|x|]).
    apply Zmod_small;rewrite wwB_wBwB;apply beta_mult;try apply spec_to_Z.
-   apply Z_mod_lt;apply Zlt_gt;apply lt_0_wB.
+   apply Z_mod_lt;apply Z.lt_gt;apply lt_0_wB.
    destruct (spec_to_Z x);split;trivial.
    change [|x|] with (0*wB+[|x|]). rewrite wwB_wBwB.
-   rewrite Zpower_2;rewrite <- (Zplus_0_r (wB*wB));apply beta_lex_inv.
-   apply lt_0_wB. apply spec_to_Z. split;[apply Zle_refl | apply lt_0_wB].
+   rewrite Z.pow_2_r;rewrite <- (Z.add_0_r (wB*wB));apply beta_lex_inv.
+   apply lt_0_wB. apply spec_to_Z. split;[apply Z.le_refl | apply lt_0_wB].
  Qed.
 
   Lemma wB_div : forall x y, ([|x|] * wB + [|y|]) / wB = [|x|].
@@ -275,33 +265,32 @@ Section DoubleBase.
    clear spec_w_0 spec_w_1 spec_w_Bm1 w_0 w_1 w_Bm1.
    unfold base;apply Zpower_lt_monotone;auto with zarith.
    assert (0 < Zpos w_digits). compute;reflexivity.
-   unfold ww_digits;rewrite Zpos_xO;auto with zarith.
+   unfold ww_digits;rewrite Pos2Z.inj_xO;auto with zarith.
   Qed.
 
   Lemma w_to_Z_wwB : forall x, x < wB -> x < wwB.
   Proof.
-   intros x H;apply Zlt_trans with wB;trivial;apply lt_wB_wwB.
+   intros x H;apply Z.lt_trans with wB;trivial;apply lt_wB_wwB.
   Qed.
 
   Lemma spec_ww_to_Z : forall x, 0 <= [[x]] < wwB.
   Proof.
    clear spec_w_0 spec_w_1 spec_w_Bm1 w_0 w_1 w_Bm1.
    destruct x as [ |h l];simpl.
-   split;[apply Zle_refl|apply lt_0_wwB].
+   split;[apply Z.le_refl|apply lt_0_wwB].
    assert (H:=spec_to_Z h);assert (L:=spec_to_Z l);split.
-   apply Zplus_le_0_compat;auto with zarith.
-   rewrite <- (Zplus_0_r wwB);rewrite wwB_wBwB; rewrite Zpower_2;
+   apply Z.add_nonneg_nonneg;auto with zarith.
+   rewrite <- (Z.add_0_r wwB);rewrite wwB_wBwB; rewrite Z.pow_2_r;
     apply beta_lex_inv;auto with zarith.
   Qed.
 
   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, (Pos2Z.inj_xO (_ << _)).
+   replace  (2 * Zpos (w_digits << n)) with
+     (Zpos (w_digits << n) + Zpos (w_digits << n)) by ring.
    symmetry; apply Zpower_exp;intro;discriminate.
-   ring.
   Qed.
 
   Lemma double_wB_pos:
@@ -315,16 +304,16 @@ 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.
-  apply Zmult_le_compat; auto with zarith.
-  apply Zle_trans with wB; auto with zarith.
-  unfold base.
-  rewrite <- (Zpower_0_r 2).
-  apply Zpower_le_monotone2; auto with zarith.
+  apply Z.le_trans with (wB * 1).
+    rewrite Z.mul_1_r; apply Z.le_refl.
   unfold base; auto with zarith.
+  apply Z.mul_le_mono_nonneg; auto with zarith.
+  apply Z.le_trans with wB; auto with zarith.
+  unfold base.
+  rewrite <- (Z.pow_0_r 2).
+  apply Z.pow_le_mono_r; auto with zarith.
   Qed.
 
   Lemma spec_double_to_Z :
@@ -337,9 +326,9 @@ Section DoubleBase.
   unfold double_wB,base;split;auto with zarith.
   assert (U0:= IHn w0);assert (U1:= IHn w1).
   split;auto with zarith.
-  apply Zlt_le_trans with ((double_wB n - 1) * double_wB n + double_wB n).
+  apply Z.lt_le_trans with ((double_wB n - 1) * double_wB n + double_wB n).
   assert (double_to_Z n w0*double_wB n <= (double_wB n - 1)*double_wB n).
-  apply Zmult_le_compat_r;auto with zarith.
+  apply Z.mul_le_mono_nonneg_r;auto with zarith.
   auto with zarith.
   rewrite <- double_wB_wwB.
   replace ((double_wB n - 1) * double_wB n + double_wB n) with (double_wB n * double_wB n);
@@ -353,22 +342,19 @@ Section DoubleBase.
   clear spec_w_1 spec_w_Bm1.
   intros n; elim n; auto; clear n.
   intros n Hrec x; case x; clear x; auto.
-  intros xx yy H1; simpl in H1.
-  assert (F1: [!n | xx!] = 0).
-    case (Zle_lt_or_eq 0 ([!n | xx!])); auto.
-      case (spec_double_to_Z n xx); auto.
-     intros F2.
-     assert (F3 := double_wB_more_digits n).
-    assert (F4: 0 <= [!n | yy!]).
-      case (spec_double_to_Z n yy); auto.
+  intros xx yy; simpl.
+  destruct (spec_double_to_Z n xx) as [F1 _]. Z.le_elim F1.
+  - (* 0 < [!n | xx!] *)
+    intros; exfalso.
+    assert (F3 := double_wB_more_digits n).
+    destruct (spec_double_to_Z n yy) as [F4 _].
     assert (F5: 1 * wB <=  [!n | xx!] * double_wB n);
      auto with zarith.
-    apply Zmult_le_compat; auto with zarith.
+    apply Z.mul_le_mono_nonneg; auto with zarith.
     unfold base; auto with zarith.
-  simpl get_low; simpl double_to_Z.
-  generalize H1; clear H1.
-  rewrite F1; rewrite Zmult_0_l; rewrite Zplus_0_l.
-  intros H1; apply Hrec; auto.
+  - (* 0 = [!n | xx!] *)
+    rewrite <- F1; rewrite Z.mul_0_l, Z.add_0_l.
+    intros; apply Hrec; auto.
   Qed.
 
   Lemma spec_double_WW : forall n (h l : word w n),
@@ -408,35 +394,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 Z.lt_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 = Z.compare [[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 (Z.compare_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 Z.lt_nge; 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 (Z.compare_spec [|xh|] 0) as [H|H|H].
+   rewrite H;simpl;reflexivity.
+   absurd (0 <= [|xh|]). apply Z.lt_nge; 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 (Z.compare_spec [|xh|] [|yh|]) as [H|H|H].
+   rewrite H.
+   symmetry. apply Z.add_compare_mono_l.
+   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..35fe948e 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-2012     *)
 (*   \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.
 
@@ -392,20 +390,21 @@ Section Z_2nZ.
  Proof. refine (spec_ww_to_Z w_digits w_to_Z _);auto. Qed.
 
  Let spec_ww_of_pos : forall p,
-     Zpos p = (Z_of_N (fst (ww_of_pos p)))*wwB + [|(snd (ww_of_pos p))|].
+     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.
-  symmetry. rewrite <- Zpower_2; exact (wwB_wBwB w_digits).
+  unfold wB,w_to_Z,w_digits;destruct n;ring.
+  symmetry. rewrite <- Z.pow_2_r; exact (wwB_wBwB w_digits).
  Qed.
 
  Let spec_ww_0 : [|W0|] = 0.
@@ -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 = Z.compare [|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,24 +571,21 @@ 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.
-  intros w0; rewrite Zmult_1_l; simpl.
-  unfold w_to_Z, w_1; rewrite spec_1; auto with zarith.
-  rewrite Zmult_1_l; auto.
+  unfold w_0; rewrite ZnZ.spec_0; simpl; auto with zarith.
+  intros w0; rewrite Z.mul_1_l; simpl.
+  unfold w_to_Z, w_1; rewrite ZnZ.spec_1; auto with zarith.
+  rewrite Z.mul_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 Z.add_comm; rewrite Z_mod_plus; auto with zarith.
   rewrite Zmod_small; auto with zarith.
   unfold wB, base; auto with zarith.
  Qed.
@@ -608,8 +596,8 @@ 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 Zpos_xO; auto with zarith.
+ rewrite ZnZ.spec_zdigits; auto.
+ rewrite Pos2Z.inj_xO; auto with zarith.
  Qed.
 
 
@@ -617,10 +605,9 @@ Section Z_2nZ.
  Proof.
  refine (spec_ww_head00 w_0 w_0W
                 w_compare w_head0 w_add2 w_zdigits _ww_zdigits
-                w_to_Z _ _ _ (refl_equal _ww_digits) _ _ _ _); auto.
- exact (spec_compare op_spec).
- exact (spec_head00 op_spec).
- exact (spec_zdigits op_spec).
+                w_to_Z _ _ _ (eq_refl _ww_digits) _ _ _ _); auto.
+ exact ZnZ.spec_head00.
+ exact ZnZ.spec_zdigits.
  Qed.
 
  Let spec_ww_head0  : forall x,  0 < [|x|] ->
@@ -629,18 +616,16 @@ 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.
  Proof.
  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).
+                w_to_Z _ _ _ (eq_refl _ww_digits) _ _ _ _); wwauto.
+ 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_digits _ _ ).
+ exact ZnZ.spec_is_even.
  Qed.
 
  Let spec_ww_sqrt2 : forall x y,
@@ -781,78 +760,72 @@ 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 <- Zpos_xO; exact spec_ww_digits.
+  rewrite ZnZ.spec_zdigits.
+  rewrite <- Pos2Z.inj_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 <- Zpos_xO; exact spec_ww_digits.
+  rewrite ZnZ.spec_zdigits.
+  rewrite <- Pos2Z.inj_xO; exact spec_ww_digits.
  Qed.
 
 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..8525b0e1 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-2012     *)
 (*   \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 = Z.compare [[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 Z.compare_spec;
     rewrite spec_w_0W; rewrite spec_zdigits; fold wB;
     intros H1.
    rewrite H1; simpl ww_to_Z.
@@ -123,19 +117,19 @@ Section POS_MOD.
      rewrite spec_low.
      apply Zmod_small; auto with zarith.
      case (spec_to_w_Z p); intros HHH1 HHH2; split; auto with zarith.
-     apply Zlt_le_trans with (1 := H1).
+     apply Z.lt_le_trans with (1 := H1).
      unfold base; apply Zpower2_le_lin; auto with zarith.
    rewrite HH0.
    rewrite Zplus_mod; auto with zarith.
    unfold base.
    rewrite <- (F0 (Zpos w_digits) [[p]]).
    rewrite Zpower_exp; auto with zarith.
-   rewrite Zmult_assoc.
+   rewrite Z.mul_assoc.
    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 Z.compare_spec; rewrite spec_ww_zdigits;
                      rewrite spec_zdigits; intros H2.
   replace (2^[[p]]) with wwB.
     rewrite Zmod_small; auto with zarith.
@@ -149,52 +143,52 @@ generalize (spec_ww_compare p ww_zdigits);
     rewrite <- Zmod_div_mod; auto with zarith.
     rewrite Zmod_small; auto with zarith.
     split; auto with zarith.
-    apply Zlt_le_trans with (Zpos w_digits); auto with zarith.
+    apply Z.lt_le_trans with (Zpos w_digits); auto with zarith.
     unfold base; apply Zpower2_le_lin; auto with zarith.
     exists wB; unfold base; rewrite <- Zpower_exp; auto with zarith.
     rewrite spec_ww_digits;
-      apply f_equal with (f := Zpower 2); rewrite Zpos_xO; auto with zarith.
+      apply f_equal with (f := Z.pow 2); rewrite Pos2Z.inj_xO; auto with zarith.
    simpl ww_to_Z; autorewrite with w_rewrite.
    rewrite spec_pos_mod; rewrite HH0.
    pattern [|xh|] at 2;
      rewrite Z_div_mod_eq with (b := 2 ^ ([[p]] - Zpos w_digits));
      auto with zarith.
-   rewrite (fun x => (Zmult_comm (2 ^ x))); rewrite Zmult_plus_distr_l.
-   unfold base; rewrite <- Zmult_assoc; rewrite <- Zpower_exp;
+   rewrite (fun x => (Z.mul_comm (2 ^ x))); rewrite Z.mul_add_distr_r.
+   unfold base; rewrite <- Z.mul_assoc; rewrite <- Zpower_exp;
     auto with zarith.
    rewrite F0; auto with zarith.
-   rewrite <- Zplus_assoc; rewrite Zplus_mod; auto with zarith.
+   rewrite <- Z.add_assoc; rewrite Zplus_mod; auto with zarith.
    rewrite Z_mod_mult; auto with zarith.
    autorewrite with rm10.
    rewrite Zmod_mod; auto with zarith.
-   apply sym_equal; apply Zmod_small; auto with zarith.
+   symmetry; apply Zmod_small; auto with zarith.
    case (spec_to_Z xh); intros U1 U2.
    case (spec_to_Z xl); intros U3 U4.
    split; auto with zarith.
-   apply Zplus_le_0_compat; auto with zarith.
-   apply Zmult_le_0_compat; auto with zarith.
+   apply Z.add_nonneg_nonneg; auto with zarith.
+   apply Z.mul_nonneg_nonneg; auto with zarith.
    match goal with |- 0 <= ?X mod ?Y =>
     case (Z_mod_lt X Y); auto with zarith
    end.
    match goal with |- ?X mod ?Y * ?U + ?Z < ?T =>
-    apply Zle_lt_trans with ((Y - 1) * U + Z );
+    apply Z.le_lt_trans with ((Y - 1) * U + Z );
      [case (Z_mod_lt X Y); auto with zarith | idtac]
    end.
    match goal with |- ?X * ?U + ?Y < ?Z =>
-    apply Zle_lt_trans with (X * U + (U - 1))
+    apply Z.le_lt_trans with (X * U + (U - 1))
    end.
-   apply Zplus_le_compat_l; auto with zarith.
+   apply Z.add_le_mono_l; auto with zarith.
    case (spec_to_Z xl); unfold base; auto with zarith.
-   rewrite Zmult_minus_distr_r; rewrite <- Zpower_exp; auto with zarith.
+   rewrite Z.mul_sub_distr_r; rewrite <- Zpower_exp; auto with zarith.
    rewrite F0; auto with zarith.
   rewrite Zmod_small; auto with zarith.
   case (spec_to_w_Z (WW xh xl)); intros U1 U2.
   split; auto with zarith.
-  apply Zlt_le_trans with (1:= U2).
+  apply Z.lt_le_trans with (1:= U2).
   unfold base; rewrite spec_ww_digits.
   apply Zpower_le_monotone; auto with zarith.
   split; auto with zarith.
-  rewrite Zpos_xO; auto with zarith.
+  rewrite Pos2Z.inj_xO; auto with zarith.
  Qed.
 
 End POS_MOD.
@@ -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 = Z.compare [|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.
@@ -301,14 +290,14 @@ Section DoubleDiv32.
    assert (H:= spec_ww_to_Z w_digits w_to_Z spec_to_Z x).
 
   Theorem wB_div2: forall x, wB/2  <= x -> wB <= 2 * x.
-   intros x H; rewrite <- wB_div_2; apply Zmult_le_compat_l; auto with zarith.
+   intros x H; rewrite <- wB_div_2; apply Z.mul_le_mono_nonneg_l; auto with zarith.
   Qed.
 
   Lemma Zmult_lt_0_reg_r_2 : forall n m : Z, 0 <= n -> 0 < m * n -> 0 < m.
   Proof.
-   intros n m H1 H2;apply Zmult_lt_0_reg_r with n;trivial.
-   destruct (Zle_lt_or_eq _ _ H1);trivial.
-   subst;rewrite Zmult_0_r in H2;discriminate H2.
+   intros n m H1 H2;apply Z.mul_pos_cancel_r with n;trivial.
+   Z.le_elim H1; trivial.
+   subst;rewrite Z.mul_0_r in H2;discriminate H2.
   Qed.
 
   Theorem spec_w_div32 : forall a1 a2 a3 b1 b2,
@@ -322,7 +311,7 @@ Section DoubleDiv32.
    intros a1 a2 a3 b1 b2 Hle Hlt.
    assert (U:= lt_0_wB w_digits); assert (U1:= lt_0_wwB w_digits).
    Spec_w_to_Z a1;Spec_w_to_Z a2;Spec_w_to_Z a3;Spec_w_to_Z b1;Spec_w_to_Z b2.
-   rewrite wwB_wBwB; rewrite Zpower_2; rewrite Zmult_assoc;rewrite <- Zmult_plus_distr_l.
+   rewrite wwB_wBwB; rewrite Z.pow_2_r; rewrite Z.mul_assoc;rewrite <- Z.mul_add_distr_r.
    change (w_div32 a1 a2 a3 b1 b2) with
     match w_compare a1 b1 with
     | Lt =>
@@ -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 Z.compare_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).
@@ -362,17 +351,17 @@ Section DoubleDiv32.
    rewrite H0;intros r.
    repeat
     (rewrite spec_ww_add;eauto || rewrite spec_w_Bm1 || rewrite spec_w_Bm2);
-   simpl ww_to_Z;try rewrite Zmult_1_l;intros H1.
+   simpl ww_to_Z;try rewrite Z.mul_1_l;intros H1.
    assert (0<= ([[r]] + ([|b1|] * wB + [|b2|])) - wwB < [|b1|] * wB + [|b2|]).
    Spec_ww_to_Z r;split;zarith.
    rewrite H1.
    assert (H12:= wB_div2 Hle). assert (wwB <= 2 * [|b1|] * wB).
-   rewrite wwB_wBwB; rewrite Zpower_2; zarith.
+   rewrite wwB_wBwB; rewrite Z.pow_2_r; zarith.
    assert (-wwB < ([|a2|] - [|b2|]) * wB + [|a3|] < 0).
-   split. apply Zlt_le_trans with (([|a2|] - [|b2|]) * wB);zarith.
+   split. apply Z.lt_le_trans with (([|a2|] - [|b2|]) * wB);zarith.
    rewrite wwB_wBwB;replace (-(wB^2)) with (-wB*wB);[zarith | ring].
-   apply Zmult_lt_compat_r;zarith.
-   apply Zle_lt_trans with (([|a2|] - [|b2|]) * wB + (wB -1));zarith.
+   apply Z.mul_lt_mono_pos_r;zarith.
+   apply Z.le_lt_trans with (([|a2|] - [|b2|]) * wB + (wB -1));zarith.
    replace ( ([|a2|] - [|b2|]) * wB + (wB - 1)) with
      (([|a2|] - [|b2|] + 1) * wB + - 1);[zarith | ring].
    assert (([|a2|] - [|b2|] + 1) * wB <= 0);zarith.
@@ -387,13 +376,13 @@ Section DoubleDiv32.
    Spec_ww_to_Z (WW b1 b2). simpl in HH4;zarith.
    rewrite H0;intros r;repeat
     (rewrite spec_w_Bm1 || rewrite spec_w_Bm2);
-   simpl ww_to_Z;try rewrite Zmult_1_l;intros H1.
+   simpl ww_to_Z;try rewrite Z.mul_1_l;intros H1.
    assert ([[r]]=([|a2|]-[|b2|])*wB+[|a3|]+([|b1|]*wB+[|b2|])). zarith.
    split. rewrite H2;rewrite Hcmp;ring.
    split. Spec_ww_to_Z r;zarith.
    rewrite H2.
    assert (([|a2|] - [|b2|]) * wB + [|a3|] < 0);zarith.
-   apply Zle_lt_trans with (([|a2|] - [|b2|]) * wB + (wB -1));zarith.
+   apply Z.le_lt_trans with (([|a2|] - [|b2|]) * wB + (wB -1));zarith.
    replace ( ([|a2|] - [|b2|]) * wB + (wB - 1)) with
      (([|a2|] - [|b2|] + 1) * wB + - 1);[zarith|ring].
    assert (([|a2|] - [|b2|] + 1) * wB <= 0);zarith.
@@ -411,7 +400,7 @@ Section DoubleDiv32.
     rewrite H1.
    split. ring. split.
    rewrite <- H1;destruct (spec_ww_to_Z w_digits w_to_Z spec_to_Z r1);trivial.
-   apply Zle_lt_trans with ([|r|] * wB + [|a3|]).
+   apply Z.le_lt_trans with ([|r|] * wB + [|a3|]).
    assert ( 0 <= [|q|] * [|b2|]);zarith.
    apply beta_lex_inv;zarith.
    assert ([[r1]] = [|r|] * wB + [|a3|] - [|q|] * [|b2|] + wwB).
@@ -429,10 +418,10 @@ Section DoubleDiv32.
    intros r2;repeat (rewrite spec_pred || rewrite spec_ww_add;eauto);
    simpl ww_to_Z;intros H7.
    assert (0 < [|q|] - 1).
-   assert (1 <= [|q|]). zarith.
-   destruct (Zle_lt_or_eq _ _ H6);zarith.
-   rewrite <- H8 in H2;rewrite H2 in H7.
-   assert (0 < [|b1|]*wB). apply Zmult_lt_0_compat;zarith.
+   assert (H6 : 1 <= [|q|]) by zarith.
+   Z.le_elim H6;zarith.
+   rewrite <- H6 in H2;rewrite H2 in H7.
+   assert (0 < [|b1|]*wB). apply Z.mul_pos_pos;zarith.
    Spec_ww_to_Z r2. zarith.
    rewrite (Zmod_small ([|q|] -1));zarith.
    rewrite (Zmod_small ([|q|] -1 -1));zarith.
@@ -450,7 +439,7 @@ Section DoubleDiv32.
        < wwB). split;try omega.
    replace (2*([|b1|]*wB+[|b2|])) with ((2*[|b1|])*wB+2*[|b2|]). 2:ring.
    assert (H12:= wB_div2 Hle). assert (wwB <= 2 * [|b1|] * wB).
-   rewrite wwB_wBwB; rewrite Zpower_2; zarith. omega.
+   rewrite wwB_wBwB; rewrite Z.pow_2_r; zarith. omega.
    rewrite <- (Zmod_unique
             ([[r2]] + ([|b1|] * wB + [|b2|]))
             wwB
@@ -545,17 +534,13 @@ 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 = Z.compare [[x]] [[y]].
   Variable spec_ww_sub : forall x y, [[ww_sub x y]] = ([[x]] - [[y]]) mod wwB.
 
   Theorem wwB_div: wwB  = 2 * (wwB / 2).
   Proof.
-   rewrite wwB_div_2; rewrite  Zmult_assoc; rewrite  wB_div_2; auto.
-   rewrite <- Zpower_2; apply wwB_wBwB.
+   rewrite wwB_div_2; rewrite  Z.mul_assoc; rewrite  wB_div_2; auto.
+   rewrite <- Z.pow_2_r; apply wwB_wBwB.
   Qed.
 
   Ltac Spec_w_to_Z x :=
@@ -576,42 +561,41 @@ 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 Z.compare_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.
    rewrite wwB_div;zarith.
    intros a1h a1l.  Spec_w_to_Z a1h;Spec_w_to_Z a1l. Spec_ww_to_Z a2.
    destruct a2 as [ |a3 a4];
-    (destruct b as [ |b1 b2];[unfold Zle in Eq;discriminate Eq|idtac]);
+    (destruct b as [ |b1 b2];[unfold Z.le in Eq;discriminate Eq|idtac]);
    try (Spec_w_to_Z a3; Spec_w_to_Z a4); Spec_w_to_Z b1; Spec_w_to_Z b2;
    intros Hlt H;  match goal with |-context [w_div32 ?X ?Y ?Z ?T ?U] =>
      generalize (@spec_w_div32 X Y Z T U); case (w_div32 X Y Z T U);
      intros q1 r H0
    end; (assert (Eq1: wB / 2 <= [|b1|]);[
     apply (@beta_lex (wB / 2) 0 [|b1|] [|b2|] wB); auto with zarith;
-    autorewrite with rm10;repeat rewrite (Zmult_comm wB);
+    autorewrite with rm10;repeat rewrite (Z.mul_comm wB);
     rewrite <- wwB_div_2; trivial
    | generalize (H0 Eq1 Hlt);clear H0;destruct r as [ |r1 r2];simpl;
-     try rewrite spec_w_0; try rewrite spec_w_0W;repeat rewrite Zplus_0_r;
+     try rewrite spec_w_0; try rewrite spec_w_0W;repeat rewrite Z.add_0_r;
      intros (H1,H2) ]).
-   split;[rewrite wwB_wBwB; rewrite Zpower_2 | trivial].
-   rewrite Zmult_assoc;rewrite Zmult_plus_distr_l;rewrite <- Zmult_assoc;
-   rewrite <- Zpower_2; rewrite <- wwB_wBwB;rewrite H1;ring.
+   split;[rewrite wwB_wBwB; rewrite Z.pow_2_r | trivial].
+   rewrite Z.mul_assoc;rewrite Z.mul_add_distr_r;rewrite <- Z.mul_assoc;
+   rewrite <- Z.pow_2_r; rewrite <- wwB_wBwB;rewrite H1;ring.
    destruct H2 as (H2,H3);match goal with |-context [w_div32 ?X ?Y ?Z ?T ?U] =>
      generalize (@spec_w_div32 X Y Z T U); case (w_div32 X Y Z T U);
      intros q r H0;generalize (H0 Eq1 H3);clear H0;intros (H4,H5) end.
    split;[rewrite wwB_wBwB | trivial].
-   rewrite Zpower_2.
-   rewrite Zmult_assoc;rewrite Zmult_plus_distr_l;rewrite <- Zmult_assoc;
-   rewrite <- Zpower_2.
+   rewrite Z.pow_2_r.
+   rewrite Z.mul_assoc;rewrite Z.mul_add_distr_r;rewrite <- Z.mul_assoc;
+   rewrite <- Z.pow_2_r.
    rewrite <- wwB_wBwB;rewrite H1.
-   rewrite spec_w_0 in H4;rewrite Zplus_0_r in H4.
-   repeat rewrite Zmult_plus_distr_l. rewrite <- (Zmult_assoc [|r1|]).
-   rewrite <- Zpower_2; rewrite <- wwB_wBwB;rewrite H4;simpl;ring.
+   rewrite spec_w_0 in H4;rewrite Z.add_0_r in H4.
+   repeat rewrite Z.mul_add_distr_r. rewrite <- (Z.mul_assoc [|r1|]).
+   rewrite <- Z.pow_2_r; rewrite <- wwB_wBwB;rewrite H4;simpl;ring.
    split;[rewrite wwB_wBwB | split;zarith].
    replace (([|a1h|] * wB + [|a1l|]) * wB^2 + ([|a3|] * wB + [|a4|]))
    with (([|a1h|] * wwB + [|a1l|] * wB + [|a3|])*wB+ [|a4|]).
@@ -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 = Z.compare [|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,42 +893,42 @@ 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 Z.compare_spec;
     rewrite spec_w_0; intros HH.
-   generalize Hh; rewrite HH; simpl Zpower;
-        rewrite Zmult_1_l; intros (HH1, HH2); clear HH.
+   generalize Hh; rewrite HH; simpl Z.pow;
+        rewrite Z.mul_1_l; intros (HH1, HH2); clear HH.
    assert (wwB <= 2*[[WW bh bl]]).
-    apply Zle_trans with (2*[|bh|]*wB).
-    rewrite wwB_wBwB; rewrite Zpower_2; apply Zmult_le_compat_r; zarith.
-    rewrite <- wB_div_2; apply Zmult_le_compat_l; zarith.
-    simpl ww_to_Z;rewrite Zmult_plus_distr_r;rewrite Zmult_assoc.
+    apply Z.le_trans with (2*[|bh|]*wB).
+    rewrite wwB_wBwB; rewrite Z.pow_2_r; apply Z.mul_le_mono_nonneg_r; zarith.
+    rewrite <- wB_div_2; apply Z.mul_le_mono_nonneg_l; zarith.
+    simpl ww_to_Z;rewrite Z.mul_add_distr_l;rewrite Z.mul_assoc.
     Spec_w_to_Z bl;zarith.
    Spec_ww_to_Z (WW ah al).
    rewrite spec_ww_sub;eauto.
-   simpl;rewrite spec_ww_1;rewrite Zmult_1_l;simpl.
+   simpl;rewrite spec_ww_1;rewrite Z.mul_1_l;simpl.
    simpl ww_to_Z in Hgt, H, HH;rewrite Zmod_small;split;zarith.
    case (spec_to_Z (w_head0 bh)); auto with zarith.
    assert ([|w_head0 bh|] < Zpos w_digits).
     destruct (Z_lt_ge_dec [|w_head0 bh|]  (Zpos w_digits));trivial.
     exfalso.
     assert (2 ^ [|w_head0 bh|] * [|bh|] >= wB);auto with zarith.
-    apply Zle_ge; replace wB with (wB * 1);try ring.
-    Spec_w_to_Z bh;apply Zmult_le_compat;zarith.
+    apply Z.le_ge; replace wB with (wB * 1);try ring.
+    Spec_w_to_Z bh;apply Z.mul_le_mono_nonneg;zarith.
     unfold base;apply Zpower_le_monotone;zarith.
    assert (HHHH : 0 < [|w_head0 bh|] < Zpos w_digits); auto with zarith.
-   assert (Hb:= Zlt_le_weak _ _ H).
+   assert (Hb:= Z.lt_le_incl _ _ H).
    generalize (spec_add_mul_div w_0 ah Hb)
     (spec_add_mul_div ah al Hb)
     (spec_add_mul_div al w_0 Hb)
     (spec_add_mul_div bh bl Hb)
     (spec_add_mul_div bl w_0  Hb);
-   rewrite spec_w_0; repeat rewrite Zmult_0_l;repeat rewrite Zplus_0_l;
-   rewrite Zdiv_0_l;repeat rewrite Zplus_0_r.
+   rewrite spec_w_0; repeat rewrite Z.mul_0_l;repeat rewrite Z.add_0_l;
+   rewrite Zdiv_0_l;repeat rewrite Z.add_0_r.
    Spec_w_to_Z ah;Spec_w_to_Z bh.
    unfold base;repeat rewrite Zmod_shift_r;zarith.
    assert (H3:=to_Z_div_minus_p ah HHHH);assert(H4:=to_Z_div_minus_p al HHHH);
    assert (H5:=to_Z_div_minus_p bl HHHH).
-   rewrite Zmult_comm in Hh.
+   rewrite Z.mul_comm in Hh.
    assert (2^[|w_head0 bh|] < wB). unfold base;apply Zpower_lt_monotone;zarith.
    unfold base in H0;rewrite Zmod_small;zarith.
    fold wB; rewrite (Zmod_small ([|bh|] * 2 ^ [|w_head0 bh|]));zarith.
@@ -964,15 +943,15 @@ Section DoubleDivGt.
               (w_add_mul_div (w_head0 bh) al w_0)
               (w_add_mul_div (w_head0 bh) bh bl)
               (w_add_mul_div (w_head0 bh) bl w_0)) as (q,r).
-   rewrite V1;rewrite V2. rewrite Zmult_plus_distr_l.
-   rewrite <- (Zplus_assoc ([|bh|] * 2 ^ [|w_head0 bh|] * wB)).
+   rewrite V1;rewrite V2. rewrite Z.mul_add_distr_r.
+   rewrite <- (Z.add_assoc ([|bh|] * 2 ^ [|w_head0 bh|] * wB)).
    unfold base;rewrite <- shift_unshift_mod;zarith. fold wB.
    replace ([|bh|] * 2 ^ [|w_head0 bh|] * wB + [|bl|] * 2 ^ [|w_head0 bh|]) with
     ([[WW bh bl]] * 2^[|w_head0 bh|]). 2:simpl;ring.
-   fold wwB. rewrite wwB_wBwB. rewrite Zpower_2. rewrite U1;rewrite U2;rewrite U3.
-   rewrite Zmult_assoc. rewrite Zmult_plus_distr_l.
-   rewrite (Zplus_assoc ([|ah|] / 2^(Zpos(w_digits) - [|w_head0 bh|])*wB * wB)).
-   rewrite <- Zmult_plus_distr_l.  rewrite <- Zplus_assoc.
+   fold wwB. rewrite wwB_wBwB. rewrite Z.pow_2_r. rewrite U1;rewrite U2;rewrite U3.
+   rewrite Z.mul_assoc. rewrite Z.mul_add_distr_r.
+   rewrite (Z.add_assoc ([|ah|] / 2^(Zpos(w_digits) - [|w_head0 bh|])*wB * wB)).
+   rewrite <- Z.mul_add_distr_r.  rewrite <- Z.add_assoc.
    unfold base;repeat rewrite <- shift_unshift_mod;zarith. fold wB.
    replace ([|ah|] * 2 ^ [|w_head0 bh|] * wB + [|al|] * 2 ^ [|w_head0 bh|]) with
     ([[WW ah al]] * 2^[|w_head0 bh|]). 2:simpl;ring.
@@ -983,42 +962,42 @@ Section DoubleDivGt.
    unfold base.
    replace (2^Zpos (w_digits)) with (2^(Zpos (w_digits) - 1)*2).
    rewrite Z_div_mult;zarith.  rewrite <- Zpower_exp;zarith.
-   apply Zlt_le_trans with wB;zarith.
+   apply Z.lt_le_trans with wB;zarith.
    unfold base;apply Zpower_le_monotone;zarith.
    pattern 2 at 2;replace 2 with (2^1);trivial.
    rewrite <- Zpower_exp;zarith. ring_simplify (Zpos (w_digits) - 1 + 1);trivial.
    change [[WW w_0 q]] with ([|w_0|]*wB+[|q|]);rewrite spec_w_0;rewrite
-   Zmult_0_l;rewrite Zplus_0_l.
+   Z.mul_0_l;rewrite Z.add_0_l.
    replace [[ww_add_mul_div (ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c w_opp w_sub w_sub_carry
        _ww_zdigits (w_0W (w_head0 bh))) W0 r]] with ([[r]]/2^[|w_head0 bh|]).
-   assert (0 < 2^[|w_head0 bh|]). apply Zpower_gt_0;zarith.
+   assert (0 < 2^[|w_head0 bh|]). apply Z.pow_pos_nonneg;zarith.
    split.
    rewrite <- (Z_div_mult [[WW ah al]] (2^[|w_head0 bh|]));zarith.
-   rewrite H1;rewrite Zmult_assoc;apply Z_div_plus_l;trivial.
+   rewrite H1;rewrite Z.mul_assoc;apply Z_div_plus_l;trivial.
    split;[apply Zdiv_le_lower_bound| apply Zdiv_lt_upper_bound];zarith.
    rewrite spec_ww_add_mul_div.
    rewrite spec_ww_sub; auto with zarith.
    rewrite spec_ww_digits_.
    change (Zpos (xO (w_digits))) with (2*Zpos (w_digits));zarith.
-   simpl ww_to_Z;rewrite Zmult_0_l;rewrite Zplus_0_l.
+   simpl ww_to_Z;rewrite Z.mul_0_l;rewrite Z.add_0_l.
    rewrite spec_w_0W.
    rewrite (fun x y => Zmod_small (x-y)); auto with zarith.
    ring_simplify (2 * Zpos w_digits - (2 * Zpos w_digits - [|w_head0 bh|])).
    rewrite Zmod_small;zarith.
    split;[apply Zdiv_le_lower_bound| apply Zdiv_lt_upper_bound];zarith.
    Spec_ww_to_Z r.
-   apply Zlt_le_trans with wwB;zarith.
-   rewrite <- (Zmult_1_r wwB);apply Zmult_le_compat;zarith.
+   apply Z.lt_le_trans with wwB;zarith.
+   rewrite <- (Z.mul_1_r wwB);apply Z.mul_le_mono_nonneg;zarith.
    split; auto with zarith.
-   apply Zle_lt_trans with (2 * Zpos w_digits); auto with zarith.
-   unfold base, ww_digits; rewrite (Zpos_xO w_digits).
+   apply Z.le_lt_trans with (2 * Zpos w_digits); auto with zarith.
+   unfold base, ww_digits; rewrite (Pos2Z.inj_xO w_digits).
    apply Zpower2_lt_lin; auto with zarith.
    rewrite spec_ww_sub; auto with zarith.
    rewrite spec_ww_digits_; rewrite spec_w_0W.
    rewrite Zmod_small;zarith.
-   rewrite Zpos_xO; split; auto with zarith.
-   apply Zle_lt_trans with (2 * Zpos w_digits); auto with zarith.
-   unfold base, ww_digits; rewrite (Zpos_xO w_digits).
+   rewrite Pos2Z.inj_xO; split; auto with zarith.
+   apply Z.le_lt_trans with (2 * Zpos w_digits); auto with zarith.
+   unfold base, ww_digits; rewrite (Pos2Z.inj_xO w_digits).
    apply Zpower2_lt_lin; auto with zarith.
    Qed.
 
@@ -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 Z.compare_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.
+   rewrite <- Hcmp;rewrite Z.mul_0_l;rewrite Z.add_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).
@@ -1101,7 +1079,7 @@ Section DoubleDivGt.
    rewrite spec_mod_gt;trivial.
    assert (H:=spec_div_gt Hgt Hpos).
    destruct (w_div_gt a b) as (q,r);simpl.
-   rewrite Zmult_comm in H;destruct H.
+   rewrite Z.mul_comm in H;destruct H.
    symmetry;apply Zmod_unique with [|q|];trivial.
   Qed.
 
@@ -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 Z.compare_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
@@ -1171,7 +1149,7 @@ Section DoubleDivGt.
    rewrite (spec_ww_mod_gt_eq a b Hgt Hpos).
    destruct (ww_div_gt a b)as(q,r);destruct H.
    apply Zmod_unique with[[q]];simpl;trivial.
-   rewrite Zmult_comm;trivial.
+   rewrite Z.mul_comm;trivial.
   Qed.
 
   Lemma Zis_gcd_mod : forall a b d,
@@ -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 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.
-   simpl;rewrite spec_w_0;rewrite Zmult_0_l;rewrite Zplus_0_l.
-   rewrite spec_w_0 in Hbl.
+   rewrite spec_compare, spec_w_0.
+   case Z.compare_spec; intros Hbh.
+   simpl ww_to_Z in *. rewrite <- Hbh.
+   rewrite Z.mul_0_l;rewrite Z.add_0_l.
+   rewrite spec_compare, spec_w_0.
+   case Z.compare_spec; intros Hbl.
+   rewrite <- Hbl;apply Zis_gcd_0.
+   simpl;rewrite spec_w_0;rewrite Z.mul_0_l;rewrite Z.add_0_l.
    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
@@ -1241,67 +1220,67 @@ Section DoubleDivGt.
     spec_div21 spec_compare spec_sub 1 (WW ah al) bl Hbl).
    apply spec_gcd_gt.
    rewrite  (@spec_double_modn1 w w_digits w_zdigits w_0 w_WW); trivial.
-   apply Zlt_gt;match goal with | |- ?x mod ?y < ?y =>
+   apply Z.lt_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.
+   simpl;Spec_w_to_Z bl. apply Z.lt_le_trans with ([|bh|]*wB);zarith.
+   apply Z.mul_pos_pos;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 Z.compare_spec; intros Hmh.
+   simpl;rewrite <- Hmh;simpl.
+   rewrite spec_compare, spec_w_0; case Z.compare_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
    spec_div21 spec_compare spec_sub 1 (WW bh bl) ml Hml).
    apply spec_gcd_gt.
    rewrite  (@spec_double_modn1 w w_digits w_zdigits w_0 w_WW); trivial.
-   apply Zlt_gt;match goal with | |- ?x mod ?y < ?y =>
+   apply Z.lt_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]]).
-   rewrite H;simpl; apply Zlt_gt;match goal with | |- ?x mod ?y < ?y =>
+   Spec_w_to_Z ml;exfalso;omega.
+   assert ([[WW bh bl]] > [[WW mh ml]]).
+   rewrite H;simpl; apply Z.lt_gt;match goal with | |- ?x mod ?y < ?y =>
    destruct (Z_mod_lt x y);zarith end.
    assert (H1:= spec_ww_mod_gt_aux _ _ _ H0 Hmh).
    assert (H3 : 0 < [[WW mh ml]]).
-   simpl;Spec_w_to_Z ml. apply Zlt_le_trans with ([|mh|]*wB);zarith.
-   apply Zmult_lt_0_compat;zarith.
+   simpl;Spec_w_to_Z ml. apply Z.lt_le_trans with ([|mh|]*wB);zarith.
+   apply Z.mul_pos_pos;zarith.
    apply Zis_gcd_mod;zarith. simpl in *;rewrite <- H1.
    destruct (ww_mod_gt_aux bh bl mh ml) as [ |rh rl]. simpl; apply Zis_gcd_0.
    simpl;apply Hcont. simpl in H1;rewrite H1.
-   apply Zlt_gt;match goal with | |- ?x mod ?y < ?y =>
+   apply Z.lt_gt;match goal with | |- ?x mod ?y < ?y =>
    destruct (Z_mod_lt x y);zarith end.
-   apply Zle_trans with (2^n/2).
+   apply Z.le_trans with (2^n/2).
    apply Zdiv_le_lower_bound;zarith.
-   apply Zle_trans with ([|bh|] * wB + [|bl|]);zarith.
-   assert (H3' := Z_div_mod_eq [[WW bh bl]] [[WW mh ml]] (Zlt_gt _ _ H3)).
-   assert (H4' : 0 <= [[WW bh bl]]/[[WW mh ml]]).
-   apply Zge_le;apply Z_div_ge0;zarith. simpl in *;rewrite H1.
+   apply Z.le_trans with ([|bh|] * wB + [|bl|]);zarith.
+   assert (H3' := Z_div_mod_eq [[WW bh bl]] [[WW mh ml]] (Z.lt_gt _ _ H3)).
+   assert (H4 : 0 <= [[WW bh bl]]/[[WW mh ml]]).
+   apply Z.ge_le;apply Z_div_ge0;zarith. simpl in *;rewrite H1.
    pattern ([|bh|] * wB + [|bl|]) at 2;rewrite H3'.
-   destruct (Zle_lt_or_eq _ _ H4').
+   Z.le_elim H4.
    assert (H6' : [[WW bh bl]] mod [[WW mh ml]] =
                   [[WW bh bl]] - [[WW mh ml]] * ([[WW bh bl]]/[[WW mh ml]])).
    simpl;pattern ([|bh|] * wB + [|bl|]) at 2;rewrite H3';ring. simpl in H6'.
    assert ([[WW mh ml]] <= [[WW mh ml]] * ([[WW bh bl]]/[[WW mh ml]])).
-   simpl;pattern ([|mh|]*wB+[|ml|]) at 1;rewrite <- Zmult_1_r;zarith.
+   simpl;pattern ([|mh|]*wB+[|ml|]) at 1;rewrite <- Z.mul_1_r;zarith.
    simpl in *;assert (H8 := Z_mod_lt [[WW bh bl]] [[WW mh ml]]);simpl in H8;
     zarith.
    assert (H8 := Z_mod_lt [[WW bh bl]] [[WW mh ml]]);simpl in *;zarith.
-   rewrite <- H4 in H3';rewrite Zmult_0_r in H3';simpl in H3';zarith.
+   rewrite <- H4 in H3';rewrite Z.mul_0_r in H3';simpl in H3';zarith.
    pattern n at 1;replace n with (n-1+1);try ring.
    rewrite Zpower_exp;zarith. change (2^1) with 2.
    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 :
@@ -1316,27 +1295,27 @@ Section DoubleDivGt.
         [[ww_gcd_gt_aux p cont ah al bh bl]].
   Proof.
    induction p;intros cont n Hcont ah al bh bl Hgt Hs;simpl ww_gcd_gt_aux.
-   assert (0 < Zpos p). unfold Zlt;reflexivity.
+   assert (0 < Zpos p). unfold Z.lt;reflexivity.
    apply spec_ww_gcd_gt_aux_body with (n := Zpos (xI p) + n);
-   trivial;rewrite Zpos_xI.
+   trivial;rewrite Pos2Z.inj_xI.
    intros. apply IHp with (n := Zpos p + n);zarith.
    intros. apply IHp with (n := n );zarith.
-   apply Zle_trans with (2 ^ (2* Zpos p + 1+ n -1));zarith.
-   apply Zpower_le_monotone2;zarith.
-   assert (0 < Zpos p). unfold Zlt;reflexivity.
+   apply Z.le_trans with (2 ^ (2* Zpos p + 1+ n -1));zarith.
+   apply Z.pow_le_mono_r;zarith.
+   assert (0 < Zpos p). unfold Z.lt;reflexivity.
    apply spec_ww_gcd_gt_aux_body with (n := Zpos (xO p) + n );trivial.
-   rewrite (Zpos_xO p).
+   rewrite (Pos2Z.inj_xO p).
    intros. apply IHp with (n := Zpos p + n - 1);zarith.
    intros. apply IHp with (n := n -1 );zarith.
    intros;apply Hcont;zarith.
-   apply Zle_trans with (2^(n-1));zarith.
-   apply Zpower_le_monotone2;zarith.
-   apply Zle_trans with (2 ^ (Zpos p + n -1));zarith.
-   apply Zpower_le_monotone2;zarith.
-   apply Zle_trans with (2 ^ (2*Zpos p + n -1));zarith.
-   apply Zpower_le_monotone2;zarith.
+   apply Z.le_trans with (2^(n-1));zarith.
+   apply Z.pow_le_mono_r;zarith.
+   apply Z.le_trans with (2 ^ (Zpos p + n -1));zarith.
+   apply Z.pow_le_mono_r;zarith.
+   apply Z.le_trans with (2 ^ (2*Zpos p + n -1));zarith.
+   apply Z.pow_le_mono_r;zarith.
    apply spec_ww_gcd_gt_aux_body with (n := n+1);trivial.
-   rewrite Zplus_comm;trivial.
+   rewrite Z.add_comm;trivial.
    ring_simplify (n + 1 - 1);trivial.
   Qed.
 
@@ -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 = Z.compare [[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 Z.compare_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 Z.compare_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 = Z.compare [|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 Z.compare_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.
 
 
@@ -1515,7 +1485,7 @@ Section DoubleDiv.
    Spec_w_to_Z bh;assert ([|bh|] = 0);zarith. rewrite H1 in Hgt;simpl in Hgt.
    rewrite H1;simpl;auto. clear H.
    apply spec_gcd_gt_fix with (n:= 0);trivial.
-   rewrite Zplus_0_r;rewrite spec_ww_digits_.
+   rewrite Z.add_0_r;rewrite spec_ww_digits_.
    change (2 ^ Zpos (xO w_digits)) with wwB. Spec_ww_to_Z (WW bh bl);zarith.
   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 Z.compare_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..5cb7405a 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-2012     *)
 (*   \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 = Z.compare [|x|] [|y|].
  Variable spec_sub: forall x y,
    [|w_sub x y|] = ([|x|] - [|y|]) mod wB.
 
@@ -112,8 +107,8 @@ Section GENDIVN1.
    destruct H4;split;trivial.
    rewrite spec_double_WW;trivial.
    rewrite <- double_wB_wwB.
-   rewrite Zmult_assoc;rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l.
-   rewrite H0;rewrite Zmult_plus_distr_l;rewrite <- Zplus_assoc.
+   rewrite Z.mul_assoc;rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r.
+   rewrite H0;rewrite Z.mul_add_distr_r;rewrite <- Z.add_assoc.
    rewrite H4;ring.
   Qed.
 
@@ -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, Pos2Z.inj_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|]).
+   rewrite Z.mul_add_distr_r 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.
+   rewrite Z.add_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).
-   rewrite <- Zplus_assoc.
+       2^(Zpos (w_digits << n)-[|p|]))
+      * 2^Zpos(w_digits << n));try (ring;fail).
+   rewrite <- Z.add_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)).
-   rewrite (Zmult_comm (([!n|hh!] * 2 ^ [|p|] +
-      [!n|hl!] / 2 ^ (Zpos (double_digits w_digits n) - [|p|])))).
+     (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 (Z.mul_comm (([!n|hh!] * 2 ^ [|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 Z.lt;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,24 +302,25 @@ 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).
-  assert (U3 : 0 < Zpos w_digits). exact (refl_equal Lt).
+  assert (U3 : 0 < Zpos w_digits). exact (eq_refl Lt).
   destruct x;unfold high;fold high.
   unfold double_to_Z,zn2z_to_Z;rewrite spec_0.
   rewrite Zdiv_0_l;trivial.
@@ -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,30 +365,30 @@ 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 Z.compare_spec;
      rewrite spec_0; intros H2; auto with zarith.
    assert (Hv1: wB/2 <= [|b|]).
-     generalize H0; rewrite H2; rewrite Zpower_0_r;
-       rewrite Zmult_1_l; auto.
+     generalize H0; rewrite H2; rewrite Z.pow_0_r;
+       rewrite Z.mul_1_l; auto.
    assert (Hv2: [|w_0|] < [|b|]).
      rewrite spec_0; auto.
    generalize (spec_double_divn1_0 Hv1 n a Hv2).
-   rewrite spec_0;rewrite Zmult_0_l; rewrite Zplus_0_l; auto.
+   rewrite spec_0;rewrite Z.mul_0_l; rewrite Z.add_0_l; auto.
    contradict H2; auto with zarith.
    assert (HHHH : 0 < [|w_head0 b|]); auto with zarith.
    assert ([|w_head0 b|] < Zpos w_digits).
-    case (Zle_or_lt (Zpos w_digits) [|w_head0 b|]); auto; intros HH.
+    case (Z.le_gt_cases (Zpos w_digits) [|w_head0 b|]); auto; intros HH.
     assert (2 ^ [|w_head0 b|] < wB).
-     apply Zle_lt_trans with (2 ^ [|w_head0 b|] * [|b|]);auto with zarith.
+     apply Z.le_lt_trans with (2 ^ [|w_head0 b|] * [|b|]);auto with zarith.
      replace (2 ^ [|w_head0 b|]) with (2^[|w_head0 b|] * 1);try (ring;fail).
-     apply Zmult_le_compat;auto with zarith.
+     apply Z.mul_le_mono_nonneg;auto with zarith.
      assert (wB <= 2^[|w_head0 b|]).
      unfold base;apply Zpower_le_monotone;auto with zarith. omega.
    assert ([|w_add_mul_div (w_head0 b) b w_0|] =
                2 ^ [|w_head0 b|] * [|b|]).
     rewrite (spec_add_mul_div b w_0); auto with zarith.
     rewrite spec_0;rewrite Zdiv_0_l; try omega.
-    rewrite Zplus_0_r; rewrite Zmult_comm.
+    rewrite Z.add_0_r; rewrite Z.mul_comm.
     rewrite Zmod_small; auto with zarith.
    assert (H5 := spec_to_Z (high n a)).
    assert
@@ -404,21 +396,21 @@ Section GENDIVN1.
           <[|w_add_mul_div (w_head0 b) b w_0|]).
     rewrite H4.
     rewrite spec_add_mul_div;auto with zarith.
-    rewrite spec_0;rewrite Zmult_0_l;rewrite Zplus_0_l.
+    rewrite spec_0;rewrite Z.mul_0_l;rewrite Z.add_0_l.
     assert (([|high n a|]/2^(Zpos w_digits - [|w_head0 b|])) < wB).
      apply Zdiv_lt_upper_bound;auto with zarith.
-     apply Zlt_le_trans with wB;auto with zarith.
+     apply Z.lt_le_trans with wB;auto with zarith.
      pattern wB at 1;replace wB with (wB*1);try ring.
-     apply Zmult_le_compat;auto with zarith.
-     assert (H6 := Zpower_gt_0 2 (Zpos w_digits - [|w_head0 b|]));
+     apply Z.mul_le_mono_nonneg;auto with zarith.
+     assert (H6 := Z.pow_pos_nonneg 2 (Zpos w_digits - [|w_head0 b|]));
        auto with zarith.
     rewrite Zmod_small;auto with zarith.
     apply Zdiv_lt_upper_bound;auto with zarith.
-    apply Zlt_le_trans with wB;auto with zarith.
-    apply Zle_trans with (2 ^ [|w_head0 b|] * [|b|] * 2).
+    apply Z.lt_le_trans with wB;auto with zarith.
+    apply Z.le_trans with (2 ^ [|w_head0 b|] * [|b|] * 2).
     rewrite <- wB_div_2; try omega.
-    apply Zmult_le_compat;auto with zarith.
-    pattern 2 at 1;rewrite <- Zpower_1_r.
+    apply Z.mul_le_mono_nonneg;auto with zarith.
+    pattern 2 at 1;rewrite <- Z.pow_1_r.
     apply Zpower_le_monotone;split;auto with zarith.
    rewrite <- H4 in H0.
    assert (Hb3: [|w_head0 b|] <= Zpos w_digits); auto with zarith.
@@ -428,40 +420,40 @@ Section GENDIVN1.
              (double_0 w_0 n)) as (q,r).
    assert (U:= spec_double_digits n).
    rewrite spec_double_0 in H7;trivial;rewrite Zdiv_0_l in H7.
-   rewrite Zplus_0_r in H7.
+   rewrite Z.add_0_r in H7.
    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.
+   rewrite spec_0 in H7;rewrite Z.mul_0_l in H7;rewrite Z.add_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.
-   assert (H8 := Zpower_gt_0 2  (Zpos w_digits - [|w_head0 b|]));auto with zarith.
+    with (Zpos (w_digits << n) - [|w_head0 b|]);trivial;ring.
+   assert (H8 := Z.pow_pos_nonneg 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.
+   apply Z.le_lt_trans with ([|high n a|]);auto with zarith.
    apply Zdiv_le_upper_bound;auto with zarith.
-   pattern ([|high n a|]) at 1;rewrite <- Zmult_1_r.
-   apply Zmult_le_compat;auto with zarith.
+   pattern ([|high n a|]) at 1;rewrite <- Z.mul_1_r.
+   apply Z.mul_le_mono_nonneg;auto with zarith.
    rewrite H8 in H7;unfold double_wB,base in H7.
    rewrite <- shift_unshift_mod in H7;auto with zarith.
    rewrite H4 in H7.
    assert ([|w_add_mul_div (w_sub w_zdigits (w_head0 b)) w_0 r|]
                = [|r|]/2^[|w_head0 b|]).
    rewrite spec_add_mul_div.
-   rewrite spec_0;rewrite Zmult_0_l;rewrite Zplus_0_l.
+   rewrite spec_0;rewrite Z.mul_0_l;rewrite Z.add_0_l.
    replace (Zpos w_digits - [|w_sub w_zdigits (w_head0 b)|])
       with ([|w_head0 b|]).
    rewrite Zmod_small;auto with zarith.
    assert (H9 := spec_to_Z r).
    split;auto with zarith.
-   apply Zle_lt_trans with ([|r|]);auto with zarith.
+   apply Z.le_lt_trans with ([|r|]);auto with zarith.
    apply Zdiv_le_upper_bound;auto with zarith.
-   pattern ([|r|]) at 1;rewrite <- Zmult_1_r.
-   apply Zmult_le_compat;auto with zarith.
-   assert (H10 := Zpower_gt_0 2  ([|w_head0 b|]));auto with zarith.
+   pattern ([|r|]) at 1;rewrite <- Z.mul_1_r.
+   apply Z.mul_le_mono_nonneg;auto with zarith.
+   assert (H10 := Z.pow_pos_nonneg 2  ([|w_head0 b|]));auto with zarith.
    rewrite spec_sub.
    rewrite Zmod_small; auto with zarith.
    split; auto with zarith.
@@ -483,7 +475,7 @@ Section GENDIVN1.
     auto with zarith.
    rewrite H9.
    apply Zdiv_lt_upper_bound;auto with zarith.
-   rewrite Zmult_comm;auto with zarith.
+   rewrite Z.mul_comm;auto with zarith.
    exact (spec_double_to_Z w_digits w_to_Z spec_to_Z n a).
  Qed.
 
@@ -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 Z.compare_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..0a70dbf4 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-2012     *)
 (*   \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 = Z.compare [|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 = Z.compare [[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|] ->
@@ -150,20 +140,20 @@ Section DoubleLift.
   case (spec_to_Z xh); intros Hx1 Hx2.
   case (spec_to_Z xl); intros Hy1 Hy2.
   assert (F1: [|xh|] = 0).
-    case (Zle_lt_or_eq _ _ Hy1); auto; intros Hy3.
-    absurd (0 < [|xh|] * wB + [|xl|]); auto with zarith.
-    apply Zlt_le_trans with (1 := Hy3); auto with zarith.
-    pattern [|xl|] at 1; rewrite <- (Zplus_0_l [|xl|]).
-    apply Zplus_le_compat_r; auto with zarith.
-    case (Zle_lt_or_eq _ _ Hx1); auto; intros Hx3.
-    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.
+  { Z.le_elim Hy1; auto.
+    - absurd (0 < [|xh|] * wB + [|xl|]); auto with zarith.
+      apply Z.lt_le_trans with (1 := Hy1); auto with zarith.
+      pattern [|xl|] at 1; rewrite <- (Z.add_0_l [|xl|]).
+      apply Z.add_le_mono_r; auto with zarith.
+    - Z.le_elim Hx1; auto.
+      absurd (0 < [|xh|] * wB + [|xl|]); auto with zarith.
+      rewrite <- Hy1; rewrite Z.add_0_r; auto with zarith.
+      apply Z.mul_pos_pos; auto with zarith. }
+  rewrite spec_compare. case Z.compare_spec.
     intros H; simpl.
     rewrite spec_w_add; rewrite spec_w_head00.
     rewrite spec_zdigits; rewrite spec_ww_digits.
-    rewrite Zpos_xO; auto with zarith.
+    rewrite Pos2Z.inj_xO; auto with zarith.
   rewrite F1 in Hx; auto with zarith.
   rewrite spec_w_0; auto with zarith.
   rewrite spec_w_0; auto with zarith.
@@ -173,44 +163,43 @@ Section DoubleLift.
 	 wwB/ 2 <= 2 ^ [[ww_head0 x]] * [[x]] < wwB.
   Proof.
    clear spec_ww_zdigits.
-   rewrite wwB_div_2;rewrite Zmult_comm;rewrite wwB_wBwB.
+   rewrite wwB_div_2;rewrite Z.mul_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.
+   unfold Z.lt in H;discriminate H.
+   rewrite spec_compare, spec_w_0. case Z.compare_spec; intros H0.
+   rewrite <- H0 in *. simpl Z.add. 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.
    rewrite spec_zdigits; rewrite Zpower_exp; auto with zarith.
    case (spec_w_head0 H); intros H1 H2.
-   rewrite Zpower_2; fold wB; rewrite <- Zmult_assoc; split.
-     apply Zmult_le_compat_l; auto with zarith.
-   apply Zmult_lt_compat_l; auto with zarith.
+   rewrite Z.pow_2_r; fold wB; rewrite <- Z.mul_assoc; split.
+     apply Z.mul_le_mono_nonneg_l; auto with zarith.
+   apply Z.mul_lt_mono_pos_l; auto with zarith.
    assert (H1 := spec_w_head0 H0).
    rewrite spec_w_0W.
    split.
-   rewrite Zmult_plus_distr_r;rewrite Zmult_assoc.
-   apply Zle_trans with (2 ^ [|w_head0 xh|] * [|xh|] * wB).
-   rewrite Zmult_comm; zarith.
+   rewrite Z.mul_add_distr_l;rewrite Z.mul_assoc.
+   apply Z.le_trans with (2 ^ [|w_head0 xh|] * [|xh|] * wB).
+   rewrite Z.mul_comm; zarith.
    assert (0 <= 2 ^ [|w_head0 xh|] * [|xl|]);zarith.
-   assert (H2:=spec_to_Z xl);apply Zmult_le_0_compat;zarith.
+   assert (H2:=spec_to_Z xl);apply Z.mul_nonneg_nonneg;zarith.
    case (spec_to_Z (w_head0 xh)); intros H2 _.
    generalize ([|w_head0 xh|]) H1 H2;clear H1 H2;
      intros p H1 H2.
    assert (Eq1 : 2^p < wB).
-     rewrite <- (Zmult_1_r (2^p));apply Zle_lt_trans with (2^p*[|xh|]);zarith.
+     rewrite <- (Z.mul_1_r (2^p));apply Z.le_lt_trans with (2^p*[|xh|]);zarith.
    assert (Eq2: p < Zpos w_digits).
-    destruct (Zle_or_lt (Zpos w_digits) p);trivial;contradict  Eq1.
-   apply Zle_not_lt;unfold base;apply Zpower_le_monotone;zarith.
+    destruct (Z.le_gt_cases (Zpos w_digits) p);trivial;contradict  Eq1.
+   apply Z.le_ngt;unfold base;apply Zpower_le_monotone;zarith.
    assert (Zpos w_digits = p + (Zpos w_digits - p)). ring.
-   rewrite Zpower_2.
+   rewrite Z.pow_2_r.
    unfold base at 2;rewrite H3;rewrite Zpower_exp;zarith.
-   rewrite <- Zmult_assoc; apply Zmult_lt_compat_l; zarith.
-   rewrite <- (Zplus_0_r (2^(Zpos w_digits - p)*wB));apply beta_lex_inv;zarith.
-   apply Zmult_lt_reg_r with (2 ^ p); zarith.
+   rewrite <- Z.mul_assoc; apply Z.mul_lt_mono_pos_l; zarith.
+   rewrite <- (Z.add_0_r (2^(Zpos w_digits - p)*wB));apply beta_lex_inv;zarith.
+   apply Z.mul_lt_mono_pos_r with (2 ^ p); zarith.
    rewrite <- Zpower_exp;zarith.
-   rewrite Zmult_comm;ring_simplify (Zpos w_digits - p + p);fold wB;zarith.
+   rewrite Z.mul_comm;ring_simplify (Zpos w_digits - p + p);fold wB;zarith.
    assert (H1 := spec_to_Z xh);zarith.
   Qed.
 
@@ -222,22 +211,22 @@ Section DoubleLift.
   case (spec_to_Z xh); intros Hx1 Hx2.
   case (spec_to_Z xl); intros Hy1 Hy2.
   assert (F1: [|xh|] = 0).
-    case (Zle_lt_or_eq _ _ Hy1); auto; intros Hy3.
-    absurd (0 < [|xh|] * wB + [|xl|]); auto with zarith.
-    apply Zlt_le_trans with (1 := Hy3); auto with zarith.
-    pattern [|xl|] at 1; rewrite <- (Zplus_0_l [|xl|]).
-    apply Zplus_le_compat_r; auto with zarith.
-    case (Zle_lt_or_eq _ _ Hx1); auto; intros Hx3.
-    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.
+  { Z.le_elim Hy1; auto.
+    - absurd (0 < [|xh|] * wB + [|xl|]); auto with zarith.
+      apply Z.lt_le_trans with (1 := Hy1); auto with zarith.
+      pattern [|xl|] at 1; rewrite <- (Z.add_0_l [|xl|]).
+      apply Z.add_le_mono_r; auto with zarith.
+    - Z.le_elim Hx1; auto.
+      absurd (0 < [|xh|] * wB + [|xl|]); auto with zarith.
+      rewrite <- Hy1; rewrite Z.add_0_r; auto with zarith.
+      apply Z.mul_pos_pos; 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 Z.compare_spec.
     intros H; simpl.
     rewrite spec_w_add; rewrite spec_w_tail00; auto.
     rewrite spec_zdigits; rewrite spec_ww_digits.
-    rewrite Zpos_xO; auto with zarith.
+    rewrite Pos2Z.inj_xO; auto with zarith.
   rewrite spec_w_0; auto with zarith.
   rewrite spec_w_0; auto with zarith.
   Qed.
@@ -247,52 +236,51 @@ Section DoubleLift.
   Proof.
    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 <- H0; rewrite Zplus_0_r.
+   unfold Z.lt in H;discriminate H.
+   rewrite spec_compare, spec_w_0. case Z.compare_spec; intros H0.
+   rewrite <- H0; rewrite Z.add_0_r.
    case (spec_to_Z (w_tail0 xh)); intros HH1 HH2.
-   generalize H; rewrite <- H0; rewrite Zplus_0_r; clear H; intros H.
+   generalize H; rewrite <- H0; rewrite Z.add_0_r; clear H; intros H.
    case (@spec_w_tail0 xh).
-     apply Zmult_lt_reg_r with wB; auto with zarith.
+     apply Z.mul_lt_mono_pos_r with wB; auto with zarith.
      unfold base; auto with zarith.
    intros z (Hz1, Hz2); exists z; split; auto.
-   rewrite spec_w_add; rewrite (fun x => Zplus_comm [|x|]).
+   rewrite spec_w_add; rewrite (fun x => Z.add_comm [|x|]).
    rewrite spec_zdigits; rewrite Zpower_exp; auto with zarith.
-   rewrite Zmult_assoc; rewrite <- Hz2; auto.
+   rewrite Z.mul_assoc; rewrite <- Hz2; auto.
 
    case (spec_to_Z (w_tail0 xh)); intros HH1 HH2.
    case (spec_w_tail0 H0); intros z (Hz1, Hz2).
    assert (Hp: [|w_tail0 xl|] < Zpos w_digits).
-     case (Zle_or_lt (Zpos w_digits) [|w_tail0 xl|]); auto; intros H1.
+     case (Z.le_gt_cases (Zpos w_digits) [|w_tail0 xl|]); auto; intros H1.
      absurd (2 ^  (Zpos w_digits) <= 2 ^ [|w_tail0 xl|]).
-       apply Zlt_not_le.
+       apply Z.lt_nge.
        case (spec_to_Z xl); intros HH3 HH4.
-       apply Zle_lt_trans with (2 := HH4).
-       apply Zle_trans with (1 * 2 ^ [|w_tail0 xl|]); auto with zarith.
+       apply Z.le_lt_trans with (2 := HH4).
+       apply Z.le_trans with (1 * 2 ^ [|w_tail0 xl|]); auto with zarith.
        rewrite Hz2.
-       apply Zmult_le_compat_r; auto with zarith.
+       apply Z.mul_le_mono_nonneg_r; auto with zarith.
      apply Zpower_le_monotone; auto with zarith.
    exists ([|xh|] * (2 ^ ((Zpos w_digits - [|w_tail0 xl|]) - 1)) + z); split.
-     apply Zplus_le_0_compat; auto.
-     apply Zmult_le_0_compat; auto with zarith.
+     apply Z.add_nonneg_nonneg; auto.
+     apply Z.mul_nonneg_nonneg; auto with zarith.
      case (spec_to_Z xh); auto.
    rewrite spec_w_0W.
-   rewrite (Zmult_plus_distr_r 2); rewrite <- Zplus_assoc.
-   rewrite Zmult_plus_distr_l; rewrite <- Hz2.
-   apply f_equal2 with (f := Zplus); auto.
-   rewrite (Zmult_comm 2).
-   repeat rewrite <- Zmult_assoc.
-   apply f_equal2 with (f := Zmult); auto.
+   rewrite (Z.mul_add_distr_l 2); rewrite <- Z.add_assoc.
+   rewrite Z.mul_add_distr_r; rewrite <- Hz2.
+   apply f_equal2 with (f := Z.add); auto.
+   rewrite (Z.mul_comm 2).
+   repeat rewrite <- Z.mul_assoc.
+   apply f_equal2 with (f := Z.mul); auto.
    case (spec_to_Z (w_tail0 xl)); intros HH3 HH4.
-   pattern 2 at 2; rewrite <- Zpower_1_r.
+   pattern 2 at 2; rewrite <- Z.pow_1_r.
    lazy beta; repeat rewrite <- Zpower_exp; auto with zarith.
-   unfold base; apply f_equal with (f := Zpower 2); auto with zarith.
+   unfold base; apply f_equal with (f := Z.pow 2); auto with zarith.
 
    contradict H0; case (spec_to_Z xl); auto with zarith.
   Qed.
 
-  Hint Rewrite Zdiv_0_l Zmult_0_l Zplus_0_l Zmult_0_r Zplus_0_r
+  Hint Rewrite Zdiv_0_l Z.mul_0_l Z.add_0_l Z.mul_0_r Z.add_0_r
     spec_w_W0 spec_w_0W spec_w_WW spec_w_0
     (wB_div w_digits w_to_Z spec_to_Z)
     (wB_div_plus w_digits w_to_Z spec_to_Z) : w_rewrite.
@@ -316,20 +304,20 @@ Section DoubleLift.
    intros xh xl yh yl p zdigits;assert (HwwB := wwB_pos w_digits).
    case (spec_to_w_Z p); intros Hv1 Hv2.
    replace (Zpos (xO w_digits)) with (Zpos w_digits + Zpos w_digits).
-   2 : rewrite Zpos_xO;ring.
+   2 : rewrite Pos2Z.inj_xO;ring.
    replace (Zpos w_digits + Zpos w_digits - [[p]]) with
      (Zpos w_digits + (Zpos w_digits - [[p]])). 2:ring.
    intros Hp; assert (Hxh := spec_to_Z xh);assert (Hxl:=spec_to_Z xl);
    assert (Hx := spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW xh xl));
    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 Z.compare_spec; intros H1.
    rewrite H1; unfold zdigits; rewrite spec_w_0W.
-   rewrite spec_zdigits; rewrite Zminus_diag; rewrite Zplus_0_r.
+   rewrite spec_zdigits; rewrite Z.sub_diag; rewrite Z.add_0_r.
    simpl ww_to_Z; w_rewrite;zarith.
    fold wB.
-   rewrite Zmult_plus_distr_l;rewrite <- Zmult_assoc;rewrite <- Zplus_assoc.
-   rewrite <- Zpower_2.
+   rewrite Z.mul_add_distr_r;rewrite <- Z.mul_assoc;rewrite <- Z.add_assoc.
+   rewrite <- Z.pow_2_r.
    rewrite <- wwB_wBwB;apply Zmod_unique with [|xh|].
    exact (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW xl yh)). ring.
    simpl ww_to_Z; w_rewrite;zarith.
@@ -339,7 +327,7 @@ Section DoubleLift.
      case (spec_to_w_Z p); intros HH1 HH2; split; auto.
      generalize H1; unfold zdigits; rewrite spec_w_0W;
       rewrite spec_zdigits; intros tmp.
-     apply Zlt_le_trans with (1 := tmp).
+     apply Z.lt_le_trans with (1 := tmp).
      unfold base.
      apply Zpower2_le_lin; auto with zarith.
    2: generalize H1; unfold zdigits; rewrite spec_w_0W;
@@ -350,22 +338,22 @@ Section DoubleLift.
      rewrite HH0; auto with zarith.
    repeat rewrite spec_w_add_mul_div with (1 := HH).
    rewrite HH0.
-   rewrite Zmult_plus_distr_l.
+   rewrite Z.mul_add_distr_r.
    pattern ([|xl|] * 2 ^ [[p]]) at 2;
    rewrite shift_unshift_mod with (n:= Zpos w_digits);fold wB;zarith.
    replace ([|xh|] * wB * 2^[[p]]) with ([|xh|] * 2^[[p]] * wB). 2:ring.
-   rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. rewrite <- Zplus_assoc.
+   rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r. rewrite <- Z.add_assoc.
    unfold base at 5;rewrite <- Zmod_shift_r;zarith.
    unfold base;rewrite Zmod_shift_r with (b:= Zpos (ww_digits w_digits));
    fold wB;fold wwB;zarith.
-   rewrite wwB_wBwB;rewrite Zpower_2; rewrite  Zmult_mod_distr_r;zarith.
-   unfold ww_digits;rewrite Zpos_xO;zarith. apply Z_mod_lt;zarith.
+   rewrite wwB_wBwB;rewrite Z.pow_2_r; rewrite  Zmult_mod_distr_r;zarith.
+   unfold ww_digits;rewrite Pos2Z.inj_xO;zarith. apply Z_mod_lt;zarith.
    split;zarith. apply Zdiv_lt_upper_bound;zarith.
    rewrite <- Zpower_exp;zarith.
    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.
@@ -374,10 +362,10 @@ Section DoubleLift.
      rewrite <- Zmod_div_mod; auto with zarith.
      rewrite Zmod_small; auto with zarith.
      split; auto with zarith.
-     apply Zle_lt_trans with (Zpos w_digits); auto with zarith.
+     apply Z.le_lt_trans with (Zpos w_digits); auto with zarith.
      unfold base; apply Zpower2_lt_lin; auto with zarith.
      exists wB; unfold base.
-     unfold ww_digits; rewrite (Zpos_xO w_digits).
+     unfold ww_digits; rewrite (Pos2Z.inj_xO w_digits).
      rewrite <- Zpower_exp; auto with zarith.
      apply f_equal with (f := fun x => 2 ^ x); auto with zarith.
    assert (HH: [|low (ww_sub p zdigits)|] <= Zpos w_digits).
@@ -390,25 +378,25 @@ Section DoubleLift.
    pattern wB at 5;replace wB with
     (2^(([[p]] - Zpos w_digits)
          + (Zpos w_digits - ([[p]] - Zpos w_digits)))).
-   rewrite Zpower_exp;zarith. rewrite Zmult_assoc.
+   rewrite Zpower_exp;zarith. rewrite Z.mul_assoc.
    rewrite Z_div_plus_l;zarith.
    rewrite shift_unshift_mod with (a:= [|yh|]) (p:= [[p]] - Zpos w_digits)
     (n := Zpos w_digits);zarith. fold wB.
    set (u := [[p]] - Zpos w_digits).
    replace [[p]] with (u + Zpos w_digits);zarith.
-   rewrite Zpower_exp;zarith. rewrite Zmult_assoc. fold wB.
-   repeat rewrite Zplus_assoc. rewrite <- Zmult_plus_distr_l.
-   repeat rewrite <- Zplus_assoc.
+   rewrite Zpower_exp;zarith. rewrite Z.mul_assoc. fold wB.
+   repeat rewrite Z.add_assoc. rewrite <- Z.mul_add_distr_r.
+   repeat rewrite <- Z.add_assoc.
    unfold base;rewrite Zmod_shift_r with (b:= Zpos (ww_digits w_digits));
    fold wB;fold wwB;zarith.
    unfold base;rewrite Zmod_shift_r with (a:= Zpos w_digits)
    (b:= Zpos w_digits);fold wB;fold wwB;zarith.
-   rewrite wwB_wBwB; rewrite Zpower_2; rewrite  Zmult_mod_distr_r;zarith.
-   rewrite Zmult_plus_distr_l.
+   rewrite wwB_wBwB; rewrite Z.pow_2_r; rewrite  Zmult_mod_distr_r;zarith.
+   rewrite Z.mul_add_distr_r.
    replace ([|xh|] * wB * 2 ^ u) with
      ([|xh|]*2^u*wB). 2:ring.
-   repeat rewrite <- Zplus_assoc.
-   rewrite (Zplus_comm ([|xh|] * 2 ^ u * wB)).
+   repeat rewrite <- Z.add_assoc.
+   rewrite (Z.add_comm ([|xh|] * 2 ^ u * wB)).
    rewrite Z_mod_plus;zarith. rewrite Z_mod_mult;zarith.
    unfold base;rewrite <- Zmod_shift_r;zarith. fold base;apply Z_mod_lt;zarith.
    unfold u; split;zarith.
@@ -416,7 +404,7 @@ Section DoubleLift.
    rewrite <- Zpower_exp;zarith.
    fold u.
    ring_simplify (u + (Zpos w_digits - u)); fold
-   wB;zarith. unfold ww_digits;rewrite Zpos_xO;zarith.
+   wB;zarith. unfold ww_digits;rewrite Pos2Z.inj_xO;zarith.
    unfold base;rewrite <- Zmod_shift_r;zarith. fold base;apply Z_mod_lt;zarith.
    unfold u; split;zarith.
    unfold u; split;zarith.
@@ -446,15 +434,14 @@ 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 Z.compare_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]]).
      rewrite spec_low.
      apply Zmod_small.
      case (spec_to_w_Z p); intros HH1 HH2; split; auto.
-     apply Zlt_le_trans with (1 := H1).
+     apply Z.lt_le_trans with (1 := H1).
      unfold base; apply Zpower2_le_lin; auto with zarith.
    rewrite HH0; auto with zarith.
    replace [[WW w_0 w_0]] with 0;[w_rewrite|simpl;w_rewrite;trivial].
@@ -462,20 +449,21 @@ Section DoubleLift.
    generalize (spec_ww_compare p (w_0W w_zdigits));
      case ww_compare; intros H1; w_rewrite.
    rewrite (spec_w_add_mul_div w_0 w_0);w_rewrite;zarith.
-   rewrite Zpos_xO in H;zarith.
+   rewrite Pos2Z.inj_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.
      rewrite Zmod_small; auto with zarith.
      split; auto with zarith.
-     apply Zle_lt_trans with (Zpos w_digits); auto with zarith.
+     apply Z.le_lt_trans with (Zpos w_digits); auto with zarith.
      unfold base; apply Zpower2_lt_lin; auto with zarith.
      unfold base; auto with zarith.
      unfold base; auto with zarith.
      exists wB; unfold base.
-     unfold ww_digits; rewrite (Zpos_xO w_digits).
+     unfold ww_digits; rewrite (Pos2Z.inj_xO w_digits).
      rewrite <- Zpower_exp; auto with zarith.
      apply f_equal with (f := fun x => 2 ^ x); auto with zarith.
   case (spec_to_Z xh); auto with zarith.
diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v
index 834e85d2..7a92ff0c 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-2012     *)
 (*   \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 = Z.compare [|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.
@@ -332,7 +325,7 @@ Section DoubleMul.
    destruct cc as [ | cch ccl]; simpl zn2z_to_Z; simpl ww_to_Z.
    rewrite spec_ww_add;rewrite spec_w_W0;rewrite Zmod_small;
     rewrite wwB_wBwB. ring.
-   rewrite <- (Zplus_0_r ([|wc|]*wB));rewrite H;apply mult_add_ineq3;zarith.
+   rewrite <- (Z.add_0_r ([|wc|]*wB));rewrite H;apply mult_add_ineq3;zarith.
    simpl ww_to_Z in H1. assert (U:=spec_to_Z cch).
    assert ([|wc|]*wB + [|cch|] <= 2*wB - 3).
     destruct (Z_le_gt_dec ([|wc|]*wB + [|cch|]) (2*wB - 3));trivial.
@@ -342,21 +335,21 @@ Section DoubleMul.
      assert (H5 := Zmult_lt_b _ _ _ (spec_to_Z xl) (spec_to_Z yh)).
      omega.
    generalize H3;clear H3;rewrite <- H1.
-   rewrite Zplus_assoc; rewrite Zpower_2; rewrite Zmult_assoc;
-     rewrite <- Zmult_plus_distr_l.
+   rewrite Z.add_assoc; rewrite Z.pow_2_r; rewrite Z.mul_assoc;
+     rewrite <- Z.mul_add_distr_r.
     assert (((2 * wB - 4) + 2)*wB <= ([|wc|] * wB + [|cch|])*wB).
-     apply Zmult_le_compat;zarith.
-    rewrite Zmult_plus_distr_l in H3.
+     apply Z.mul_le_mono_nonneg;zarith.
+    rewrite Z.mul_add_distr_r in H3.
     intros. assert (U2 := spec_to_Z ccl);omega.
    generalize (spec_ww_add_c (w_W0 ccl) ll);destruct (ww_add_c (w_W0 ccl) ll)
-   as [l|l];unfold interp_carry;rewrite spec_w_W0;try rewrite Zmult_1_l;
+   as [l|l];unfold interp_carry;rewrite spec_w_W0;try rewrite Z.mul_1_l;
    simpl zn2z_to_Z;
    try rewrite spec_ww_add;try rewrite spec_ww_add_carry;rewrite spec_w_WW;
    rewrite Zmod_small;rewrite wwB_wBwB;intros.
    rewrite H4;ring. rewrite H;apply mult_add_ineq2;zarith.
-   rewrite Zplus_assoc;rewrite Zmult_plus_distr_l.
-   rewrite Zmult_1_l;rewrite <- Zplus_assoc;rewrite H4;ring.
-   repeat rewrite <- Zplus_assoc;rewrite H;apply mult_add_ineq2;zarith.
+   rewrite Z.add_assoc;rewrite Z.mul_add_distr_r.
+   rewrite Z.mul_1_l;rewrite <- Z.add_assoc;rewrite H4;ring.
+   repeat rewrite <- Z.add_assoc;rewrite H;apply mult_add_ineq2;zarith.
   Qed.
 
   Lemma spec_double_mul_c : forall cross:w->w->w->w->zn2z w -> zn2z w -> w*zn2z w,
@@ -368,7 +361,7 @@ Section DoubleMul.
      forall x y, [||double_mul_c cross x y||] = [[x]] * [[y]].
   Proof.
    intros cross Hcross x y;destruct x as [ |xh xl];simpl;trivial.
-   destruct y as [ |yh yl];simpl. rewrite Zmult_0_r;trivial.
+   destruct y as [ |yh yl];simpl. rewrite Z.mul_0_r;trivial.
    assert (H1:= spec_w_mul_c xh yh);assert (H2:= spec_w_mul_c xl yl).
    generalize (Hcross _ _ _ _ _ _ H1 H2).
    destruct (cross xh xl yh yl (w_mul_c xh yh) (w_mul_c xl yl)) as (wc,cc).
@@ -389,7 +382,7 @@ Section DoubleMul.
   Lemma spec_w_2: [|w_2|] = 2.
   unfold w_2; rewrite spec_w_add; rewrite spec_w_1; simpl.
   apply Zmod_small; split; auto with zarith.
-  rewrite <- (Zpower_1_r 2); unfold base; apply Zpower_lt_monotone; auto with zarith.
+  rewrite <- (Z.pow_1_r 2); unfold base; apply Zpower_lt_monotone; auto with zarith.
   Qed.
 
   Lemma kara_prod_aux : forall xh xl yh yl,
@@ -408,19 +401,19 @@ 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 Z.compare_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 Z.compare_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).
    repeat rewrite Zmod_small; auto with zarith; try (ring; fail).
    split; auto with zarith.
    simpl in Hz; rewrite Hz; rewrite H; rewrite H0.
-   rewrite kara_prod_aux; apply Zplus_le_0_compat; apply Zmult_le_0_compat; auto with zarith.
-   apply Zle_lt_trans with ([[z]]-0); auto with zarith.
-   unfold Zminus; apply Zplus_le_compat_l; apply Zle_left_rev; simpl; rewrite Zopp_involutive.
-   apply Zmult_le_0_compat; auto with zarith.
+   rewrite kara_prod_aux; apply Z.add_nonneg_nonneg; apply Z.mul_nonneg_nonneg; auto with zarith.
+   apply Z.le_lt_trans with ([[z]]-0); auto with zarith.
+   unfold Z.sub; apply Z.add_le_mono_l; apply Z.le_0_sub; simpl; rewrite Z.opp_involutive.
+   apply Z.mul_nonneg_nonneg; auto with zarith.
    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;
      intros z1 Hz2
@@ -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 Z.compare_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;
@@ -449,15 +442,15 @@ Section DoubleMul.
      replace ((x - y) * (z - t)) with ((y - x) * (t - z)); [idtac | ring]
    end.
    simpl in Hz; rewrite Hz; rewrite H; rewrite H0.
-   rewrite kara_prod_aux; apply Zplus_le_0_compat; apply Zmult_le_0_compat; auto with zarith.
-   apply Zle_lt_trans with ([[z]]-0); auto with zarith.
-   unfold Zminus; apply Zplus_le_compat_l; apply Zle_left_rev; simpl; rewrite Zopp_involutive.
-   apply Zmult_le_0_compat; auto with zarith.
+   rewrite kara_prod_aux; apply Z.add_nonneg_nonneg; apply Z.mul_nonneg_nonneg; auto with zarith.
+   apply Z.le_lt_trans with ([[z]]-0); auto with zarith.
+   unfold Z.sub; apply Z.add_le_mono_l; apply Z.le_0_sub; simpl; rewrite Z.opp_involutive.
+   apply Z.mul_nonneg_nonneg; 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 Z.mul_1_l.
+   rewrite spec_w_compare; case Z.compare_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 Z.compare_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;
@@ -465,7 +458,7 @@ Section DoubleMul.
    end.
    simpl in Hz2; rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c).
    repeat rewrite Zmod_small; auto with zarith; try (ring; fail).
-   rewrite spec_w_0; rewrite Zmult_0_l; rewrite Zplus_0_l.
+   rewrite spec_w_0; rewrite Z.mul_0_l; rewrite Z.add_0_l.
    generalize Hz2; clear Hz2; unfold interp_carry.
    repeat (rewrite spec_w_sub || rewrite spec_w_mul_c).
    repeat rewrite Zmod_small; auto with zarith; try (ring; fail).
@@ -476,11 +469,11 @@ Section DoubleMul.
    simpl in Hz2; rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c).
    repeat rewrite Zmod_small; auto with zarith; try (ring; fail).
    rewrite spec_w_2; unfold interp_carry in Hz2.
-   apply trans_equal with (wwB + (1 * wwB + [[z1]])).
+   transitivity (wwB + (1 * wwB + [[z1]])).
    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 Z.compare_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;
@@ -489,7 +482,7 @@ Section DoubleMul.
    simpl in Hz2; rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c).
    repeat rewrite Zmod_small; auto with zarith; try (ring; fail).
    rewrite spec_w_2; unfold interp_carry in Hz2.
-   apply trans_equal with (wwB + (1 * wwB + [[z1]])).
+   transitivity (wwB + (1 * wwB + [[z1]])).
    ring.
    rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c).
    repeat rewrite Zmod_small; auto with zarith; try (ring; fail).
@@ -499,7 +492,7 @@ Section DoubleMul.
    end.
    simpl in Hz2; rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c).
    repeat rewrite Zmod_small; auto with zarith; try (ring; fail).
-   rewrite spec_w_0; rewrite Zmult_0_l; rewrite Zplus_0_l.
+   rewrite spec_w_0; rewrite Z.mul_0_l; rewrite Z.add_0_l.
    match goal with |- context[(?x - ?y) * (?z - ?t)] =>
      replace ((x - y) * (z - t)) with ((y - x) * (t - z)); [idtac | ring]
    end.
@@ -520,7 +513,7 @@ Section DoubleMul.
    rewrite <- wwB_wBwB;intros H1 H2.
    assert (H3 := wB_pos w_digits).
    assert (2*wB <= wwB).
-    rewrite wwB_wBwB; rewrite Zpower_2; apply Zmult_le_compat;zarith.
+    rewrite wwB_wBwB; rewrite Z.pow_2_r; apply Z.mul_le_mono_nonneg;zarith.
    omega.
   Qed.
 
@@ -544,14 +537,14 @@ Section DoubleMul.
    assert (U1:= lt_0_wwB w_digits).
    intros x y; case x; auto; intros xh xl.
    case y; auto.
-   simpl; rewrite Zmult_0_r; rewrite Zmod_small; auto with zarith.
+   simpl; rewrite Z.mul_0_r; rewrite Zmod_small; auto with zarith.
    intros yh yl;simpl.
    repeat (rewrite spec_ww_add || rewrite spec_w_W0 || rewrite spec_w_mul_c
     || rewrite spec_w_add || rewrite spec_w_mul).
    rewrite <- Zplus_mod; auto with zarith.
-   repeat (rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r).
+   repeat (rewrite Z.mul_add_distr_r || rewrite Z.mul_add_distr_l).
    rewrite <- Zmult_mod_distr_r; auto with zarith.
-   rewrite <- Zpower_2; rewrite <- wwB_wBwB; auto with zarith.
+   rewrite <- Z.pow_2_r; rewrite <- wwB_wBwB; auto with zarith.
    rewrite Zplus_mod; auto with zarith.
    rewrite Zmod_mod; auto with zarith.
    rewrite <- Zplus_mod; auto with zarith.
@@ -571,10 +564,10 @@ Section DoubleMul.
    apply (spec_mul_aux xh xl xh xl wc cc);trivial.
    generalize Heq (spec_ww_add_c (w_mul_c xh xl) (w_mul_c xh xl));clear Heq.
    rewrite spec_w_mul_c;destruct (ww_add_c (w_mul_c xh xl) (w_mul_c xh xl));
-   unfold interp_carry;try rewrite Zmult_1_l;intros Heq Heq';inversion Heq;
-   rewrite (Zmult_comm [|xl|]);subst.
-   rewrite spec_w_0;rewrite Zmult_0_l;rewrite Zplus_0_l;trivial.
-   rewrite spec_w_1;rewrite Zmult_1_l;rewrite <- wwB_wBwB;trivial.
+   unfold interp_carry;try rewrite Z.mul_1_l;intros Heq Heq';inversion Heq;
+   rewrite (Z.mul_comm [|xl|]);subst.
+   rewrite spec_w_0;rewrite Z.mul_0_l;rewrite Z.add_0_l;trivial.
+   rewrite spec_w_1;rewrite Z.mul_1_l;rewrite <- wwB_wBwB;trivial.
   Qed.
 
   Section DoubleMulAddn1Proof.
@@ -596,8 +589,8 @@ Section DoubleMul.
     assert(H:=IHn xl y r);destruct (double_mul_add_n1 w_mul_add n xl y r)as(rl,l).
    assert(U:=IHn xh y rl);destruct(double_mul_add_n1 w_mul_add n xh y rl)as(rh,h).
     rewrite <- double_wB_wwB. rewrite spec_double_WW;simpl;trivial.
-    rewrite Zmult_plus_distr_l;rewrite <- Zplus_assoc;rewrite <- H.
-    rewrite Zmult_assoc;rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l.
+    rewrite Z.mul_add_distr_r;rewrite <- Z.add_assoc;rewrite <- H.
+    rewrite Z.mul_assoc;rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r.
     rewrite U;ring.
    Qed.
 
@@ -611,9 +604,9 @@ Section DoubleMul.
    destruct (w_mul_c x y) as [ |h l];simpl;rewrite <- H.
    rewrite spec_w_0;trivial.
    assert (U:=spec_w_add_c l r);destruct (w_add_c l r) as [lr|lr];unfold
-   interp_carry in U;try rewrite Zmult_1_l in H;simpl.
+   interp_carry in U;try rewrite Z.mul_1_l in H;simpl.
    rewrite U;ring. rewrite spec_w_succ. rewrite Zmod_small.
-   rewrite <- Zplus_assoc;rewrite <- U;ring.
+   rewrite <- Z.add_assoc;rewrite <- U;ring.
    simpl in H;assert (H1:= Zmult_lt_b _ _ _ (spec_to_Z x) (spec_to_Z y)).
    rewrite <- H in H1.
    assert (H2:=spec_to_Z h);split;zarith.
diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v
index 4394178f..40556c4a 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-2012     *)
 (*   \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 = Z.compare [|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,
@@ -238,7 +232,7 @@ Section DoubleSqrt.
         [|p|] <= Zpos w_digits ->
        [| w_add_mul_div p x y |] =
          ([|x|] * (2 ^ [|p|]) +
-          [|y|] / (Zpower 2 ((Zpos w_digits) - [|p|]))) mod wB.
+          [|y|] / (Z.pow 2 ((Zpos w_digits) - [|p|]))) mod wB.
  Variable spec_ww_add_mul_div : forall x y p,
        [[p]] <= Zpos (xO w_digits) ->
        [[ ww_add_mul_div p x y ]] =
@@ -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 = Z.compare [[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.
@@ -282,10 +272,9 @@ intros x; case x; simpl ww_is_even.
  unfold base.
  rewrite Zplus_mod; auto with zarith.
  rewrite (fun x y => (Zdivide_mod (x * y))); auto with zarith.
- rewrite Zplus_0_l; rewrite Zmod_mod; auto with zarith.
+ rewrite Z.add_0_l; rewrite Zmod_mod; auto with zarith.
  apply spec_w_is_even; auto with zarith.
- apply Zdivide_mult_r; apply Zpower_divide; auto with zarith.
- red; simpl; auto.
+ apply Z.divide_mul_r; apply Zpower_divide; auto with zarith.
  Qed.
 
 
@@ -296,13 +285,10 @@ intros x; case x; simpl ww_is_even.
  intros a1 a2 b Hb; unfold w_div21c.
  assert (H: 0 < [|b|]); auto with zarith.
  assert (U := wB_pos w_digits).
- apply Zlt_le_trans with (2 := Hb); auto with zarith.
- apply Zlt_le_trans with 1; auto with zarith.
+ apply Z.lt_le_trans with (2 := Hb); auto with zarith.
+ apply Z.lt_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 Z.compare_spec.
  intros H1 H2; split.
  unfold interp_carry; autorewrite with w_rewrite rm10; auto with zarith.
  rewrite H1; rewrite H2; ring.
@@ -321,7 +307,7 @@ intros x; case x; simpl ww_is_even.
  rewrite Zmod_small; auto with zarith.
  split; auto with zarith.
  assert ([|a2|] < 2 * [|b|]); auto with zarith.
- apply Zlt_le_trans with (2 * (wB / 2)); auto with zarith.
+ apply Z.lt_le_trans with (2 * (wB / 2)); auto with zarith.
  rewrite wB_div_2; auto.
  intros H1.
  match goal with |- context[w_div21 ?y ?z ?t] =>
@@ -334,7 +320,7 @@ intros x; case x; simpl ww_is_even.
  rewrite spec_w_sub; auto with zarith.
  rewrite Zmod_small; auto with zarith.
  assert ([|a1|] < 2 * [|b|]); auto with zarith.
- apply Zlt_le_trans with (2 * (wB / 2)); auto with zarith.
+ apply Z.lt_le_trans with (2 * (wB / 2)); auto with zarith.
  rewrite wB_div_2; auto.
  destruct (spec_to_Z a1);auto with zarith.
  destruct (spec_to_Z a1);auto with zarith.
@@ -346,11 +332,11 @@ intros x; case x; simpl ww_is_even.
  intros w0 w1; replace [+|C1 w0|] with (wB + [|w0|]).
  rewrite Zmod_small; auto with zarith.
  intros (H3, H4); split; auto.
- rewrite Zmult_plus_distr_l.
- rewrite <- Zplus_assoc; rewrite <- H3; ring.
+ rewrite Z.mul_add_distr_r.
+ rewrite <- Z.add_assoc; rewrite <- H3; ring.
  split; auto with zarith.
  assert ([|a1|] < 2 * [|b|]); auto with zarith.
- apply Zlt_le_trans with (2 * (wB / 2)); auto with zarith.
+ apply Z.lt_le_trans with (2 * (wB / 2)); auto with zarith.
  rewrite wB_div_2; auto.
  destruct (spec_to_Z a1);auto with zarith.
  destruct (spec_to_Z a1);auto with zarith.
@@ -368,14 +354,14 @@ intros x; case x; simpl ww_is_even.
    rewrite spec_pred; rewrite spec_w_zdigits.
    rewrite Zmod_small; auto with zarith.
    split; auto with zarith.
-   apply Zlt_le_trans with (Zpos w_digits); auto with zarith.
+   apply Z.lt_le_trans with (Zpos w_digits); auto with zarith.
    unfold base; apply Zpower2_le_lin; auto with zarith.
  rewrite spec_w_add_mul_div; auto with zarith.
  autorewrite with w_rewrite rm10.
  match goal with |- context[?X - ?Y] =>
   replace (X - Y) with 1
  end.
- rewrite Zpower_1_r; rewrite Zmod_small; auto with zarith.
+ rewrite Z.pow_1_r; rewrite Zmod_small; auto with zarith.
  destruct (spec_to_Z w1) as [H1 H2];auto with zarith.
  split; auto with zarith.
  apply Zdiv_lt_upper_bound; auto with zarith.
@@ -390,15 +376,15 @@ intros x; case x; simpl ww_is_even.
    rewrite spec_pred; rewrite spec_w_zdigits.
    rewrite Zmod_small; auto with zarith.
    split; auto with zarith.
-   apply Zlt_le_trans with (Zpos w_digits); auto with zarith.
+   apply Z.lt_le_trans with (Zpos w_digits); auto with zarith.
    unfold base; apply Zpower2_le_lin; auto with zarith.
  autorewrite with w_rewrite rm10; auto with zarith.
  match goal with |- context[?X - ?Y] =>
   replace (X - Y) with 1
  end; rewrite Hp; try ring.
- rewrite Zpos_minus; auto with zarith.
- rewrite Zmax_right; auto with zarith.
- rewrite Zpower_1_r; rewrite Zmod_small; auto with zarith.
+ rewrite Pos2Z.inj_sub_max; auto with zarith.
+ rewrite Z.max_r; auto with zarith.
+ rewrite Z.pow_1_r; rewrite Zmod_small; auto with zarith.
  destruct (spec_to_Z w1) as [H1 H2];auto with zarith.
  split; auto with zarith.
  unfold base.
@@ -406,14 +392,14 @@ intros x; case x; simpl ww_is_even.
  assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith;
   rewrite <- (tmp X); clear tmp
  end.
- rewrite Zpower_exp; try rewrite Zpower_1_r; auto with zarith.
+ rewrite Zpower_exp; try rewrite Z.pow_1_r; auto with zarith.
  assert (tmp: forall p, 1 + (p -1) - 1 = p - 1); auto with zarith;
   rewrite tmp; clear tmp; auto with zarith.
  match goal with |- ?X + ?Y < _ =>
  assert (Y < X); auto with zarith
  end.
  apply Zdiv_lt_upper_bound; auto with zarith.
- pattern 2 at 2; rewrite <- Zpower_1_r; rewrite <- Zpower_exp;
+ pattern 2 at 2; rewrite <- Z.pow_1_r; rewrite <- Zpower_exp;
   auto with zarith.
  assert (tmp: forall p, (p - 1) + 1 = p); auto with zarith;
   rewrite tmp; clear tmp; auto with zarith.
@@ -423,8 +409,8 @@ intros x; case x; simpl ww_is_even.
     [|w_add_mul_div w_1 w w_0|] = 2 * [|w|] mod wB.
  intros w1.
  autorewrite with w_rewrite rm10; auto with zarith.
- rewrite Zpower_1_r; auto with zarith.
- rewrite Zmult_comm; auto.
+ rewrite Z.pow_1_r; auto with zarith.
+ rewrite Z.mul_comm; auto.
  Qed.
 
  Theorem ww_add_mult_mult_2: forall w,
@@ -433,8 +419,8 @@ intros x; case x; simpl ww_is_even.
  rewrite spec_ww_add_mul_div; auto with zarith.
  autorewrite with w_rewrite rm10.
  rewrite spec_w_0W; rewrite spec_w_1.
- rewrite Zpower_1_r; auto with zarith.
- rewrite Zmult_comm; auto.
+ rewrite Z.pow_1_r; auto with zarith.
+ rewrite Z.mul_comm; auto.
  rewrite spec_w_0W; rewrite spec_w_1; auto with zarith.
  red; simpl; intros; discriminate.
  Qed.
@@ -445,18 +431,18 @@ intros x; case x; simpl ww_is_even.
  intros w1.
  rewrite spec_ww_add_mul_div; auto with zarith.
  rewrite spec_w_0W; rewrite spec_w_1; auto with zarith.
- rewrite Zpower_1_r; auto with zarith.
+ rewrite Z.pow_1_r; auto with zarith.
  f_equal; auto.
- rewrite Zmult_comm; f_equal; auto.
+ rewrite Z.mul_comm; f_equal; auto.
  autorewrite with w_rewrite rm10.
  unfold ww_digits, base.
- apply sym_equal; apply Zdiv_unique with (r := 2 ^ (Zpos (ww_digits w_digits) - 1) -1);
+ symmetry; apply Zdiv_unique with (r := 2 ^ (Zpos (ww_digits w_digits) - 1) -1);
   auto with zarith.
  unfold ww_digits; split; auto with zarith.
  match goal with  |- 0 <= ?X - 1 =>
    assert (0 < X); auto with zarith
  end.
- apply Zpower_gt_0; auto with zarith.
+ apply Z.pow_pos_nonneg; auto with zarith.
  match goal with  |- 0 <= ?X - 1 =>
    assert (0 < X); auto with zarith; red; reflexivity
  end.
@@ -466,7 +452,7 @@ intros x; case x; simpl ww_is_even.
  assert (tmp: forall p, p + p = 2 * p); auto with zarith;
   rewrite tmp; clear tmp.
  f_equal; auto.
- pattern 2 at 2; rewrite <- Zpower_1_r; rewrite <- Zpower_exp;
+ pattern 2 at 2; rewrite <- Z.pow_1_r; rewrite <- Zpower_exp;
   auto with zarith.
  assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith;
   rewrite tmp; clear tmp; auto.
@@ -479,7 +465,7 @@ intros x; case x; simpl ww_is_even.
 
  Theorem Zplus_mod_one: forall a1 b1, 0 < b1 -> (a1 + b1) mod b1 = a1 mod b1.
  intros a1 b1 H; rewrite Zplus_mod; auto with zarith.
- rewrite Z_mod_same; try rewrite Zplus_0_r; auto with zarith.
+ rewrite Z_mod_same; try rewrite Z.add_0_r; auto with zarith.
  apply Zmod_mod; auto.
  Qed.
 
@@ -494,8 +480,8 @@ intros x; case x; simpl ww_is_even.
  intros a1 a2 b H.
  assert (HH: 0 < [|b|]); auto with zarith.
  assert (U := wB_pos w_digits).
- apply Zlt_le_trans with (2 := H); auto with zarith.
- apply Zlt_le_trans with 1; auto with zarith.
+ apply Z.lt_le_trans with (2 := H); auto with zarith.
+ apply Z.lt_le_trans with 1; auto with zarith.
  apply Zdiv_le_lower_bound; auto with zarith.
  unfold w_div2s; case a1; intros w0 H0.
  match goal with |- context[w_div21c ?y ?z ?t] =>
@@ -541,10 +527,10 @@ intros x; case x; simpl ww_is_even.
  match goal with |- context[_ ^ ?X] =>
  assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith;
   rewrite <- (tmp X); clear tmp; rewrite Zpower_exp;
-  try rewrite Zpower_1_r; auto with zarith
+  try rewrite Z.pow_1_r; auto with zarith
  end.
- rewrite Zpos_minus; auto with zarith.
- rewrite Zmax_right; auto with zarith.
+ rewrite Pos2Z.inj_sub_max; auto with zarith.
+ rewrite Z.max_r; auto with zarith.
  ring.
  repeat rewrite C0_id.
  rewrite spec_w_add_c; auto with zarith.
@@ -558,10 +544,10 @@ intros x; case x; simpl ww_is_even.
  match goal with |- context[_ ^ ?X] =>
  assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith;
   rewrite <- (tmp X); clear tmp; rewrite Zpower_exp;
-  try rewrite Zpower_1_r; auto with zarith
+  try rewrite Z.pow_1_r; auto with zarith
  end.
- rewrite Zpos_minus; auto with zarith.
- rewrite Zmax_right; auto with zarith.
+ rewrite Pos2Z.inj_sub_max; auto with zarith.
+ rewrite Z.max_r; auto with zarith.
  ring.
  repeat rewrite C1_plus_wB in H0.
  rewrite C1_plus_wB.
@@ -583,7 +569,7 @@ intros x; case x; simpl ww_is_even.
  rewrite add_mult_div_2_plus_1.
  replace (wB + [|w0|]) with ([|b|] + ([|w0|] - [|b|] + wB));
   auto with zarith.
- rewrite Zmult_plus_distr_l; rewrite <- Zplus_assoc.
+ rewrite Z.mul_add_distr_r; rewrite <- Z.add_assoc.
  rewrite Hw1.
  pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] 2);
   auto with zarith.
@@ -591,10 +577,10 @@ intros x; case x; simpl ww_is_even.
  match goal with |- context[_ ^ ?X] =>
  assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith;
   rewrite <- (tmp X); clear tmp; rewrite Zpower_exp;
-  try rewrite Zpower_1_r; auto with zarith
+  try rewrite Z.pow_1_r; auto with zarith
  end.
- rewrite Zpos_minus; auto with zarith.
- rewrite Zmax_right; auto with zarith.
+ rewrite Pos2Z.inj_sub_max; auto with zarith.
+ rewrite Z.max_r; auto with zarith.
  ring.
  repeat rewrite C0_id.
  rewrite add_mult_div_2_plus_1.
@@ -602,7 +588,7 @@ intros x; case x; simpl ww_is_even.
  intros H1; split; auto with zarith.
  replace (wB + [|w0|]) with ([|b|] + ([|w0|] - [|b|] + wB));
   auto with zarith.
- rewrite Zmult_plus_distr_l; rewrite <- Zplus_assoc.
+ rewrite Z.mul_add_distr_r; rewrite <- Z.add_assoc.
  rewrite Hw1.
  pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] 2);
   auto with zarith.
@@ -610,10 +596,10 @@ intros x; case x; simpl ww_is_even.
  match goal with |- context[_ ^ ?X] =>
  assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith;
   rewrite <- (tmp X); clear tmp; rewrite Zpower_exp;
-  try rewrite Zpower_1_r; auto with zarith
+  try rewrite Z.pow_1_r; auto with zarith
  end.
- rewrite Zpos_minus; auto with zarith.
- rewrite Zmax_right; auto with zarith.
+ rewrite Pos2Z.inj_sub_max; auto with zarith.
+ rewrite Z.max_r; auto with zarith.
  ring.
  split; auto with zarith.
  destruct (spec_to_Z b);auto with zarith.
@@ -633,7 +619,7 @@ intros x; case x; simpl ww_is_even.
  rewrite add_mult_div_2.
  replace (wB + [|w0|]) with ([|b|] + ([|w0|] - [|b|] + wB));
   auto with zarith.
- rewrite Zmult_plus_distr_l; rewrite <- Zplus_assoc.
+ rewrite Z.mul_add_distr_r; rewrite <- Z.add_assoc.
  rewrite Hw1.
  pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] 2);
   auto with zarith.
@@ -644,7 +630,7 @@ intros x; case x; simpl ww_is_even.
  rewrite add_mult_div_2.
  replace (wB + [|w0|]) with ([|b|] + ([|w0|] - [|b|] + wB));
   auto with zarith.
- rewrite Zmult_plus_distr_l; rewrite <- Zplus_assoc.
+ rewrite Z.mul_add_distr_r; rewrite <- Z.add_assoc.
  rewrite Hw1.
  pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] 2);
   auto with zarith.
@@ -665,20 +651,20 @@ intros x; case x; simpl ww_is_even.
   rewrite <- Zpower_exp; auto with zarith.
   f_equal; auto with zarith.
   rewrite H.
-  rewrite (fun x => (Zmult_comm 4 (2 ^x))).
+  rewrite (fun x => (Z.mul_comm 4 (2 ^x))).
   rewrite Z_div_mult; auto with zarith.
  Qed.
 
  Theorem Zsquare_mult: forall p, p ^ 2 = p * p.
  intros p; change 2 with (1 + 1); rewrite Zpower_exp;
-  try rewrite Zpower_1_r; auto with zarith.
+  try rewrite Z.pow_1_r; auto with zarith.
  Qed.
 
  Theorem Zsquare_pos: forall p, 0 <= p ^ 2.
- intros p; case (Zle_or_lt 0 p); intros H1.
- rewrite Zsquare_mult; apply Zmult_le_0_compat; auto with zarith.
+ intros p; case (Z.le_gt_cases 0 p); intros H1.
+ rewrite Zsquare_mult; apply Z.mul_nonneg_nonneg; auto with zarith.
  rewrite Zsquare_mult; replace (p * p) with ((- p) * (- p)); try ring.
- apply Zmult_le_0_compat; auto with zarith.
+ apply Z.mul_nonneg_nonneg; auto with zarith.
  Qed.
 
  Lemma spec_split: forall x,
@@ -689,13 +675,12 @@ intros x; case x; simpl ww_is_even.
 
  Theorem mult_wwB: forall x y, [|x|] * [|y|] < wwB.
  Proof.
-  intros x y; rewrite wwB_wBwB; rewrite Zpower_2.
+  intros x y; rewrite wwB_wBwB; rewrite Z.pow_2_r.
   generalize (spec_to_Z x); intros U.
   generalize (spec_to_Z y); intros U1.
-  apply Zle_lt_trans with ((wB -1 ) * (wB - 1)); auto with zarith.
-  apply Zmult_le_compat; auto with zarith.
-  repeat (rewrite Zmult_minus_distr_r || rewrite Zmult_minus_distr_l);
-        auto with zarith.
+  apply Z.le_lt_trans with ((wB -1 ) * (wB - 1)); auto with zarith.
+  apply Z.mul_le_mono_nonneg; auto with zarith.
+  rewrite ?Z.mul_sub_distr_l, ?Z.mul_sub_distr_r; auto with zarith.
  Qed.
  Hint Resolve mult_wwB.
 
@@ -710,22 +695,22 @@ intros x; case x; simpl ww_is_even.
  end; simpl fst; simpl snd.
  intros w0 w1 Hw0 w2 w3 Hw1.
  assert (U: wB/4 <= [|w2|]).
- case (Zle_or_lt (wB / 4) [|w2|]); auto; intros H1.
- contradict H; apply Zlt_not_le.
- rewrite wwB_wBwB; rewrite Zpower_2.
- pattern wB at 1; rewrite <- wB_div_4; rewrite <- Zmult_assoc;
-   rewrite Zmult_comm.
+ case (Z.le_gt_cases (wB / 4) [|w2|]); auto; intros H1.
+ contradict H; apply Z.lt_nge.
+ rewrite wwB_wBwB; rewrite Z.pow_2_r.
+ pattern wB at 1; rewrite <- wB_div_4; rewrite <- Z.mul_assoc;
+   rewrite Z.mul_comm.
  rewrite Z_div_mult; auto with zarith.
  rewrite <- Hw1.
  match goal with |- _  < ?X =>
-  pattern X; rewrite <- Zplus_0_r; apply beta_lex_inv;
+  pattern X; rewrite <- Z.add_0_r; apply beta_lex_inv;
   auto with zarith
  end.
  destruct (spec_to_Z w3);auto with zarith.
  generalize (@spec_w_sqrt2 w2 w3 U); case (w_sqrt2 w2 w3).
  intros w4 c (H1, H2).
  assert (U1: wB/2 <= [|w4|]).
- case (Zle_or_lt (wB/2) [|w4|]); auto with zarith.
+ case (Z.le_gt_cases (wB/2) [|w4|]); auto with zarith.
  intros U1.
  assert (U2 : [|w4|] <= wB/2 -1); auto with zarith.
  assert (U3 : [|w4|] ^ 2 <= wB/4 * wB - wB + 1); auto with zarith.
@@ -733,19 +718,19 @@ intros x; case x; simpl ww_is_even.
   rewrite Zsquare_mult;
   replace Y with ((wB/2 - 1) * (wB/2 -1))
  end.
- apply Zmult_le_compat; auto with zarith.
+ apply Z.mul_le_mono_nonneg; auto with zarith.
  destruct (spec_to_Z w4);auto with zarith.
  destruct (spec_to_Z w4);auto with zarith.
  pattern wB at 4 5; rewrite <- wB_div_2.
- rewrite Zmult_assoc.
+ rewrite Z.mul_assoc.
  replace ((wB / 4) * 2) with (wB / 2).
  ring.
  pattern wB at 1; rewrite <- wB_div_4.
  change 4 with (2 * 2).
- rewrite <- Zmult_assoc; rewrite (Zmult_comm 2).
+ rewrite <- Z.mul_assoc; rewrite (Z.mul_comm 2).
  rewrite Z_div_mult; try ring; auto with zarith.
  assert (U4 : [+|c|]  <= wB -2); auto with zarith.
- apply Zle_trans with (1 := H2).
+ apply Z.le_trans with (1 := H2).
  match goal with |- ?X <= ?Y =>
   replace Y with (2 * (wB/ 2 - 1)); auto with zarith
  end.
@@ -754,10 +739,10 @@ intros x; case x; simpl ww_is_even.
   assert (U5: X < wB / 4 * wB)
  end.
  rewrite H1; auto with zarith.
- contradict U; apply Zlt_not_le.
- apply Zmult_lt_reg_r with wB; auto with zarith.
+ contradict U; apply Z.lt_nge.
+ apply Z.mul_lt_mono_pos_r with wB; auto with zarith.
  destruct (spec_to_Z w4);auto with zarith.
- apply Zle_lt_trans with (2 := U5).
+ apply Z.le_lt_trans with (2 := U5).
  unfold ww_to_Z, zn2z_to_Z.
  destruct (spec_to_Z w3);auto with zarith.
  generalize (@spec_w_div2s c w0 w4 U1 H2).
@@ -779,7 +764,7 @@ intros x; case x; simpl ww_is_even.
  unfold ww_to_Z, zn2z_to_Z in H1; rewrite H1.
  rewrite <- Hw0.
  match goal with |- (?X ^2 + ?Y) * wwB + (?Z * wB + ?T) = ?U =>
-  apply trans_equal with ((X * wB) ^ 2 + (Y * wB + Z) * wB + T)
+  transitivity ((X * wB) ^ 2 + (Y * wB + Z) * wB + T)
  end.
  repeat rewrite Zsquare_mult.
  rewrite wwB_wBwB; ring.
@@ -792,17 +777,17 @@ intros x; case x; simpl ww_is_even.
  match goal with |- ?X - ?Y * ?Y <= _ =>
   assert (V := Zsquare_pos Y);
   rewrite Zsquare_mult in V;
-  apply Zle_trans with X; auto with zarith;
+  apply Z.le_trans with X; auto with zarith;
   clear V
  end.
  match goal with |- ?X * wB + ?Y <= 2 * (?Z * wB + ?T) =>
-  apply Zle_trans with ((2 * Z - 1) * wB + wB); auto with zarith
+  apply Z.le_trans with ((2 * Z - 1) * wB + wB); auto with zarith
  end.
  destruct (spec_to_Z w1);auto with zarith.
  match goal with |- ?X <= _ =>
   replace X with (2 * [|w4|] * wB); auto with zarith
  end.
- rewrite Zmult_plus_distr_r; rewrite Zmult_assoc.
+ rewrite Z.mul_add_distr_l; rewrite Z.mul_assoc.
  destruct (spec_to_Z w5); auto with zarith.
  ring.
  intros z; replace [-[C1 z]] with (- wwB + [[z]]).
@@ -828,7 +813,7 @@ intros x; case x; simpl ww_is_even.
  unfold ww_to_Z, zn2z_to_Z in H1; rewrite H1.
  rewrite <- Hw0.
  match goal with |- (?X ^2 + ?Y) * wwB + (?Z * wB + ?T) = ?U =>
-  apply trans_equal with ((X * wB) ^ 2 + (Y * wB + Z) * wB + T)
+  transitivity ((X * wB) ^ 2 + (Y * wB + Z) * wB + T)
  end.
  repeat rewrite Zsquare_mult.
  rewrite wwB_wBwB; ring.
@@ -841,11 +826,11 @@ intros x; case x; simpl ww_is_even.
  destruct (spec_ww_to_Z w_digits w_to_Z spec_to_Z z);auto with zarith.
  assert (V1 := spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW w4 w5)).
  assert (0 <  [[WW w4 w5]]); auto with zarith.
- apply Zlt_le_trans with (wB/ 2 * wB + 0); auto with zarith.
- autorewrite with rm10; apply Zmult_lt_0_compat; auto with zarith.
- apply Zmult_lt_reg_r with 2; auto with zarith.
+ apply Z.lt_le_trans with (wB/ 2 * wB + 0); auto with zarith.
+ autorewrite with rm10; apply Z.mul_pos_pos; auto with zarith.
+ apply Z.mul_lt_mono_pos_r with 2; auto with zarith.
  autorewrite with rm10.
- rewrite Zmult_comm; rewrite wB_div_2; auto with zarith.
+ rewrite Z.mul_comm; rewrite wB_div_2; auto with zarith.
  case (spec_to_Z w5);auto with zarith.
  case (spec_to_Z w5);auto with zarith.
  simpl.
@@ -853,11 +838,11 @@ intros x; case x; simpl ww_is_even.
  assert (V1 := spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW w4 w5)); auto with zarith.
  split; auto with zarith.
  assert (wwB <= 2 * [[WW w4 w5]]); auto with zarith.
- apply Zle_trans with (2 * ([|w4|] * wB)).
- rewrite wwB_wBwB; rewrite Zpower_2.
- rewrite Zmult_assoc; apply Zmult_le_compat_r; auto with zarith.
- rewrite <- wB_div_2; auto with zarith.
+ apply Z.le_trans with (2 * ([|w4|] * wB)).
+ rewrite wwB_wBwB; rewrite Z.pow_2_r.
+ rewrite Z.mul_assoc; apply Z.mul_le_mono_nonneg_r; auto with zarith.
  assert (V2 := spec_to_Z w5);auto with zarith.
+ rewrite <- wB_div_2; auto with zarith.
  simpl ww_to_Z; assert (V2 := spec_to_Z w5);auto with zarith.
  assert (V1 := spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW w4 w5)); auto with zarith.
  intros z1; change [-[C1 z1]] with (-wwB + [[z1]]).
@@ -869,21 +854,21 @@ intros x; case x; simpl ww_is_even.
  rewrite ww_add_mult_mult_2.
  rename V1 into VV1.
  assert (VV2: 0 <  [[WW w4 w5]]); auto with zarith.
- apply Zlt_le_trans with (wB/ 2 * wB + 0); auto with zarith.
- autorewrite with rm10; apply Zmult_lt_0_compat; auto with zarith.
- apply Zmult_lt_reg_r with 2; auto with zarith.
+ apply Z.lt_le_trans with (wB/ 2 * wB + 0); auto with zarith.
+ autorewrite with rm10; apply Z.mul_pos_pos; auto with zarith.
+ apply Z.mul_lt_mono_pos_r with 2; auto with zarith.
  autorewrite with rm10.
- rewrite Zmult_comm; rewrite wB_div_2; auto with zarith.
+ rewrite Z.mul_comm; rewrite wB_div_2; auto with zarith.
  assert (VV3 := spec_to_Z w5);auto with zarith.
  assert (VV3 := spec_to_Z w5);auto with zarith.
  simpl.
  assert (VV3 := spec_to_Z w5);auto with zarith.
  assert (VV3: wwB <= 2 * [[WW w4 w5]]); auto with zarith.
- apply Zle_trans with (2 * ([|w4|] * wB)).
- rewrite wwB_wBwB; rewrite Zpower_2.
- rewrite Zmult_assoc; apply Zmult_le_compat_r; auto with zarith.
- rewrite <- wB_div_2; auto with zarith.
+ apply Z.le_trans with (2 * ([|w4|] * wB)).
+ rewrite wwB_wBwB; rewrite Z.pow_2_r.
+ rewrite Z.mul_assoc; apply Z.mul_le_mono_nonneg_r; auto with zarith.
  case (spec_to_Z w5);auto with zarith.
+ rewrite <- wB_div_2; auto with zarith.
  simpl ww_to_Z; assert (V4 := spec_to_Z w5);auto with zarith.
  rewrite <- Zmod_unique with (q := 1) (r := -wwB + 2 * [[WW w4 w5]]);
   auto with zarith.
@@ -905,7 +890,7 @@ intros x; case x; simpl ww_is_even.
  rewrite <- Hw0.
  split.
  match goal with |- (?X ^2 + ?Y) * wwB + (?Z * wB + ?T) = ?U =>
-  apply trans_equal with ((X * wB) ^ 2 + (Y * wB + Z) * wB + T)
+  transitivity ((X * wB) ^ 2 + (Y * wB + Z) * wB + T)
  end.
  repeat rewrite Zsquare_mult.
  rewrite wwB_wBwB; ring.
@@ -918,17 +903,17 @@ intros x; case x; simpl ww_is_even.
  assert (V2 := spec_ww_to_Z w_digits w_to_Z spec_to_Z z);auto with zarith.
  assert (V3 := spec_ww_to_Z w_digits w_to_Z spec_to_Z z1);auto with zarith.
  split; auto with zarith.
- rewrite (Zplus_comm (-wwB)); rewrite <- Zplus_assoc.
+ rewrite (Z.add_comm (-wwB)); rewrite <- Z.add_assoc.
  rewrite H5.
  match goal with |- 0 <= ?X + (?Y - ?Z)  =>
-  apply Zle_trans with (X - Z); auto with zarith
+  apply Z.le_trans with (X - Z); auto with zarith
  end.
  2: generalize (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW w6 w1)); unfold ww_to_Z; auto with zarith.
  rewrite V1.
  match goal with |- 0 <= ?X - 1 - ?Y =>
    assert (Y < X); auto with zarith
  end.
- apply Zlt_le_trans with wwB; auto with zarith.
+ apply Z.lt_le_trans with wwB; auto with zarith.
  intros (H3, H4).
  match goal with |- context [ww_sub_c ?y ?z] =>
   generalize (spec_ww_sub_c y z); case (ww_sub_c y z)
@@ -946,7 +931,7 @@ intros x; case x; simpl ww_is_even.
  unfold ww_to_Z, zn2z_to_Z in H1; rewrite H1.
  rewrite <- Hw0.
  match goal with |- (?X ^2 + ?Y) * wwB + (?Z * wB + ?T) = ?U =>
-  apply trans_equal with ((X * wB) ^ 2 + (Y * wB + Z) * wB + T)
+  transitivity ((X * wB) ^ 2 + (Y * wB + Z) * wB + T)
  end.
  repeat rewrite Zsquare_mult.
  rewrite wwB_wBwB; ring.
@@ -958,27 +943,27 @@ intros x; case x; simpl ww_is_even.
  simpl ww_to_Z.
  rewrite H5.
  simpl ww_to_Z.
- rewrite wwB_wBwB; rewrite Zpower_2.
+ rewrite wwB_wBwB; rewrite Z.pow_2_r.
  match goal with |- ?X * ?Y + (?Z * ?Y + ?T - ?U) <= _ =>
-  apply Zle_trans with (X * Y + (Z * Y + T - 0));
+  apply Z.le_trans with (X * Y + (Z * Y + T - 0));
   auto with zarith
  end.
  assert (V := Zsquare_pos [|w5|]);
  rewrite Zsquare_mult in V; auto with zarith.
  autorewrite with rm10.
  match goal with |- _ <= 2 * (?U * ?V + ?W) =>
-  apply Zle_trans with (2 * U * V + 0);
+  apply Z.le_trans with (2 * U * V + 0);
   auto with zarith
  end.
  match goal with |- ?X * ?Y + (?Z * ?Y + ?T) <= _ =>
   replace (X * Y + (Z * Y + T)) with ((X + Z) * Y + T);
   try ring
  end.
- apply Zlt_le_weak; apply beta_lex_inv; auto with zarith.
+ apply Z.lt_le_incl; apply beta_lex_inv; auto with zarith.
  destruct (spec_to_Z w1);auto with zarith.
  destruct (spec_to_Z w5);auto with zarith.
- rewrite Zmult_plus_distr_r; auto with zarith.
- rewrite Zmult_assoc; auto with zarith.
+ rewrite Z.mul_add_distr_l; auto with zarith.
+ rewrite Z.mul_assoc; auto with zarith.
  intros z; replace [-[C1 z]] with (- wwB + [[z]]).
  2: simpl; case wwB; auto with zarith.
  intros H5; rewrite spec_w_square_c in H5;
@@ -997,7 +982,7 @@ intros x; case x; simpl ww_is_even.
  rewrite <- Hw0.
  split.
  match goal with |- (?X ^2 + ?Y) * wwB + (?Z * wB + ?T) = ?U =>
-  apply trans_equal with ((X * wB) ^ 2 + (Y * wB + Z) * wB + T)
+  transitivity ((X * wB) ^ 2 + (Y * wB + Z) * wB + T)
  end.
  repeat rewrite Zsquare_mult.
  rewrite wwB_wBwB; ring.
@@ -1008,40 +993,38 @@ intros x; case x; simpl ww_is_even.
  repeat rewrite Zsquare_mult; ring.
  rewrite V.
  simpl ww_to_Z.
- rewrite wwB_wBwB; rewrite Zpower_2.
+ rewrite wwB_wBwB; rewrite Z.pow_2_r.
  match goal with |- (?Z * ?Y + ?T - ?U) + ?X * ?Y <= _ =>
-  apply Zle_trans with ((Z * Y + T - 0) + X * Y);
+  apply Z.le_trans with ((Z * Y + T - 0) + X * Y);
   auto with zarith
  end.
  assert (V1 := Zsquare_pos [|w5|]);
  rewrite Zsquare_mult in V1; auto with zarith.
  autorewrite with rm10.
  match goal with |- _ <= 2 * (?U * ?V + ?W) =>
-  apply Zle_trans with (2 * U * V + 0);
+  apply Z.le_trans with (2 * U * V + 0);
   auto with zarith
  end.
  match goal with |- (?Z * ?Y + ?T) + ?X * ?Y  <= _ =>
   replace ((Z * Y + T) + X * Y) with ((X + Z) * Y + T);
   try ring
  end.
- apply Zlt_le_weak; apply beta_lex_inv; auto with zarith.
+ apply Z.lt_le_incl; apply beta_lex_inv; auto with zarith.
  destruct (spec_to_Z w1);auto with zarith.
  destruct (spec_to_Z w5);auto with zarith.
- rewrite Zmult_plus_distr_r; auto with zarith.
- rewrite Zmult_assoc; auto with zarith.
- case Zle_lt_or_eq with (1 := H2); clear H2; intros H2.
+ rewrite Z.mul_add_distr_l; auto with zarith.
+ rewrite Z.mul_assoc; auto with zarith.
+ Z.le_elim H2.
  intros c1 (H3, H4).
- match type of H3 with ?X = ?Y =>
-   absurd (X < Y)
- end.
- apply Zle_not_lt; rewrite <- H3; auto with zarith.
- rewrite Zmult_plus_distr_l.
- apply Zlt_le_trans with ((2 * [|w4|]) * wB + 0);
+ match type of H3 with ?X = ?Y => absurd (X < Y) end.
+ apply Z.le_ngt; rewrite <- H3; auto with zarith.
+ rewrite Z.mul_add_distr_r.
+ apply Z.lt_le_trans with ((2 * [|w4|]) * wB + 0);
   auto with zarith.
  apply beta_lex_inv; auto with zarith.
  destruct (spec_to_Z w0);auto with zarith.
  assert (V1 := spec_to_Z w5);auto with zarith.
- rewrite (Zmult_comm wB); auto with zarith.
+ rewrite (Z.mul_comm wB); auto with zarith.
  assert (0 <= [|w5|] * (2 * [|w4|])); auto with zarith.
  intros c1 (H3, H4); rewrite H2 in H3.
  match type of H3 with ?X + ?Y = (?Z + ?T) * ?U + ?V =>
@@ -1051,20 +1034,19 @@ intros x; case x; simpl ww_is_even.
  end.
  assert (V1 := spec_to_Z w0);auto with zarith.
  assert (V2 := spec_to_Z w5);auto with zarith.
- case (Zle_lt_or_eq 0 [|w5|]); auto with zarith; intros V3.
- match type of VV with ?X = ?Y =>
-   absurd (X < Y)
- end.
- apply Zle_not_lt; rewrite <- VV; auto with zarith.
- apply Zlt_le_trans with wB; auto with zarith.
+ case V2; intros V3 _.
+ Z.le_elim V3; auto with zarith.
+ match type of VV with ?X = ?Y => absurd (X < Y) end.
+ apply Z.le_ngt; rewrite <- VV; auto with zarith.
+ apply Z.lt_le_trans with wB; auto with zarith.
  match goal with |- _ <= ?X + _ =>
-  apply Zle_trans with X; auto with zarith
+  apply Z.le_trans with X; auto with zarith
  end.
  match goal with |- _ <= _ * ?X =>
-  apply Zle_trans with (1 * X); auto with zarith
+  apply Z.le_trans with (1 * X); auto with zarith
  end.
  autorewrite with rm10.
- rewrite <- wB_div_2; apply Zmult_le_compat_l; auto with zarith.
+ rewrite <- wB_div_2; apply Z.mul_le_mono_nonneg_l; auto with zarith.
  rewrite <- V3 in VV; generalize VV; autorewrite with rm10;
  clear VV; intros VV.
  rewrite spec_ww_add_c; auto with zarith.
@@ -1080,7 +1062,7 @@ intros x; case x; simpl ww_is_even.
  simpl ww_to_Z in H1; rewrite H1.
  rewrite <- Hw0.
  match goal with |- (?X ^2 + ?Y) * wwB + (?Z * wB + ?T) = ?U =>
-  apply trans_equal with ((X * wB) ^ 2 + (Y * wB + Z) * wB + T)
+  transitivity ((X * wB) ^ 2 + (Y * wB + Z) * wB + T)
  end.
  repeat rewrite Zsquare_mult.
  rewrite wwB_wBwB; ring.
@@ -1092,41 +1074,41 @@ intros x; case x; simpl ww_is_even.
  simpl ww_to_Z; unfold ww_to_Z.
  rewrite spec_w_Bm1; auto with zarith.
  split.
- rewrite wwB_wBwB; rewrite Zpower_2.
+ rewrite wwB_wBwB; rewrite Z.pow_2_r.
  match goal with |- _ <= -?X + (2 * (?Z * ?T + ?U) + ?V) =>
   assert (X <= 2 * Z * T); auto with zarith
  end.
- apply Zmult_le_compat_r; auto with zarith.
- rewrite <- wB_div_2; apply Zmult_le_compat_l; auto with zarith.
- rewrite Zmult_plus_distr_r; auto with zarith.
- rewrite Zmult_assoc; auto with zarith.
+ apply Z.mul_le_mono_nonneg_r; auto with zarith.
+ rewrite <- wB_div_2; apply Z.mul_le_mono_nonneg_l; auto with zarith.
+ rewrite Z.mul_add_distr_l; auto with zarith.
+ rewrite Z.mul_assoc; auto with zarith.
  match goal with |- _ + ?X  < _ =>
   replace X with ((2 * (([|w4|]) + 1) * wB) - 1); try ring
  end.
  assert (2 * ([|w4|] + 1) * wB <= 2 * wwB); auto with zarith.
- rewrite <- Zmult_assoc; apply Zmult_le_compat_l; auto with zarith.
- rewrite wwB_wBwB; rewrite Zpower_2.
- apply Zmult_le_compat_r; auto with zarith.
+ rewrite <- Z.mul_assoc; apply Z.mul_le_mono_nonneg_l; auto with zarith.
+ rewrite wwB_wBwB; rewrite Z.pow_2_r.
+ apply Z.mul_le_mono_nonneg_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 Z.compare_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.
   Qed.
 
   Lemma wwB_4_2: 2 * (wwB / 4) = wwB/ 2.
-  pattern wwB at 1; rewrite wwB_wBwB; rewrite Zpower_2.
+  pattern wwB at 1; rewrite wwB_wBwB; rewrite Z.pow_2_r.
   rewrite <- wB_div_2.
   match goal with |- context[(2 * ?X) * (2 * ?Z)] =>
     replace ((2 * X) * (2 * Z)) with ((X * Z) * 4); try ring
   end.
   rewrite Z_div_mult; auto with zarith.
-  rewrite Zmult_assoc; rewrite wB_div_2.
+  rewrite Z.mul_assoc; rewrite wB_div_2.
   rewrite wwB_div_2; ring.
   Qed.
 
@@ -1142,10 +1124,10 @@ intros x; case x; simpl ww_is_even.
   intros H2.
   generalize (spec_ww_head0 x H2); case (ww_head0 x);  autorewrite with rm10.
   intros (H3, H4); split; auto with zarith.
-  apply Zle_trans with (2 := H3).
+  apply Z.le_trans with (2 := H3).
   apply Zdiv_le_compat_l; auto with zarith.
   intros xh xl (H3, H4); split; auto with zarith.
-  apply Zle_trans with (2 := H3).
+  apply Z.le_trans with (2 := H3).
   apply Zdiv_le_compat_l; auto with zarith.
   intros H1.
   case (spec_to_w_Z (ww_head0 x)); intros Hv1 Hv2.
@@ -1169,24 +1151,24 @@ intros x; case x; simpl ww_is_even.
   case (spec_ww_head0 x); auto; intros Hv3 Hv4.
   assert (Hu: forall u, 0 < u -> 2 *  2 ^ (u - 1) = 2 ^u).
     intros u Hu.
-    pattern 2 at 1; rewrite <- Zpower_1_r.
+    pattern 2 at 1; rewrite <- Z.pow_1_r.
     rewrite <- Zpower_exp; auto with zarith.
     ring_simplify (1 + (u - 1)); auto with zarith.
   split; auto with zarith.
-  apply Zmult_le_reg_r with 2; auto with zarith.
-  repeat rewrite (fun x => Zmult_comm x 2).
+  apply Z.mul_le_mono_pos_r with 2; auto with zarith.
+  repeat rewrite (fun x => Z.mul_comm x 2).
   rewrite wwB_4_2.
-  rewrite Zmult_assoc; rewrite Hu; auto with zarith.
-  apply Zle_lt_trans with (2 * 2 ^ ([[ww_head0 x]] - 1) * [[x]]); auto with zarith;
+  rewrite Z.mul_assoc; rewrite Hu; auto with zarith.
+  apply Z.le_lt_trans with (2 * 2 ^ ([[ww_head0 x]] - 1) * [[x]]); auto with zarith;
     rewrite Hu; auto with zarith.
-  apply Zmult_le_compat_r; auto with zarith.
+  apply Z.mul_le_mono_nonneg_r; auto with zarith.
   apply Zpower_le_monotone; auto with zarith.
   Qed.
 
   Theorem wwB_4_wB_4: wwB / 4 = wB / 4 * wB.
-  apply sym_equal; apply Zdiv_unique with 0;
-    auto with zarith.
-  rewrite Zmult_assoc; rewrite wB_div_4; auto with zarith.
+  Proof.
+  symmetry; apply Zdiv_unique with 0; auto with zarith.
+  rewrite Z.mul_assoc; rewrite wB_div_4; auto with zarith.
   rewrite wwB_wBwB; ring.
   Qed.
 
@@ -1195,10 +1177,10 @@ intros x; case x; simpl ww_is_even.
   assert (U := wB_pos w_digits).
   intro x; unfold ww_sqrt.
   generalize (spec_ww_is_zero x); case (ww_is_zero x).
-  simpl ww_to_Z; simpl Zpower; unfold Zpower_pos; simpl;
+  simpl ww_to_Z; simpl Z.pow; unfold Z.pow_pos; simpl;
     auto with zarith.
   intros H1.
-  generalize (spec_ww_compare (ww_head1 x) W0); case ww_compare;
+  rewrite spec_ww_compare. case Z.compare_spec;
     simpl ww_to_Z; autorewrite with rm10.
   generalize H1; case x.
   intros HH; contradict HH; simpl ww_to_Z; auto with zarith.
@@ -1216,7 +1198,7 @@ intros x; case x; simpl ww_is_even.
   intros w3 (H6, H7); rewrite H6.
   assert (V1 := spec_to_Z w3);auto with zarith.
   split; auto with zarith.
-  apply Zle_lt_trans with ([|w2|] ^2  + 2 * [|w2|]); auto with zarith.
+  apply Z.le_lt_trans with ([|w2|] ^2  + 2 * [|w2|]); auto with zarith.
   match goal with |- ?X < ?Z =>
     replace Z with (X + 1); auto with zarith
   end.
@@ -1224,7 +1206,7 @@ intros x; case x; simpl ww_is_even.
   intros w3 (H6, H7); rewrite H6.
   assert (V1 := spec_to_Z w3);auto with zarith.
   split; auto with zarith.
-  apply Zle_lt_trans with ([|w2|] ^2  + 2 * [|w2|]); auto with zarith.
+  apply Z.le_lt_trans with ([|w2|] ^2  + 2 * [|w2|]); auto with zarith.
   match goal with |- ?X < ?Z =>
     replace Z with (X + 1); auto with zarith
   end.
@@ -1234,42 +1216,42 @@ intros x; case x; simpl ww_is_even.
   case (spec_ww_head1 x); intros Hp1 Hp2.
   generalize (Hp2 H1); clear Hp2; intros Hp2.
   assert (Hv2: [[ww_head1 x]] <= Zpos (xO w_digits)).
-    case (Zle_or_lt (Zpos (xO w_digits)) [[ww_head1 x]]); auto with zarith; intros HH1.
+    case (Z.le_gt_cases (Zpos (xO w_digits)) [[ww_head1 x]]); auto with zarith; intros HH1.
     case Hp2; intros _ HH2; contradict HH2.
-    apply Zle_not_lt; unfold base.
-    apply Zle_trans with (2 ^ [[ww_head1 x]]).
+    apply Z.le_ngt; unfold base.
+    apply Z.le_trans with (2 ^ [[ww_head1 x]]).
       apply Zpower_le_monotone; auto with zarith.
     pattern (2 ^ [[ww_head1 x]]) at 1;
-      rewrite <- (Zmult_1_r (2 ^ [[ww_head1 x]])).
-    apply Zmult_le_compat_l; auto with zarith.
+      rewrite <- (Z.mul_1_r (2 ^ [[ww_head1 x]])).
+    apply Z.mul_le_mono_nonneg_l; auto with zarith.
   generalize (spec_ww_add_mul_div x W0 (ww_head1 x) Hv2);
      case ww_add_mul_div.
   simpl ww_to_Z; autorewrite with w_rewrite rm10.
   rewrite Zmod_small; auto with zarith.
-  intros H2; case (Zmult_integral _ _ (sym_equal H2)); clear H2; intros H2.
-  rewrite H2; unfold Zpower, Zpower_pos; simpl; auto with zarith.
+  intros H2. symmetry in H2. rewrite Z.mul_eq_0 in H2. destruct H2 as [H2|H2].
+  rewrite H2; unfold Z.pow, Z.pow_pos; simpl; auto with zarith.
   match type of H2 with ?X = ?Y =>
    absurd (Y < X); try (rewrite H2; auto with zarith; fail)
   end.
-  apply Zpower_gt_0; auto with zarith.
+  apply Z.pow_pos_nonneg; auto with zarith.
   split; auto with zarith.
-  case Hp2; intros _ tmp; apply Zle_lt_trans with (2 := tmp);
+  case Hp2; intros _ tmp; apply Z.le_lt_trans with (2 := tmp);
    clear tmp.
-  rewrite Zmult_comm; apply Zmult_le_compat_r; auto with zarith.
+  rewrite Z.mul_comm; apply Z.mul_le_mono_nonneg_r; auto with zarith.
   assert (Hv0: [[ww_head1 x]] = 2 * ([[ww_head1 x]]/2)).
     pattern [[ww_head1 x]] at 1; rewrite (Z_div_mod_eq [[ww_head1 x]] 2);
       auto with zarith.
     generalize (spec_ww_is_even (ww_head1 x)); rewrite Hp1;
-      intros tmp; rewrite tmp; rewrite Zplus_0_r; auto.
+      intros tmp; rewrite tmp; rewrite Z.add_0_r; auto.
   intros w0 w1; autorewrite with w_rewrite rm10.
   rewrite Zmod_small; auto with zarith.
-  2: rewrite Zmult_comm; auto with zarith.
+  2: rewrite Z.mul_comm; auto with zarith.
   intros H2.
   assert (V: wB/4 <= [|w0|]).
   apply beta_lex with 0 [|w1|] wB; auto with zarith; autorewrite with rm10.
   simpl ww_to_Z in H2; rewrite H2.
   rewrite <- wwB_4_wB_4; auto with zarith.
-  rewrite Zmult_comm; auto with zarith.
+  rewrite Z.mul_comm; auto with zarith.
   assert (V1 := spec_to_Z w1);auto with zarith.
   generalize (@spec_w_sqrt2 w0 w1 V);auto with zarith.
   case (w_sqrt2 w0 w1); intros w2 c.
@@ -1280,13 +1262,13 @@ intros x; case x; simpl ww_is_even.
     rewrite spec_ww_pred; rewrite spec_ww_zdigits.
     rewrite Zmod_small; auto with zarith.
     split; auto with zarith.
-    apply Zlt_le_trans with (Zpos (xO w_digits)); auto with zarith.
+    apply Z.lt_le_trans with (Zpos (xO w_digits)); auto with zarith.
     unfold base; apply Zpower2_le_lin; auto with zarith.
   assert (Hv4: [[ww_head1 x]]/2 < wB).
-    apply Zle_lt_trans with (Zpos w_digits).
-    apply Zmult_le_reg_r with 2; auto with zarith.
-    repeat rewrite (fun x => Zmult_comm x 2).
-    rewrite <- Hv0;  rewrite <- Zpos_xO; auto.
+    apply Z.le_lt_trans with (Zpos w_digits).
+    apply Z.mul_le_mono_pos_r with 2; auto with zarith.
+    repeat rewrite (fun x => Z.mul_comm x 2).
+    rewrite <- Hv0;  rewrite <- Pos2Z.inj_xO; auto.
     unfold base; apply Zpower2_lt_lin; auto with zarith.
   assert (Hv5: [[(ww_add_mul_div (ww_pred ww_zdigits) W0 (ww_head1 x))]]
                  = [[ww_head1 x]]/2).
@@ -1294,12 +1276,12 @@ intros x; case x; simpl ww_is_even.
     simpl ww_to_Z; autorewrite with rm10.
     rewrite Hv3.
     ring_simplify (Zpos (xO w_digits) - (Zpos (xO w_digits) - 1)).
-    rewrite Zpower_1_r.
+    rewrite Z.pow_1_r.
     rewrite Zmod_small; auto with zarith.
     split; auto with zarith.
-    apply Zlt_le_trans with (1 := Hv4); auto with zarith.
+    apply Z.lt_le_trans with (1 := Hv4); auto with zarith.
     unfold base; apply Zpower_le_monotone; auto with zarith.
-    split; unfold ww_digits; try rewrite Zpos_xO; auto with zarith.
+    split; unfold ww_digits; try rewrite Pos2Z.inj_xO; auto with zarith.
     rewrite Hv3; auto with zarith.
   assert (Hv6: [|low(ww_add_mul_div (ww_pred ww_zdigits) W0 (ww_head1 x))|]
                  = [[ww_head1 x]]/2).
@@ -1315,13 +1297,13 @@ intros x; case x; simpl ww_is_even.
   rewrite Zmod_small.
   simpl ww_to_Z in H2; rewrite H2; auto with zarith.
   intros (H4, H5); split.
-  apply Zmult_le_reg_r with (2 ^ [[ww_head1 x]]); auto with zarith.
+  apply Z.mul_le_mono_pos_r with (2 ^ [[ww_head1 x]]); auto with zarith.
   rewrite H4.
-  apply Zle_trans with ([|w2|] ^ 2); auto with zarith.
-  rewrite Zmult_comm.
+  apply Z.le_trans with ([|w2|] ^ 2); auto with zarith.
+  rewrite Z.mul_comm.
   pattern [[ww_head1 x]] at 1;
     rewrite Hv0; auto with zarith.
-  rewrite (Zmult_comm 2); rewrite Zpower_mult;
+  rewrite (Z.mul_comm 2); rewrite Z.pow_mul_r;
     auto with zarith.
   assert (tmp: forall p q, p ^ 2 * q ^ 2 = (p * q) ^2);
    try (intros; repeat rewrite Zsquare_mult; ring);
@@ -1337,17 +1319,17 @@ intros x; case x; simpl ww_is_even.
   case (Z_mod_lt [|w2|] (2 ^ ([[ww_head1 x]] / 2))); auto with zarith.
   case c; unfold interp_carry; autorewrite with rm10;
     intros w3; assert (V3 := spec_to_Z w3);auto with zarith.
-  apply Zmult_lt_reg_r with (2 ^ [[ww_head1 x]]); auto with zarith.
+  apply Z.mul_lt_mono_pos_r with (2 ^ [[ww_head1 x]]); auto with zarith.
   rewrite H4.
-  apply Zle_lt_trans with ([|w2|] ^ 2 + 2 * [|w2|]); auto with zarith.
-  apply Zlt_le_trans with (([|w2|] + 1) ^ 2); auto with zarith.
+  apply Z.le_lt_trans with ([|w2|] ^ 2 + 2 * [|w2|]); auto with zarith.
+  apply Z.lt_le_trans with (([|w2|] + 1) ^ 2); auto with zarith.
   match goal with |- ?X < ?Y =>
     replace Y with (X + 1); auto with zarith
   end.
   repeat rewrite (Zsquare_mult); ring.
-  rewrite Zmult_comm.
+  rewrite Z.mul_comm.
   pattern [[ww_head1 x]] at 1; rewrite Hv0.
-  rewrite (Zmult_comm 2); rewrite Zpower_mult;
+  rewrite (Z.mul_comm 2); rewrite Z.pow_mul_r;
    auto with zarith.
   assert (tmp: forall p q, p ^ 2 * q ^ 2 = (p * q) ^2);
    try (intros; repeat rewrite Zsquare_mult; ring);
@@ -1356,20 +1338,20 @@ intros x; case x; simpl ww_is_even.
   split; auto with zarith.
   pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] (2 ^ ([[ww_head1 x]]/2)));
     auto with zarith.
-  rewrite <- Zplus_assoc; rewrite Zmult_plus_distr_r.
-  autorewrite with rm10; apply Zplus_le_compat_l; auto with zarith.
+  rewrite <- Z.add_assoc; rewrite Z.mul_add_distr_l.
+  autorewrite with rm10; apply Z.add_le_mono_l; auto with zarith.
   case (Z_mod_lt [|w2|] (2 ^ ([[ww_head1 x]]/2))); auto with zarith.
   split; auto with zarith.
-  apply Zle_lt_trans with ([|w2|]); auto with zarith.
+  apply Z.le_lt_trans with ([|w2|]); auto with zarith.
   apply Zdiv_le_upper_bound; auto with zarith.
   pattern [|w2|] at 1; replace [|w2|] with ([|w2|] * 2 ^0);
     auto with zarith.
-  apply Zmult_le_compat_l; auto with zarith.
+  apply Z.mul_le_mono_nonneg_l; auto with zarith.
   apply Zpower_le_monotone; auto with zarith.
-  rewrite Zpower_0_r; autorewrite with rm10; auto.
+  rewrite Z.pow_0_r; autorewrite with rm10; auto.
   split; auto with zarith.
-  rewrite Hv0 in Hv2; rewrite (Zpos_xO w_digits) in Hv2; auto with zarith.
-  apply Zle_lt_trans with (Zpos w_digits); auto with zarith.
+  rewrite Hv0 in Hv2; rewrite (Pos2Z.inj_xO w_digits) in Hv2; auto with zarith.
+  apply Z.le_lt_trans with (Zpos w_digits); auto with zarith.
   unfold base; apply Zpower2_lt_lin; auto with zarith.
   rewrite spec_w_sub; auto with zarith.
   rewrite Hv6; rewrite spec_w_zdigits; auto with zarith.
@@ -1377,10 +1359,10 @@ intros x; case x; simpl ww_is_even.
   rewrite Zmod_small; auto with zarith.
   split; auto with zarith.
   assert ([[ww_head1 x]]/2 <= Zpos w_digits); auto with zarith.
-  apply Zmult_le_reg_r with 2; auto with zarith.
-  repeat rewrite (fun x => Zmult_comm x 2).
-  rewrite <- Hv0; rewrite <- Zpos_xO; auto with zarith.
-  apply Zle_lt_trans with (Zpos w_digits); auto with zarith.
+  apply Z.mul_le_mono_pos_r with 2; auto with zarith.
+  repeat rewrite (fun x => Z.mul_comm x 2).
+  rewrite <- Hv0; rewrite <- Pos2Z.inj_xO; auto with zarith.
+  apply Z.le_lt_trans with (Zpos w_digits); auto with zarith.
   unfold base; apply Zpower2_lt_lin; auto with zarith.
   Qed.
 
diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v
index 3167f4c7..799c4e42 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-2012     *)
 (*   \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.
@@ -197,9 +195,9 @@ Section DoubleSub.
   Lemma spec_ww_opp_c : forall x, [-[ww_opp_c x]] = -[[x]].
   Proof.
    destruct x as [ |xh xl];simpl. reflexivity.
-   rewrite Zopp_plus_distr;generalize (spec_opp_c xl);destruct (w_opp_c xl)
+   rewrite Z.opp_add_distr;generalize (spec_opp_c xl);destruct (w_opp_c xl)
    as [l|l];intros H;unfold interp_carry in H;rewrite <- H;
-   rewrite Zopp_mult_distr_l.
+   rewrite <- Z.mul_opp_l.
    assert ([|l|] = 0).
     assert (H1:= spec_to_Z l);assert (H2 := spec_to_Z xl);omega.
    rewrite H0;generalize (spec_opp_c xh);destruct (w_opp_c xh)
@@ -215,13 +213,13 @@ Section DoubleSub.
   Lemma spec_ww_opp : forall x, [[ww_opp x]] = (-[[x]]) mod wwB.
   Proof.
    destruct x as [ |xh xl];simpl. reflexivity.
-   rewrite Zopp_plus_distr;rewrite Zopp_mult_distr_l.
+   rewrite Z.opp_add_distr, <- Z.mul_opp_l.
    generalize (spec_opp_c xl);destruct (w_opp_c xl)
    as [l|l];intros H;unfold interp_carry in H;rewrite <- H;simpl ww_to_Z.
-   rewrite spec_w_0;rewrite Zplus_0_r;rewrite wwB_wBwB.
+   rewrite spec_w_0;rewrite Z.add_0_r;rewrite wwB_wBwB.
    assert ([|l|] = 0).
     assert (H1:= spec_to_Z l);assert (H2 := spec_to_Z xl);omega.
-   rewrite H0;rewrite Zplus_0_r; rewrite Zpower_2;
+   rewrite H0;rewrite Z.add_0_r; rewrite Z.pow_2_r;
     rewrite Zmult_mod_distr_r;try apply lt_0_wB.
    rewrite spec_opp;trivial.
    apply Zmod_unique with (q:= -1).
@@ -242,7 +240,7 @@ Section DoubleSub.
    simpl ww_to_Z;replace (([|xh|]*wB+[|xl|])-1) with ([|xh|]*wB+([|xl|]-1)).
    2:ring. generalize (spec_pred_c xl);destruct (w_pred_c xl) as [l|l];
    intros H;unfold interp_carry in H;rewrite <- H. simpl;apply spec_w_WW.
-   rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l.
+   rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r.
    assert ([|l|] = wB - 1).
      assert (H1:= spec_to_Z l);assert (H2 := spec_to_Z xl);omega.
    rewrite H0;change ([|xh|] + -1) with ([|xh|] - 1).
@@ -265,7 +263,7 @@ Section DoubleSub.
    generalize (spec_sub_c xh yh);destruct (w_sub_c xh yh) as [h|h];intros H1;
    unfold interp_carry in H1;rewrite <- H1;unfold interp_carry;
    try rewrite spec_w_WW;simpl ww_to_Z;try rewrite wwB_wBwB;ring.
-   rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l.
+   rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r.
    change ([|xh|] - [|yh|] + -1) with ([|xh|] - [|yh|] - 1).
    generalize (spec_sub_carry_c xh yh);destruct (w_sub_carry_c xh yh) as [h|h];
    intros H1;unfold interp_carry in *;rewrite <- H1;simpl ww_to_Z;
@@ -276,7 +274,7 @@ Section DoubleSub.
      forall x y, [-[ww_sub_carry_c x y]] = [[x]] - [[y]] - 1.
   Proof.
    destruct y as [ |yh yl];simpl.
-   unfold Zminus;simpl;rewrite Zplus_0_r;exact (spec_ww_pred_c x).
+   unfold Z.sub;simpl;rewrite Z.add_0_r;exact (spec_ww_pred_c x).
    destruct x as [ |xh xl].
    unfold interp_carry;rewrite spec_w_WW;simpl ww_to_Z;rewrite wwB_wBwB;
    repeat rewrite spec_opp_carry;ring.
@@ -288,7 +286,7 @@ Section DoubleSub.
    generalize (spec_sub_c xh yh);destruct (w_sub_c xh yh) as [h|h];intros H1;
    unfold interp_carry in H1;rewrite <- H1;unfold interp_carry;
    try rewrite spec_w_WW;simpl ww_to_Z;try rewrite wwB_wBwB;ring.
-   rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l.
+   rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r.
    change ([|xh|] - [|yh|] + -1) with ([|xh|] - [|yh|] - 1).
    generalize (spec_sub_carry_c xh yh);destruct (w_sub_carry_c xh yh) as [h|h];
    intros H1;unfold interp_carry in *;rewrite <- H1;try rewrite spec_w_WW;
@@ -305,7 +303,7 @@ Section DoubleSub.
    unfold interp_carry in H;rewrite <- H;simpl ww_to_Z.
    rewrite Zmod_small. apply spec_w_WW.
    exact (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW xh l)).
-   rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l.
+   rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r.
    change ([|xh|] + -1) with ([|xh|] - 1).
    assert ([|l|] = wB - 1).
     assert (H1:= spec_to_Z l);assert (H2:= spec_to_Z xl);omega.
@@ -324,7 +322,7 @@ Section DoubleSub.
    unfold interp_carry in H;rewrite <- H.
    rewrite spec_w_WW;rewrite (mod_wwB w_digits w_to_Z spec_to_Z).
    rewrite spec_sub;trivial.
-   simpl ww_to_Z;rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l.
+   simpl ww_to_Z;rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r.
    rewrite (mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_sub_carry;trivial.
   Qed.
 
@@ -343,7 +341,7 @@ Section DoubleSub.
    generalize (spec_sub_carry_c xl yl);destruct (w_sub_carry_c xl yl)as[l|l];
    intros H;unfold interp_carry in H;rewrite <- H;rewrite spec_w_WW.
    rewrite (mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_sub;trivial.
-   rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l.
+   rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r.
    rewrite (mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_sub_carry;trivial.
   Qed.
 
diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v
index eb1132d4..ce1c0bef 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,14 +8,12 @@
 (*            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.
 Local Open Scope Z_scope.
 
-Definition base digits := Zpower 2 (Zpos digits).
+Definition base digits := Z.pow 2 (Zpos digits).
 
 Section Carry.
 
@@ -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..385217d0 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-2012     *)
 (*   \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 *)
 
 (**
@@ -370,7 +368,7 @@ Section Basics.
  (** Variant of [phi] via [recrbis] *)
 
  Let Phi := fun b (_:int31) =>
-       match b with D0 => Zdouble | D1 => Zdouble_plus_one end.
+       match b with D0 => Z.double | D1 => Z.succ_double end.
 
  Definition phibis_aux n x := recrbis_aux n _ Z0 Phi x.
 
@@ -383,7 +381,7 @@ Section Basics.
  (** Recursive equations satisfied by [phi] *)
 
  Lemma phi_eqn1 : forall x, firstr x = D0 ->
-  phi x = Zdouble (phi (shiftr x)).
+  phi x = Z.double (phi (shiftr x)).
  Proof.
  intros.
  case_eq (iszero x); intros.
@@ -393,7 +391,7 @@ Section Basics.
  Qed.
 
  Lemma phi_eqn2 : forall x, firstr x = D1 ->
-  phi x = Zdouble_plus_one (phi (shiftr x)).
+  phi x = Z.succ_double (phi (shiftr x)).
  Proof.
  intros.
  case_eq (iszero x); intros.
@@ -403,7 +401,7 @@ Section Basics.
  Qed.
 
  Lemma phi_twice_firstl : forall x, firstl x = D0 ->
-  phi (twice x) = Zdouble (phi x).
+  phi (twice x) = Z.double (phi x).
  Proof.
  intros.
  rewrite phi_eqn1; auto; [ | destruct x; auto ].
@@ -412,7 +410,7 @@ Section Basics.
  Qed.
 
  Lemma phi_twice_plus_one_firstl : forall x, firstl x = D0 ->
-  phi (twice_plus_one x) = Zdouble_plus_one (phi x).
+  phi (twice_plus_one x) = Z.succ_double (phi x).
  Proof.
  intros.
  rewrite phi_eqn2; auto; [ | destruct x; auto ].
@@ -432,13 +430,13 @@ Section Basics.
  unfold phibis_aux, recrbis_aux; fold recrbis_aux;
   fold (phibis_aux n (shiftr x)).
  destruct (firstr x).
- specialize IHn with (shiftr x); rewrite Zdouble_mult; omega.
- specialize IHn with (shiftr x); rewrite Zdouble_plus_one_mult; omega.
+ specialize IHn with (shiftr x); rewrite Z.double_spec; omega.
+ specialize IHn with (shiftr x); rewrite Z.succ_double_spec; omega.
  Qed.
 
  Lemma phibis_aux_bounded :
   forall n x, n <= size ->
-  (phibis_aux n (nshiftr (size-n) x) < 2 ^ (Z_of_nat n))%Z.
+  (phibis_aux n (nshiftr (size-n) x) < 2 ^ (Z.of_nat n))%Z.
  Proof.
  induction n.
  simpl; unfold phibis_aux; simpl; auto with zarith.
@@ -452,13 +450,13 @@ Section Basics.
  assert (H1 : n <= size) by omega.
  specialize (IHn x H1).
  set (y:=phibis_aux n (nshiftr (size - n) x)) in *.
- rewrite inj_S, Zpower_Zsucc; auto with zarith.
+ rewrite Nat2Z.inj_succ, Z.pow_succ_r; auto with zarith.
  case_eq (firstr (nshiftr (size - S n) x)); intros.
- rewrite Zdouble_mult; auto with zarith.
- rewrite Zdouble_plus_one_mult; auto with zarith.
+ rewrite Z.double_spec; auto with zarith.
+ rewrite Z.succ_double_spec; auto with zarith.
  Qed.
 
- Lemma phi_bounded  : forall x, (0 <= phi x < 2 ^ (Z_of_nat size))%Z.
+ Lemma phi_bounded  : forall x, (0 <= phi x < 2 ^ (Z.of_nat size))%Z.
  Proof.
  intros.
  rewrite <- phibis_aux_equiv.
@@ -470,32 +468,32 @@ Section Basics.
 
  Lemma phibis_aux_lowerbound :
   forall n x, firstr (nshiftr n x) = D1 ->
-  (2 ^ Z_of_nat n <= phibis_aux (S n) x)%Z.
+  (2 ^ Z.of_nat n <= phibis_aux (S n) x)%Z.
  Proof.
  induction n.
  intros.
  unfold nshiftr in H; simpl in *.
  unfold phibis_aux, recrbis_aux.
- rewrite H, Zdouble_plus_one_mult; omega.
+ rewrite H, Z.succ_double_spec; omega.
 
  intros.
  remember (S n) as m.
  unfold phibis_aux, recrbis_aux; fold recrbis_aux;
   fold (phibis_aux m (shiftr x)).
  subst m.
- rewrite inj_S, Zpower_Zsucc; auto with zarith.
- assert (2^(Z_of_nat n) <= phibis_aux (S n) (shiftr x))%Z.
+ rewrite Nat2Z.inj_succ, Z.pow_succ_r; auto with zarith.
+ assert (2^(Z.of_nat n) <= phibis_aux (S n) (shiftr x))%Z.
   apply IHn.
   rewrite <- nshiftr_S_tail; auto.
  destruct (firstr x).
- change (Zdouble (phibis_aux (S n) (shiftr x))) with
+ change (Z.double (phibis_aux (S n) (shiftr x))) with
         (2*(phibis_aux (S n) (shiftr x)))%Z.
  omega.
- rewrite Zdouble_plus_one_mult; omega.
+ rewrite Z.succ_double_spec; omega.
  Qed.
 
  Lemma phi_lowerbound :
-  forall x, firstl x = D1 -> (2^(Z_of_nat (pred size)) <= phi x)%Z.
+  forall x, firstl x = D1 -> (2^(Z.of_nat (pred size)) <= phi x)%Z.
  Proof.
  intros.
  generalize (phibis_aux_lowerbound (pred size) x).
@@ -778,7 +776,7 @@ Section Basics.
  (** First, recursive equations *)
 
  Lemma phi_inv_double_plus_one : forall z,
-   phi_inv (Zdouble_plus_one z) = twice_plus_one (phi_inv z).
+   phi_inv (Z.succ_double z) = twice_plus_one (phi_inv z).
  Proof.
  destruct z; simpl; auto.
  induction p; simpl.
@@ -790,20 +788,20 @@ Section Basics.
  Qed.
 
  Lemma phi_inv_double : forall z,
-   phi_inv (Zdouble z) = twice (phi_inv z).
+   phi_inv (Z.double z) = twice (phi_inv z).
  Proof.
  destruct z; simpl; auto.
  rewrite incr_twice_plus_one; auto.
  Qed.
 
  Lemma phi_inv_incr : forall z,
-  phi_inv (Zsucc z) = incr (phi_inv z).
+  phi_inv (Z.succ z) = incr (phi_inv z).
  Proof.
  destruct z.
  simpl; auto.
  simpl; auto.
  induction p; simpl; auto.
- rewrite Pplus_one_succ_r, IHp, incr_twice_plus_one; auto.
+ rewrite <- Pos.add_1_r, IHp, incr_twice_plus_one; auto.
  rewrite incr_twice; auto.
  simpl; auto.
  destruct p; simpl; auto.
@@ -907,30 +905,32 @@ 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.
- replace (2^(Z_of_nat (S n)))%Z with (2*2^(Z_of_nat n))%Z by
-  (rewrite <- Zpower_Zsucc, <- Zpos_P_of_succ_nat;
+ simpl; rewrite Pos.mul_1_r; auto.
+ replace (2^(Z.of_nat (S n)))%Z with (2*2^(Z.of_nat n))%Z by
+  (rewrite <- Z.pow_succ_r, <- Zpos_P_of_succ_nat;
    auto with zarith).
- rewrite (Zmult_comm 2).
- assert (n<=size) by omega.
+ rewrite (Z.mul_comm 2).
+ assert (n<=size)%nat by omega.
  destruct p; simpl; [ | | auto];
   specialize (IHn p H0);
   generalize (p2ibis_bounded n p);
   destruct (p2ibis n p) as (r,i); simpl in *; intros.
 
  change (Zpos p~1) with (2*Zpos p + 1)%Z.
- rewrite phi_twice_plus_one_firstl, Zdouble_plus_one_mult.
+ rewrite phi_twice_plus_one_firstl, Z.succ_double_spec.
  rewrite IHn; ring.
  apply (nshiftr_0_firstl n); auto; try omega.
 
  change (Zpos p~0) with (2*Zpos p)%Z.
  rewrite phi_twice_firstl.
- change (Zdouble (phi i)) with (2*(phi i))%Z.
+ change (Z.double (phi i)) with (2*(phi i))%Z.
  rewrite IHn; ring.
  apply (nshiftr_0_firstl n); auto; try omega.
  Qed.
@@ -956,12 +956,12 @@ Section Basics.
      for the positive case. *)
 
  Lemma phi_phi_inv_positive : forall p,
-  phi (phi_inv_positive p) = (Zpos p) mod (2^(Z_of_nat size)).
+  phi (phi_inv_positive p) = (Zpos p) mod (2^(Z.of_nat size)).
  Proof.
  intros.
  replace (phi_inv_positive p) with (snd (p2ibis size p)).
  rewrite (p2ibis_spec size p) by auto.
- rewrite Zplus_comm, Z_mod_plus.
+ rewrite Z.add_comm, Z_mod_plus.
  symmetry; apply Zmod_small.
  apply phi_bounded.
  auto with zarith.
@@ -973,20 +973,21 @@ 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.
- rewrite <- Zdouble_mult, <- phi_twice_firstl, phi_inv_phi; auto.
+ rewrite <- Z.double_spec, <- phi_twice_firstl, phi_inv_phi; auto.
  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.
  unfold add31.
- rewrite phi_twice_firstl, <- Zdouble_plus_one_mult,
+ rewrite phi_twice_firstl, <- Z.succ_double_spec,
    <- phi_twice_plus_one_firstl, phi_inv_phi; auto.
  Qed.
 
@@ -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.
@@ -1028,43 +1029,43 @@ Section Basics.
      [phi o twice] and so one. *)
 
  Lemma phi_twice : forall x,
-   phi (twice x) = (Zdouble (phi x)) mod 2^(Z_of_nat size).
+   phi (twice x) = (Z.double (phi x)) mod 2^(Z.of_nat size).
  Proof.
  intros.
  pattern x at 1; rewrite <- (phi_inv_phi x).
  rewrite <- phi_inv_double.
- assert (0 <= Zdouble (phi x))%Z.
-  rewrite Zdouble_mult; generalize (phi_bounded x); omega.
- destruct (Zdouble (phi x)).
+ assert (0 <= Z.double (phi x)).
+  rewrite Z.double_spec; generalize (phi_bounded x); omega.
+ destruct (Z.double (phi x)).
  simpl; auto.
  apply phi_phi_inv_positive.
  compute in H; elim H; auto.
  Qed.
 
  Lemma phi_twice_plus_one : forall x,
-   phi (twice_plus_one x) = (Zdouble_plus_one (phi x)) mod 2^(Z_of_nat size).
+   phi (twice_plus_one x) = (Z.succ_double (phi x)) mod 2^(Z.of_nat size).
  Proof.
  intros.
  pattern x at 1; rewrite <- (phi_inv_phi x).
  rewrite <- phi_inv_double_plus_one.
- assert (0 <= Zdouble_plus_one (phi x))%Z.
-  rewrite Zdouble_plus_one_mult; generalize (phi_bounded x); omega.
- destruct (Zdouble_plus_one (phi x)).
+ assert (0 <= Z.succ_double (phi x)).
+  rewrite Z.succ_double_spec; generalize (phi_bounded x); omega.
+ destruct (Z.succ_double (phi x)).
  simpl; auto.
  apply phi_phi_inv_positive.
  compute in H; elim H; auto.
  Qed.
 
  Lemma phi_incr : forall x,
-   phi (incr x) = (Zsucc (phi x)) mod 2^(Z_of_nat size).
+   phi (incr x) = (Z.succ (phi x)) mod 2^(Z.of_nat size).
  Proof.
  intros.
  pattern x at 1; rewrite <- (phi_inv_phi x).
  rewrite <- phi_inv_incr.
- assert (0 <= Zsucc (phi x))%Z.
-  change (Zsucc (phi x)) with ((phi x)+1)%Z;
+ assert (0 <= Z.succ (phi x)).
+  change (Z.succ (phi x)) with ((phi x)+1)%Z;
    generalize (phi_bounded x); omega.
- destruct (Zsucc (phi x)).
+ destruct (Z.succ (phi x)).
  simpl; auto.
  apply phi_phi_inv_positive.
  compute in H; elim H; auto.
@@ -1074,7 +1075,7 @@ Section Basics.
     in the negative case *)
 
  Lemma phi_phi_inv_negative :
-  forall p, phi (incr (complement_negative p)) = (Zneg p) mod 2^(Z_of_nat size).
+  forall p, phi (incr (complement_negative p)) = (Zneg p) mod 2^(Z.of_nat size).
  Proof.
  induction p.
 
@@ -1082,21 +1083,21 @@ Section Basics.
  rewrite phi_incr in IHp.
  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.
+ rewrite Z.succ_double_spec.
+ replace (2*q+1) with (2*(Z.succ 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.
 
  simpl complement_negative.
  rewrite incr_twice_plus_one, phi_twice.
  remember (phi (incr (complement_negative p))) as q.
- rewrite Zdouble_mult, IHp, Zmult_mod_idemp_r; auto with zarith.
+ rewrite Z.double_spec, IHp, Zmult_mod_idemp_r; auto with zarith.
 
  simpl; auto.
  Qed.
 
  Lemma phi_phi_inv :
-  forall z, phi (phi_inv z) = z mod 2 ^ (Z_of_nat size).
+  forall z, phi (phi_inv z) = z mod 2 ^ (Z.of_nat size).
  Proof.
  destruct z.
  simpl; auto.
@@ -1106,87 +1107,67 @@ 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.
 
  Notation "[| x |]" := (phi x)  (at level 0, x at level 99).
 
- Local Notation wB := (2 ^ (Z_of_nat size)).
+ Local Notation wB := (2 ^ (Z.of_nat size)).
 
  Lemma wB_pos : wB > 0.
  Proof.
@@ -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 *)
 
@@ -1248,14 +1221,14 @@ Section Int31_Spec.
  set (X:=[|x|]) in *; set (Y:=[|y|]) in *; clearbody X Y.
 
  assert ((X+Y) mod wB ?= X+Y <> Eq -> [+|C1 (phi_inv (X+Y))|] = X+Y).
-  unfold interp_carry; rewrite phi_phi_inv, Zcompare_Eq_iff_eq; intros.
+  unfold interp_carry; rewrite phi_phi_inv, Z.compare_eq_iff; intros.
   destruct (Z_lt_le_dec (X+Y) wB).
   contradict H1; auto using Zmod_small with zarith.
   rewrite <- (Z_mod_plus_full (X+Y) (-1) wB).
   rewrite Zmod_small; romega.
 
- generalize (Zcompare_Eq_eq ((X+Y) mod wB) (X+Y)); intros Heq.
- destruct Zcompare; intros;
+ generalize (Z.compare_eq ((X+Y) mod wB) (X+Y)); intros Heq.
+ destruct Z.compare; intros;
   [ rewrite phi_phi_inv; auto | now apply H1 | now apply H1].
  Qed.
 
@@ -1272,14 +1245,14 @@ Section Int31_Spec.
  set (X:=[|x|]) in *; set (Y:=[|y|]) in *; clearbody X Y.
 
  assert ((X+Y+1) mod wB ?= X+Y+1 <> Eq -> [+|C1 (phi_inv (X+Y+1))|] = X+Y+1).
-  unfold interp_carry; rewrite phi_phi_inv, Zcompare_Eq_iff_eq; intros.
+  unfold interp_carry; rewrite phi_phi_inv, Z.compare_eq_iff; intros.
   destruct (Z_lt_le_dec (X+Y+1) wB).
   contradict H1; auto using Zmod_small with zarith.
   rewrite <- (Z_mod_plus_full (X+Y+1) (-1) wB).
   rewrite Zmod_small; romega.
 
- generalize (Zcompare_Eq_eq ((X+Y+1) mod wB) (X+Y+1)); intros Heq.
- destruct Zcompare; intros;
+ generalize (Z.compare_eq ((X+Y+1) mod wB) (X+Y+1)); intros Heq.
+ destruct Z.compare; intros;
   [ rewrite phi_phi_inv; auto | now apply H1 | now apply H1].
  Qed.
 
@@ -1311,14 +1284,14 @@ Section Int31_Spec.
  set (X:=[|x|]) in *; set (Y:=[|y|]) in *; clearbody X Y.
 
  assert ((X-Y) mod wB ?= X-Y <> Eq -> [-|C1 (phi_inv (X-Y))|] = X-Y).
-  unfold interp_carry; rewrite phi_phi_inv, Zcompare_Eq_iff_eq; intros.
+  unfold interp_carry; rewrite phi_phi_inv, Z.compare_eq_iff; intros.
   destruct (Z_lt_le_dec (X-Y) 0).
   rewrite <- (Z_mod_plus_full (X-Y) 1 wB).
   rewrite Zmod_small; romega.
   contradict H1; apply Zmod_small; romega.
 
- generalize (Zcompare_Eq_eq ((X-Y) mod wB) (X-Y)); intros Heq.
- destruct Zcompare; intros;
+ generalize (Z.compare_eq ((X-Y) mod wB) (X-Y)); intros Heq.
+ destruct Z.compare; intros;
   [ rewrite phi_phi_inv; auto | now apply H1 | now apply H1].
  Qed.
 
@@ -1330,14 +1303,14 @@ Section Int31_Spec.
  set (X:=[|x|]) in *; set (Y:=[|y|]) in *; clearbody X Y.
 
  assert ((X-Y-1) mod wB ?= X-Y-1 <> Eq -> [-|C1 (phi_inv (X-Y-1))|] = X-Y-1).
-  unfold interp_carry; rewrite phi_phi_inv, Zcompare_Eq_iff_eq; intros.
+  unfold interp_carry; rewrite phi_phi_inv, Z.compare_eq_iff; intros.
   destruct (Z_lt_le_dec (X-Y-1) 0).
   rewrite <- (Z_mod_plus_full (X-Y-1) 1 wB).
   rewrite Zmod_small; romega.
   contradict H1; apply Zmod_small; romega.
 
- generalize (Zcompare_Eq_eq ((X-Y-1) mod wB) (X-Y-1)); intros Heq.
- destruct Zcompare; intros;
+ generalize (Z.compare_eq ((X-Y-1) mod wB) (X-Y-1)); intros Heq.
+ destruct Z.compare; intros;
   [ rewrite phi_phi_inv; auto | now apply H1 | now apply H1].
  Qed.
 
@@ -1413,7 +1386,7 @@ Section Int31_Spec.
  apply Zmod_small.
  generalize (phi_bounded x)(phi_bounded y); intros.
  change (wB^2) with (wB * wB).
- auto using Zmult_lt_compat with zarith.
+ auto using Z.mul_lt_mono_nonneg with zarith.
  Qed.
 
  Lemma spec_mul : forall x y, [|x*y|] = ([|x|] * [|y|]) mod wB.
@@ -1439,29 +1412,26 @@ Section Int31_Spec.
  generalize (phi_bounded a1)(phi_bounded a2)(phi_bounded b); intros.
  assert ([|b|]>0) by (auto with zarith).
  generalize (Z_div_mod (phi2 a1 a2) [|b|] H4) (Z_div_pos (phi2 a1 a2) [|b|] H4).
- unfold Zdiv; destruct (Zdiv_eucl (phi2 a1 a2) [|b|]); simpl.
+ unfold Z.div; destruct (Z.div_eucl (phi2 a1 a2) [|b|]); simpl.
  rewrite ?phi_phi_inv.
  destruct 1; intros.
  unfold phi2 in *.
  change base with wB; change base with wB in H5.
- change (Zpower_pos 2 31) with wB; change (Zpower_pos 2 31) with wB in H.
- rewrite H5, Zmult_comm.
+ change (Z.pow_pos 2 31) with wB; change (Z.pow_pos 2 31) with wB in H.
+ rewrite H5, Z.mul_comm.
  replace (z0 mod wB) with z0 by (symmetry; apply Zmod_small; omega).
  replace (z mod wB) with z; auto with zarith.
   symmetry; apply Zmod_small.
   split.
   apply H7; change base with wB; auto with zarith.
-  apply Zmult_gt_0_lt_reg_r with [|b|].
-  omega.
-  rewrite Zmult_comm.
-  apply Zle_lt_trans with ([|b|]*z+z0).
-  omega.
+  apply Z.mul_lt_mono_pos_r with [|b|]; [omega| ].
+  rewrite Z.mul_comm.
+  apply Z.le_lt_trans with ([|b|]*z+z0); [omega| ].
   rewrite <- H5.
-  apply Zle_lt_trans with ([|a1|]*wB+(wB-1)).
-  omega.
+  apply Z.le_lt_trans with ([|a1|]*wB+(wB-1)); [omega | ].
   replace ([|a1|]*wB+(wB-1)) with (wB*([|a1|]+1)-1) by ring.
   assert (wB*([|a1|]+1) <= wB*[|b|]); try omega.
-  apply Zmult_le_compat; omega.
+  apply Z.mul_le_mono_nonneg; omega.
  Qed.
 
  Lemma spec_div : forall a b, 0 < [|b|] ->
@@ -1472,20 +1442,20 @@ Section Int31_Spec.
  unfold div31; intros.
  assert ([|b|]>0) by (auto with zarith).
  generalize (Z_div_mod [|a|] [|b|] H0) (Z_div_pos [|a|] [|b|] H0).
- unfold Zdiv; destruct (Zdiv_eucl [|a|] [|b|]); simpl.
+ unfold Z.div; destruct (Z.div_eucl [|a|] [|b|]); simpl.
  rewrite ?phi_phi_inv.
  destruct 1; intros.
- rewrite H1, Zmult_comm.
+ rewrite H1, Z.mul_comm.
  generalize (phi_bounded a)(phi_bounded b); intros.
  replace (z0 mod wB) with z0 by (symmetry; apply Zmod_small; omega).
  replace (z mod wB) with z; auto with zarith.
   symmetry; apply Zmod_small.
   split; auto with zarith.
-  apply Zle_lt_trans with [|a|]; auto with zarith.
+  apply Z.le_lt_trans with [|a|]; auto with zarith.
   rewrite H1.
-  apply Zle_trans with ([|b|]*z); try omega.
-  rewrite <- (Zmult_1_l z) at 1.
-  apply Zmult_le_compat; auto with zarith.
+  apply Z.le_trans with ([|b|]*z); try omega.
+  rewrite <- (Z.mul_1_l z) at 1.
+  apply Z.mul_le_mono_nonneg; auto with zarith.
  Qed.
 
  Lemma spec_mod :  forall a b, 0 < [|b|] ->
@@ -1493,9 +1463,9 @@ Section Int31_Spec.
  Proof.
  unfold div31; intros.
  assert ([|b|]>0) by (auto with zarith).
- unfold Zmod.
+ unfold Z.modulo.
  generalize (Z_div_mod [|a|] [|b|] H0).
- destruct (Zdiv_eucl [|a|] [|b|]); simpl.
+ destruct (Z.div_eucl [|a|] [|b|]); simpl.
  rewrite ?phi_phi_inv.
  destruct 1; intros.
  generalize (phi_bounded b); intros.
@@ -1533,12 +1503,12 @@ Section Int31_Spec.
  destruct [|b|].
  unfold size; auto with zarith.
  intros (_,H).
- cut (Psize p <= size)%nat; [ omega | rewrite <- Zpower2_Psize; auto].
+ cut (Pos.size_nat p <= size)%nat; [ omega | rewrite <- Zpower2_Psize; auto].
  intros (H,_); compute in H; elim H; auto.
  Qed.
 
  Lemma iter_int31_iter_nat : forall A f i a,
-  iter_int31 i A f a = iter_nat (Zabs_nat [|i|]) A f a.
+  iter_int31 i A f a = iter_nat (Z.abs_nat [|i|]) A f a.
  Proof.
  intros.
  unfold iter_int31.
@@ -1555,15 +1525,15 @@ Section Int31_Spec.
   rewrite <- iter_nat_plus.
 
  f_equal.
- rewrite Zdouble_mult, Zmult_comm, <- Zplus_diag_eq_mult_2.
- symmetry; apply Zabs_nat_Zplus; auto with zarith.
+ rewrite Z.double_spec, <- Z.add_diag.
+ symmetry; apply Zabs2Nat.inj_add; auto with zarith.
 
- change (iter_nat (S (Zabs_nat z + Zabs_nat z)) A f a =
-         iter_nat (Zabs_nat (Zdouble_plus_one z)) A f a); f_equal.
- rewrite Zdouble_plus_one_mult, Zmult_comm, <- Zplus_diag_eq_mult_2.
- rewrite Zabs_nat_Zplus; auto with zarith.
- rewrite Zabs_nat_Zplus; auto with zarith.
- change (Zabs_nat 1) with 1%nat; omega.
+ change (iter_nat (S (Z.abs_nat z + Z.abs_nat z)) A f a =
+         iter_nat (Z.abs_nat (Z.succ_double z)) A f a); f_equal.
+ rewrite Z.succ_double_spec, <- Z.add_diag.
+ rewrite Zabs2Nat.inj_add; auto with zarith.
+ rewrite Zabs2Nat.inj_add; auto with zarith.
+ change (Z.abs_nat 1) with 1%nat; omega.
  Qed.
 
  Fixpoint addmuldiv31_alt n i j :=
@@ -1573,12 +1543,12 @@ Section Int31_Spec.
   end.
 
  Lemma addmuldiv31_equiv : forall p x y,
-  addmuldiv31 p x y = addmuldiv31_alt (Zabs_nat [|p|]) x y.
+  addmuldiv31 p x y = addmuldiv31_alt (Z.abs_nat [|p|]) x y.
  Proof.
  intros.
  unfold addmuldiv31.
  rewrite iter_int31_iter_nat.
- set (n:=Zabs_nat [|p|]); clearbody n; clear p.
+ set (n:=Z.abs_nat [|p|]); clearbody n; clear p.
  revert x y; induction n.
  simpl; auto.
  intros.
@@ -1593,21 +1563,21 @@ Section Int31_Spec.
  Proof.
  intros.
  rewrite addmuldiv31_equiv.
- assert ([|p|] = Z_of_nat (Zabs_nat [|p|])).
-  rewrite inj_Zabs_nat; symmetry; apply Zabs_eq.
+ assert ([|p|] = Z.of_nat (Z.abs_nat [|p|])).
+  rewrite Zabs2Nat.id_abs; symmetry; apply Z.abs_eq.
   destruct (phi_bounded p); auto.
- rewrite H0; rewrite H0 in H; clear H0; rewrite Zabs_nat_Z_of_nat.
- set (n := Zabs_nat [|p|]) in *; clearbody n.
+ rewrite H0; rewrite H0 in H; clear H0; rewrite Zabs2Nat.id.
+ set (n := Z.abs_nat [|p|]) in *; clearbody n.
  assert (n <= 31)%nat.
-  rewrite inj_le_iff; auto with zarith.
+  rewrite Nat2Z.inj_le; auto with zarith.
  clear p H; revert x y.
 
  induction n.
  simpl; intros.
- change (Zpower_pos 2 31) with (2^31).
- rewrite Zmult_1_r.
+ change (Z.pow_pos 2 31) with (2^31).
+ rewrite Z.mul_1_r.
  replace ([|y|] / 2^31) with 0.
- rewrite Zplus_0_r.
+ rewrite Z.add_0_r.
  symmetry; apply Zmod_small; apply phi_bounded.
  symmetry; apply Zdiv_small; apply phi_bounded.
 
@@ -1615,76 +1585,74 @@ Section Int31_Spec.
  rewrite IHn; [ | omega ].
  case_eq (firstl y); intros.
 
- rewrite phi_twice, Zdouble_mult.
+ rewrite phi_twice, Z.double_spec.
  rewrite phi_twice_firstl; auto.
- change (Zdouble [|y|]) with (2*[|y|]).
- rewrite inj_S, Zpower_Zsucc; auto with zarith.
+ change (Z.double [|y|]) with (2*[|y|]).
+ rewrite Nat2Z.inj_succ, Z.pow_succ_r; auto with zarith.
  rewrite Zplus_mod; rewrite Zmult_mod_idemp_l; rewrite <- Zplus_mod.
  f_equal.
- apply Zplus_eq_compat.
+ f_equal.
  ring.
- replace (31-Z_of_nat n) with (Zsucc(31-Zsucc(Z_of_nat n))) by ring.
- rewrite Zpower_Zsucc, <- Zdiv_Zdiv; auto with zarith.
- rewrite Zmult_comm, Z_div_mult; auto with zarith.
+ replace (31-Z.of_nat n) with (Z.succ(31-Z.succ(Z.of_nat n))) by ring.
+ rewrite Z.pow_succ_r, <- Zdiv_Zdiv; auto with zarith.
+ rewrite Z.mul_comm, Z_div_mult; auto with zarith.
 
- rewrite phi_twice_plus_one, Zdouble_plus_one_mult.
+ rewrite phi_twice_plus_one, Z.succ_double_spec.
  rewrite phi_twice; auto.
- change (Zdouble [|y|]) with (2*[|y|]).
- rewrite inj_S, Zpower_Zsucc; auto with zarith.
+ change (Z.double [|y|]) with (2*[|y|]).
+ rewrite Nat2Z.inj_succ, Z.pow_succ_r; auto with zarith.
  rewrite Zplus_mod; rewrite Zmult_mod_idemp_l; rewrite <- Zplus_mod.
- rewrite Zmult_plus_distr_l, Zmult_1_l, <- Zplus_assoc.
+ rewrite Z.mul_add_distr_r, Z.mul_1_l, <- Z.add_assoc.
+ f_equal.
  f_equal.
- apply Zplus_eq_compat.
  ring.
  assert ((2*[|y|]) mod wB = 2*[|y|] - wB).
   clear - H. symmetry. apply Zmod_unique with 1; [ | ring ].
   generalize (phi_lowerbound  _ H) (phi_bounded y).
-  set (wB' := 2^Z_of_nat (pred size)).
+  set (wB' := 2^Z.of_nat (pred size)).
   replace wB with (2*wB'); [ omega | ].
-  unfold wB'. rewrite <- Zpower_Zsucc, <- inj_S by (auto with zarith).
+  unfold wB'. rewrite <- Z.pow_succ_r, <- Nat2Z.inj_succ by (auto with zarith).
   f_equal.
  rewrite H1.
- replace wB with (2^(Z_of_nat n)*2^(31-Z_of_nat n)) by
+ replace wB with (2^(Z.of_nat n)*2^(31-Z.of_nat n)) by
   (rewrite <- Zpower_exp; auto with zarith; f_equal; unfold size; ring).
- unfold Zminus; rewrite Zopp_mult_distr_l.
+ unfold Z.sub; rewrite <- Z.mul_opp_l.
  rewrite Z_div_plus; auto with zarith.
  ring_simplify.
- replace (31+-Z_of_nat n) with (Zsucc(31-Zsucc(Z_of_nat n))) by ring.
- rewrite Zpower_Zsucc, <- Zdiv_Zdiv; auto with zarith.
- rewrite Zmult_comm, Z_div_mult; auto with zarith.
+ replace (31+-Z.of_nat n) with (Z.succ(31-Z.succ(Z.of_nat n))) by ring.
+ rewrite Z.pow_succ_r, <- Zdiv_Zdiv; auto with zarith.
+ rewrite Z.mul_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.
   generalize (phi_bounded w).
   symmetry; apply Zmod_small.
   split; auto with zarith.
-  apply Zlt_le_trans with wB; auto with zarith.
+  apply Z.lt_le_trans with wB; auto with zarith.
   apply Zpower_le_monotone; auto with zarith.
  intros.
  case_eq ([|p|] ?= 31); intros;
-  [ apply H; rewrite (Zcompare_Eq_eq _ _ H0); auto with zarith | |
+  [ apply H; rewrite (Z.compare_eq _ _ H0); auto with zarith | |
     apply H; change ([|p|]>31)%Z in H0; auto with zarith ].
  change ([|p|]<31) in H0.
  rewrite spec_add_mul_div by auto with zarith.
- change [|0|] with 0%Z; rewrite Zmult_0_l, Zplus_0_l.
+ change [|0|] with 0%Z; rewrite Z.mul_0_l, Z.add_0_l.
  generalize (phi_bounded p)(phi_bounded w); intros.
  assert (31-[|p|]<wB).
-  apply Zle_lt_trans with 31%Z; auto with zarith.
+  apply Z.le_lt_trans with 31%Z; auto with zarith.
   compute; auto.
  assert ([|31-p|]=31-[|p|]).
   unfold sub31; rewrite phi_phi_inv.
   change [|31|] with 31%Z.
   apply Zmod_small; auto with zarith.
  rewrite spec_add_mul_div by (rewrite H4; auto with zarith).
- change [|0|] with 0%Z; rewrite Zdiv_0_l, Zplus_0_r.
+ change [|0|] with 0%Z; rewrite Zdiv_0_l, Z.add_0_r.
  rewrite H4.
  apply shift_unshift_mod_2; auto with zarith.
  Qed.
@@ -1711,7 +1679,7 @@ Section Int31_Spec.
   end.
 
  Lemma head031_equiv :
-   forall x, [|head031 x|] = Z_of_nat (head031_alt size x).
+   forall x, [|head031 x|] = Z.of_nat (head031_alt size x).
  Proof.
  intros.
  case_eq (iszero x); intros.
@@ -1719,9 +1687,9 @@ Section Int31_Spec.
  simpl; auto.
 
  unfold head031, recl.
- change On with (phi_inv (Z_of_nat (31-size))).
+ 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.
@@ -1729,12 +1697,12 @@ Section Int31_Spec.
  unfold recl_aux; fold recl_aux.
  unfold head031_alt; fold head031_alt.
  rewrite H.
- assert ([|phi_inv (Z_of_nat (31-S n))|] = Z_of_nat (31 - S n)).
+ assert ([|phi_inv (Z.of_nat (31-S n))|] = Z.of_nat (31 - S n)).
   rewrite phi_phi_inv.
   apply Zmod_small.
   split.
-  change 0 with (Z_of_nat O); apply inj_le; omega.
-  apply Zle_lt_trans with (Z_of_nat 31).
+  change 0 with (Z.of_nat O); apply inj_le; omega.
+  apply Z.le_lt_trans with (Z.of_nat 31).
   apply inj_le; omega.
   compute; auto.
  case_eq (firstl x); intros; auto.
@@ -1747,7 +1715,7 @@ Section Int31_Spec.
  f_equal.
  change [|In|] with 1.
  replace (31-n)%nat with (S (31 - S n))%nat by omega.
- rewrite inj_S; ring.
+ rewrite Nat2Z.inj_succ; ring.
 
  clear - H H2.
  rewrite (sneakr_shiftl x) in H.
@@ -1776,16 +1744,16 @@ Section Int31_Spec.
  revert x H H0.
  unfold size at 2 5.
  induction size.
- simpl Z_of_nat.
+ simpl Z.of_nat.
  intros.
  compute in H0; rewrite H0 in H; discriminate.
 
  intros.
  simpl head031_alt.
  case_eq (firstl x); intros.
- rewrite (inj_S (head031_alt n (shiftl x))), Zpower_Zsucc; auto with zarith.
- rewrite <- Zmult_assoc, Zmult_comm, <- Zmult_assoc, <-(Zmult_comm 2).
- rewrite <- Zdouble_mult, <- (phi_twice_firstl _ H1).
+ rewrite (Nat2Z.inj_succ (head031_alt n (shiftl x))), Z.pow_succ_r; auto with zarith.
+ rewrite <- Z.mul_assoc, Z.mul_comm, <- Z.mul_assoc, <-(Z.mul_comm 2).
+ rewrite <- Z.double_spec, <- (phi_twice_firstl _ H1).
  apply IHn.
 
  rewrite phi_nz; rewrite phi_nz in H; contradict H.
@@ -1794,9 +1762,9 @@ Section Int31_Spec.
 
  rewrite <- nshiftl_S_tail; auto.
 
- change (2^(Z_of_nat 0)) with 1; rewrite Zmult_1_l.
+ change (2^(Z.of_nat 0)) with 1; rewrite Z.mul_1_l.
  generalize (phi_bounded x); unfold size; split; auto with zarith.
- change (2^(Z_of_nat 31)/2) with (2^(Z_of_nat (pred size))).
+ change (2^(Z.of_nat 31)/2) with (2^(Z.of_nat (pred size))).
  apply phi_lowerbound; auto.
  Qed.
 
@@ -1819,7 +1787,7 @@ Section Int31_Spec.
   end.
 
  Lemma tail031_equiv :
-   forall x, [|tail031 x|] = Z_of_nat (tail031_alt size x).
+   forall x, [|tail031 x|] = Z.of_nat (tail031_alt size x).
  Proof.
  intros.
  case_eq (iszero x); intros.
@@ -1827,9 +1795,9 @@ Section Int31_Spec.
  simpl; auto.
 
  unfold tail031, recr.
- change On with (phi_inv (Z_of_nat (31-size))).
+ 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.
@@ -1837,12 +1805,12 @@ Section Int31_Spec.
  unfold recr_aux; fold recr_aux.
  unfold tail031_alt; fold tail031_alt.
  rewrite H.
- assert ([|phi_inv (Z_of_nat (31-S n))|] = Z_of_nat (31 - S n)).
+ assert ([|phi_inv (Z.of_nat (31-S n))|] = Z.of_nat (31 - S n)).
   rewrite phi_phi_inv.
   apply Zmod_small.
   split.
-  change 0 with (Z_of_nat O); apply inj_le; omega.
-  apply Zle_lt_trans with (Z_of_nat 31).
+  change 0 with (Z.of_nat O); apply inj_le; omega.
+  apply Z.le_lt_trans with (Z.of_nat 31).
   apply inj_le; omega.
   compute; auto.
  case_eq (firstr x); intros; auto.
@@ -1855,7 +1823,7 @@ Section Int31_Spec.
  f_equal.
  change [|In|] with 1.
  replace (31-n)%nat with (S (31 - S n))%nat by omega.
- rewrite inj_S; ring.
+ rewrite Nat2Z.inj_succ; ring.
 
  clear - H H2.
  rewrite (sneakl_shiftr x) in H.
@@ -1873,14 +1841,14 @@ Section Int31_Spec.
   apply nshiftr_size.
  revert x H H0.
  induction size.
- simpl Z_of_nat.
+ simpl Z.of_nat.
  intros.
  compute in H0; rewrite H0 in H; discriminate.
 
  intros.
  simpl tail031_alt.
  case_eq (firstr x); intros.
- rewrite (inj_S (tail031_alt n (shiftr x))), Zpower_Zsucc; auto with zarith.
+ rewrite (Nat2Z.inj_succ (tail031_alt n (shiftr x))), Z.pow_succ_r; auto with zarith.
  destruct (IHn (shiftr x)) as (y & Hy1 & Hy2).
 
  rewrite phi_nz; rewrite phi_nz in H; contradict H.
@@ -1890,13 +1858,13 @@ Section Int31_Spec.
 
  exists y; split; auto.
  rewrite phi_eqn1; auto.
- rewrite Zdouble_mult, Hy2; ring.
+ rewrite Z.double_spec, Hy2; ring.
 
  exists [|shiftr x|].
  split.
  generalize (phi_bounded (shiftr x)); auto with zarith.
  rewrite phi_eqn2; auto.
- rewrite Zdouble_plus_one_mult; simpl; ring.
+ rewrite Z.succ_double_spec; simpl; ring.
  Qed.
 
  (* Sqrt *)
@@ -1915,30 +1883,30 @@ Section Int31_Spec.
  Proof.
  intros Hj; generalize Hj k; pattern j; apply natlike_ind;
    auto; clear k j Hj.
- intros _ k Hk; repeat rewrite Zplus_0_l.
- apply  Zmult_le_0_compat; generalize (Z_div_pos k 2); auto with zarith.
+ intros _ k Hk; repeat rewrite Z.add_0_l.
+ apply  Z.mul_nonneg_nonneg; generalize (Z_div_pos k 2); auto with zarith.
  intros j Hj Hrec _ k Hk; pattern k; apply natlike_ind; auto; clear k Hk.
- rewrite Zmult_0_r, Zplus_0_r, Zplus_0_l.
- generalize (sqr_pos (Zsucc j / 2)) (quotient_by_2 (Zsucc j));
-   unfold Zsucc.
- rewrite Zpower_2, Zmult_plus_distr_l; repeat rewrite Zmult_plus_distr_r.
+ rewrite Z.mul_0_r, Z.add_0_r, Z.add_0_l.
+ generalize (sqr_pos (Z.succ j / 2)) (quotient_by_2 (Z.succ j));
+   unfold Z.succ.
+ rewrite Z.pow_2_r, Z.mul_add_distr_r; repeat rewrite Z.mul_add_distr_l.
  auto with zarith.
  intros k Hk _.
- replace ((Zsucc j + Zsucc k) / 2) with ((j + k)/2 + 1).
+ replace ((Z.succ j + Z.succ k) / 2) with ((j + k)/2 + 1).
  generalize (Hrec Hj k Hk) (quotient_by_2 (j + k)).
- unfold Zsucc; repeat rewrite Zpower_2;
-   repeat rewrite Zmult_plus_distr_l; repeat rewrite Zmult_plus_distr_r.
- repeat rewrite Zmult_1_l; repeat rewrite Zmult_1_r.
+ unfold Z.succ; repeat rewrite Z.pow_2_r;
+   repeat rewrite Z.mul_add_distr_r; repeat rewrite Z.mul_add_distr_l.
+ repeat rewrite Z.mul_1_l; repeat rewrite Z.mul_1_r.
  auto with zarith.
- rewrite Zplus_comm, <- Z_div_plus_full_l; auto with zarith.
- apply f_equal2 with (f := Zdiv); auto with zarith.
+ rewrite Z.add_comm, <- Z_div_plus_full_l; auto with zarith.
+ apply f_equal2 with (f := Z.div); auto with zarith.
  Qed.
 
  Lemma sqrt_main i j: 0 <= i -> 0 < j -> i < ((j + (i/j))/2 + 1) ^ 2.
  Proof.
  intros Hi Hj.
  assert (Hij: 0 <= i/j) by (apply Z_div_pos; auto with zarith).
- apply Zlt_le_trans with (2 := sqrt_main_trick _ _ (Zlt_le_weak _ _ Hj) Hij).
+ apply Z.lt_le_trans with (2 := sqrt_main_trick _ _ (Z.lt_le_incl _ _ Hj) Hij).
  pattern i at 1; rewrite (Z_div_mod_eq i j); case (Z_mod_lt i j); auto with zarith.
  Qed.
 
@@ -1948,48 +1916,34 @@ Section Int31_Spec.
  assert (H1: 0 <= i - 2) by auto with zarith.
  assert (H2: 1 <= (i / 2) ^ 2); auto with zarith.
    replace i with (1* 2 + (i - 2)); auto with zarith.
-   rewrite Zpower_2, Z_div_plus_full_l; auto with zarith.
+   rewrite Z.pow_2_r, Z_div_plus_full_l; auto with zarith.
    generalize (sqr_pos ((i - 2)/ 2)) (Z_div_pos (i - 2) 2).
-   rewrite Zmult_plus_distr_l; repeat rewrite Zmult_plus_distr_r.
+   rewrite Z.mul_add_distr_r; repeat rewrite Z.mul_add_distr_l.
    auto with zarith.
  generalize (quotient_by_2 i).
- rewrite Zpower_2 in H2 |- *;
-   repeat (rewrite Zmult_plus_distr_l ||
-           rewrite Zmult_plus_distr_r ||
-           rewrite Zmult_1_l || rewrite Zmult_1_r).
+ rewrite Z.pow_2_r in H2 |- *;
+   repeat (rewrite Z.mul_add_distr_r ||
+           rewrite Z.mul_add_distr_l ||
+           rewrite Z.mul_1_l || rewrite Z.mul_1_r).
    auto with zarith.
  Qed.
 
  Lemma sqrt_test_true i j: 0 <= i -> 0 < j -> i/j >= j -> j ^ 2 <= i.
  Proof.
- intros Hi Hj Hd; rewrite Zpower_2.
- apply Zle_trans with (j * (i/j)); auto with zarith.
+ intros Hi Hj Hd; rewrite Z.pow_2_r.
+ apply Z.le_trans with (j * (i/j)); auto with zarith.
  apply Z_mult_div_ge; auto with zarith.
  Qed.
 
  Lemma sqrt_test_false i j: 0 <= i -> 0 < j -> i/j < j ->  (j + (i/j))/2 < j.
  Proof.
- intros Hi Hj H; case (Zle_or_lt j ((j + (i/j))/2)); auto.
- intros H1; contradict H; apply Zle_not_lt.
+ intros Hi Hj H; case (Z.le_gt_cases j ((j + (i/j))/2)); auto.
+ intros H1; contradict H; apply Z.le_ngt.
  assert (2 * j <= j + (i/j)); auto with zarith.
- apply Zle_trans with (2 * ((j + (i/j))/2)); auto with zarith.
+ apply Z.le_trans with (2 * ((j + (i/j))/2)); auto with zarith.
  apply Z_mult_div_ge; auto with zarith.
  Qed.
 
- (* George's trick *)
- Inductive ZcompareSpec (i j: Z): comparison -> Prop :=
-   ZcompareSpecEq: i = j -> ZcompareSpec i j Eq
- | ZcompareSpecLt: i < j -> ZcompareSpec i j Lt
- | ZcompareSpecGt: j < i -> ZcompareSpec i j Gt.
-
- Lemma Zcompare_spec i j: ZcompareSpec i j (i ?= j).
- Proof.
- case_eq (Zcompare i j); intros H.
- apply ZcompareSpecEq; apply Zcompare_Eq_eq; auto.
- apply ZcompareSpecLt; auto.
- apply ZcompareSpecGt; apply Zgt_lt; auto.
- Qed.
-
  Lemma sqrt31_step_def rec i j:
    sqrt31_step rec i j =
    match (fst (i/j) ?= j)%int31 with
@@ -2016,65 +1970,66 @@ Section Int31_Spec.
     [|rec i j1|] ^ 2 <= [|i|] < ([|rec i j1|] + 1) ^ 2) ->
   [|sqrt31_step rec i j|] ^ 2 <= [|i|] < ([|sqrt31_step rec i j|] + 1) ^ 2.
  Proof.
- assert (Hp2: 0 < [|2|]) by exact (refl_equal Lt).
+ assert (Hp2: 0 < [|2|]) by exact (eq_refl 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 Z.compare_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|]).
  split.
- case (Zle_lt_or_eq 1 [|j|]); auto with zarith; intros Hj1.
+ apply Z.le_succ_l in Hj. change (1 <= [|j|]) in Hj.
+ Z.le_elim Hj.
  replace ([|j|] + [|i|]/[|j|]) with
         (1 * 2 + (([|j|] - 2) + [|i|] / [|j|])); try ring.
  rewrite Z_div_plus_full_l; auto with zarith.
  assert (0 <= [|i|]/ [|j|]) by (apply Z_div_pos; auto with zarith).
  assert (0 <= ([|j|] - 2 + [|i|] / [|j|]) / [|2|]) ; auto with zarith.
- rewrite <- Hj1, Zdiv_1_r.
+ rewrite <- Hj, Zdiv_1_r.
  replace (1 + [|i|])%Z with (1 * 2 + ([|i|] - 1))%Z; try ring.
  rewrite Z_div_plus_full_l; auto with zarith.
  assert (0 <= ([|i|] - 1) /2)%Z by (apply Z_div_pos; auto with zarith).
  change ([|2|]) with 2%Z; auto with zarith.
  apply sqrt_test_false; auto with zarith.
  rewrite spec_add, div31_phi; auto.
- apply sym_equal; apply Zmod_small.
+ symmetry; apply Zmod_small.
  split; auto with zarith.
  replace [|j + fst (i / j)%int31|] with ([|j|] + [|i|] / [|j|]).
  apply sqrt_main; auto with zarith.
  rewrite spec_add, div31_phi; auto.
- apply sym_equal; apply Zmod_small.
+ symmetry; apply Zmod_small.
  split; auto with zarith.
  Qed.
 
  Lemma iter31_sqrt_correct n rec i j: 0 < [|i|] -> 0 < [|j|] ->
-  [|i|] < ([|j|] + 1) ^ 2 -> 2 * [|j|] < 2 ^ (Z_of_nat size) ->
-  (forall j1, 0 < [|j1|] -> 2^(Z_of_nat n) + [|j1|] <= [|j|] ->
-      [|i|] < ([|j1|] + 1) ^ 2 -> 2 * [|j1|] < 2 ^ (Z_of_nat size) ->
+  [|i|] < ([|j|] + 1) ^ 2 -> 2 * [|j|] < 2 ^ (Z.of_nat size) ->
+  (forall j1, 0 < [|j1|] -> 2^(Z.of_nat n) + [|j1|] <= [|j|] ->
+      [|i|] < ([|j1|] + 1) ^ 2 -> 2 * [|j1|] < 2 ^ (Z.of_nat size) ->
        [|rec i j1|] ^ 2 <= [|i|] < ([|rec i j1|] + 1) ^ 2) ->
   [|iter31_sqrt n rec i j|] ^ 2 <= [|i|] < ([|iter31_sqrt n rec i j|] + 1) ^ 2.
  Proof.
  revert rec i j; elim n; unfold iter31_sqrt; fold iter31_sqrt; clear n.
  intros rec i j Hi Hj Hij H31 Hrec; apply sqrt31_step_correct; auto with zarith.
  intros; apply Hrec; auto with zarith.
- rewrite Zpower_0_r; auto with zarith.
+ rewrite Z.pow_0_r; auto with zarith.
  intros n Hrec rec i j Hi Hj Hij H31 HHrec.
  apply sqrt31_step_correct; auto.
  intros j1 Hj1  Hjp1; apply Hrec; auto with zarith.
  intros j2 Hj2 H2j2 Hjp2 Hj31; apply Hrec; auto with zarith.
  intros j3 Hj3 Hpj3.
  apply HHrec; auto.
- rewrite inj_S, Zpower_Zsucc.
- apply Zle_trans with (2 ^Z_of_nat n + [|j2|]); auto with zarith.
- apply Zle_0_nat.
+ rewrite Nat2Z.inj_succ, Z.pow_succ_r.
+ apply Z.le_trans with (2 ^Z.of_nat n + [|j2|]); auto with zarith.
+ apply Nat2Z.is_nonneg.
  Qed.
 
  Lemma spec_sqrt : forall x,
        [|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 Z.compare_spec; change [|1|] with 1;
    intros Hi; auto with zarith.
- repeat rewrite Zpower_2; auto with zarith.
+ repeat rewrite Z.pow_2_r; auto with zarith.
  apply iter31_sqrt_correct; auto with zarith.
   rewrite div31_phi; change ([|2|]) with 2;  auto with zarith.
   replace ([|i|]) with (1 * 2 + ([|i|] - 2))%Z; try ring.
@@ -2083,18 +2038,18 @@ Section Int31_Spec.
   rewrite div31_phi; change ([|2|]) with 2; auto with zarith.
   apply sqrt_init; auto.
  rewrite div31_phi; change ([|2|]) with 2; auto with zarith.
- apply Zle_lt_trans with ([|i|]).
+ apply Z.le_lt_trans with ([|i|]).
  apply Z_mult_div_ge; auto with zarith.
  case (phi_bounded i); auto.
- intros j2 H1 H2; contradict H2; apply Zlt_not_le.
+ intros j2 H1 H2; contradict H2; apply Z.lt_nge.
  rewrite div31_phi; change ([|2|]) with 2; auto with zarith.
- apply Zle_lt_trans with ([|i|]); auto with zarith.
+ apply Z.le_lt_trans with ([|i|]); auto with zarith.
  assert (0 <= [|i|]/2)%Z by (apply Z_div_pos; auto with zarith).
- apply Zle_trans with (2 * ([|i|]/2)); auto with zarith.
+ apply Z.le_trans with (2 * ([|i|]/2)); auto with zarith.
  apply Z_mult_div_ge; auto with zarith.
  case (phi_bounded i); unfold size; auto with zarith.
  change [|0|] with 0; auto with zarith.
- case (phi_bounded i); repeat rewrite Zpower_2; auto with zarith.
+ case (phi_bounded i); repeat rewrite Z.pow_2_r; auto with zarith.
  Qed.
 
  Lemma sqrt312_step_def rec ih il j:
@@ -2124,10 +2079,10 @@ Section Int31_Spec.
  case (phi_bounded il); intros Hbil _.
  case (phi_bounded ih); intros Hbih Hbih1.
  assert (([|ih|] < [|j|] + 1)%Z); auto with zarith.
- apply Zlt_square_simpl; auto with zarith.
- repeat rewrite <-Zpower_2; apply Zle_lt_trans with (2 := H1).
- apply Zle_trans with ([|ih|] * base)%Z; unfold phi2, base;
-  try rewrite Zpower_2; auto with zarith.
+ apply Z.square_lt_simpl_nonneg; auto with zarith.
+ repeat rewrite <-Z.pow_2_r; apply Z.le_lt_trans with (2 := H1).
+ apply Z.le_trans with ([|ih|] * base)%Z; unfold phi2, base;
+  try rewrite Z.pow_2_r; auto with zarith.
  Qed.
 
  Lemma div312_phi ih il j: (2^30 <= [|j|] -> [|ih|] < [|j|] ->
@@ -2137,7 +2092,7 @@ Section Int31_Spec.
  generalize (spec_div21 ih il j Hj Hj1).
  case div3121; intros q r (Hq, Hr).
  apply Zdiv_unique with (phi r); auto with zarith.
- simpl fst; apply trans_equal with (1 := Hq); ring.
+ simpl fst; apply eq_trans with (1 := Hq); ring.
  Qed.
 
  Lemma sqrt312_step_correct rec ih il j:
@@ -2147,32 +2102,33 @@ Section Int31_Spec.
   [|sqrt312_step rec ih il  j|] ^ 2 <= phi2 ih il
       < ([|sqrt312_step rec ih il j|] + 1) ^  2.
  Proof.
- assert (Hp2: (0 < [|2|])%Z) by exact (refl_equal Lt).
+ assert (Hp2: (0 < [|2|])%Z) by exact (eq_refl Lt).
  intros Hih Hj Hij Hrec; rewrite sqrt312_step_def.
  assert (H1: ([|ih|] <= [|j|])%Z) by (apply sqrt312_lower_bound with il; auto).
  case (phi_bounded ih); intros Hih1 _.
  case (phi_bounded il); intros Hil1 _.
  case (phi_bounded j); intros _ Hj1.
  assert (Hp3: (0 < phi2 ih il)).
- 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.
+ unfold phi2; apply Z.lt_le_trans with ([|ih|] * base)%Z; auto with zarith.
+ apply Z.mul_pos_pos; auto with zarith.
+ apply Z.lt_le_trans with (2:= Hih); auto with zarith.
+ rewrite spec_compare. case Z.compare_spec; intros Hc1.
  split; auto.
  apply sqrt_test_true; auto.
  unfold phi2, base; auto with zarith.
  unfold phi2; rewrite Hc1.
  assert (0 <= [|il|]/[|j|]) by (apply Z_div_pos; auto with zarith).
- 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 Z.mul_comm, Z_div_plus_full_l; unfold base; auto with zarith.
+ unfold Z.pow, Z.pow_pos in Hj1; simpl in Hj1; auto with zarith.
+ case (Z.le_gt_cases (2 ^ 30) [|j|]); intros Hjj.
+ rewrite spec_compare; case Z.compare_spec;
   rewrite div312_phi; auto; intros Hc;
   try (split; auto; apply sqrt_test_true; auto with zarith; fail).
  apply Hrec.
  assert (Hf1: 0 <= phi2 ih il/ [|j|]) by (apply Z_div_pos; auto with zarith).
- case (Zle_lt_or_eq 1 ([|j|])); auto with zarith; intros Hf2.
- 2: contradict Hc; apply Zle_not_lt; rewrite <- Hf2, Zdiv_1_r; auto with zarith.
+ apply Z.le_succ_l in Hj. change (1 <= [|j|]) in Hj.
+ Z.le_elim Hj.
+ 2: contradict Hc; apply Z.le_ngt; rewrite <- Hj, Zdiv_1_r; auto with zarith.
  assert (Hf3: 0 < ([|j|] + phi2 ih il / [|j|]) / 2).
  replace ([|j|] + phi2 ih il/ [|j|])%Z with
         (1 * 2 + (([|j|] - 2) + phi2 ih il / [|j|])); try ring.
@@ -2186,9 +2142,9 @@ Section Int31_Spec.
  rewrite div31_phi; change [|2|] with 2%Z; auto with zarith.
  intros HH; rewrite HH; clear HH; auto with zarith.
  rewrite spec_add, div31_phi; change [|2|] with 2%Z; auto.
- rewrite Zmult_1_l; intros HH.
- rewrite Zplus_comm, <- Z_div_plus_full_l; auto with zarith.
- change (phi v30 * 2) with (2 ^ Z_of_nat size).
+ rewrite Z.mul_1_l; intros HH.
+ rewrite Z.add_comm, <- Z_div_plus_full_l; auto with zarith.
+ change (phi v30 * 2) with (2 ^ Z.of_nat size).
  rewrite HH, Zmod_small; auto with zarith.
  replace (phi
     match j +c fst (div3121 ih il j) with
@@ -2202,41 +2158,41 @@ Section Int31_Spec.
  rewrite div31_phi; auto with zarith.
  intros HH; rewrite HH; auto with zarith.
  intros HH; rewrite <- HH.
- change (1 * 2 ^ Z_of_nat size) with (phi (v30) * 2).
+ change (1 * 2 ^ Z.of_nat size) with (phi (v30) * 2).
  rewrite Z_div_plus_full_l; auto with zarith.
- rewrite Zplus_comm.
+ rewrite Z.add_comm.
  rewrite spec_add, Zmod_small.
  rewrite div31_phi; auto.
  split; auto with zarith.
  case (phi_bounded (fst (r/2)%int31));
    case (phi_bounded v30); auto with zarith.
  rewrite div31_phi; change (phi 2) with 2%Z; auto.
- change (2 ^Z_of_nat size) with (base/2 + phi v30).
+ change (2 ^Z.of_nat size) with (base/2 + phi v30).
  assert (phi r / 2 < base/2); auto with zarith.
- apply Zmult_gt_0_lt_reg_r with 2; auto with zarith.
+ apply Z.mul_lt_mono_pos_r with 2; auto with zarith.
  change (base/2 * 2) with base.
- apply Zle_lt_trans with (phi r).
- rewrite Zmult_comm; apply Z_mult_div_ge; auto with zarith.
+ apply Z.le_lt_trans with (phi r).
+ rewrite Z.mul_comm; apply Z_mult_div_ge; auto with zarith.
  case (phi_bounded r); auto with zarith.
- contradict Hij; apply Zle_not_lt.
+ contradict Hij; apply Z.le_ngt.
  assert ((1 + [|j|]) <= 2 ^ 30); auto with zarith.
- apply Zle_trans with ((2 ^ 30) * (2 ^ 30)); auto with zarith.
+ apply Z.le_trans with ((2 ^ 30) * (2 ^ 30)); auto with zarith.
  assert (0 <= 1 + [|j|]); auto with zarith.
- apply Zmult_le_compat; auto with zarith.
+ apply Z.mul_le_mono_nonneg; auto with zarith.
  change ((2 ^ 30) * (2 ^ 30)) with ((2 ^ 29) * base).
- apply Zle_trans with ([|ih|] * base); auto with zarith.
+ apply Z.le_trans with ([|ih|] * base); auto with zarith.
  unfold phi2, base; auto with zarith.
  split; auto.
  apply sqrt_test_true; auto.
  unfold phi2, base; auto with zarith.
- apply Zle_ge; apply Zle_trans with (([|j|] * base)/[|j|]).
- rewrite Zmult_comm, Z_div_mult; auto with zarith.
- apply Zge_le; apply Z_div_ge; auto with zarith.
+ apply Z.le_ge; apply Z.le_trans with (([|j|] * base)/[|j|]).
+ rewrite Z.mul_comm, Z_div_mult; auto with zarith.
+ apply Z.ge_le; apply Z_div_ge; auto with zarith.
  Qed.
 
  Lemma iter312_sqrt_correct n rec ih il j:
   2^29 <= [|ih|] ->  0 < [|j|] -> phi2 ih il < ([|j|] + 1) ^ 2 ->
-  (forall j1, 0 < [|j1|] -> 2^(Z_of_nat n) + [|j1|] <= [|j|] ->
+  (forall j1, 0 < [|j1|] -> 2^(Z.of_nat n) + [|j1|] <= [|j|] ->
       phi2 ih il < ([|j1|] + 1) ^ 2 ->
        [|rec ih il j1|] ^ 2 <= phi2 ih il < ([|rec ih il j1|] + 1) ^ 2)  ->
   [|iter312_sqrt n rec ih il j|] ^ 2 <= phi2 ih il
@@ -2245,16 +2201,16 @@ Section Int31_Spec.
  revert rec ih il j; elim n; unfold iter312_sqrt; fold iter312_sqrt; clear n.
  intros rec ih il j Hi Hj Hij Hrec; apply sqrt312_step_correct; auto with zarith.
  intros; apply Hrec; auto with zarith.
- rewrite Zpower_0_r; auto with zarith.
+ rewrite Z.pow_0_r; auto with zarith.
  intros n Hrec rec ih il j Hi Hj Hij HHrec.
  apply sqrt312_step_correct; auto.
  intros j1 Hj1  Hjp1; apply Hrec; auto with zarith.
  intros j2 Hj2 H2j2 Hjp2; apply Hrec; auto with zarith.
  intros j3 Hj3 Hpj3.
  apply HHrec; auto.
- rewrite inj_S, Zpower_Zsucc.
- apply Zle_trans with (2 ^Z_of_nat n + [|j2|])%Z; auto with zarith.
- apply Zle_0_nat.
+ rewrite Nat2Z.inj_succ, Z.pow_succ_r.
+ apply Z.le_trans with (2 ^Z.of_nat n + [|j2|])%Z; auto with zarith.
+ apply Nat2Z.is_nonneg.
  Qed.
 
  Lemma spec_sqrt2 : forall x y,
@@ -2269,30 +2225,30 @@ Section Int31_Spec.
   (intros s; ring).
  assert (Hb: 0 <= base) by (red; intros HH; discriminate).
  assert (Hi2: phi2 ih il < (phi Tn + 1) ^ 2).
-   change ((phi Tn + 1) ^ 2) with (2^62).
-  apply Zle_lt_trans with ((2^31 -1) * base + (2^31 - 1)); auto with zarith.
-  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.
+ { change ((phi Tn + 1) ^ 2) with (2^62).
+   apply Z.le_lt_trans with ((2^31 -1) * base + (2^31 - 1)); auto with zarith.
+   2: simpl; unfold Z.pow_pos; simpl; auto with zarith.
+   case (phi_bounded ih); case (phi_bounded il); intros H1 H2 H3 H4.
+   unfold base, Z.pow, Z.pow_pos in H2,H4; simpl in H2,H4.
+   unfold phi2,Z.pow, Z.pow_pos. simpl Pos.iter; auto with zarith. }
  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.
- apply Zlt_not_le.
+ apply Z.lt_nge.
  change [|Tn|] with 2147483647; auto with zarith.
- change (2 ^ Z_of_nat 31) with 2147483648; auto with zarith.
+ change (2 ^ Z.of_nat 31) with 2147483648; auto with zarith.
  case (phi_bounded j1); auto with zarith.
  set (s := iter312_sqrt 31 (fun _ _ j : int31 => j) ih il Tn).
  intros Hs1 Hs2.
  generalize (spec_mul_c s s); case mul31c.
  simpl zn2z_to_Z; intros HH.
  assert ([|s|] = 0).
- case (Zmult_integral _ _ (sym_equal HH)); auto.
- contradict Hs2; apply Zle_not_lt; rewrite H.
+ { symmetry in HH. rewrite Z.mul_eq_0 in HH. destruct HH; auto. }
+ contradict Hs2; apply Z.le_ngt; rewrite H.
  change ((0 + 1) ^ 2) with 1.
- apply Zle_trans with (2 ^ Z_of_nat size / 4 * base).
+ apply Z.le_trans with (2 ^ Z.of_nat size / 4 * base).
  simpl; auto with zarith.
- apply Zle_trans with ([|ih|] * base); auto with zarith.
+ apply Z.le_trans with ([|ih|] * base); auto with zarith.
  unfold phi2; case (phi_bounded il); auto with zarith.
  intros ih1 il1.
  change [||WW ih1 il1||] with (phi2 ih1 il1).
@@ -2300,10 +2256,10 @@ 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 Z.compare_spec.
  unfold interp_carry.
  intros H1; split.
- rewrite Zpower_2, <- Hihl1.
+ rewrite Z.pow_2_r, <- Hihl1.
  unfold phi2; ring[Hil2 H1].
  replace [|il2|] with (phi2 ih il - phi2 ih1 il1).
  rewrite Hihl1.
@@ -2311,132 +2267,130 @@ Section Int31_Spec.
  unfold phi2; rewrite H1, Hil2; ring.
  unfold interp_carry.
  intros H1; contradict Hs1.
- apply Zlt_not_le; rewrite Zpower_2, <-Hihl1.
+ apply Z.lt_nge; rewrite Z.pow_2_r, <-Hihl1.
  unfold phi2.
  case (phi_bounded il); intros _ H2.
- apply Zlt_le_trans with (([|ih|] + 1) * base + 0).
- rewrite Zmult_plus_distr_l, Zplus_0_r; auto with zarith.
+ apply Z.lt_le_trans with (([|ih|] + 1) * base + 0).
+ rewrite Z.mul_add_distr_r, Z.add_0_r; auto with zarith.
  case (phi_bounded il1); intros H3 _.
- apply Zplus_le_compat; auto with zarith.
- unfold interp_carry; change (1 * 2 ^ Z_of_nat size) with base.
- rewrite Zpower_2, <- Hihl1, Hil2.
+ apply Z.add_le_mono; auto with zarith.
+ unfold interp_carry; change (1 * 2 ^ Z.of_nat size) with base.
+ rewrite Z.pow_2_r, <- Hihl1, Hil2.
  intros H1.
- case (Zle_lt_or_eq ([|ih1|] + 1) ([|ih|])); auto with zarith.
- intros H2; contradict Hs2; apply Zle_not_lt.
+ rewrite <- Z.le_succ_l, <- Z.add_1_r in H1.
+ Z.le_elim H1.
+ contradict Hs2; apply Z.le_ngt.
  replace (([|s|] + 1) ^ 2) with (phi2 ih1 il1 + 2 * [|s|] + 1).
  unfold phi2.
  case (phi_bounded il); intros Hpil _.
  assert (Hl1l: [|il1|] <= [|il|]).
-  case (phi_bounded il2); rewrite Hil2; auto with zarith.
+ { case (phi_bounded il2); rewrite Hil2; auto with zarith. }
  assert ([|ih1|] * base + 2 * [|s|] + 1 <= [|ih|] * base); auto with zarith.
- case (phi_bounded s);  change (2 ^ Z_of_nat size) with base; intros _ Hps.
+ case (phi_bounded s);  change (2 ^ Z.of_nat size) with base; intros _ Hps.
  case (phi_bounded ih1); intros Hpih1 _; auto with zarith.
- apply Zle_trans with (([|ih1|] + 2) * base); auto with zarith.
- rewrite Zmult_plus_distr_l.
+ apply Z.le_trans with (([|ih1|] + 2) * base); auto with zarith.
+ rewrite Z.mul_add_distr_r.
  assert (2 * [|s|] + 1 <= 2 * base); auto with zarith.
  rewrite Hihl1, Hbin; auto.
- intros H2; split.
- unfold phi2; rewrite <- H2; ring.
+ split.
+ unfold phi2; rewrite <- H1; ring.
  replace (base + ([|il|] - [|il1|])) with (phi2 ih il - ([|s|] * [|s|])).
  rewrite <-Hbin in Hs2; auto with zarith.
- rewrite <- Hihl1; unfold phi2; rewrite <- H2; ring.
+ rewrite <- Hihl1; unfold phi2; rewrite <- H1; ring.
  unfold interp_carry in Hil2 |- *.
- unfold interp_carry; change (1 * 2 ^ Z_of_nat size) with base.
+ unfold interp_carry; change (1 * 2 ^ Z.of_nat size) with base.
  assert (Hsih: [|ih - 1|] = [|ih|] - 1).
-  rewrite spec_sub, Zmod_small; auto; change [|1|] with 1.
-  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_sub, Zmod_small; auto; change [|1|] with 1.
+   case (phi_bounded ih); intros H1 H2.
+   generalize Hih; change (2 ^ Z.of_nat size / 4) with 536870912.
+   split; auto with zarith. }
+ rewrite spec_compare; case Z.compare_spec.
  rewrite Hsih.
  intros H1; split.
- rewrite Zpower_2, <- Hihl1.
+ rewrite Z.pow_2_r, <- Hihl1.
  unfold phi2; rewrite <-H1.
- apply trans_equal with ([|ih|] * base + [|il1|] + ([|il|] - [|il1|])).
+ transitivity ([|ih|] * base + [|il1|] + ([|il|] - [|il1|])).
  ring.
  rewrite <-Hil2.
- change (2 ^ Z_of_nat size) with base; ring.
+ change (2 ^ Z.of_nat size) with base; ring.
  replace [|il2|] with (phi2 ih il - phi2 ih1 il1).
  rewrite Hihl1.
  rewrite <-Hbin in Hs2; auto with zarith.
  unfold phi2.
  rewrite <-H1.
  ring_simplify.
- apply trans_equal with (base + ([|il|] - [|il1|])).
+ transitivity (base + ([|il|] - [|il1|])).
  ring.
  rewrite <-Hil2.
- change (2 ^ Z_of_nat size) with base; ring.
+ change (2 ^ Z.of_nat size) with base; ring.
  rewrite Hsih; intros H1.
  assert (He: [|ih|] = [|ih1|]).
-   apply Zle_antisym; auto with zarith.
-   case (Zle_or_lt [|ih1|] [|ih|]); auto; intros H2.
-   contradict Hs1; apply Zlt_not_le; rewrite Zpower_2, <-Hihl1.
-  unfold phi2.
-  case (phi_bounded il); change (2 ^ Z_of_nat size) with base;
+ { apply Z.le_antisymm; auto with zarith.
+   case (Z.le_gt_cases [|ih1|] [|ih|]); auto; intros H2.
+   contradict Hs1; apply Z.lt_nge; rewrite Z.pow_2_r, <-Hihl1.
+   unfold phi2.
+   case (phi_bounded il); change (2 ^ Z.of_nat size) with base;
     intros _ Hpil1.
-  apply Zlt_le_trans with (([|ih|] + 1) * base).
-  rewrite Zmult_plus_distr_l, Zmult_1_l; auto with zarith.
-  case (phi_bounded il1); intros Hpil2 _.
-  apply Zle_trans with (([|ih1|]) * base); auto with zarith.
- rewrite Zpower_2, <-Hihl1; unfold phi2; rewrite <-He.
- contradict Hs1; apply Zlt_not_le; rewrite Zpower_2, <-Hihl1.
+   apply Z.lt_le_trans with (([|ih|] + 1) * base).
+   rewrite Z.mul_add_distr_r, Z.mul_1_l; auto with zarith.
+   case (phi_bounded il1); intros Hpil2 _.
+   apply Z.le_trans with (([|ih1|]) * base); auto with zarith. }
+ rewrite Z.pow_2_r, <-Hihl1; unfold phi2; rewrite <-He.
+ contradict Hs1; apply Z.lt_nge; rewrite Z.pow_2_r, <-Hihl1.
  unfold phi2; rewrite He.
  assert (phi il - phi il1 < 0); auto with zarith.
  rewrite <-Hil2.
  case (phi_bounded il2); auto with zarith.
  intros H1.
- rewrite Zpower_2, <-Hihl1.
- case (Zle_lt_or_eq ([|ih1|] + 2) [|ih|]); auto with zarith.
- intros H2; contradict Hs2; apply Zle_not_lt.
+ rewrite Z.pow_2_r, <-Hihl1.
+ assert (H2 : [|ih1|]+2 <= [|ih|]); auto with zarith.
+ Z.le_elim H2.
+ contradict Hs2; apply Z.le_ngt.
  replace (([|s|] + 1) ^ 2) with (phi2 ih1 il1 + 2 * [|s|] + 1).
  unfold phi2.
  assert ([|ih1|] * base + 2 * phi s + 1 <= [|ih|] * base + ([|il|] - [|il1|]));
   auto with zarith.
  rewrite <-Hil2.
- change (-1 * 2 ^ Z_of_nat size) with (-base).
+ change (-1 * 2 ^ Z.of_nat size) with (-base).
  case (phi_bounded il2); intros Hpil2 _.
- apply Zle_trans with ([|ih|] * base + - base); auto with zarith.
- case (phi_bounded s);  change (2 ^ Z_of_nat size) with base; intros _ Hps.
+ apply Z.le_trans with ([|ih|] * base + - base); auto with zarith.
+ case (phi_bounded s);  change (2 ^ Z.of_nat size) with base; intros _ Hps.
  assert (2 * [|s|] + 1 <= 2 * base); auto with zarith.
- apply Zle_trans with ([|ih1|] * base + 2 * base); auto with zarith.
+ apply Z.le_trans with ([|ih1|] * base + 2 * base); auto with zarith.
  assert (Hi: ([|ih1|] + 3) * base <= [|ih|] * base); auto with zarith.
- rewrite Zmult_plus_distr_l in Hi; auto with zarith.
+ rewrite Z.mul_add_distr_r in Hi; auto with zarith.
  rewrite Hihl1, Hbin; auto.
- intros H2; unfold phi2; rewrite <-H2.
+ unfold phi2; rewrite <-H2.
  split.
  replace [|il|] with (([|il|] - [|il1|]) + [|il1|]); try ring.
  rewrite <-Hil2.
- change (-1 * 2 ^ Z_of_nat size) with (-base); ring.
+ change (-1 * 2 ^ Z.of_nat size) with (-base); ring.
  replace (base + [|il2|]) with (phi2 ih il - phi2 ih1 il1).
  rewrite Hihl1.
  rewrite <-Hbin in Hs2; auto with zarith.
  unfold phi2; rewrite <-H2.
  replace [|il|] with (([|il|] - [|il1|]) + [|il1|]); try ring.
  rewrite <-Hil2.
- change (-1 * 2 ^ Z_of_nat size) with (-base); ring.
- Qed.
+ change (-1 * 2 ^ Z.of_nat size) with (-base); ring.
+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.
+ apply Z.compare_eq.
  now destruct ([|x|] ?= 0).
  Qed.
 
  (* 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 +2399,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 Z.compare_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..f414663a 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-2012     *)
 (*   \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
@@ -121,12 +117,12 @@ Definition iszero : int31 -> bool := Eval compute in
    It seems to work, but later "unfold iszero" takes forever. *)
 
 
-(** [base] is [2^31], obtained via iterations of [Zdouble].
+(** [base] is [2^31], obtained via iterations of [Z.double].
    It can also be seen as the smallest b > 0 s.t. phi_inv b = 0
    (see below) *)
 
 Definition base := Eval compute in
- iter_nat size Z Zdouble 1%Z.
+ iter_nat size Z Z.double 1%Z.
 
 (** * Recursors *)
 
@@ -159,11 +155,11 @@ Definition recr := recr_aux size.
 
 (** * Conversions *)
 
-(** From int31 to Z, we simply iterates [Zdouble] or [Zdouble_plus_one]. *)
+(** From int31 to Z, we simply iterates [Z.double] or [Z.succ_double]. *)
 
 Definition phi : int31 -> Z :=
  recr Z (0%Z)
-  (fun b _ => match b with D0 => Zdouble | D1 => Zdouble_plus_one end).
+  (fun b _ => match b with D0 => Z.double | D1 => Z.succ_double end).
 
 (** From positive to int31. An abstract definition could be :
       [ phi_inv (2n) = 2*(phi_inv n) /\
@@ -297,13 +293,13 @@ Notation "n '*c' m" := (mul31c n m) (at level 40, no associativity) : int31_scop
 (** Division of a double size word modulo [2^31] *)
 
 Definition div3121 (nh nl m : int31) :=
-  let (q,r) := Zdiv_eucl (phi2 nh nl) (phi m) in
+  let (q,r) := Z.div_eucl (phi2 nh nl) (phi m) in
   (phi_inv q, phi_inv r).
 
 (** Division modulo [2^31] *)
 
 Definition div31 (n m : int31) :=
-  let (q,r) := Zdiv_eucl (phi n) (phi m) in
+  let (q,r) := Z.div_eucl (phi n) (phi m) in
   (phi_inv q, phi_inv r).
 Notation "n / m" := (div31 n m) : int31_scope.
 
@@ -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
@@ -395,7 +391,7 @@ Eval lazy delta [On In Twon] in
   | Lt => iter31_sqrt 31 (fun i j => j) i (fst (i/Twon))
   end.
 
-Definition v30 := Eval compute in (addmuldiv31 (phi_inv (Z_of_nat size - 1)) In On).
+Definition v30 := Eval compute in (addmuldiv31 (phi_inv (Z.of_nat size - 1)) In On).
 
 Definition sqrt312_step (rec: int31 -> int31 -> int31 -> int31)
    (ih il j: int31)  :=
@@ -456,7 +452,7 @@ Definition positive_to_int31 (p:positive) := p2i size p.
     It is used as default answer for numbers of zeros
     in [head0] and [tail0] *)
 
-Definition T31 : int31 := Eval compute in phi_inv (Z_of_nat size).
+Definition T31 : int31 := Eval compute in phi_inv (Z.of_nat size).
 
 Definition head031 (i:int31) :=
   recl _ (fun _ => T31)
diff --git a/theories/Numbers/Cyclic/Int31/Ring31.v b/theories/Numbers/Cyclic/Int31/Ring31.v
index 37dc0871..f5a08438 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-2012     *)
 (*   \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 Z.compare_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..9e3f4ef4 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-2012     *)
 (*   \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,111 +75,103 @@ Section ZModulo.
   auto.
  Qed.
 
- Definition znz_of_pos x :=
-   let (q,r) := Zdiv_eucl_POS x wB in (N_of_Z q, r).
+ Definition of_pos x :=
+   let (q,r) := Z.pos_div_eucl 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.
+  destruct (Z.pos_div_eucl p wB); simpl; destruct 1.
+  unfold to_Z; rewrite Zmod_small; auto.
   assert (0 <= z).
    replace z with (Zpos p / wB) by
     (symmetry; apply Zdiv_unique with z0; auto).
    apply Z_div_pos; auto with zarith.
-  replace (Z_of_N (N_of_Z z)) with z by
+  replace (Z.of_N (N_of_Z z)) with z by
     (destruct z; simpl; auto; elim H1; auto).
-  rewrite Zmult_comm; auto.
+  rewrite Z.mul_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 Z.lt_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.
-  apply Zle_trans with (Zpos digits); auto with zarith.
+  apply Z.le_trans with (Zpos digits); auto with zarith.
   apply Zpower2_le_lin; auto with zarith.
  Qed.
 
- Definition znz_compare x y := Zcompare [|x|] [|y|].
+ Definition compare x y := Z.compare [|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 = Z.compare [|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,41 +182,40 @@ Section ZModulo.
  generalize (Z_mod_lt x wB wB_pos); omega.
  Qed.
 
- Definition znz_succ_c x :=
-  let y := Zsucc x in
-  if znz_eq0 y then C1 0 else C0 y.
+ Definition succ_c x :=
+  let y := Z.succ x in
+  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 := Z.succ.
+ Definition add := Z.add.
+ 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.
  Proof.
  intros.
- generalize (Z_div_mod_eq (x-y) z H); rewrite H0, Zplus_0_r.
+ generalize (Z_div_mod_eq (x-y) z H); rewrite H0, Z.add_0_r.
  remember ((x-y)/z) as k.
- intros H1; symmetry in H1; rewrite <- Zeq_plus_swap in H1.
- subst x.
- rewrite Zplus_comm, Zmult_comm, Z_mod_plus; auto.
+ rewrite Z.sub_move_r, Z.add_comm, Z.mul_comm. intros ->.
+ now apply Z_mod_plus.
  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, Z.succ.
+ case_eq (eq0 (x+1)); intros; unfold interp_carry.
 
- rewrite Zmult_1_l.
+ rewrite Z.mul_1_l.
  replace (wB + 0 mod wB) with wB by auto with zarith.
- symmetry; rewrite Zeq_plus_swap.
+ symmetry. rewrite Z.add_move_r.
  assert ((x+1) mod wB = 0) by (apply spec_eq0; auto).
  replace (wB-1) with ((wB-1) mod wB) by
   (apply Zmod_small; generalize wB_pos; omega).
@@ -236,10 +223,10 @@ 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.
+  rewrite Z.add_move_r in H0; simpl in H0.
   rewrite <- Zplus_mod_idemp_l; rewrite H0.
   replace (wB-1+1) with wB; auto with zarith; apply Z_mod_same; auto.
  rewrite <- Zplus_mod_idemp_l.
@@ -247,81 +234,81 @@ 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.
- rewrite Zmult_1_l, Zplus_comm, Zeq_plus_swap.
+ rewrite Z.mul_1_l, Z.add_comm, Z.add_move_r.
  apply Zmod_small;
   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.
- rewrite Zmult_1_l, Zplus_comm, Zeq_plus_swap.
+ rewrite Z.mul_1_l, Z.add_comm, Z.add_move_r.
  apply Zmod_small;
   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, Z.succ.
  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 := Z.pred.
+ Definition sub := Z.sub.
+ 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 +320,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,41 +334,41 @@ 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, Z.pred.
  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 :=
-  let (h,l) := Zdiv_eucl ([|x|]*[|y|]) wB in
-  if znz_eq0 h then if znz_eq0 l then W0 else WW h l else WW h l.
+ Definition mul_c x y :=
+  let (h,l) := Z.div_eucl ([|x|]*[|y|]) wB in
+  if eq0 h then if eq0 l then W0 else WW h l else WW h l.
 
- Definition znz_mul := Zmult.
+ Definition mul := Z.mul.
 
- 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.
- 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).
+ intros; unfold mul_c, zn2z_to_Z.
+ assert (Z.div_eucl ([|x|]*[|y|]) wB = (([|x|]*[|y|])/wB,([|x|]*[|y|]) mod wB)).
+  unfold Z.modulo, Z.div; destruct Z.div_eucl; auto.
+ generalize (Z_div_mod ([|x|]*[|y|]) wB wB_pos); destruct Z.div_eucl as (h,l).
  destruct 1; injection H; clear H; intros.
  rewrite H0.
  assert ([|l|] = l).
@@ -392,38 +379,38 @@ Section ZModulo.
   split.
   apply Z_div_pos; auto with zarith.
   apply Zdiv_lt_upper_bound; auto with zarith.
-  apply Zmult_lt_compat; auto with zarith.
+  apply Z.mul_lt_mono_nonneg; 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 := Z.div_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.
+ assert (Z.div_eucl [|a|] [|b|] = ([|a|]/[|b|], [|a|] mod [|b|])).
+  unfold Z.modulo, Z.div; destruct Z.div_eucl; auto.
  generalize (Z_div_mod [|a|] [|b|] H0).
- destruct Zdiv_eucl as (q,r); destruct 1; intros.
+ destruct Z.div_eucl as (q,r); destruct 1; intros.
  injection H1; clear H1; intros.
  assert ([|r|]=r).
   apply Zmod_small; generalize (Z_mod_lt b wB wB_pos); fold [|b|];
@@ -434,16 +421,16 @@ Section ZModulo.
   split.
   apply Z_div_pos; auto with zarith.
   apply Zdiv_lt_upper_bound; auto with zarith.
-  apply Zlt_le_trans with (wB*1).
-  rewrite Zmult_1_r; auto with zarith.
-  apply Zmult_le_compat; generalize wB_pos; auto with zarith.
- rewrite H5, H6; rewrite Zmult_comm; auto with zarith.
+  apply Z.lt_le_trans with (wB*1).
+  rewrite Z.mul_1_r; auto with zarith.
+  apply Z.mul_le_mono_nonneg; generalize wB_pos; auto with zarith.
+ rewrite H5, H6; rewrite Z.mul_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,90 +438,90 @@ 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 := Z.gcd [|x|] [|y|].
+ Definition gcd_gt x y := Z.gcd [|x|] [|y|].
 
- Lemma Zgcd_bound : forall a b, 0<=a -> 0<=b -> Zgcd a b <= Zmax a b.
+ Lemma Zgcd_bound : forall a b, 0<=a -> 0<=b -> Z.gcd a b <= Z.max 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 (Z_eq_dec (Zgcd a b) 0).
+ destruct H2 as (q,H2); destruct H3 as (q',H3); clear H4.
+ assert (H4:=Z.gcd_nonneg a b).
+ destruct (Z.eq_dec (Z.gcd a b) 0).
  rewrite e; generalize (Zmax_spec a b); omega.
  assert (0 <= q).
-  apply Zmult_le_reg_r with (Zgcd a b); auto with zarith.
- destruct (Z_eq_dec q 0).
+  apply Z.mul_le_mono_pos_r with (Z.gcd a b); auto with zarith.
+ destruct (Z.eq_dec q 0).
 
  subst q; simpl in *; subst a; simpl; auto.
  generalize (Zmax_spec 0 b) (Zabs_spec b); omega.
 
- apply Zle_trans with a.
- rewrite H1 at 2.
- rewrite <- (Zmult_1_l (Zgcd a b)) at 1.
- apply Zmult_le_compat; auto with zarith.
+ apply Z.le_trans with a.
+ rewrite H2 at 2.
+ rewrite <- (Z.mul_1_l (Z.gcd a b)) at 1.
+ apply Z.mul_le_mono_nonneg; 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|]).
+ replace ([|Z.gcd [|a|] [|b|]|]) with (Z.gcd [|a|] [|b|]).
  apply Zgcd_is_gcd.
  symmetry; apply Zmod_small.
  split.
- apply Zgcd_is_pos.
- apply Zle_lt_trans with (Zmax [|a|] [|b|]).
+ apply Z.gcd_nonneg.
+ apply Z.le_lt_trans with (Z.max [|a|] [|b|]).
  apply Zgcd_bound; auto with zarith.
  generalize (Zmax_spec [|a|] [|b|]); omega.
  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 :=
-  Zdiv_eucl ([|a1|]*wB+[|a2|]) [|b|].
+ Definition div21 a1 a2 b :=
+  Z.div_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.
  remember ([|a1|]*wB+[|a2|]) as a.
- assert (Zdiv_eucl a [|b|] = (a/[|b|], a mod [|b|])).
-  unfold Zmod, Zdiv; destruct Zdiv_eucl; auto.
+ assert (Z.div_eucl a [|b|] = (a/[|b|], a mod [|b|])).
+  unfold Z.modulo, Z.div; destruct Z.div_eucl; auto.
  generalize (Z_div_mod a [|b|] H3).
- destruct Zdiv_eucl as (q,r); destruct 1; intros.
+ destruct Z.div_eucl as (q,r); destruct 1; intros.
  injection H4; clear H4; intros.
  assert ([|r|]=r).
   apply Zmod_small; generalize (Z_mod_lt b wB wB_pos); fold [|b|];
@@ -548,109 +535,102 @@ Section ZModulo.
   apply Zdiv_lt_upper_bound; auto with zarith.
   subst a.
   replace (wB*[|b|]) with (([|b|]-1)*wB + wB) by ring.
-  apply Zlt_le_trans with ([|a1|]*wB+wB); auto with zarith.
- rewrite H8, H9; rewrite Zmult_comm; auto with zarith.
+  apply Z.lt_le_trans with ([|a1|]*wB+wB); auto with zarith.
+ rewrite H8, H9; rewrite Z.mul_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.
  destruct H; auto with zarith.
- apply Zle_lt_trans with [|w|]; auto with zarith.
+ apply Z.le_lt_trans with [|w|]; auto with zarith.
  apply Zmod_le; auto with zarith.
  Qed.
 
- Definition znz_is_even x :=
-   if Z_eq_dec ([|x|] mod 2) 0 then true else false.
+ 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.
- repeat rewrite Zpower_2.
- replace [|Zsqrt_plain [|x|]|] with (Zsqrt_plain [|x|]).
- apply Zsqrt_interval; auto with zarith.
+ unfold sqrt.
+ repeat rewrite Z.pow_2_r.
+ 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 Z.le_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.
-   apply Zle_trans with (s*s); try omega.
-   apply Zmult_le_compat; generalize wB_pos; auto with zarith.
+   rewrite U.
+   apply Z.le_trans with (s*s); try omega.
+   apply Z.mul_le_mono_nonneg; generalize wB_pos; auto with zarith.
   assert (Zpos p < wB*wB).
    rewrite Heqz.
    replace (wB*wB) with ((wB-1)*wB+wB) by ring.
-   apply Zplus_le_lt_compat; auto with zarith.
-   apply Zmult_le_compat; auto with zarith.
+   apply Z.add_le_lt_mono; auto with zarith.
+   apply Z.mul_le_mono_nonneg; auto with zarith.
    generalize (spec_to_Z x); auto with zarith.
    generalize wB_pos; auto with zarith.
   omega.
  replace [|s|] with s by (symmetry; apply Zmod_small; auto with zarith).
  destruct Z_lt_le_dec; unfold interp_carry.
  replace [|r|] with r by (symmetry; apply Zmod_small; auto with zarith).
- rewrite Zpower_2; auto with zarith.
+ rewrite Z.pow_2_r; auto with zarith.
  replace [|r-wB|] with (r-wB) by (symmetry; apply Zmod_small; auto with zarith).
- rewrite Zpower_2; omega.
+ rewrite Z.pow_2_r; omega.
 
  assert (0<=Zneg p).
   rewrite Heqz; generalize wB_pos; auto with zarith.
@@ -665,15 +645,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.
@@ -686,58 +666,58 @@ Section ZModulo.
  cut (log_inf x < p - 1); [omega| ].
  apply IHx.
  change (Zpos x~1) with (2*(Zpos x)+1) in H.
- replace p with (Zsucc (p-1)) in H; auto with zarith.
- rewrite Zpower_Zsucc in H; auto with zarith.
+ replace p with (Z.succ (p-1)) in H; auto with zarith.
+ rewrite Z.pow_succ_r in H; auto with zarith.
 
  assert (0 < p) by (destruct p; compute; auto with zarith; discriminate).
  cut (log_inf x < p - 1); [omega| ].
  apply IHx.
  change (Zpos x~0) with (2*(Zpos x)) in H.
- replace p with (Zsucc (p-1)) in H; auto with zarith.
- rewrite Zpower_Zsucc in H; auto with zarith.
+ replace p with (Z.succ (p-1)) in H; auto with zarith.
+ rewrite Z.pow_succ_r in H; auto with zarith.
 
  simpl; intros; destruct p; compute; auto with zarith.
  Qed.
 
 
  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 Z.lt_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 Z.le_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
+ rewrite Z.mul_comm; rewrite <- Z.pow_succ_r; auto with zarith.
+ replace (Z.succ (zdigits - log_inf p -1 +log_inf p)) with zdigits
    by ring.
- unfold wB, base, znz_zdigits; auto with zarith.
- apply Zmult_le_compat; auto with zarith.
+ unfold wB, base, zdigits; auto with zarith.
+ apply Z.mul_le_mono_nonneg; auto with zarith.
 
- apply Zlt_le_trans
-   with (2^(znz_zdigits - log_inf p - 1)*(2^(Zsucc (log_inf p)))).
- apply Zmult_lt_compat_l; auto with zarith.
+ apply Z.lt_le_trans
+   with (2^(zdigits - log_inf p - 1)*(2^(Z.succ (log_inf p)))).
+ apply Z.mul_lt_mono_pos_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 +Z.succ (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
@@ -758,120 +738,120 @@ Section ZModulo.
  assert (d <> xH).
   intro; subst.
   compute in H; destruct p; discriminate.
- assert (Zsucc (Zpos (Ppred d)) = Zpos d).
+ assert (Z.succ (Zpos (Pos.pred d)) = Zpos d).
   simpl; f_equal.
-  rewrite <- Pplus_one_succ_r.
-  destruct (Psucc_pred d); auto.
+  rewrite Pos.add_1_r.
+  destruct (Pos.succ_pred_or d); auto.
   rewrite H1 in H0; elim H0; auto.
- assert (Ptail p < Zpos (Ppred d)).
+ assert (Ptail p < Zpos (Pos.pred d)).
   apply IHp.
-  apply Zmult_lt_reg_r with 2; auto with zarith.
-  rewrite (Zmult_comm (Zpos p)).
+  apply Z.mul_lt_mono_pos_r with 2; auto with zarith.
+  rewrite (Z.mul_comm (Zpos p)).
   change (2 * Zpos p) with (Zpos p~0).
-  rewrite Zmult_comm.
-  rewrite <- Zpower_Zsucc; auto with zarith.
+  rewrite Z.mul_comm.
+  rewrite <- Z.pow_succ_r; auto with zarith.
   rewrite H1; auto.
  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).
   apply Zmod_small.
   split; auto.
   unfold wB, base in *.
-  apply Zlt_trans with (Zpos digits).
+  apply Z.lt_trans with (Zpos digits).
   apply Ptail_bounded; auto with zarith.
   apply Zpower2_lt_lin; auto with zarith.
  rewrite H1.
 
  clear; induction p.
- exists (Zpos p); simpl; rewrite Pmult_1_r; auto with zarith.
+ exists (Zpos p); simpl; rewrite Pos.mul_1_r; auto with zarith.
  destruct IHp as (y & Yp & Ye).
  exists y.
  split; auto.
  change (Zpos p~0) with (2*Zpos p).
  rewrite Ye.
- change (Ptail p~0) with (Zsucc (Ptail p)).
- rewrite Zpower_Zsucc; auto; ring.
+ change (Ptail p~0) with (Z.succ (Ptail p)).
+ rewrite Z.pow_succ_r; auto; ring.
 
  exists 0; simpl; auto with zarith.
  Qed.
 
  (** 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 +890,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 +914,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..ac113dfd 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-2012     *)
 (*   \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..06ac0ba0 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-2012     *)
 (*   \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..f2947c30 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-2012     *)
 (*   \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..bc78a4b9 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-2012     *)
 (*   \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..1d410a02
--- /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-2012     *)
+(*   \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 [Pos.size_nat] and [Pos.size]).
+*)
+
+(** 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..dd8aa100 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-2012     *)
 (*   \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..2ccc79e9 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-2012     *)
 (*   \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,
@@ -14,7 +16,7 @@
 
     [a = bq+r /\ 0 <= |r| < |b| /\ Sign(r) = Sign(b)]
 
-    This is the convention followed historically by [Zdiv] in Coq, and
+    This is the convention followed historically by [Z.div] in Coq, and
     corresponds to convention "F" in the following paper:
 
     R. Boute, "The Euclidean definition of the functions div and mod",
@@ -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..d69d0e10 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-2012     *)
 (*   \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..feac10b3
--- /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-2012     *)
+(*   \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..45da2dee
--- /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-2012     *)
+(*   \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..96be5811 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-2012     *)
 (*   \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..dc7598e3
--- /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-2012     *)
+(*   \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..c5fbd450 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-2012     *)
 (*   \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..8edf97f4 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-2012     *)
 (*   \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..13541309
--- /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-2012     *)
+(*   \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..d30cea33
--- /dev/null
+++ b/theories/Numbers/Integer/Abstract/ZPow.v
@@ -0,0 +1,135 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** 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.
+
+(** A particular case of [pow_add_r], with no precondition *)
+
+Lemma pow_twice_r a b : a^(2*b) == a^b * a^b.
+Proof.
+ rewrite two_succ. nzsimpl.
+ destruct (le_gt_cases 0 b).
+ - now rewrite pow_add_r.
+ - rewrite !pow_neg_r. now nzsimpl. trivial.
+   now apply add_neg_neg.
+Qed.
+
+(** 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..8973df35 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-2012     *)
 (*   \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..24b6003c 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-2012     *)
 (*   \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..a56f90b0 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-2012     *)
 (*   \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,82 +19,64 @@ 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] *)
 
 Theorem spec_to_Z: forall n : bigZ,
-  BigN.to_Z (BigZ.to_N n) = ((Zsgn [n]) * [n])%Z.
+  BigN.to_Z (BigZ.to_N n) = ((Z.sgn [n]) * [n])%Z.
 Proof.
 intros n; case n; simpl; intros p;
   generalize (BigN.spec_pos p); case (BigN.to_Z p); auto.
@@ -105,7 +85,7 @@ intros p1 H1; case H1; auto.
 Qed.
 
 Theorem spec_to_N n:
- ([n] = Zsgn [n] * (BigN.to_Z (BigZ.to_N n)))%Z.
+ ([n] = Z.sgn [n] * (BigN.to_Z (BigZ.to_N n)))%Z.
 Proof.
 case n; simpl; intros p;
   generalize (BigN.spec_pos p); case (BigN.to_Z p); auto.
@@ -135,29 +115,31 @@ 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).
 generalize (Z_div_mod_full [a] [b] NEQ).
-destruct BigZ.div_eucl as (q,r), Zdiv_eucl as (q',r').
+destruct BigZ.div_eucl as (q,r), Z.div_eucl as (q',r').
 intros (EQ,_). injection 1. intros EQr EQq.
 BigZ.zify. rewrite EQr, EQq; auto.
 Qed.
@@ -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..180fe0a9 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-2012     *)
 (*   \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.
@@ -23,113 +21,148 @@ Open Scope Z_scope.
   [NSig.NType] to a structure of integers [ZSig.ZType].
 *)
 
-Module Make (N:NType) <: ZType.
+Module Make (NN:NType) <: ZType.
 
  Inductive t_ :=
-  | Pos : N.t -> t_
-  | Neg : N.t -> t_.
+  | Pos : NN.t -> t_
+  | Neg : NN.t -> t_.
 
  Definition t := t_.
 
- Definition zero := Pos N.zero.
- Definition one  := Pos N.one.
- Definition minus_one := Neg N.one.
+ Bind Scope abstract_scope with t t_.
+
+ Definition zero := Pos NN.zero.
+ Definition one  := Pos NN.one.
+ Definition two := Pos NN.two.
+ Definition minus_one := Neg NN.one.
 
  Definition of_Z x :=
   match x with
-  | Zpos x => Pos (N.of_N (Npos x))
+  | Zpos x => Pos (NN.of_N (Npos x))
   | Z0 => zero
-  | Zneg x => Neg (N.of_N (Npos x))
+  | Zneg x => Neg (NN.of_N (Npos x))
   end.
 
  Definition to_Z x :=
   match x with
-  | Pos nx => N.to_Z nx
-  | Neg nx => Zopp (N.to_Z nx)
+  | Pos nx => NN.to_Z nx
+  | Neg nx => Z.opp (NN.to_Z nx)
   end.
 
  Theorem spec_of_Z: forall x, to_Z (of_Z x) = x.
  Proof.
  intros x; case x; unfold to_Z, of_Z, zero.
-   exact N.spec_0.
-   intros; rewrite N.spec_of_N; auto.
-   intros; rewrite N.spec_of_N; auto.
+   exact NN.spec_0.
+   intros; rewrite NN.spec_of_N; auto.
+   intros; rewrite NN.spec_of_N; auto.
  Qed.
 
  Definition eq x y := (to_Z x = to_Z y).
 
  Theorem spec_0: to_Z zero = 0.
- exact N.spec_0.
+ exact NN.spec_0.
  Qed.
 
  Theorem spec_1: to_Z one = 1.
- exact N.spec_1.
+ exact NN.spec_1.
+ Qed.
+
+ Theorem spec_2: to_Z two = 2.
+ exact NN.spec_2.
  Qed.
 
  Theorem spec_m1: to_Z minus_one = -1.
- simpl; rewrite N.spec_1; auto.
+ simpl; rewrite NN.spec_1; auto.
  Qed.
 
  Definition compare x y :=
   match x, y with
-  | Pos nx, Pos ny => N.compare nx ny
+  | Pos nx, Pos ny => NN.compare nx ny
   | Pos nx, Neg ny =>
-    match N.compare nx N.zero with
+    match NN.compare nx NN.zero with
     | Gt => Gt
-    | _ => N.compare ny N.zero
+    | _ => NN.compare ny NN.zero
     end
   | Neg nx, Pos ny =>
-    match N.compare N.zero nx with
+    match NN.compare NN.zero nx with
     | Lt => Lt
-    | _ => N.compare N.zero ny
+    | _ => NN.compare NN.zero ny
     end
-  | Neg nx, Neg ny => N.compare ny nx
+  | Neg nx, Neg ny => NN.compare ny nx
   end.
 
  Theorem spec_compare :
-  forall x y, compare x y = Zcompare (to_Z x) (to_Z y).
+  forall x y, compare x y = Z.compare (to_Z x) (to_Z y).
  Proof.
  unfold compare, to_Z.
  destruct x as [x|x], y as [y|y];
- rewrite ?N.spec_compare, ?N.spec_0, <-?Zcompare_opp; auto;
- assert (Hx:=N.spec_pos x); assert (Hy:=N.spec_pos y);
- set (X:=N.to_Z x) in *; set (Y:=N.to_Z y) in *; clearbody X Y.
- destruct (Zcompare_spec X 0) as [EQ|LT|GT].
-  rewrite EQ. rewrite <- Zopp_0 at 2. apply Zcompare_opp.
-  exfalso. omega.
-  symmetry. change (X > -Y). omega.
- destruct (Zcompare_spec 0 X) as [EQ|LT|GT].
-  rewrite <- EQ. rewrite Zopp_0; auto.
-  symmetry. change (-X < Y). omega.
-  exfalso. omega.
- Qed.
-
- Definition eq_bool x y :=
+ rewrite ?NN.spec_compare, ?NN.spec_0, ?Z.compare_opp; auto;
+ assert (Hx:=NN.spec_pos x); assert (Hy:=NN.spec_pos y);
+ set (X:=NN.to_Z x) in *; set (Y:=NN.to_Z y) in *; clearbody X Y.
+ - destruct (Z.compare_spec X 0) as [EQ|LT|GT].
+   + rewrite <- Z.opp_0 in EQ. now rewrite EQ, Z.compare_opp.
+   + exfalso. omega.
+   + symmetry. change (X > -Y). omega.
+ - destruct (Z.compare_spec 0 X) as [EQ|LT|GT].
+   + rewrite <- EQ, Z.opp_0; auto.
+   + symmetry. change (-X < Y). omega.
+   + exfalso. omega.
+ Qed.
+
+ 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.
 
- Theorem spec_min : forall n m, to_Z (min n m) = Zmin (to_Z n) (to_Z m).
+ Theorem spec_min : forall n m, to_Z (min n m) = Z.min (to_Z n) (to_Z m).
  Proof.
- unfold min, Zmin. intros. rewrite spec_compare. destruct Zcompare; auto.
+ unfold min, Z.min. intros. rewrite spec_compare. destruct Z.compare; auto.
  Qed.
 
- Theorem spec_max : forall n m, to_Z (max n m) = Zmax (to_Z n) (to_Z m).
+ Theorem spec_max : forall n m, to_Z (max n m) = Z.max (to_Z n) (to_Z m).
  Proof.
- unfold max, Zmax. intros. rewrite spec_compare. destruct Zcompare; auto.
+ unfold max, Z.max. intros. rewrite spec_compare. destruct Z.compare; auto.
  Qed.
 
  Definition to_N x :=
@@ -140,11 +173,11 @@ Module Make (N:NType) <: ZType.
 
  Definition abs x := Pos (to_N x).
 
- Theorem spec_abs: forall x, to_Z (abs x) = Zabs (to_Z x).
+ Theorem spec_abs: forall x, to_Z (abs x) = Z.abs (to_Z x).
  Proof.
- intros x; case x; clear x; intros x; assert (F:=N.spec_pos x).
-    simpl; rewrite Zabs_eq; auto.
- simpl; rewrite Zabs_non_eq; simpl; auto with zarith.
+ intros x; case x; clear x; intros x; assert (F:=NN.spec_pos x).
+    simpl; rewrite Z.abs_eq; auto.
+ simpl; rewrite Z.abs_neq; simpl; auto with zarith.
  Qed.
 
  Definition opp x :=
@@ -160,10 +193,10 @@ Module Make (N:NType) <: ZType.
 
  Definition succ x :=
   match x with
-  | Pos n => Pos (N.succ n)
+  | Pos n => Pos (NN.succ n)
   | Neg n =>
-    match N.compare N.zero n with
-    | Lt => Neg (N.pred n)
+    match NN.compare NN.zero n with
+    | Lt => Neg (NN.pred n)
     | _ => one
     end
   end.
@@ -171,232 +204,260 @@ Module Make (N:NType) <: ZType.
  Theorem spec_succ: forall n, to_Z (succ n) = to_Z n + 1.
  Proof.
  intros x; case x; clear x; intros x.
-   exact (N.spec_succ x).
- simpl. rewrite N.spec_compare. case Zcompare_spec; rewrite ?N.spec_0; simpl.
-  intros HH; rewrite <- HH; rewrite N.spec_1; ring.
-  intros HH; rewrite N.spec_pred, Zmax_r; auto with zarith.
- generalize (N.spec_pos x); auto with zarith.
+   exact (NN.spec_succ x).
+ simpl. rewrite NN.spec_compare. case Z.compare_spec; rewrite ?NN.spec_0; simpl.
+  intros HH; rewrite <- HH; rewrite NN.spec_1; ring.
+  intros HH; rewrite NN.spec_pred, Z.max_r; auto with zarith.
+ generalize (NN.spec_pos x); auto with zarith.
  Qed.
 
  Definition add x y :=
   match x, y with
-  | Pos nx, Pos ny => Pos (N.add nx ny)
+  | Pos nx, Pos ny => Pos (NN.add nx ny)
   | Pos nx, Neg ny =>
-    match N.compare nx ny with
-    | Gt => Pos (N.sub nx ny)
+    match NN.compare nx ny with
+    | Gt => Pos (NN.sub nx ny)
     | Eq => zero
-    | Lt => Neg (N.sub ny nx)
+    | Lt => Neg (NN.sub ny nx)
     end
   | Neg nx, Pos ny =>
-    match N.compare nx ny with
-    | Gt => Neg (N.sub nx ny)
+    match NN.compare nx ny with
+    | Gt => Neg (NN.sub nx ny)
     | Eq => zero
-    | Lt => Pos (N.sub ny nx)
+    | Lt => Pos (NN.sub ny nx)
     end
-  | Neg nx, Neg ny => Neg (N.add nx ny)
+  | Neg nx, Neg ny => Neg (NN.add nx ny)
   end.
 
  Theorem spec_add: forall x y, to_Z (add x y) = to_Z x +  to_Z y.
  Proof.
  unfold add, to_Z; intros [x | x] [y | y];
-   try (rewrite N.spec_add; auto with zarith);
- rewrite N.spec_compare; case Zcompare_spec;
-  unfold zero; rewrite ?N.spec_0, ?N.spec_sub; omega with *.
+   try (rewrite NN.spec_add; auto with zarith);
+ rewrite NN.spec_compare; case Z.compare_spec;
+  unfold zero; rewrite ?NN.spec_0, ?NN.spec_sub; omega with *.
  Qed.
 
  Definition pred x :=
   match x with
   | Pos nx =>
-    match N.compare N.zero nx with
-    | Lt => Pos (N.pred nx)
+    match NN.compare NN.zero nx with
+    | Lt => Pos (NN.pred nx)
     | _ => minus_one
     end
-  | Neg nx => Neg (N.succ nx)
+  | Neg nx => Neg (NN.succ nx)
   end.
 
  Theorem spec_pred: forall x, to_Z (pred x) = to_Z x - 1.
  Proof.
  unfold pred, to_Z, minus_one; intros [x | x];
-   try (rewrite N.spec_succ; ring).
- rewrite N.spec_compare; case Zcompare_spec;
-  rewrite ?N.spec_0, ?N.spec_1, ?N.spec_pred;
-  generalize (N.spec_pos x); omega with *.
+   try (rewrite NN.spec_succ; ring).
+ rewrite NN.spec_compare; case Z.compare_spec;
+  rewrite ?NN.spec_0, ?NN.spec_1, ?NN.spec_pred;
+  generalize (NN.spec_pos x); omega with *.
  Qed.
 
  Definition sub x y :=
   match x, y with
   | Pos nx, Pos ny =>
-    match N.compare nx ny with
-    | Gt => Pos (N.sub nx ny)
+    match NN.compare nx ny with
+    | Gt => Pos (NN.sub nx ny)
     | Eq => zero
-    | Lt => Neg (N.sub ny nx)
+    | Lt => Neg (NN.sub ny nx)
     end
-  | Pos nx, Neg ny => Pos (N.add nx ny)
-  | Neg nx, Pos ny => Neg (N.add nx ny)
+  | Pos nx, Neg ny => Pos (NN.add nx ny)
+  | Neg nx, Pos ny => Neg (NN.add nx ny)
   | Neg nx, Neg ny =>
-    match N.compare nx ny with
-    | Gt => Neg (N.sub nx ny)
+    match NN.compare nx ny with
+    | Gt => Neg (NN.sub nx ny)
     | Eq => zero
-    | Lt => Pos (N.sub ny nx)
+    | Lt => Pos (NN.sub ny nx)
     end
   end.
 
  Theorem spec_sub: forall x y, to_Z (sub x y) = to_Z x - to_Z y.
  Proof.
  unfold sub, to_Z; intros [x | x] [y | y];
-  try (rewrite N.spec_add; auto with zarith);
- rewrite N.spec_compare; case Zcompare_spec;
-  unfold zero; rewrite ?N.spec_0, ?N.spec_sub; omega with *.
+  try (rewrite NN.spec_add; auto with zarith);
+ rewrite NN.spec_compare; case Z.compare_spec;
+  unfold zero; rewrite ?NN.spec_0, ?NN.spec_sub; omega with *.
  Qed.
 
  Definition mul x y :=
   match x, y with
-  | Pos nx, Pos ny => Pos (N.mul nx ny)
-  | Pos nx, Neg ny => Neg (N.mul nx ny)
-  | Neg nx, Pos ny => Neg (N.mul nx ny)
-  | Neg nx, Neg ny => Pos (N.mul nx ny)
+  | Pos nx, Pos ny => Pos (NN.mul nx ny)
+  | Pos nx, Neg ny => Neg (NN.mul nx ny)
+  | Neg nx, Pos ny => Neg (NN.mul nx ny)
+  | Neg nx, Neg ny => Pos (NN.mul nx ny)
   end.
 
  Theorem spec_mul: forall x y, to_Z (mul x y) = to_Z x * to_Z y.
  Proof.
- unfold mul, to_Z; intros [x | x] [y | y]; rewrite N.spec_mul; ring.
+ unfold mul, to_Z; intros [x | x] [y | y]; rewrite NN.spec_mul; ring.
  Qed.
 
  Definition square x :=
   match x with
-  | Pos nx => Pos (N.square nx)
-  | Neg nx => Pos (N.square nx)
+  | Pos nx => Pos (NN.square nx)
+  | Neg nx => Pos (NN.square nx)
   end.
 
  Theorem spec_square: forall x, to_Z (square x) = to_Z x *  to_Z x.
  Proof.
- unfold square, to_Z; intros [x | x]; rewrite N.spec_square; ring.
+ unfold square, to_Z; intros [x | x]; rewrite NN.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 (NN.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 (NN.pow_pos nx p)
+    | xI _ => Neg (NN.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.
+   intros x; rewrite Z.pow_2_r; ring.
+ unfold pow_pos, to_Z; intros [x | x] [p | p |];
+   try rewrite NN.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.
- repeat rewrite Zpower_mult; auto with zarith.
+ rewrite Pos2Z.inj_xI; repeat rewrite Zpower_exp; auto with zarith.
+ repeat rewrite Z.pow_mul_r; auto with zarith.
  rewrite F0; ring.
  assert (F: 0 <= 2 * Zpos p).
   assert (0 <= Zpos p); auto with zarith.
- rewrite Zpos_xO; repeat rewrite Zpower_exp; auto with zarith.
- repeat rewrite Zpower_mult; auto with zarith.
+ rewrite Pos2Z.inj_xO; repeat rewrite Zpower_exp; auto with zarith.
+ repeat rewrite Z.pow_mul_r; auto with zarith.
  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 NN.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 NN.spec_1.
+ apply spec_pow_pos.
+ apply NN.spec_0.
  Qed.
 
+ Definition log2 x :=
+  match x with
+  | Pos nx => Pos (NN.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 NN.spec_log2.
+  rewrite NN.spec_0.
+  destruct (Z_le_lt_eq_dec _ _ (NN.spec_pos p)) as [LT|EQ].
+  rewrite Z.log2_nonpos; auto with zarith.
+  now rewrite <- EQ.
+ Qed.
 
  Definition sqrt x :=
   match x with
-  | Pos nx => Pos (N.sqrt nx)
-  | Neg nx => Neg N.zero
+  | Pos nx => Pos (NN.sqrt nx)
+  | Neg nx => Neg NN.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 NN.spec_sqrt.
+  rewrite NN.spec_0.
+  destruct (Z_le_lt_eq_dec _ _ (NN.spec_pos p)) as [LT|EQ].
+  rewrite Z.sqrt_neg; auto with zarith.
+  now rewrite <- EQ.
  Qed.
 
  Definition div_eucl x y :=
   match x, y with
   | Pos nx, Pos ny =>
-    let (q, r) := N.div_eucl nx ny in
+    let (q, r) := NN.div_eucl nx ny in
     (Pos q, Pos r)
   | Pos nx, Neg ny =>
-    let (q, r) := N.div_eucl nx ny in
-    if N.eq_bool N.zero r
+    let (q, r) := NN.div_eucl nx ny in
+    if NN.eqb NN.zero r
     then (Neg q, zero)
-    else (Neg (N.succ q), Neg (N.sub ny r))
+    else (Neg (NN.succ q), Neg (NN.sub ny r))
   | Neg nx, Pos ny =>
-    let (q, r) := N.div_eucl nx ny in
-    if N.eq_bool N.zero r
+    let (q, r) := NN.div_eucl nx ny in
+    if NN.eqb NN.zero r
     then (Neg q, zero)
-    else (Neg (N.succ q), Pos (N.sub ny r))
+    else (Neg (NN.succ q), Pos (NN.sub ny r))
   | Neg nx, Neg ny =>
-    let (q, r) := N.div_eucl nx ny in
+    let (q, r) := NN.div_eucl nx ny in
     (Pos q, Neg r)
   end.
 
  Ltac break_nonneg x px EQx :=
   let H := fresh "H" in
-  assert (H:=N.spec_pos x);
-  destruct (N.to_Z x) as [|px|px]_eqn:EQx;
+  assert (H:=NN.spec_pos x);
+  destruct (NN.to_Z x) as [|px|px] eqn:EQx;
    [clear H|clear H|elim H; reflexivity].
 
  Theorem spec_div_eucl: forall x y,
    let (q,r) := div_eucl x y in
-   (to_Z q, to_Z r) = Zdiv_eucl (to_Z x) (to_Z y).
+   (to_Z q, to_Z r) = Z.div_eucl (to_Z x) (to_Z y).
  Proof.
  unfold div_eucl, to_Z. intros [x | x] [y | y].
  (* Pos Pos *)
- generalize (N.spec_div_eucl x y); destruct (N.div_eucl x y); auto.
+ generalize (NN.spec_div_eucl x y); destruct (NN.div_eucl x y); auto.
  (* Pos Neg *)
- generalize (N.spec_div_eucl x y); destruct (N.div_eucl x y) as (q,r).
+ generalize (NN.spec_div_eucl x y); destruct (NN.div_eucl x y) as (q,r).
  break_nonneg x px EQx; break_nonneg y py EQy;
- try (injection 1; intros Hr Hq; rewrite N.spec_eq_bool, N.spec_0, Hr;
-      simpl; rewrite Hq, N.spec_0; auto).
+ try (injection 1; intros Hr Hq; rewrite NN.spec_eqb, NN.spec_0, Hr;
+      simpl; rewrite Hq, NN.spec_0; auto).
  change (- Zpos py) with (Zneg py).
  assert (GT : Zpos py > 0) by (compute; auto).
  generalize (Z_div_mod (Zpos px) (Zpos py) GT).
- unfold Zdiv_eucl. destruct (Zdiv_eucl_POS px (Zpos py)) as (q',r').
+ unfold Z.div_eucl. destruct (Z.pos_div_eucl px (Zpos py)) as (q',r').
  intros (EQ,MOD). injection 1. intros Hr' Hq'.
- rewrite N.spec_eq_bool, N.spec_0, Hr'.
+ rewrite NN.spec_eqb, NN.spec_0, Hr'.
  break_nonneg r pr EQr.
- subst; simpl. rewrite N.spec_0; auto.
- subst. lazy iota beta delta [Zeq_bool Zcompare].
- rewrite N.spec_sub, N.spec_succ, EQy, EQr. f_equal. omega with *.
+ subst; simpl. rewrite NN.spec_0; auto.
+ subst. lazy iota beta delta [Z.eqb].
+ rewrite NN.spec_sub, NN.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).
+ generalize (NN.spec_div_eucl x y); destruct (NN.div_eucl x y) as (q,r).
  break_nonneg x px EQx; break_nonneg y py EQy;
- try (injection 1; intros Hr Hq; rewrite N.spec_eq_bool, N.spec_0, Hr;
-      simpl; rewrite Hq, N.spec_0; auto).
+ try (injection 1; intros Hr Hq; rewrite NN.spec_eqb, NN.spec_0, Hr;
+      simpl; rewrite Hq, NN.spec_0; auto).
  change (- Zpos px) with (Zneg px).
  assert (GT : Zpos py > 0) by (compute; auto).
  generalize (Z_div_mod (Zpos px) (Zpos py) GT).
- unfold Zdiv_eucl. destruct (Zdiv_eucl_POS px (Zpos py)) as (q',r').
+ unfold Z.div_eucl. destruct (Z.pos_div_eucl px (Zpos py)) as (q',r').
  intros (EQ,MOD). injection 1. intros Hr' Hq'.
- rewrite N.spec_eq_bool, N.spec_0, Hr'.
+ rewrite NN.spec_eqb, NN.spec_0, Hr'.
  break_nonneg r pr EQr.
- subst; simpl. rewrite N.spec_0; auto.
- subst. lazy iota beta delta [Zeq_bool Zcompare].
- rewrite N.spec_sub, N.spec_succ, EQy, EQr. f_equal. omega with *.
+ subst; simpl. rewrite NN.spec_0; auto.
+ subst. lazy iota beta delta [Z.eqb].
+ rewrite NN.spec_sub, NN.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).
+ generalize (NN.spec_div_eucl x y); destruct (NN.div_eucl x y) as (q,r).
  break_nonneg x px EQx; break_nonneg y py EQy;
  try (injection 1; intros Hr Hq; rewrite Hr, Hq; auto).
  simpl. intros <-; auto.
@@ -407,8 +468,8 @@ Module Make (N:NType) <: ZType.
  Definition spec_div: forall x y,
      to_Z (div x y) = to_Z x / to_Z y.
  Proof.
- intros x y; generalize (spec_div_eucl x y); unfold div, Zdiv.
- case div_eucl; case Zdiv_eucl; simpl; auto.
+ intros x y; generalize (spec_div_eucl x y); unfold div, Z.div.
+ case div_eucl; case Z.div_eucl; simpl; auto.
  intros q r q11 r1 H; injection H; auto.
  Qed.
 
@@ -417,25 +478,69 @@ Module Make (N:NType) <: ZType.
  Theorem spec_modulo:
    forall x y, to_Z (modulo x y) = to_Z x mod to_Z y.
  Proof.
- intros x y; generalize (spec_div_eucl x y); unfold modulo, Zmod.
- case div_eucl; case Zdiv_eucl; simpl; auto.
+ intros x y; generalize (spec_div_eucl x y); unfold modulo, Z.modulo.
+ case div_eucl; case Z.div_eucl; simpl; auto.
  intros q r q11 r1 H; injection H; auto.
  Qed.
 
+ Definition quot x y :=
+  match x, y with
+  | Pos nx, Pos ny => Pos (NN.div nx ny)
+  | Pos nx, Neg ny => Neg (NN.div nx ny)
+  | Neg nx, Pos ny => Neg (NN.div nx ny)
+  | Neg nx, Neg ny => Pos (NN.div nx ny)
+  end.
+
+ Definition rem x y :=
+  if eqb y zero then x
+  else
+    match x, y with
+      | Pos nx, Pos ny => Pos (NN.modulo nx ny)
+      | Pos nx, Neg ny => Pos (NN.modulo nx ny)
+      | Neg nx, Pos ny => Neg (NN.modulo nx ny)
+      | Neg nx, Neg ny => Neg (NN.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 NN.spec_div;
+  (* Nota: we rely here on [forall a b, a ÷ 0 = b / 0] *)
+  destruct (Z.eq_dec (NN.to_Z y) 0) as [EQ|NEQ];
+    try (rewrite EQ; now destruct (NN.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 (NN.spec_pos x) (NN.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 NN.spec_modulo, ?Z.rem_opp_r, ?Z.rem_opp_l, ?Z.opp_involutive,
+    ?Z.opp_inj_wd;
+   trivial; apply Z.rem_mod_nonneg;
+    generalize (NN.spec_pos x) (NN.spec_pos y); Z.order.
+ Qed.
+
  Definition gcd x y :=
   match x, y with
-  | Pos nx, Pos ny => Pos (N.gcd nx ny)
-  | Pos nx, Neg ny => Pos (N.gcd nx ny)
-  | Neg nx, Pos ny => Pos (N.gcd nx ny)
-  | Neg nx, Neg ny => Pos (N.gcd nx ny)
+  | Pos nx, Pos ny => Pos (NN.gcd nx ny)
+  | Pos nx, Neg ny => Pos (NN.gcd nx ny)
+  | Neg nx, Pos ny => Pos (NN.gcd nx ny)
+  | Neg nx, Neg ny => Pos (NN.gcd nx ny)
   end.
 
- Theorem spec_gcd: forall a b, to_Z (gcd a b) = Zgcd (to_Z a) (to_Z b).
+ Theorem spec_gcd: forall a b, to_Z (gcd a b) = Z.gcd (to_Z a) (to_Z b).
  Proof.
- unfold gcd, Zgcd, to_Z; intros [x | x] [y | y]; rewrite N.spec_gcd; unfold Zgcd;
-  auto; case N.to_Z; simpl; auto with zarith;
-  try rewrite Zabs_Zopp; auto;
-  case N.to_Z; simpl; auto with zarith.
+ unfold gcd, Z.gcd, to_Z; intros [x | x] [y | y]; rewrite NN.spec_gcd; unfold Z.gcd;
+  auto; case NN.to_Z; simpl; auto with zarith;
+  try rewrite Z.abs_opp; auto;
+  case NN.to_Z; simpl; auto with zarith.
  Qed.
 
  Definition sgn x :=
@@ -445,12 +550,212 @@ Module Make (N:NType) <: ZType.
    | Gt => minus_one
   end.
 
- Lemma spec_sgn : forall x, to_Z (sgn x) = Zsgn (to_Z x).
+ Lemma spec_sgn : forall x, to_Z (sgn x) = Z.sgn (to_Z x).
  Proof.
- intros. unfold sgn. rewrite spec_compare. case Zcompare_spec.
+ intros. unfold sgn. rewrite spec_compare. case Z.compare_spec.
  rewrite spec_0. intros <-; auto.
- rewrite spec_0, spec_1. symmetry. rewrite Zsgn_pos; auto.
- rewrite spec_0, spec_m1. symmetry. rewrite Zsgn_neg; auto with zarith.
+ rewrite spec_0, spec_1. symmetry. rewrite Z.sgn_pos_iff; auto.
+ rewrite spec_0, spec_m1. symmetry. rewrite Z.sgn_neg_iff; auto with zarith.
+ Qed.
+
+ Definition even z :=
+  match z with
+   | Pos n => NN.even n
+   | Neg n => NN.even n
+  end.
+
+ Definition odd z :=
+  match z with
+   | Pos n => NN.odd n
+   | Neg n => NN.odd n
+  end.
+
+ Lemma spec_even : forall z, even z = Z.even (to_Z z).
+ Proof.
+  intros [n|n]; simpl; rewrite NN.spec_even; trivial.
+  destruct (NN.to_Z n) as [|p|p]; now try destruct p.
+ Qed.
+
+ Lemma spec_odd : forall z, odd z = Z.odd (to_Z z).
+ Proof.
+  intros [n|n]; simpl; rewrite NN.spec_odd; trivial.
+  destruct (NN.to_Z n) as [|p|p]; now try destruct p.
+ Qed.
+
+ Definition norm_pos z :=
+   match z with
+     | Pos _ => z
+     | Neg n => if NN.eqb n NN.zero then Pos n else z
+   end.
+
+ Definition testbit a n :=
+   match norm_pos n, norm_pos a with
+     | Pos p, Pos a => NN.testbit a p
+     | Pos p, Neg a => negb (NN.testbit (NN.pred a) p)
+     | Neg p, _ => false
+   end.
+
+ Definition shiftl a n :=
+   match norm_pos a, n with
+     | Pos a, Pos n => Pos (NN.shiftl a n)
+     | Pos a, Neg n => Pos (NN.shiftr a n)
+     | Neg a, Pos n => Neg (NN.shiftl a n)
+     | Neg a, Neg n => Neg (NN.succ (NN.shiftr (NN.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 (NN.lor a b)
+     | Neg a, Pos b => Neg (NN.succ (NN.ldiff (NN.pred a) b))
+     | Pos a, Neg b => Neg (NN.succ (NN.ldiff (NN.pred b) a))
+     | Neg a, Neg b => Neg (NN.succ (NN.land (NN.pred a) (NN.pred b)))
+   end.
+
+ Definition land a b :=
+   match norm_pos a, norm_pos b with
+     | Pos a, Pos b => Pos (NN.land a b)
+     | Neg a, Pos b => Pos (NN.ldiff b (NN.pred a))
+     | Pos a, Neg b => Pos (NN.ldiff a (NN.pred b))
+     | Neg a, Neg b => Neg (NN.succ (NN.lor (NN.pred a) (NN.pred b)))
+   end.
+
+ Definition ldiff a b :=
+   match norm_pos a, norm_pos b with
+     | Pos a, Pos b => Pos (NN.ldiff a b)
+     | Neg a, Pos b => Neg (NN.succ (NN.lor (NN.pred a) b))
+     | Pos a, Neg b => Pos (NN.land a (NN.pred b))
+     | Neg a, Neg b => Pos (NN.ldiff (NN.pred b) (NN.pred a))
+   end.
+
+ Definition lxor a b :=
+   match norm_pos a, norm_pos b with
+     | Pos a, Pos b => Pos (NN.lxor a b)
+     | Neg a, Pos b => Neg (NN.succ (NN.lxor (NN.pred a) b))
+     | Pos a, Neg b => Neg (NN.succ (NN.lxor a (NN.pred b)))
+     | Neg a, Neg b => Pos (NN.lxor (NN.pred a) (NN.pred b))
+   end.
+
+ Definition div2 x := shiftr x one.
+
+ Lemma Zlnot_alt1 : forall x, -(x+1) = Z.lnot x.
+ Proof.
+  unfold Z.lnot, Z.pred; auto with zarith.
+ Qed.
+
+ Lemma Zlnot_alt2 : forall x, Z.lnot (x-1) = -x.
+ Proof.
+  unfold Z.lnot, Z.pred; auto with zarith.
+ Qed.
+
+ Lemma Zlnot_alt3 : forall x, Z.lnot (-x) = x-1.
+ Proof.
+  unfold Z.lnot, Z.pred; 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 NN.spec_eqb, NN.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 < NN.to_Z y.
+ Proof.
+  intros [x|x] y; simpl; try easy.
+  rewrite NN.spec_eqb, NN.spec_0.
+  case Z.eqb_spec; simpl; try easy.
+  inversion 2. subst. generalize (NN.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 NN.spec_testbit.
+  rewrite NN.spec_testbit, NN.spec_pred, Z.max_r by auto with zarith.
+  symmetry. apply Z.bits_opp. apply NN.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 := NN.spec_pos p).
+  apply NN.spec_shiftl.
+  rewrite Z.shiftl_opp_r. apply NN.spec_shiftr.
+  rewrite !NN.spec_shiftl.
+  rewrite !Z.shiftl_mul_pow2 by apply NN.spec_pos.
+  symmetry. apply Z.mul_opp_l.
+  rewrite Z.shiftl_opp_r, NN.spec_succ, NN.spec_shiftr, NN.spec_pred, Z.max_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 ?NN.spec_succ, ?NN.spec_land, ?NN.spec_ldiff, ?NN.spec_lor,
+    ?NN.spec_pred, ?Z.max_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 ?NN.spec_succ, ?NN.spec_land, ?NN.spec_ldiff, ?NN.spec_lor,
+    ?NN.spec_pred, ?Z.max_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 ?NN.spec_succ, ?NN.spec_land, ?NN.spec_ldiff, ?NN.spec_lor,
+    ?NN.spec_pred, ?Z.max_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 ?NN.spec_succ, ?NN.spec_lxor, ?NN.spec_pred, ?Z.max_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..fc600eae 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,107 +8,35 @@
 (*                      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 *)
 
-(*Lemma Zring : ring_theory 0 1 NZadd NZmul NZsub Zopp NZeq.
+(*Lemma Zring : ring_theory 0 1 NZadd NZmul NZsub Z.opp NZeq.
 Proof.
 constructor.
 exact Zadd_0_l.
@@ -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..b5e1fa5b 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-2012     *)
 (*   \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).
@@ -57,7 +59,7 @@ Definition le (n m : t) := n#1 + m#2 <= m#1 + n#2.
 Definition min (n m : t) : t := (min (n#1 + m#2) (m#1 + n#2), n#2 + m#2).
 Definition max (n m : t) : t := (max (n#1 + m#2) (m#1 + n#2), n#2 + m#2).
 
-(** NB : We do not have [Zpred (Zsucc n) = n] but only [Zpred (Zsucc n) == n].
+(** NB : We do not have [Z.pred (Z.succ n) = n] but only [Z.pred (Z.succ n) == n].
     It could be possible to consider as canonical only pairs where
     one of the elements is 0, and make all operations convert
     canonical values into other canonical values. In that case, we
@@ -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..0a26a910 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-2012     *)
 (*   \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..e2ec3482 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-2012     *)
 (*   \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).
@@ -86,7 +93,7 @@ replace z with (-(-z))%Z in * by (auto with zarith).
 remember (-z)%Z as z'.
 pattern z'; apply natlike_ind.
 apply B0.
-intros; rewrite Zopp_succ; unfold Zpred; apply BP; auto.
+intros; rewrite Z.opp_succ; unfold Z.pred; apply BP; auto.
 subst z'; auto with zarith.
 Qed.
 
@@ -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,22 +263,108 @@ 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.
 
 Theorem div_mod : forall a b, ~b==0 -> a == b*(div a b) + (modulo a b).
 Proof.
-intros a b. zify. intros. apply Z_div_mod_eq_full; auto.
+intros a b. zify. intros. apply Z.div_mod; auto.
 Qed.
 
 Theorem mod_pos_bound :
@@ -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..7cf3daea 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-2012     *)
 (*   \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..83b2d63b 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-2012     *)
 (*   \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..ed179699 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-2012     *)
 (*   \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..3a432eaa 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-2012     *)
 (*   \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 (N.succ 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..62b14829 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-2012     *)
 (*   \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..8be5d45c
--- /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-2012     *)
+(*   \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..4b8a62a8 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-2012     *)
 (*   \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..4b71d539 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-2012     *)
 (*   \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..d7e598fb
--- /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-2012     *)
+(*   \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..fba91bf3
--- /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-2012     *)
+(*   \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..117a9621 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-2012     *)
 (*   \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..a1fe4bf5 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-2012     *)
 (*   \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,19 +255,25 @@ 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.
 
-Theorem lt_0_mul : forall n m, 0 < n * m <-> (0 < n /\ 0 < m) \/ (m < 0 /\ n < 0).
+(** 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 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]]].
+split; [intro H | intros [[H1 H2] | [H1 H2]]].
 destruct (lt_trichotomy n 0) as [H1 | [H1 | H1]];
 [| rewrite H1 in H; rewrite mul_0_l in H; false_hyp H lt_irrefl |];
 (destruct (lt_trichotomy m 0) as [H2 | [H2 | H2]];
@@ -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..3dae9c70 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-2012     *)
 (*   \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,19 +146,17 @@ Definition lt_compat := lt_wd.
 Definition lt_total := lt_trichotomy.
 Definition le_lteq := lt_eq_cases.
 
-Module OrderElts <: TotalOrder.
- Definition t := t.
- Definition eq := eq.
- Definition lt := lt.
- Definition le := le.
+Module Private_OrderTac.
+Module IsTotal.
  Definition eq_equiv := eq_equiv.
  Definition lt_strorder := lt_strorder.
  Definition lt_compat := lt_compat.
  Definition lt_total := lt_total.
  Definition le_lteq := le_lteq.
-End OrderElts.
-Module OrderTac := !MakeOrderTac OrderElts.
-Ltac order := OrderTac.order.
+End IsTotal.
+Module Tac := !MakeOrderTac NZ IsTotal.
+End Private_OrderTac.
+Ltac order := Private_OrderTac.Tac.order.
 
 (** Some direct consequences of [order]. *)
 
@@ -208,12 +204,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 +229,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 +361,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 +373,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 +411,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 +470,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 +548,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 +576,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 +603,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 +616,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 +630,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 NZ <+ Compare2EqBool <+ HasEqBool2Dec.
diff --git a/theories/Numbers/NatInt/NZParity.v b/theories/Numbers/NatInt/NZParity.v
new file mode 100644
index 00000000..0e932378
--- /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-2012     *)
+(*   \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..26d5ffef
--- /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-2012     *)
+(*   \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..a2eb1996 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-2012     *)
 (*   \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..8146fd01
--- /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-2012     *)
+(*   \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..0ff86fca 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-2012     *)
 (*   \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..5f80714a 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-2012     *)
 (*   \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..061da038 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-2012     *)
 (*   \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..09e9ccdf 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-2012     *)
 (*   \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..1581ce57
--- /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-2012     *)
+(*   \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 [Pos.size_nat] and [Pos.size]).
+*)
+
+(** 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..621a2ed9 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-2012     *)
 (*   \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,
@@ -406,11 +376,11 @@ Lemma log_good_step : forall n h1 h2,
   (if n << 2 then 0 else S (h2 (half n))).
 Proof.
 intros n h1 h2 E.
-destruct (n<<2) as [ ]_eqn:H.
+destruct (n<<2) 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..d7fb447e 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-2012     *)
 (*   \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..1c5829dd
--- /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-2012     *)
+(*   \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..b17f0c3d 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-2012     *)
 (*   \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..9d8e3e6d
--- /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-2012     *)
+(*   \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..f8dc1a2b
--- /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-2012     *)
+(*   \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..dde7aba5
--- /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-2012     *)
+(*   \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..2f4c91e3 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-2012     *)
 (*   \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..a5a12d37 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-2012     *)
 (*   \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..69b7778a
--- /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-2012     *)
+(*   \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..ee29a4a7
--- /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-2012     *)
+(*   \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..90739410 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-2012     *)
 (*   \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..9cd62ae9
--- /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-2012     *)
+(*   \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..e4cbf090 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-2012     *)
 (*   \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..68bfffad 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-2012     *)
 (*   \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..072b75f7 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-2012     *)
 (*   \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,29 +97,29 @@ 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).
 generalize (Z_div_mod_full [a] [b] NEQ).
-destruct BigN.div_eucl as (q,r), Zdiv_eucl as (q',r').
+destruct BigN.div_eucl as (q,r), Z.div_eucl as (q',r').
 intros (EQ,_). injection 1. intros EQr EQq.
 BigN.zify. rewrite EQr, EQq; auto.
 Qed.
@@ -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..5012a1b9 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -16,118 +16,577 @@
     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 Z.mul_le_mono_nonneg_l; auto with zarith.
+ apply Z.pow_le_mono_r; 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 *)
 
- Lemma spec_pred : forall x, [pred x] = Zmax 0 ([x]-1).
+ 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. destruct (Zle_lt_or_eq _ _ (spec_pos x)).
- rewrite Zmax_r; auto with zarith.
- apply spec_pred_pos; auto.
- rewrite <- H; apply spec_pred0; auto.
+  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 x : [pred x] = Z.max 0 ([x]-1).
+ Proof.
+ rewrite Z.max_comm.
+ destruct (Z.max_spec ([x]-1) 0) as [(H,->)|(H,->)].
+ - apply spec_pred0; generalize (spec_pos x); auto with zarith.
+ - apply spec_pred_pos; auto with zarith.
+ Qed.
 
  (** * Subtraction *)
 
- Lemma spec_sub : forall x y, [sub x y] = Zmax 0 ([x]-[y]).
+ 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. destruct (Zle_or_lt [y] [x]).
- rewrite Zmax_r; auto with zarith. apply spec_sub_pos; auto.
- rewrite Zmax_l; auto with zarith. apply spec_sub0; auto.
+  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] = Z.max 0 ([x]-[y]).
+ Proof.
+ intros. destruct (Z.le_gt_cases [y] [x]).
+ rewrite Z.max_r; auto with zarith. apply spec_sub_pos; auto.
+ rewrite Z.max_l; auto with zarith. apply spec_sub0; auto.
  Qed.
 
  (** * 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 = Z.compare (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.
+ lazy beta iota delta [iter_sym dom_op dom_t comparen_m]. reflexivity.
+ Qed.
+
+ Theorem spec_compare : forall x y,
+   compare x y = Z.compare [x] [y].
  Proof.
- intros x y. generalize (spec_compare_aux x y); destruct compare;
- intros; symmetry; try rewrite Zcompare_Eq_iff_eq; assumption.
+  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. now rewrite <- Z.compare_antisym.
  Qed.
 
- Definition eq_bool x y :=
+ 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.
+ 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.
+
+ 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. unfold eq_bool, Zeq_bool. rewrite spec_compare; reflexivity.
+ apply eq_iff_eq_true.
+ rewrite Z.ltb_lt. unfold Z.lt, ltb. rewrite 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 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.
- intros x y; unfold eq_bool.
- generalize (spec_compare_aux x y); case compare; auto with zarith.
+ 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 lt n m := [n] < [m].
- Definition le n m := [n] <= [m].
+ 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.
 
- Definition min n m := match compare n m with Gt => m | _ => n end.
- Definition max n m := match compare n m with Lt => m | _ => n end.
+ Theorem spec_max : forall n m, [max n m] = Z.max [n] [m].
+ Proof.
+ intros. unfold max, Z.max. rewrite spec_compare; destruct Z.compare; reflexivity.
+ Qed.
 
- Theorem spec_max : forall n m, [max n m] = Zmax [n] [m].
+ Theorem spec_min : forall n m, [min n m] = Z.min [n] [m].
  Proof.
- intros. unfold max, Zmax. rewrite spec_compare; destruct Zcompare; reflexivity.
+ intros. unfold min, Z.min. rewrite spec_compare; destruct Z.compare; reflexivity.
  Qed.
 
- Theorem spec_min : forall n m, [min n m] = Zmin [n] [m].
+ (** * 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.
- intros. unfold min, Zmin. rewrite spec_compare; destruct Zcompare; reflexivity.
+  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.
 
+ 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.
 
- (** * Power *)
+ 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.
 
- 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_wn_mul : forall n m x y,
+   [wn_mul n m x y] = (eval n (S m) x) * ZnZ.to_Z y.
+ Proof.
+  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, Z.add_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.
 
- Theorem spec_power_pos: forall x n, [power_pos x n] = [x] ^ Zpos n.
+ Theorem spec_mul : forall x y, [mul x y] = [x] * [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 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 Z.mul_comm; auto.
  Qed.
 
- Definition power x (n:N) := match n with
-  | BinNat.N0 => one
-  | BinNat.Npos p => power_pos x p
- end.
+ (** * 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.
+  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 Z.le_lt_trans with (ZnZ.to_Z y); auto.
+    rewrite <- nmake_double; auto.
+  case (ZnZ.spec_to_Z y); auto.
+ Qed.
 
- Theorem spec_power: forall x n, [power x n] = [x] ^ Z_of_N n.
+ 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.
- destruct n; simpl. apply (spec_1 w0_spec).
- apply spec_power_pos.
+  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 Z.mul_comm; auto.
+  apply (Zmod_unique [x] [y] [q] [r]); auto.
+  rewrite Z.mul_comm; auto.
+ Qed.
 
- (** * Div *)
+ (** * General Division *)
 
- Definition div_eucl x y :=
-  if eq_bool y zero then (zero,zero) else
+ 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)
@@ -136,49 +595,123 @@ Module Make (Import W0:CyclicType) <: NType.
 
  Theorem spec_div_eucl: forall x y,
       let (q,r) := div_eucl x y in
-      ([q], [r]) = Zdiv_eucl [x] [y].
+      ([q], [r]) = Z.div_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));
-  unfold Zdiv, Zmod; case Zdiv_eucl; intros; subst; auto.
- assert (F2: 0 <= [x] < [y]).
-   generalize (spec_pos x); auto.
- generalize (Zdiv_small _ _ F2)
-            (Zmod_small _ _ F2);
-  unfold Zdiv, Zmod; case Zdiv_eucl; intros; subst; auto.
- generalize (spec_div_gt _ _ H0 H); auto.
- unfold Zdiv, Zmod; case Zdiv_eucl; case div_gt.
+ case Z.compare_spec; intros Cmp;
+   rewrite ?spec_0, ?spec_1; intros; auto with zarith.
+ rewrite Cmp; generalize (Z_div_same [y] (Z.lt_gt _ _ H))
+                         (Z_mod_same [y] (Z.lt_gt _ _ H));
+  unfold Z.div, Z.modulo; case Z.div_eucl; intros; subst; auto.
+ assert (LeLt: 0 <= [x] < [y]) by (generalize (spec_pos x); auto).
+ generalize (Zdiv_small _ _ LeLt) (Zmod_small _ _ LeLt);
+  unfold Z.div, Z.modulo; case Z.div_eucl; intros; subst; auto.
+ generalize (spec_div_gt _ _ (Z.lt_gt _ _ Cmp) H); auto.
+ unfold Z.div, Z.modulo; case Z.div_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].
  Proof.
  intros x y; unfold div; generalize (spec_div_eucl x y);
    case div_eucl; simpl fst.
- intros xx yy; unfold Zdiv; case Zdiv_eucl; intros qq rr H;
+ intros xx yy; unfold Z.div; case Z.div_eucl; intros qq rr H;
   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,25 +721,130 @@ 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.
- rewrite H0; apply sym_equal; apply Z_mod_same; auto with zarith.
- apply sym_equal; apply Zmod_small; auto with zarith.
+ case Z.compare_spec;
+   rewrite ?spec_0, ?spec_1; intros; try split; auto with zarith.
+ rewrite H0; symmetry; apply Z_mod_same; auto with zarith.
+ symmetry; 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 <- ! Z.pow_2_r. 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 Pos2Z.inj_xI; rewrite Zpower_exp; auto with zarith.
+ rewrite (Z.mul_comm 2); rewrite Z.pow_mul_r; auto with zarith.
+ rewrite Z.pow_2_r; rewrite Z.pow_1_r; auto.
+ intros; rewrite spec_square; rewrite H.
+ rewrite Pos2Z.inj_xO; auto with zarith.
+ rewrite (Z.mul_comm 2); rewrite Z.pow_mul_r; auto with zarith.
+ rewrite Z.pow_2_r; auto.
+ intros; rewrite Z.pow_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 *)
 
  Definition gcd_gt_body a b cont :=
@@ -226,19 +864,16 @@ 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 Z.compare_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 H6; rewrite <- (Zmult_1_r [b]).
+ intros H5; case Z.compare_spec.
+ intros H6; rewrite <- (Z.mul_1_r [b]).
  rewrite (Z_div_mod_eq [a] [b]); auto with zarith.
  rewrite <- spec_mod_gt; auto with zarith.
- rewrite H6; rewrite Zplus_0_r.
+ rewrite H6; rewrite Z.add_0_r.
  apply Zis_gcd_mult; apply Zis_gcd_1.
  intros; apply False_ind.
  case (spec_digits (mod_gt a b)); auto with zarith.
@@ -253,27 +888,22 @@ Module Make (Import W0:CyclicType) <: NType.
    rewrite <- spec_mod_gt; auto with zarith.
  repeat rewrite <- spec_mod_gt; auto with zarith.
  apply H4; auto with zarith.
- apply Zmult_lt_reg_r with 2; auto with zarith.
- apply Zle_lt_trans with ([b] + [mod_gt a b]); auto with zarith.
- apply Zle_lt_trans with (([a]/[b]) * [b] + [mod_gt a b]); auto with zarith.
-   apply Zplus_le_compat_r.
- pattern [b] at 1; rewrite <- (Zmult_1_l [b]).
- apply Zmult_le_compat_r; auto with zarith.
- case (Zle_lt_or_eq 0 ([a]/[b])); auto with zarith.
- intros HH; rewrite (Z_div_mod_eq [a] [b]) in H2;
-   try rewrite <- HH in H2; auto with zarith.
- case (Z_mod_lt [a] [b]); auto with zarith.
- rewrite Zmult_comm; rewrite spec_mod_gt; auto with zarith.
- rewrite <- Z_div_mod_eq; auto with zarith.
- pattern 2 at 2; rewrite <- (Zpower_1_r 2).
- rewrite <- Zpower_exp; auto with zarith.
- ring_simplify (p - 1 + 1); auto.
- case (Zle_lt_or_eq 0 p); auto with zarith.
- generalize H3; case p; simpl Zpower; auto with zarith.
- intros HH; generalize H3; rewrite <- HH; simpl Zpower; auto with zarith.
- Qed.
-
- Fixpoint gcd_gt_aux (p:positive) (cont:t->t->t) (a b:t) {struct p} : t :=
+ apply Z.mul_lt_mono_pos_r with 2; auto with zarith.
+ apply Z.le_lt_trans with ([b] + [mod_gt a b]); auto with zarith.
+ apply Z.le_lt_trans with (([a]/[b]) * [b] + [mod_gt a b]); auto with zarith.
+ - apply Z.add_le_mono_r.
+   rewrite <- (Z.mul_1_l [b]) at 1.
+   apply Z.mul_le_mono_nonneg_r; auto with zarith.
+   change 1 with (Z.succ 0). apply Z.le_succ_l.
+   apply Z.div_str_pos; auto with zarith.
+ - rewrite Z.mul_comm; rewrite spec_mod_gt; auto with zarith.
+   rewrite <- Z_div_mod_eq; auto with zarith.
+   rewrite Z.mul_comm, <- Z.pow_succ_r, Z.sub_1_r, Z.succ_pred; auto.
+   apply Z.le_0_sub. change 1 with (Z.succ 0). apply Z.le_succ_l.
+   destruct p; simpl in H3; auto with zarith.
+ Qed.
+
+ 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
@@ -294,7 +924,7 @@ Module Make (Import W0:CyclicType) <: NType.
      apply Hrec with (Zpos p + n); auto.
        replace (Zpos p + (Zpos p + n)) with
          (Zpos (xI p) + n  - 1); auto.
-       rewrite Zpos_xI; ring.
+       rewrite Pos2Z.inj_xI; ring.
    intros a2 b2 H9 H10.
      apply Hrec with n; auto.
  intros p Hrec n a b cont H2 H3 H4.
@@ -303,23 +933,18 @@ Module Make (Import W0:CyclicType) <: NType.
      apply Hrec with (Zpos p + n - 1); auto.
        replace (Zpos p + (Zpos p + n - 1)) with
          (Zpos (xO p) + n  - 1); auto.
-       rewrite Zpos_xO; ring.
+       rewrite Pos2Z.inj_xO; ring.
    intros a2 b2 H9 H10.
      apply Hrec with (n - 1); auto.
        replace (Zpos p + (n - 1)) with
          (Zpos p + n  - 1); auto with zarith.
    intros a3 b3 H12 H13; apply H4; auto with zarith.
-    apply Zlt_le_trans with (1 := H12).
-    case (Zle_or_lt 1 n); intros HH.
-    apply Zpower_le_monotone; auto with zarith.
-    apply Zle_trans with 0; auto with zarith.
-    assert (HH1: n - 1 < 0); auto with zarith.
-    generalize HH1; case (n - 1); auto with zarith.
-    intros p1 HH2; discriminate.
+    apply Z.lt_le_trans with (1 := H12).
+    apply Z.pow_le_mono_r; 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.
-  rewrite Zplus_comm; auto.
+  rewrite Z.add_comm; auto.
   intros a1 b1 H5 H6; apply H3; auto.
   replace n with (n + 1 - 1); auto; try ring.
  Qed.
@@ -333,192 +958,699 @@ Module Make (Import W0:CyclicType) <: NType.
  Definition gcd_gt a b := gcd_gt_aux (digits a) gcd_cont a b.
 
  Theorem spec_gcd_gt: forall a b,
-   [a] > [b] -> [gcd_gt a b] = Zgcd [a] [b].
+   [a] > [b] -> [gcd_gt a b] = Z.gcd [a] [b].
  Proof.
  intros a b H2.
  case (spec_digits (gcd_gt a b)); intros H3 H4.
  case (spec_digits a); intros H5 H6.
- apply sym_equal; apply Zis_gcd_gcd; auto with zarith.
+ symmetry; apply Zis_gcd_gcd; auto with zarith.
  unfold gcd_gt; apply Zspec_gcd_gt_aux with 0; auto with zarith.
- intros a1 a2; rewrite Zpower_0_r.
+ intros a1 a2; rewrite Z.pow_0_r.
  case (spec_digits a2); intros H7 H8;
    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
   | Gt => gcd_gt a b
   end.
 
- Theorem spec_gcd: forall a b, [gcd a b] = Zgcd [a] [b].
+ Theorem spec_gcd: forall a b, [gcd a b] = Z.gcd [a] [b].
  Proof.
  intros a b.
  case (spec_digits a); intros H1 H2.
  case (spec_digits b); intros H3 H4.
- unfold gcd; generalize (spec_compare_aux a b); case compare.
- intros HH; rewrite HH; apply sym_equal; apply Zis_gcd_gcd; auto.
+ unfold gcd. rewrite spec_compare. case Z.compare_spec.
+ intros HH; rewrite HH; symmetry; apply Zis_gcd_gcd; auto.
    apply Zis_gcd_refl.
- intros; apply trans_equal with (Zgcd [b] [a]).
+ intros; transitivity (Z.gcd [b] [a]).
    apply spec_gcd_gt; auto with zarith.
  apply Zis_gcd_gcd; auto with zarith.
- apply Zgcd_is_pos.
+ apply Z.gcd_nonneg.
  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 = Z.even [x].
+ Proof.
+ intros x. assert (H := spec_even_aux x). symmetry.
+ rewrite (Z.div_mod [x] 2); auto with zarith.
+ destruct (even x); rewrite H, ?Z.add_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 = Z.odd [x].
+ Proof.
+ intros x. unfold odd.
+ assert (H := spec_even_aux x). symmetry.
+ rewrite (Z.div_mod [x] 2); auto with zarith.
+ destruct (even x); rewrite H, ?Z.add_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 (Pos.to_nat (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.
+ rewrite Nat2Z.inj_pred by apply Pos2Nat.is_pos.
+ rewrite positive_nat_Z.
+ rewrite <- Z.sub_1_r.
+ assert (F2:= (get_height_correct (ZnZ.digits (dom_op 0)) (plength p))).
+ apply Z.lt_le_trans with (Zpos (Pos.succ p)).
+   rewrite Pos2Z.inj_succ; auto with zarith.
+  apply Z.le_trans with (1 := plength_pred_correct (Pos.succ p)).
+ rewrite Pos.pred_succ.
+ apply Z.pow_le_mono_r; 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 Z.lt_le_trans with (1 := pheight_correct x).
+ apply Z.pow_le_mono_r; 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
   end.
 
  Theorem spec_of_N: forall x,
-   [of_N x] = Z_of_N x.
+   [of_N x] = Z.of_N x.
  Proof.
  intros x; case x.
-  simpl of_N.
-  unfold zero, w_0, to_Z; rewrite (spec_0 w0_spec); auto.
+  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 Z.add_0_r. f_equal. auto with zarith.
+ Qed.
+
+ 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 Z.mul_le_mono_nonneg; auto with zarith.
+  apply Z.pow_le_mono_r; auto with zarith.
+ rewrite Z.mul_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.sub_simpl_r.
+ 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, !Z.add_simpl_l.
+ 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 Z.le_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 Z.mul_le_mono_nonneg_l; auto.
+   apply Z.pow_le_mono_r; auto with zarith.
+   rewrite Z.pow_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, Z.mul_0_l, Z.add_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 Z.lt_le_trans with (base (ZnZ.digits (dom_op n))); auto with zarith.
+  unfold base. apply Z.pow_le_mono_r; 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, Z.add_0_r.
+ apply Zmod_small. unfold base.
+ split; auto with zarith.
+ rewrite Z.mul_comm.
+ apply Z.lt_le_trans with (2^(ZnZ.to_Z p + K)).
+ rewrite Zpower_exp; auto with zarith.
+ apply Z.mul_lt_mono_pos_l; auto with zarith.
+ apply Z.pow_le_mono_r; 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.
 
- 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
+ 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,
+         Nat2Z.inj_succ, Z.pow_succ_r; 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.
+ assert (HH := spec_pos x). Z.le_elim 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 (Z.le_gt_cases ([head0 (double_size x)]) (2 * [head0 x])); auto; intros HH4.
+ absurd (2 ^ (2 * [head0 x] )* [x] < 2 ^ [head0 (double_size x)] * [x]); auto.
+ apply Z.le_ngt.
+ apply Z.mul_le_mono_nonneg_r; auto with zarith.
+ apply Z.pow_le_mono_r; auto; auto with zarith.
+ assert (HH5: 2 ^[head0 x] <= 2 ^(Zpos (digits x) - 1)).
+ { apply Z.le_succ_l in HH. change (1 <= [x]) in HH.
+   Z.le_elim HH.
+   - apply Z.mul_le_mono_pos_r with (2 ^ 1); auto with zarith.
+     rewrite <- (fun x y z => Z.pow_add_r x (y - z)); auto with zarith.
+     rewrite Z.sub_add.
+     apply Z.le_trans with (2 := Z.lt_le_incl _ _ HH2).
+     apply Z.mul_le_mono_nonneg_l; auto with zarith.
+     rewrite Z.pow_1_r; auto with zarith.
+   - apply Z.pow_le_mono_r; auto with zarith.
+     case (Z.le_gt_cases (Zpos (digits x)) [head0 x]); auto with zarith; intros HH6.
+     absurd (2 ^ Zpos (digits x) <= 2 ^ [head0 x] * [x]); auto with zarith.
+     rewrite <- HH; rewrite Z.mul_1_r.
+     apply Z.pow_le_mono_r; auto with zarith. }
+ rewrite (Z.mul_comm 2).
+ rewrite Z.pow_mul_r; auto with zarith.
+ rewrite Z.pow_2_r.
+ apply Z.lt_le_trans with (2 := HH3).
+ rewrite <- Z.mul_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 Z.mul_pos_pos; auto with zarith.
+ rewrite Pos2Z.inj_xO; ring.
+ apply Z.lt_le_incl; auto.
+ repeat rewrite spec_head00; auto.
+ rewrite spec_double_size_digits.
+ rewrite Pos2Z.inj_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 := Pos2Z.is_pos (digits x)).
+ assert (F0 := spec_pos (head0 (double_size x))).
+ Z.le_elim F0; auto.
+ assert (F1 := spec_pos (head0 x)).
+ Z.le_elim F1.
+  apply Z.lt_le_trans with (2 := (spec_double_size_head0 x)); auto with zarith.
+ assert (F3 := spec_pos x).
+ Z.le_elim F3.
+ generalize F3; rewrite <- (spec_double_size x); intros F4.
+ absurd (2 ^ (Zpos (xO (digits x)) - 1) < 2 ^ (Zpos (digits x))).
+ { apply Z.le_ngt.
+   apply Z.pow_le_mono_r; auto with zarith.
+   rewrite Pos2Z.inj_xO; auto with zarith. }
+ case (spec_head0 x F3).
+ rewrite <- F1; rewrite Z.pow_0_r; rewrite Z.mul_1_l; intros _ HH.
+ apply Z.le_lt_trans with (2 := HH).
+ case (spec_head0 _ F4).
+ rewrite (spec_double_size x); rewrite (spec_double_size_digits x).
+ rewrite <- F0; rewrite Z.pow_0_r; rewrite Z.mul_1_l; auto.
+ generalize F1; rewrite (spec_head00 _ (eq_sym 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 Z.compare_spec; intros H.
   apply spec_unsafe_shiftl; auto with zarith.
   apply spec_unsafe_shiftl; auto with zarith.
  rewrite H2.
  rewrite spec_double_size; auto.
- rewrite Zplus_comm; rewrite Zpower_exp; auto with zarith.
- apply Zle_trans with (2 := spec_double_size_head0 x).
- rewrite Zpower_1_r; apply Zmult_le_compat_l; auto with zarith.
+ rewrite Z.add_comm; rewrite Zpower_exp; auto with zarith.
+ apply Z.le_trans with (2 := spec_double_size_head0 x).
+ rewrite Z.pow_1_r; apply Z.mul_le_mono_nonneg_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.
- rewrite <- Pplus_assoc.
- rewrite Zpos_plus_distr; auto.
+ rewrite <- Pos.add_assoc.
+ rewrite Pos2Z.inj_add; auto.
  intros x3 H5; apply H2.
- rewrite Zpos_xI.
+ rewrite Pos2Z.inj_xI.
  replace (2 * Zpos p + 1 + Zpos q) with (Zpos p + Zpos (p + q + 1));
    auto.
- repeat rewrite Zpos_plus_distr; ring.
+ rewrite !Pos2Z.inj_add; ring.
  intros p Hrec q n x cont H1 H2.
  apply spec_shiftl_aux_body with (q); auto.
  intros x1 H3; apply Hrec with (q); auto.
- apply Zle_trans with (2 := H3); auto with zarith.
- apply Zpower_le_monotone; auto with zarith.
+ apply Z.le_trans with (2 := H3); auto with zarith.
+ apply Z.pow_le_mono_r; auto with zarith.
  intros x2 H4; apply Hrec with (p + q)%positive; auto.
  intros x3 H5; apply H2.
- rewrite (Zpos_xO p).
+ rewrite (Pos2Z.inj_xO p).
  replace (2 * Zpos p + Zpos q) with (Zpos p + Zpos (p + q));
    auto.
- repeat rewrite Zpos_plus_distr; ring.
+ rewrite Pos2Z.inj_add; ring.
  intros q n x cont H1 H2.
  apply spec_shiftl_aux_body with (q); auto.
- rewrite Zplus_comm; auto.
+ rewrite Z.add_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 Z.compare_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 Z.compare_spec; intros H1.
   apply spec_unsafe_shiftl; auto with zarith.
   apply spec_unsafe_shiftl; auto with zarith.
  rewrite <- (spec_double_size (double_size x)).
  apply spec_shiftl_aux with 1%positive.
- apply Zle_trans with (2 := spec_double_size_head0 (double_size x)).
+ apply Z.le_trans with (2 := spec_double_size_head0 (double_size x)).
  replace (2 ^ 1) with (2 * 1).
- apply Zmult_le_compat_l; auto with zarith.
+ apply Z.mul_le_mono_nonneg_l; auto with zarith.
  generalize (spec_double_size_head0_pos x); auto with zarith.
- rewrite Zpower_1_r; ring.
+ rewrite Z.pow_1_r; ring.
  intros x1 H2; apply spec_unsafe_shiftl.
- apply Zle_trans with (2 := H2).
- apply Zle_trans with (2 ^ Zpos (digits n)); auto with zarith.
+ apply Z.le_trans with (2 := H2).
+ apply Z.le_trans with (2 ^ Zpos (digits n)); auto with zarith.
  case (spec_digits n); auto with zarith.
- apply Zpower_le_monotone; auto with zarith.
+ apply Z.pow_le_mono_r; 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.
+  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.
- exact (spec_1 w0_spec).
+  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..278cc8bf 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-2012     *)
 (*   \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..5bde1008 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-2012     *)
 (*   \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,44 +16,64 @@ 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 Nat2Z.inj_succ.
+ rewrite <- Z.pow_succ_r; auto with zarith.
+Qed.
+
 (* To compute the necessary height *)
 
 Fixpoint plength (p: positive) : positive :=
   match p with
     xH => xH
-  | xO p1 => Psucc (plength p1)
-  | xI p1 => Psucc (plength p1)
+  | xO p1 => Pos.succ (plength p1)
+  | xI p1 => Pos.succ (plength p1)
   end.
 
 Theorem plength_correct: forall p, (Zpos p < 2 ^ Zpos (plength p))%Z.
-assert (F: (forall p, 2 ^ (Zpos (Psucc p)) = 2 * 2 ^ Zpos p)%Z).
-intros p; replace (Zpos (Psucc p)) with (1 + Zpos p)%Z.
+assert (F: (forall p, 2 ^ (Zpos (Pos.succ p)) = 2 * 2 ^ Zpos p)%Z).
+intros p; replace (Zpos (Pos.succ p)) with (1 + Zpos p)%Z.
 rewrite Zpower_exp; auto with zarith.
-rewrite Zpos_succ_morphism; unfold Zsucc; auto with zarith.
+rewrite Pos2Z.inj_succ; unfold Z.succ; auto with zarith.
 intros p; elim p; simpl plength; auto.
-intros p1 Hp1; rewrite F; repeat rewrite Zpos_xI.
+intros p1 Hp1; rewrite F; repeat rewrite Pos2Z.inj_xI.
 assert (tmp: (forall p, 2 * p = p + p)%Z);
   try repeat rewrite tmp; auto with zarith.
-intros p1 Hp1; rewrite F; rewrite (Zpos_xO p1).
+intros p1 Hp1; rewrite F; rewrite (Pos2Z.inj_xO p1).
 assert (tmp: (forall p, 2 * p = p + p)%Z);
   try repeat rewrite tmp; auto with zarith.
-rewrite Zpower_1_r; auto with zarith.
+rewrite Z.pow_1_r; auto with zarith.
 Qed.
 
-Theorem plength_pred_correct: forall p, (Zpos p <= 2 ^ Zpos (plength (Ppred p)))%Z.
-intros p; case (Psucc_pred p); intros H1.
+Theorem plength_pred_correct: forall p, (Zpos p <= 2 ^ Zpos (plength (Pos.pred p)))%Z.
+intros p; case (Pos.succ_pred_or p); intros H1.
 subst; simpl plength.
-rewrite Zpower_1_r; auto with zarith.
+rewrite Z.pow_1_r; auto with zarith.
 pattern p at 1; rewrite <- H1.
-rewrite Zpos_succ_morphism; unfold Zsucc; auto with zarith.
-generalize (plength_correct (Ppred p)); auto with zarith.
+rewrite Pos2Z.inj_succ; unfold Z.succ; auto with zarith.
+generalize (plength_correct (Pos.pred p)); auto with zarith.
 Qed.
 
 Definition Pdiv p q :=
-  match Zdiv (Zpos p) (Zpos q) with
+  match Z.div (Zpos p) (Zpos q) with
     Zpos q1 => match (Zpos p) - (Zpos q) * (Zpos q1) with
                  Z0 => q1
-               | _ => (Psucc q1)
+               | _ => (Pos.succ q1)
                end
   |  _ => xH
   end.
@@ -67,20 +85,20 @@ unfold Pdiv.
 assert (H1: Zpos q > 0); auto with zarith.
 assert (H1b: Zpos p >= 0); auto with zarith.
 generalize (Z_div_ge0 (Zpos p) (Zpos q) H1 H1b).
-generalize (Z_div_mod_eq (Zpos p) (Zpos q) H1); case Zdiv.
-  intros HH _; rewrite HH; rewrite Zmult_0_r; rewrite Zmult_1_r; simpl.
+generalize (Z_div_mod_eq (Zpos p) (Zpos q) H1); case Z.div.
+  intros HH _; rewrite HH; rewrite Z.mul_0_r; rewrite Z.mul_1_r; simpl.
 case (Z_mod_lt (Zpos p) (Zpos q) H1); auto with zarith.
 intros q1 H2.
 replace (Zpos p - Zpos q * Zpos q1) with (Zpos p mod Zpos q).
   2: pattern (Zpos p) at 2; rewrite H2; auto with zarith.
 generalize H2 (Z_mod_lt (Zpos p) (Zpos q) H1); clear H2;
-  case Zmod.
+  case Z.modulo.
   intros HH _; rewrite HH; auto with zarith.
-  intros r1 HH (_,HH1); rewrite HH; rewrite Zpos_succ_morphism.
-  unfold Zsucc; rewrite Zmult_plus_distr_r; auto with zarith.
+  intros r1 HH (_,HH1); rewrite HH; rewrite Pos2Z.inj_succ.
+  unfold Z.succ; rewrite Z.mul_add_distr_l; auto with zarith.
   intros r1 _ (HH,_); case HH; auto.
 intros q1 HH; rewrite HH.
-unfold Zge; simpl Zcompare; intros HH1; case HH1; auto.
+unfold Z.ge; simpl Z.compare; intros HH1; case HH1; auto.
 Qed.
 
 Definition is_one p := match p with xH => true | _ => false end.
@@ -91,7 +109,7 @@ Qed.
 
 Definition get_height digits p :=
   let r := Pdiv p digits in
-   if is_one r then xH else Psucc (plength (Ppred r)).
+   if is_one r then xH else Pos.succ (plength (Pos.pred r)).
 
 Theorem get_height_correct:
   forall digits N,
@@ -101,13 +119,13 @@ unfold get_height.
 assert (H1 := Pdiv_le N digits).
 case_eq (is_one (Pdiv N digits)); intros H2.
 rewrite (is_one_one _ H2) in H1.
-rewrite Zmult_1_r in H1.
-change (2^(1-1))%Z with 1; rewrite Zmult_1_r; auto.
+rewrite Z.mul_1_r in H1.
+change (2^(1-1))%Z with 1; rewrite Z.mul_1_r; auto.
 clear H2.
-apply Zle_trans with (1 := H1).
-apply Zmult_le_compat_l; auto with zarith.
-rewrite Zpos_succ_morphism; unfold Zsucc.
-rewrite Zplus_comm; rewrite Zminus_plus.
+apply Z.le_trans with (1 := H1).
+apply Z.mul_le_mono_nonneg_l; auto with zarith.
+rewrite Pos2Z.inj_succ; unfold Z.succ.
+rewrite Z.add_comm; rewrite Z.add_simpl_l.
 apply plength_pred_correct.
 Qed.
 
@@ -134,18 +152,18 @@ Open Scope nat_scope.
 
 Fixpoint plusnS (n m: nat) {struct n} : (n + S m = S (n + m))%nat :=
   match n return  (n + S m = S (n + m))%nat with
-  | 0 => refl_equal (S m)
+  | 0 => eq_refl (S m)
   | S n1 =>
       let v := S (S n1 + m) in
-      eq_ind_r (fun n => S n = v) (refl_equal v) (plusnS n1 m)
+      eq_ind_r (fun n => S n = v) (eq_refl v) (plusnS n1 m)
   end.
 
 Fixpoint plusn0 n : n + 0 = n :=
   match n return (n + 0 = n) with
-  | 0 => refl_equal 0
+  | 0 => eq_refl 0
   | S n1 =>
       let v := S n1 in
-      eq_ind_r (fun n : nat => S n = v) (refl_equal v) (plusn0 n1)
+      eq_ind_r (fun n : nat => S n = v) (eq_refl v) (plusn0 n1)
   end.
 
  Fixpoint diff (m n: nat) {struct m}: nat * nat :=
@@ -159,8 +177,8 @@ Fixpoint diff_l (m n : nat) {struct m} : fst (diff m n) + n = max m n :=
   match m return fst (diff m n) + n = max m n with
   | 0 =>
       match n return (n = max 0 n) with
-      | 0 => refl_equal _
-      | S n0 => refl_equal _
+      | 0 => eq_refl _
+      | S n0 => eq_refl _
       end
   | S m1 =>
       match n return (fst (diff (S m1) n) + n = max (S m1) n)
@@ -170,7 +188,7 @@ Fixpoint diff_l (m n : nat) {struct m} : fst (diff m n) + n = max m n :=
           let v := fst (diff m1 n1) + n1 in
           let v1 := fst (diff m1 n1) + S n1 in
           eq_ind v (fun n => v1 = S n)
-            (eq_ind v1 (fun n => v1 = n) (refl_equal v1) (S v) (plusnS _ _))
+            (eq_ind v1 (fun n => v1 = n) (eq_refl v1) (S v) (plusnS _ _))
             _ (diff_l _ _)
       end
   end.
@@ -179,17 +197,17 @@ Fixpoint diff_r (m n: nat) {struct m}: snd (diff m n) + m = max m n :=
   match m return (snd (diff m n) + m = max m n) with
   | 0 =>
       match n return (snd (diff 0 n) + 0 = max 0 n) with
-      | 0 => refl_equal _
+      | 0 => eq_refl _
       | S _ => plusn0 _
       end
   | S m =>
       match n return (snd (diff (S m) n) + S m = max (S m) n) with
-      | 0 => refl_equal (snd (diff (S m) 0) + S m)
+      | 0 => eq_refl (snd (diff (S m) 0) + S m)
       | S n1 =>
           let v := S (max m n1) in
           eq_ind_r (fun n => n = v)
             (eq_ind_r (fun n => S n = v)
-               (refl_equal v) (diff_r _ _)) (plusnS _ _)
+               (eq_refl v) (diff_r _ _)) (plusnS _ _)
       end
   end.
 
@@ -198,7 +216,7 @@ Fixpoint diff_r (m n: nat) {struct m}: snd (diff m n) + m = max m n :=
  Definition castm (m n: nat) (H: m = n) (x: word w (S m)):
      (word w (S n)) :=
  match H in (_ = y) return (word w (S y)) with
- | refl_equal => x
+ | eq_refl => x
  end.
 
 Variable m: nat.
@@ -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.
@@ -300,7 +314,7 @@ Section CompareRec.
  Lemma base_xO: forall n, base (xO n) = (base n)^2.
  Proof.
  intros n1; unfold base.
- rewrite (Zpos_xO n1); rewrite Zmult_comm; rewrite Zpower_mult; auto with zarith.
+ rewrite (Pos2Z.inj_xO n1); rewrite Z.mul_comm; rewrite Z.pow_mul_r; auto with zarith.
  Qed.
 
  Let double_to_Z_pos: forall n x, 0 <= double_to_Z n x < double_wB n :=
@@ -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.
+  rewrite 2 Hrec.
+  simpl double_to_Z.
+  set (wB := DoubleBase.double_wB wm_base n).
+  case Z.compare_spec; intros Cmp.
+  rewrite <- Cmp. reflexivity.
+  symmetry. apply Z.gt_lt, Z.lt_gt. (* ;-) *)
+  assert (0 < wB).
+   unfold wB, DoubleBase.double_wB, base; auto with zarith.
+  change 0 with (0 + 0); apply Z.add_lt_le_mono; auto with zarith.
+  apply Z.mul_pos_pos; auto with zarith.
   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.
-  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 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 = Z.compare (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 = Z.compare (wm_to_Z x) (w_to_Z y).
  Variable wm_base_lt: forall x,
    0 <= w_to_Z x < base (wm_base).
 
@@ -367,39 +369,36 @@ Section CompareRec.
  Proof.
  intros n x; elim n; simpl; auto; clear n.
  intros n (H0, H); split; auto.
- apply Zlt_le_trans with (1:= H).
+ apply Z.lt_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.
- apply Zle_trans with (1 * u); auto with zarith.
- unfold Zpower_pos; simpl; ring.
+ apply Z.le_trans with (1 * u); auto with zarith.
+ unfold Z.pow_pos; simpl; ring.
  Qed.
 
 
  Lemma spec_compare_mn_1: forall n x y,
-   match compare_mn_1 n x y with
-     Eq => double_to_Z n x = w_to_Z y
-   | 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 = Z.compare (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.
- rewrite <- H1b; rewrite Zmult_0_l; rewrite Zplus_0_l; auto.
- apply Hrec.
- apply Zlt_gt.
+ intros y; rewrite spec_compare; rewrite w_to_Z_0. reflexivity.
+ intros xh xl y; simpl;
+ rewrite spec_compare0_mn, Hrec. case Z.compare_spec.
+ intros H1b.
+ rewrite <- H1b; rewrite Z.mul_0_l; rewrite Z.add_0_l; auto.
+ symmetry. apply Z.lt_gt.
  case (double_wB_lt n y); intros _ H0.
- apply Zlt_le_trans with (1:= H0).
+ apply Z.lt_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.
+ apply Z.le_trans with (double_to_Z n xh * double_wB n); auto with zarith.
+ apply Z.le_trans with (1 * double_wB n); 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.
 
@@ -457,8 +440,8 @@ End AddS.
  Proof.
  intros x; elim x; clear x; [intros x1 Hrec | intros x1 Hrec | idtac];
    intros y; case y; clear y; intros y1 H || intros H; simpl length_pos;
-   try (rewrite (Zpos_xI x1) || rewrite (Zpos_xO x1));
-   try (rewrite (Zpos_xI y1) || rewrite (Zpos_xO y1));
+   try (rewrite (Pos2Z.inj_xI x1) || rewrite (Pos2Z.inj_xO x1));
+   try (rewrite (Pos2Z.inj_xI y1) || rewrite (Pos2Z.inj_xO y1));
    try (inversion H; fail);
    try (assert (Zpos x1 < Zpos y1); [apply Hrec; apply lt_S_n | idtac]; auto with zarith);
    assert (0 < Zpos y1); auto with zarith; red; auto.
@@ -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..3150c561 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-2012     *)
 (*   \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.
@@ -166,8 +31,8 @@ Time Eval vm_compute in (log 500000). (* 11 sec *)
 Fixpoint binposlog (p : positive) : N :=
 match p with
 | xH => 0
-| xO p' => Nsucc (binposlog p')
-| xI p' => Nsucc (binposlog p')
+| xO p' => N.succ (binposlog p')
+| xI p' => N.succ (binposlog p')
 end.
 
 Definition binlog (n : N) : N :=
diff --git a/theories/Numbers/Natural/Peano/NPeano.v b/theories/Numbers/Natural/Peano/NPeano.v
index fbc63c04..a510b3ae 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-2012     *)
 (*   \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..0b8bded0 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-2012     *)
 (*   \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..37d5db10 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-2012     *)
 (*   \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,24 +221,231 @@ 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.
 
 Theorem div_mod : forall a b, ~b==0 -> a == b*(div a b) + (modulo a b).
 Proof.
-intros a b. zify. intros. apply Z_div_mod_eq_full; auto.
+intros a b. zify. intros. apply Z.div_mod; auto.
+Qed.
+
+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.
 
-Theorem mod_upper_bound : forall a b, ~b==0 -> modulo a b < b.
+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) :=
+  N.peano_rect (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 N.peano_rect_succ. 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)).
-rewrite Nrect_step.
+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 N.peano_rect_succ.
 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..d637295e 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-2012     *)
 (*   \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..a2bc5e26 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -26,56 +26,31 @@ Module BigN_BigZ <: NType_ZType BigN.BigN BigZ.
  reflexivity.
  Qed.
  Definition Zabs_N := BigZ.to_N.
- Lemma spec_Zabs_N : forall z, BigN.to_Z (Zabs_N z) = Zabs (BigZ.to_Z z).
+ Lemma spec_Zabs_N : forall z, BigN.to_Z (Zabs_N z) = Z.abs (BigZ.to_Z z).
  Proof.
  unfold Zabs_N; intros.
- rewrite BigZ.spec_to_Z, Zmult_comm; apply Zsgn_Zabs.
+ rewrite BigZ.spec_to_Z, Z.mul_comm; apply Z.sgn_abs.
  Qed.
 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.
+ Ltac order := Private_Tac.order.
+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 +63,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 :
@@ -117,10 +90,10 @@ exact BigQ.div_mul_inv. exact BigQ.mul_inv_diag_l.
 Qed.
 
 Lemma BigQpowerth :
- power_theory 1 BigQ.mul BigQ.eq Z_of_N BigQ.power.
+ power_theory 1 BigQ.mul BigQ.eq Z.of_N BigQ.power.
 Proof.
 constructor. intros. BigQ.qify.
-replace ([r] ^ Z_of_N n)%Q with (pow_N 1 Qmult [r] n)%Q by (now destruct n).
+replace ([r] ^ Z.of_N n)%Q with (pow_N 1 Qmult [r] n)%Q by (now destruct n).
 destruct n. reflexivity.
 induction p; simpl; auto; rewrite ?BigQ.spec_mul, ?IHp; reflexivity.
 Qed.
@@ -172,8 +145,7 @@ End TestField.
 
 (** [BigQ] can also benefit from an "order" tactic *)
 
-Module BigQ_Order := !OrdersTac.MakeOrderTac BigQ.
-Ltac bigQ_order := BigQ_Order.order.
+Ltac bigQ_order := BigQ.order.
 
 Section TestOrder.
 Let test : forall x y : bigQ, x<=y -> y<=x -> x==y.
diff --git a/theories/Numbers/Rational/BigQ/QMake.v b/theories/Numbers/Rational/BigQ/QMake.v
index 49e9d075..a13bb511 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -19,14 +19,14 @@ Require Import NSig ZSig QSig.
     denominators. But first we will need some glue between [NType] and
     [ZType]. *)
 
-Module Type NType_ZType (N:NType)(Z:ZType).
- Parameter Z_of_N : N.t -> Z.t.
- Parameter spec_Z_of_N : forall n, Z.to_Z (Z_of_N n) = N.to_Z n.
- Parameter Zabs_N : Z.t -> N.t.
- Parameter spec_Zabs_N : forall z, N.to_Z (Zabs_N z) = Zabs (Z.to_Z z).
+Module Type NType_ZType (NN:NType)(ZZ:ZType).
+ Parameter Z_of_N : NN.t -> ZZ.t.
+ Parameter spec_Z_of_N : forall n, ZZ.to_Z (Z_of_N n) = NN.to_Z n.
+ Parameter Zabs_N : ZZ.t -> NN.t.
+ Parameter spec_Zabs_N : forall z, NN.to_Z (Zabs_N z) = Z.abs (ZZ.to_Z z).
 End NType_ZType.
 
-Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
+Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType.
 
  (** The notation of a rational number is either an integer x,
      interpreted as itself or a pair (x,y) of an integer x and a natural
@@ -34,58 +34,52 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
      interpreted as 0. *)
 
  Inductive t_ :=
-  | Qz : Z.t -> t_
-  | Qq : Z.t -> N.t -> t_.
+  | Qz : ZZ.t -> t_
+  | Qq : ZZ.t -> NN.t -> t_.
 
  Definition t := t_.
 
+ Bind Scope abstract_scope with t t_.
+
  (** Specification with respect to [QArith] *)
 
  Local Open Scope Q_scope.
 
- Definition of_Z x: t := Qz (Z.of_Z x).
+ Definition of_Z x: t := Qz (ZZ.of_Z x).
 
  Definition of_Q (q:Q) : t :=
   let (x,y) := q in
   match y with
-    | 1%positive => Qz (Z.of_Z x)
-    | _ => Qq (Z.of_Z x) (N.of_N (Npos y))
+    | 1%positive => Qz (ZZ.of_Z x)
+    | _ => Qq (ZZ.of_Z x) (NN.of_N (Npos y))
   end.
 
  Definition to_Q (q: t) :=
  match q with
-   | Qz x => Z.to_Z x # 1
-   | Qq x y => if N.eq_bool y N.zero then 0
-               else Z.to_Z x # Z2P (N.to_Z y)
+   | Qz x => ZZ.to_Z x # 1
+   | Qq x y => if NN.eqb y NN.zero then 0
+               else ZZ.to_Z x # Z.to_pos (NN.to_Z y)
  end.
 
  Notation "[ x ]" := (to_Q x).
 
  Lemma N_to_Z_pos :
-  forall x, (N.to_Z x <> N.to_Z N.zero)%Z -> (0 < N.to_Z x)%Z.
+  forall x, (NN.to_Z x <> NN.to_Z NN.zero)%Z -> (0 < NN.to_Z x)%Z.
  Proof.
- intros x; rewrite N.spec_0; generalize (N.spec_pos x). romega.
+ intros x; rewrite NN.spec_0; generalize (NN.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 [ZZ.eqb ?x ?y] =>
+     rewrite (ZZ.spec_eqb x y);
+     case (Z.eqb_spec (ZZ.to_Z x) (ZZ.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 [NN.eqb ?x ?y] =>
+     rewrite (NN.spec_eqb x y);
+     case (Z.eqb_spec (NN.to_Z x) (NN.to_Z y));
      [ | let H:=fresh "H" in
          try (intro H;generalize (N_to_Z_pos _ H); clear H)];
      destr_eqb
@@ -93,24 +87,25 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
   end.
 
  Hint Rewrite
-  Zplus_0_r Zplus_0_l Zmult_0_r Zmult_0_l Zmult_1_r Zmult_1_l
-  Z.spec_0 N.spec_0 Z.spec_1 N.spec_1 Z.spec_m1 Z.spec_opp
-  Z.spec_compare N.spec_compare
-  Z.spec_add N.spec_add Z.spec_mul N.spec_mul Z.spec_div N.spec_div
-  Z.spec_gcd N.spec_gcd Zgcd_Zabs Zgcd_1
+  Z.add_0_r Z.add_0_l Z.mul_0_r Z.mul_0_l Z.mul_1_r Z.mul_1_l
+  ZZ.spec_0 NN.spec_0 ZZ.spec_1 NN.spec_1 ZZ.spec_m1 ZZ.spec_opp
+  ZZ.spec_compare NN.spec_compare
+  ZZ.spec_add NN.spec_add ZZ.spec_mul NN.spec_mul ZZ.spec_div NN.spec_div
+  ZZ.spec_gcd NN.spec_gcd Z.gcd_abs_l Z.gcd_1_r
   spec_Z_of_N spec_Zabs_N
  : nz.
+
  Ltac nzsimpl := autorewrite with nz in *.
 
  Ltac qsimpl := try red; unfold to_Q; simpl; intros;
   destr_eqb; simpl; nzsimpl; intros;
-  rewrite ?Z2P_correct by auto;
+  rewrite ?Z2Pos.id by auto;
   auto.
 
  Theorem strong_spec_of_Q: forall q: Q, [of_Q q] = q.
  Proof.
- intros(x,y); destruct y; simpl; rewrite ?Z.spec_of_Z; auto;
-  destr_eqb; now rewrite ?N.spec_0, ?N.spec_of_N.
+ intros(x,y); destruct y; simpl; rewrite ?ZZ.spec_of_Z; auto;
+  destr_eqb; now rewrite ?NN.spec_0, ?NN.spec_of_N.
  Qed.
 
  Theorem spec_of_Q: forall q: Q, [of_Q q] == q.
@@ -120,9 +115,9 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
 
  Definition eq x y := [x] == [y].
 
- Definition zero: t := Qz Z.zero.
- Definition one: t := Qz Z.one.
- Definition minus_one: t := Qz Z.minus_one.
+ Definition zero: t := Qz ZZ.zero.
+ Definition one: t := Qz ZZ.one.
+ Definition minus_one: t := Qz ZZ.minus_one.
 
  Lemma spec_0: [zero] == 0.
  Proof.
@@ -141,20 +136,20 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
 
  Definition compare (x y: t) :=
   match x, y with
-  | Qz zx, Qz zy => Z.compare zx zy
+  | Qz zx, Qz zy => ZZ.compare zx zy
   | Qz zx, Qq ny dy =>
-    if N.eq_bool dy N.zero then Z.compare zx Z.zero
-    else Z.compare (Z.mul zx (Z_of_N dy)) ny
+    if NN.eqb dy NN.zero then ZZ.compare zx ZZ.zero
+    else ZZ.compare (ZZ.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
-    else Z.compare nx (Z.mul zy (Z_of_N dx))
+    if NN.eqb dx NN.zero then ZZ.compare ZZ.zero zy
+    else ZZ.compare nx (ZZ.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 NN.eqb dx NN.zero, NN.eqb dy NN.zero with
     | true, true => Eq
-    | true, false => Z.compare Z.zero ny
-    | false, true => Z.compare nx Z.zero
-    | false, false => Z.compare (Z.mul nx (Z_of_N dy))
-                                (Z.mul ny (Z_of_N dx))
+    | true, false => ZZ.compare ZZ.zero ny
+    | false, true => ZZ.compare nx ZZ.zero
+    | false, false => ZZ.compare (ZZ.mul nx (Z_of_N dy))
+                                (ZZ.mul ny (Z_of_N dx))
     end
   end.
 
@@ -193,7 +188,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  (** [check_int] : is a reduced fraction [n/d] in fact a integer ? *)
 
  Definition check_int n d :=
-  match N.compare N.one d with
+  match NN.compare NN.one d with
   | Lt => Qq n d
   | Eq => Qz n
   | Gt => zero  (* n/0 encodes 0 *)
@@ -212,9 +207,9 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  (** Normalisation function *)
 
  Definition norm n d : t :=
-  let gcd := N.gcd (Zabs_N n) d in
-  match N.compare N.one gcd with
-  | Lt => check_int (Z.div n (Z_of_N gcd)) (N.div d gcd)
+  let gcd := NN.gcd (Zabs_N n) d in
+  match NN.compare NN.one gcd with
+  | Lt => check_int (ZZ.div n (Z_of_N gcd)) (NN.div d gcd)
   | Eq => check_int n d
   | Gt => zero (* gcd = 0 => both numbers are 0 *)
   end.
@@ -222,8 +217,8 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  Theorem spec_norm: forall n q, [norm n q] == [Qq n q].
  Proof.
  intros p q; unfold norm.
- assert (Hp := N.spec_pos (Zabs_N p)).
- assert (Hq := N.spec_pos q).
+ assert (Hp := NN.spec_pos (Zabs_N p)).
+ assert (Hq := NN.spec_pos q).
  nzsimpl.
  destr_zcompare.
  (* Eq *)
@@ -231,15 +226,15 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  (* Lt *)
  rewrite strong_spec_check_int.
  qsimpl.
- generalize (Zgcd_div_pos (Z.to_Z p) (N.to_Z q)). romega.
- replace (N.to_Z q) with 0%Z in * by assumption.
+ generalize (Zgcd_div_pos (ZZ.to_Z p) (NN.to_Z q)). romega.
+ replace (NN.to_Z q) with 0%Z in * by assumption.
  rewrite Zdiv_0_l in *; auto with zarith.
  apply Zgcd_div_swap0; romega.
  (* Gt *)
  qsimpl.
- assert (H' : Zgcd (Z.to_Z p) (N.to_Z q) = 0%Z).
-  generalize (Zgcd_is_pos (Z.to_Z p) (N.to_Z q)); romega.
- symmetry; apply (Zgcd_inv_0_l _ _ H'); auto.
+ assert (H' : Z.gcd (ZZ.to_Z p) (NN.to_Z q) = 0%Z).
+  generalize (Z.gcd_nonneg (ZZ.to_Z p) (NN.to_Z q)); romega.
+ symmetry; apply (Z.gcd_eq_0_l _ _ H'); auto.
  Qed.
 
  Theorem strong_spec_norm : forall p q, [norm p q] = Qred [Qq p q].
@@ -249,8 +244,8 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
   (apply Qred_complete; apply spec_norm).
  symmetry; apply Qred_identity.
  unfold norm.
- assert (Hp := N.spec_pos (Zabs_N p)).
- assert (Hq := N.spec_pos q).
+ assert (Hp := NN.spec_pos (Zabs_N p)).
+ assert (Hq := NN.spec_pos q).
  nzsimpl.
  destr_zcompare; rewrite ?strong_spec_check_int.
  (* Eq *)
@@ -258,10 +253,10 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  (* Lt *)
  qsimpl.
  rewrite Zgcd_1_rel_prime.
- destruct (Z_lt_le_dec 0 (N.to_Z q)).
+ destruct (Z_lt_le_dec 0 (NN.to_Z q)).
  apply Zis_gcd_rel_prime; auto with zarith.
  apply Zgcd_is_gcd.
- replace (N.to_Z q) with 0%Z in * by romega.
+ replace (NN.to_Z q) with 0%Z in * by romega.
  rewrite Zdiv_0_l in *; romega.
  (* Gt *)
  simpl; auto with zarith.
@@ -297,20 +292,20 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
   match x with
   | Qz zx =>
     match y with
-    | Qz zy => Qz (Z.add zx zy)
+    | Qz zy => Qz (ZZ.add zx zy)
     | Qq ny dy =>
-      if N.eq_bool dy N.zero then x
-      else Qq (Z.add (Z.mul zx (Z_of_N dy)) ny) dy
+      if NN.eqb dy NN.zero then x
+      else Qq (ZZ.add (ZZ.mul zx (Z_of_N dy)) ny) dy
     end
   | Qq nx dx =>
-    if N.eq_bool dx N.zero then y
+    if NN.eqb dx NN.zero then y
     else match y with
-    | Qz zy => Qq (Z.add nx (Z.mul zy (Z_of_N dx))) dx
+    | Qz zy => Qq (ZZ.add nx (ZZ.mul zy (Z_of_N dx))) dx
     | Qq ny dy =>
-      if N.eq_bool dy N.zero then x
+      if NN.eqb dy NN.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
+       let n := ZZ.add (ZZ.mul nx (Z_of_N dy)) (ZZ.mul ny (Z_of_N dx)) in
+       let d := NN.mul dx dy in
        Qq n d
     end
   end.
@@ -319,30 +314,30 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  Proof.
  intros [x | nx dx] [y | ny dy]; unfold Qplus; qsimpl;
   auto with zarith.
- rewrite Pmult_1_r, Z2P_correct; auto.
- rewrite Pmult_1_r, Z2P_correct; auto.
- destruct (Zmult_integral (N.to_Z dx) (N.to_Z dy)); intuition.
- rewrite Zpos_mult_morphism, 2 Z2P_correct; auto.
+ rewrite Pos.mul_1_r, Z2Pos.id; auto.
+ rewrite Pos.mul_1_r, Z2Pos.id; auto.
+ rewrite Z.mul_eq_0 in *; intuition.
+ rewrite Pos2Z.inj_mul, 2 Z2Pos.id; auto.
  Qed.
 
  Definition add_norm (x y: t): t :=
   match x with
   | Qz zx =>
     match y with
-    | Qz zy => Qz (Z.add zx zy)
+    | Qz zy => Qz (ZZ.add zx zy)
     | Qq ny dy =>
-      if N.eq_bool dy N.zero then x
-      else norm (Z.add (Z.mul zx (Z_of_N dy)) ny) dy
+      if NN.eqb dy NN.zero then x
+      else norm (ZZ.add (ZZ.mul zx (Z_of_N dy)) ny) dy
     end
   | Qq nx dx =>
-    if N.eq_bool dx N.zero then y
+    if NN.eqb dx NN.zero then y
     else match y with
-    | Qz zy => norm (Z.add nx (Z.mul zy (Z_of_N dx))) dx
+    | Qz zy => norm (ZZ.add nx (ZZ.mul zy (Z_of_N dx))) dx
     | Qq ny dy =>
-      if N.eq_bool dy N.zero then x
+      if NN.eqb dy NN.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
+       let n := ZZ.add (ZZ.mul nx (Z_of_N dy)) (ZZ.mul ny (Z_of_N dx)) in
+       let d := NN.mul dx dy in
        norm n d
     end
   end.
@@ -368,18 +363,18 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
 
  Definition opp (x: t): t :=
   match x with
-  | Qz zx => Qz (Z.opp zx)
-  | Qq nx dx => Qq (Z.opp nx) dx
+  | Qz zx => Qz (ZZ.opp zx)
+  | Qq nx dx => Qq (ZZ.opp nx) dx
   end.
 
  Theorem strong_spec_opp: forall q, [opp q] = -[q].
  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
- end; auto; rewrite N.spec_0.
- rewrite Z.spec_opp; auto.
+ rewrite ZZ.spec_opp; auto.
+ match goal with  |- context[NN.eqb ?X ?Y] =>
+  generalize (NN.spec_eqb X Y); case NN.eqb
+ end; auto; rewrite NN.spec_0.
+ rewrite ZZ.spec_opp; auto.
  Qed.
 
  Theorem spec_opp : forall q, [opp q] == -[q].
@@ -421,69 +416,72 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
 
  Definition mul (x y: t): t :=
   match x, y with
-  | Qz zx, Qz zy => Qz (Z.mul zx zy)
-  | Qz zx, Qq ny dy => Qq (Z.mul zx ny) dy
-  | Qq nx dx, Qz zy => Qq (Z.mul nx zy) dx
-  | Qq nx dx, Qq ny dy => Qq (Z.mul nx ny) (N.mul dx dy)
+  | Qz zx, Qz zy => Qz (ZZ.mul zx zy)
+  | Qz zx, Qq ny dy => Qq (ZZ.mul zx ny) dy
+  | Qq nx dx, Qz zy => Qq (ZZ.mul nx zy) dx
+  | Qq nx dx, Qq ny dy => Qq (ZZ.mul nx ny) (NN.mul dx dy)
   end.
 
+ Ltac nsubst :=
+  match goal with E : NN.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.
- rewrite Zpos_mult_morphism, 2 Z2P_correct; auto.
+ rewrite Pos.mul_1_r, Z2Pos.id; auto.
+ rewrite Z.mul_eq_0 in *; intuition.
+ nsubst; auto with zarith.
+ nsubst; auto with zarith.
+ nsubst; nzsimpl; auto with zarith.
+ rewrite Pos2Z.inj_mul, 2 Z2Pos.id; auto.
  Qed.
 
  Definition norm_denum n d :=
-  if N.eq_bool d N.one then Qz n else Qq n d.
+  if NN.eqb d NN.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 :=
-   let gcd := N.gcd (Zabs_N n) d in
-   match N.compare gcd N.one with
-     | Gt => (Z.div n (Z_of_N gcd), N.div d gcd)
+   let gcd := NN.gcd (Zabs_N n) d in
+   match NN.compare gcd NN.one with
+     | Gt => (ZZ.div n (Z_of_N gcd), NN.div d gcd)
      | _ => (n, d)
    end.
 
  Lemma spec_irred : forall n d, exists g,
   let (n',d') := irred n d in
-  (Z.to_Z n' * g = Z.to_Z n)%Z /\ (N.to_Z d' * g = N.to_Z d)%Z.
+  (ZZ.to_Z n' * g = ZZ.to_Z n)%Z /\ (NN.to_Z d' * g = NN.to_Z d)%Z.
  Proof.
  intros.
  unfold irred; nzsimpl; simpl.
  destr_zcompare.
  exists 1%Z; nzsimpl; auto.
  exists 0%Z; nzsimpl.
- assert (Zgcd (Z.to_Z n) (N.to_Z d) = 0%Z).
-  generalize (Zgcd_is_pos (Z.to_Z n) (N.to_Z d)); romega.
+ assert (Z.gcd (ZZ.to_Z n) (NN.to_Z d) = 0%Z).
+  generalize (Z.gcd_nonneg (ZZ.to_Z n) (NN.to_Z d)); romega.
  clear H.
  split.
- symmetry; apply (Zgcd_inv_0_l _ _ H0).
- symmetry; apply (Zgcd_inv_0_r _ _ H0).
- exists (Zgcd (Z.to_Z n) (N.to_Z d)).
+ symmetry; apply (Z.gcd_eq_0_l _ _ H0).
+ symmetry; apply (Z.gcd_eq_0_r _ _ H0).
+ exists (Z.gcd (ZZ.to_Z n) (NN.to_Z d)).
  simpl.
  split.
  nzsimpl.
- destruct (Zgcd_is_gcd (Z.to_Z n) (N.to_Z d)).
- rewrite Zmult_comm; symmetry; apply Zdivide_Zdiv_eq; auto with zarith.
+ destruct (Zgcd_is_gcd (ZZ.to_Z n) (NN.to_Z d)).
+ rewrite Z.mul_comm; symmetry; apply Zdivide_Zdiv_eq; auto with zarith.
  nzsimpl.
- destruct (Zgcd_is_gcd (Z.to_Z n) (N.to_Z d)).
- rewrite Zmult_comm; symmetry; apply Zdivide_Zdiv_eq; auto with zarith.
+ destruct (Zgcd_is_gcd (ZZ.to_Z n) (NN.to_Z d)).
+ rewrite Z.mul_comm; symmetry; apply Zdivide_Zdiv_eq; auto with zarith.
  Qed.
 
  Lemma spec_irred_zero : forall n d,
-   (N.to_Z d = 0)%Z <-> (N.to_Z (snd (irred n d)) = 0)%Z.
+   (NN.to_Z d = 0)%Z <-> (NN.to_Z (snd (irred n d)) = 0)%Z.
  Proof.
  intros.
  unfold irred.
@@ -496,8 +494,8 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  nzsimpl; destr_zcompare; simpl; auto.
  nzsimpl.
  intros.
- generalize (N.spec_pos d); intros.
- destruct (N.to_Z d); auto.
+ generalize (NN.spec_pos d); intros.
+ destruct (NN.to_Z d); auto.
  assert (0 < 0)%Z.
   rewrite <- H0 at 2.
   apply Zgcd_div_pos; auto with zarith.
@@ -507,60 +505,60 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  Qed.
 
  Lemma strong_spec_irred : forall n d,
-  (N.to_Z d <> 0%Z) ->
-  let (n',d') := irred n d in Zgcd (Z.to_Z n') (N.to_Z d') = 1%Z.
+  (NN.to_Z d <> 0%Z) ->
+  let (n',d') := irred n d in Z.gcd (ZZ.to_Z n') (NN.to_Z d') = 1%Z.
  Proof.
  unfold irred; intros.
  nzsimpl.
  destr_zcompare; simpl; auto.
  elim H.
- apply (Zgcd_inv_0_r (Z.to_Z n)).
- generalize (Zgcd_is_pos (Z.to_Z n) (N.to_Z d)); romega.
+ apply (Z.gcd_eq_0_r (ZZ.to_Z n)).
+ generalize (Z.gcd_nonneg (ZZ.to_Z n) (NN.to_Z d)); romega.
 
  nzsimpl.
  rewrite Zgcd_1_rel_prime.
  apply Zis_gcd_rel_prime.
- generalize (N.spec_pos d); romega.
- generalize (Zgcd_is_pos (Z.to_Z n) (N.to_Z d)); romega.
+ generalize (NN.spec_pos d); romega.
+ generalize (Z.gcd_nonneg (ZZ.to_Z n) (NN.to_Z d)); romega.
  apply Zgcd_is_gcd; auto.
  Qed.
 
  Definition mul_norm_Qz_Qq z n d :=
-   if Z.eq_bool z Z.zero then zero
+   if ZZ.eqb z ZZ.zero then zero
    else
-    let gcd := N.gcd (Zabs_N z) d in
-    match N.compare gcd N.one with
+    let gcd := NN.gcd (Zabs_N z) d in
+    match NN.compare gcd NN.one with
       | Gt =>
-        let z := Z.div z (Z_of_N gcd) in
-        let d := N.div d gcd in
-        norm_denum (Z.mul z n) d
-      | _  => Qq (Z.mul z n) d
+        let z := ZZ.div z (Z_of_N gcd) in
+        let d := NN.div d gcd in
+        norm_denum (ZZ.mul z n) d
+      | _  => Qq (ZZ.mul z n) d
     end.
 
  Definition mul_norm (x y: t): t :=
  match x, y with
- | Qz zx, Qz zy => Qz (Z.mul zx zy)
+ | Qz zx, Qz zy => Qz (ZZ.mul zx zy)
  | Qz zx, Qq ny dy => mul_norm_Qz_Qq zx ny dy
  | Qq nx dx, Qz zy => mul_norm_Qz_Qq zy nx dx
  | Qq nx dx, Qq ny dy =>
     let (nx, dy) := irred nx dy in
     let (ny, dx) := irred ny dx in
-    norm_denum (Z.mul ny nx) (N.mul dx dy)
+    norm_denum (ZZ.mul ny nx) (NN.mul dx dy)
  end.
 
  Lemma spec_mul_norm_Qz_Qq : forall z n d,
-   [mul_norm_Qz_Qq z n d] == [Qq (Z.mul z n) d].
+   [mul_norm_Qz_Qq z n d] == [Qq (ZZ.mul z n) d].
  Proof.
  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 <- Zmult_assoc, (Zmult_comm (Z.to_Z n)), Zmult_assoc.
+ rewrite Zdiv_gcd_zero in GT; auto with zarith.
+ nsubst. rewrite Zdiv_0_l in *; discriminate.
+ rewrite <- Z.mul_assoc, (Z.mul_comm (ZZ.to_Z n)), Z.mul_assoc.
  rewrite Zgcd_div_swap0; try romega.
  ring.
  Qed.
@@ -584,34 +582,34 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  destr_eqb; simpl; nzsimpl; auto.
  nzsimpl; rewrite Hd, Zdiv_0_l; auto with zarith.
 
- rewrite Z2P_correct in H; auto.
+ rewrite Z2Pos.id in H; auto.
  unfold mul_norm_Qz_Qq; nzsimpl; rewrite Zcompare_gt.
  destr_eqb; intros Hz; simpl; nzsimpl; simpl; auto.
  destruct Z_le_gt_dec as [H'|H'].
  simpl; nzsimpl.
  destr_eqb; simpl; nzsimpl; auto.
  intros.
- rewrite Z2P_correct; auto.
+ rewrite Z2Pos.id; auto.
  apply Zgcd_mult_rel_prime; auto.
-  generalize (Zgcd_inv_0_l (Z.to_Z z) (N.to_Z d))
-    (Zgcd_is_pos (Z.to_Z z) (N.to_Z d)); romega.
+  generalize (Z.gcd_eq_0_l (ZZ.to_Z z) (NN.to_Z d))
+    (Z.gcd_nonneg (ZZ.to_Z z) (NN.to_Z d)); romega.
  destr_eqb; simpl; nzsimpl; auto.
  unfold norm_denum.
  destr_eqb; nzsimpl; simpl; destr_eqb; simpl; auto.
  intros; nzsimpl.
- rewrite Z2P_correct; auto.
+ rewrite Z2Pos.id; auto.
  apply Zgcd_mult_rel_prime.
  rewrite Zgcd_1_rel_prime.
  apply Zis_gcd_rel_prime.
- generalize (N.spec_pos d); romega.
- generalize (Zgcd_is_pos (Z.to_Z z) (N.to_Z d)); romega.
+ generalize (NN.spec_pos d); romega.
+ generalize (Z.gcd_nonneg (ZZ.to_Z z) (NN.to_Z d)); romega.
  apply Zgcd_is_gcd.
- destruct (Zgcd_is_gcd (Z.to_Z z) (N.to_Z d)) as [ (z0,Hz0) (d0,Hd0) Hzd].
- replace (N.to_Z d / Zgcd (Z.to_Z z) (N.to_Z d))%Z with d0.
+ destruct (Zgcd_is_gcd (ZZ.to_Z z) (NN.to_Z d)) as [ (z0,Hz0) (d0,Hd0) Hzd].
+ replace (NN.to_Z d / Z.gcd (ZZ.to_Z z) (NN.to_Z d))%Z with d0.
  rewrite Zgcd_1_rel_prime in *.
  apply bezout_rel_prime.
  destruct (rel_prime_bezout _ _ H) as [u v Huv].
- apply Bezout_intro with u (v*(Zgcd (Z.to_Z z) (N.to_Z d)))%Z.
+ apply Bezout_intro with u (v*(Z.gcd (ZZ.to_Z z) (NN.to_Z d)))%Z.
  rewrite <- Huv; rewrite Hd0 at 2; ring.
  rewrite Hd0 at 1.
  symmetry; apply Z_div_mult_full; auto with zarith.
@@ -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 |- _ =>
+  rewrite Z.mul_eq_0 in E; destruct 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 |- _ =>
+  rewrite Z.mul_eq_0 in E; destruct 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.
 
@@ -671,31 +671,31 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
 
  unfold norm_denum; qsimpl.
 
- assert (NEQ : N.to_Z dy <> 0%Z) by
+ assert (NEQ : NN.to_Z dy <> 0%Z) by
   (rewrite Hz; intros EQ; rewrite EQ in *; romega).
  specialize (Hgc NEQ).
 
- assert (NEQ' : N.to_Z dx <> 0%Z) by
+ assert (NEQ' : NN.to_Z dx <> 0%Z) by
   (rewrite Hz'; intro EQ; rewrite EQ in *; romega).
  specialize (Hgc' NEQ').
 
  revert H H0.
  rewrite 2 strong_spec_red, 2 Qred_iff; simpl.
  destr_eqb; simpl; nzsimpl; try romega; intros.
- rewrite Z2P_correct in *; auto.
+ rewrite Z2Pos.id in *; auto.
 
- apply Zgcd_mult_rel_prime; rewrite Zgcd_comm;
-  apply Zgcd_mult_rel_prime; rewrite Zgcd_comm; auto.
+ apply Zgcd_mult_rel_prime; rewrite Z.gcd_comm;
+  apply Zgcd_mult_rel_prime; rewrite Z.gcd_comm; auto.
 
  rewrite Zgcd_1_rel_prime in *.
  apply bezout_rel_prime.
- destruct (rel_prime_bezout _ _ H4) as [u v Huv].
+ destruct (rel_prime_bezout (ZZ.to_Z ny) (NN.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 (ZZ.to_Z nx) (NN.to_Z dx)) as [u v Huv]; trivial.
  apply Bezout_intro with (u*g)%Z (v*g')%Z.
  rewrite <- Huv, <- Hg2', <- Hg1. ring.
  Qed.
@@ -703,16 +703,16 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  Definition inv (x: t): t :=
  match x with
  | Qz z =>
-   match Z.compare Z.zero z with
+   match ZZ.compare ZZ.zero z with
      | Eq => zero
-     | Lt => Qq Z.one (Zabs_N z)
-     | Gt => Qq Z.minus_one (Zabs_N z)
+     | Lt => Qq ZZ.one (Zabs_N z)
+     | Gt => Qq ZZ.minus_one (Zabs_N z)
    end
  | Qq n d =>
-   match Z.compare Z.zero n with
+   match ZZ.compare ZZ.zero n with
      | Eq => zero
      | Lt => Qq (Z_of_N d) (Zabs_N n)
-     | Gt => Qq (Z.opp (Z_of_N d)) (Zabs_N n)
+     | Gt => Qq (ZZ.opp (Z_of_N d)) (Zabs_N n)
    end
  end.
 
@@ -721,29 +721,29 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  destruct x as [ z | n d ].
  (* Qz z *)
  simpl.
- rewrite Z.spec_compare; destr_zcompare.
+ rewrite ZZ.spec_compare; destr_zcompare.
  (* 0 = z *)
  rewrite <- H.
  simpl; nzsimpl; compute; auto.
  (* 0 < z *)
  simpl.
- destr_eqb; nzsimpl; [ intros; rewrite Zabs_eq in *; romega | intros _ ].
- set (z':=Z.to_Z z) in *; clearbody z'.
+ destr_eqb; nzsimpl; [ intros; rewrite Z.abs_eq in *; romega | intros _ ].
+ set (z':=ZZ.to_Z z) in *; clearbody z'.
  red; simpl.
- rewrite Zabs_eq by romega.
- rewrite Z2P_correct by auto.
+ rewrite Z.abs_eq by romega.
+ rewrite Z2Pos.id by auto.
  unfold Qinv; simpl; destruct z'; simpl; auto; discriminate.
  (* 0 > z *)
  simpl.
- destr_eqb; nzsimpl; [ intros; rewrite Zabs_non_eq in *; romega | intros _ ].
- set (z':=Z.to_Z z) in *; clearbody z'.
+ destr_eqb; nzsimpl; [ intros; rewrite Z.abs_neq in *; romega | intros _ ].
+ set (z':=ZZ.to_Z z) in *; clearbody z'.
  red; simpl.
- rewrite Zabs_non_eq by romega.
- rewrite Z2P_correct by romega.
+ rewrite Z.abs_neq by romega.
+ rewrite Z2Pos.id by romega.
  unfold Qinv; simpl; destruct z'; simpl; auto; discriminate.
  (* Qq n d *)
  simpl.
- rewrite Z.spec_compare; destr_zcompare.
+ rewrite ZZ.spec_compare; destr_zcompare.
  (* 0 = n *)
  rewrite <- H.
  simpl; nzsimpl.
@@ -751,56 +751,51 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  (* 0 < n *)
  simpl.
  destr_eqb; nzsimpl; intros.
- intros; rewrite Zabs_eq in *; romega.
- intros; rewrite Zabs_eq in *; romega.
- clear H1.
- rewrite H0.
- compute; auto.
- clear H1.
- set (n':=Z.to_Z n) in *; clearbody n'.
- rewrite Zabs_eq by romega.
+ intros; rewrite Z.abs_eq in *; romega.
+ intros; rewrite Z.abs_eq in *; romega.
+ nsubst; compute; auto.
+ set (n':=ZZ.to_Z n) in *; clearbody n'.
+ rewrite Z.abs_eq by romega.
  red; simpl.
- rewrite Z2P_correct by auto.
+ rewrite Z2Pos.id by auto.
  unfold Qinv; simpl; destruct n'; simpl; auto; try discriminate.
- rewrite Zpos_mult_morphism, Z2P_correct; auto.
+ rewrite Pos2Z.inj_mul, Z2Pos.id; auto.
  (* 0 > n *)
  simpl.
  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.
- set (n':=Z.to_Z n) in *; clearbody n'.
+ intros; rewrite Z.abs_neq in *; romega.
+ intros; rewrite Z.abs_neq in *; romega.
+ nsubst; compute; auto.
+ set (n':=ZZ.to_Z n) in *; clearbody n'.
  red; simpl; nzsimpl.
- rewrite Zabs_non_eq by romega.
- rewrite Z2P_correct by romega.
+ rewrite Z.abs_neq by romega.
+ rewrite Z2Pos.id by romega.
  unfold Qinv; simpl; destruct n'; simpl; auto; try discriminate.
- assert (T : forall x, Zneg x = Zopp (Zpos x)) by auto.
- rewrite T, Zpos_mult_morphism, Z2P_correct; auto; ring.
+ assert (T : forall x, Zneg x = Z.opp (Zpos x)) by auto.
+ rewrite T, Pos2Z.inj_mul, Z2Pos.id; auto; ring.
  Qed.
 
  Definition inv_norm (x: t): t :=
    match x with
      | Qz z =>
-       match Z.compare Z.zero z with
+       match ZZ.compare ZZ.zero z with
          | Eq => zero
-         | Lt => Qq Z.one (Zabs_N z)
-         | Gt => Qq Z.minus_one (Zabs_N z)
+         | Lt => Qq ZZ.one (Zabs_N z)
+         | Gt => Qq ZZ.minus_one (Zabs_N z)
        end
      | Qq n d =>
-       if N.eq_bool d N.zero then zero else
-       match Z.compare Z.zero n with
+       if NN.eqb d NN.zero then zero else
+       match ZZ.compare ZZ.zero n with
          | Eq => zero
          | Lt =>
-           match Z.compare n Z.one with
+           match ZZ.compare n ZZ.one with
              | Gt => Qq (Z_of_N d) (Zabs_N n)
              | _ => Qz (Z_of_N d)
            end
          | Gt =>
-           match Z.compare n Z.minus_one with
-             | Lt => Qq (Z.opp (Z_of_N d)) (Zabs_N n)
-             | _ => Qz (Z.opp (Z_of_N d))
+           match ZZ.compare n ZZ.minus_one with
+             | Lt => Qq (ZZ.opp (Z_of_N d)) (Zabs_N n)
+             | _ => Qz (ZZ.opp (Z_of_N d))
            end
        end
    end.
@@ -812,7 +807,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  destruct x as [ z | n d ].
  (* Qz z *)
  simpl.
- rewrite Z.spec_compare; destr_zcompare; auto with qarith.
+ rewrite ZZ.spec_compare; destr_zcompare; auto with qarith.
  (* Qq n d *)
  simpl; nzsimpl; destr_eqb.
  destr_zcompare; simpl; auto with qarith.
@@ -823,12 +818,12 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  (* 0 < n *)
  destr_zcompare; auto with qarith.
  destr_zcompare; nzsimpl; simpl; auto with qarith; intros.
- destr_eqb; nzsimpl; [ intros; rewrite Zabs_eq in *; romega | intros _ ].
+ destr_eqb; nzsimpl; [ intros; rewrite Z.abs_eq in *; romega | intros _ ].
  rewrite H0; auto with qarith.
  romega.
  (* 0 > n *)
  destr_zcompare; nzsimpl; simpl; auto with qarith.
- destr_eqb; nzsimpl; [ intros; rewrite Zabs_non_eq in *; romega | intros _ ].
+ destr_eqb; nzsimpl; [ intros; rewrite Z.abs_neq in *; romega | intros _ ].
  rewrite H0; auto with qarith.
  romega.
  Qed.
@@ -852,36 +847,36 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  (* 0 < n *)
  destr_zcompare; simpl; nzsimpl; auto.
  destr_eqb; nzsimpl; simpl; auto.
- rewrite Zabs_eq; romega.
+ rewrite Z.abs_eq; romega.
  intros _.
  rewrite strong_spec_norm; simpl; nzsimpl.
  destr_eqb; nzsimpl.
- rewrite Zabs_eq; romega.
+ rewrite Z.abs_eq; romega.
  intros _.
  rewrite Qred_iff.
  simpl.
- rewrite Zabs_eq; auto with zarith.
- rewrite Z2P_correct in *; auto.
- rewrite Zgcd_comm; auto.
+ rewrite Z.abs_eq; auto with zarith.
+ rewrite Z2Pos.id in *; auto.
+ rewrite Z.gcd_comm; auto.
  (* 0 > n *)
  destr_eqb; nzsimpl; simpl; auto; intros.
  destr_zcompare; simpl; nzsimpl; auto.
  destr_eqb; nzsimpl.
- rewrite Zabs_non_eq; romega.
+ rewrite Z.abs_neq; romega.
  intros _.
  rewrite strong_spec_norm; simpl; nzsimpl.
  destr_eqb; nzsimpl.
- rewrite Zabs_non_eq; romega.
+ rewrite Z.abs_neq; romega.
  intros _.
  rewrite Qred_iff.
  simpl.
- rewrite Z2P_correct in *; auto.
+ rewrite Z2Pos.id in *; auto.
  intros.
- rewrite Zgcd_comm, Zgcd_Zabs, Zgcd_comm.
+ rewrite Z.gcd_comm, Z.gcd_abs_l, Z.gcd_comm.
  apply Zis_gcd_gcd; auto with zarith.
  apply Zis_gcd_minus.
- rewrite Zopp_involutive, <- H1; apply Zgcd_is_gcd.
- rewrite Zabs_non_eq; romega.
+ rewrite Z.opp_involutive, <- H1; apply Zgcd_is_gcd.
+ rewrite Z.abs_neq; romega.
  Qed.
 
  Definition div x y := mul x (inv y).
@@ -914,31 +909,30 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
 
  Definition square (x: t): t :=
   match x with
-  | Qz zx => Qz (Z.square zx)
-  | Qq nx dx => Qq (Z.square nx) (N.square dx)
+  | Qz zx => Qz (ZZ.square zx)
+  | Qq nx dx => Qq (ZZ.square nx) (NN.square dx)
   end.
 
  Theorem spec_square : forall x, [square x] == [x] ^ 2.
  Proof.
  destruct x as [ z | n d ].
- simpl; rewrite Z.spec_square; red; auto.
+ simpl; rewrite ZZ.spec_square; red; auto.
  simpl.
  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.
- rewrite Z.spec_square, N.spec_square.
+ rewrite NN.spec_square in *; nzsimpl.
+ rewrite Z.mul_eq_0 in *; romega.
+ rewrite NN.spec_square in *; nzsimpl; nsubst; romega.
+ rewrite ZZ.spec_square, NN.spec_square.
  red; simpl.
- rewrite Zpos_mult_morphism; rewrite !Z2P_correct; auto.
- apply Zmult_lt_0_compat; auto.
+ rewrite Pos2Z.inj_mul; rewrite !Z2Pos.id; auto.
+ apply Z.mul_pos_pos; auto.
  Qed.
 
  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 (ZZ.pow_pos zx p)
+  | Qq nx dx => Qq (ZZ.pow_pos nx p) (NN.pow_pos dx p)
   end.
 
  Theorem spec_power_pos : forall x p, [power_pos x p] == [x] ^ Zpos p.
@@ -946,25 +940,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 Qpower_decomp.
+ rewrite ZZ.spec_pow_pos, Qpower_decomp.
  red; simpl; f_equal.
- rewrite Zpower_pos_1_l; auto.
+ now rewrite Pos2Z.inj_pow, Z.pow_1_l.
  (* Qq *)
  simpl.
- rewrite Z.spec_power_pos.
+ rewrite ZZ.spec_pow_pos.
  destr_eqb; nzsimpl; intros.
- apply Qeq_sym; apply Qpower_positive_0.
- rewrite N.spec_power_pos in *.
- assert (0 < N.to_Z d ^ ' p)%Z by
-  (apply Zpower_gt_0; auto with zarith).
- romega.
- rewrite N.spec_power_pos, H in *.
- rewrite Zpower_0_l in H0; [romega|discriminate].
- rewrite Qpower_decomp.
- red; simpl; do 3 f_equal.
- rewrite Z2P_correct by (generalize (N.spec_pos d); romega).
- rewrite N.spec_power_pos. auto.
+ - apply Qeq_sym; apply Qpower_positive_0.
+ - rewrite NN.spec_pow_pos in *.
+   assert (0 < NN.to_Z d ^ ' p)%Z by
+    (apply Z.pow_pos_nonneg; auto with zarith).
+   romega.
+ - exfalso.
+   rewrite NN.spec_pow_pos in *. nsubst.
+   rewrite Z.pow_0_l' in *; [romega|discriminate].
+ - rewrite Qpower_decomp.
+   red; simpl; do 3 f_equal.
+   apply Pos2Z.inj. rewrite Pos2Z.inj_pow.
+   rewrite 2 Z2Pos.id by (generalize (NN.spec_pos d); romega).
+   now rewrite NN.spec_pow_pos.
  Qed.
 
  Instance strong_spec_power_pos x p `(Reduced x) : Reduced (power_pos x p).
@@ -979,10 +974,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].
- rewrite Z2P_correct in *; auto.
- rewrite N.spec_power_pos, Z.spec_power_pos; auto.
+ exfalso.
+ rewrite NN.spec_pow_pos in *. nsubst.
+ rewrite Z.pow_0_l' in *; [romega|discriminate].
+ rewrite Z2Pos.id in *; auto.
+ rewrite NN.spec_pow_pos, ZZ.spec_pow_pos; auto.
  rewrite Zgcd_1_rel_prime in *.
  apply rel_prime_Zpower; auto with zarith.
  Qed.
@@ -1089,7 +1085,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
   [[add x y]] = [[x]] + [[y]].
  Proof.
  unfold to_Qc.
- apply trans_equal with (!! ([x] + [y])).
+ transitivity (!! ([x] + [y])).
  unfold Q2Qc.
  apply Qc_decomp; intros _ _; unfold this.
  apply Qred_complete; apply spec_add; auto.
@@ -1103,7 +1099,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
   [[add_norm x y]] = [[x]] + [[y]].
  Proof.
  unfold to_Qc.
- apply trans_equal with (!! ([x] + [y])).
+ transitivity (!! ([x] + [y])).
  unfold Q2Qc.
  apply Qc_decomp; intros _ _; unfold this.
  apply Qred_complete; apply spec_add_norm; auto.
@@ -1151,7 +1147,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
   [[mul x y]] = [[x]] * [[y]].
  Proof.
  unfold to_Qc.
- apply trans_equal with (!! ([x] * [y])).
+ transitivity (!! ([x] * [y])).
  unfold Q2Qc.
  apply Qc_decomp; intros _ _; unfold this.
  apply Qred_complete; apply spec_mul; auto.
@@ -1165,7 +1161,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
    [[mul_norm x y]] = [[x]] * [[y]].
  Proof.
  unfold to_Qc.
- apply trans_equal with (!! ([x] * [y])).
+ transitivity (!! ([x] * [y])).
  unfold Q2Qc.
  apply Qc_decomp; intros _ _; unfold this.
  apply Qred_complete; apply spec_mul_norm; auto.
@@ -1189,7 +1185,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
    [[inv x]] =  /[[x]].
  Proof.
  unfold to_Qc.
- apply trans_equal with (!! (/[x])).
+ transitivity (!! (/[x])).
  unfold Q2Qc.
  apply Qc_decomp; intros _ _; unfold this.
  apply Qred_complete; apply spec_inv; auto.
@@ -1203,7 +1199,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
    [[inv_norm x]] =  /[[x]].
  Proof.
  unfold to_Qc.
- apply trans_equal with (!! (/[x])).
+ transitivity (!! (/[x])).
  unfold Q2Qc.
  apply Qc_decomp; intros _ _; unfold this.
  apply Qred_complete; apply spec_inv_norm; auto.
@@ -1251,7 +1247,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  Theorem spec_squarec x: [[square x]] = [[x]]^2.
  Proof.
  unfold to_Qc.
- apply trans_equal with (!! ([x]^2)).
+ transitivity (!! ([x]^2)).
  unfold Q2Qc.
  apply Qc_decomp; intros _ _; unfold this.
  apply Qred_complete; apply spec_square; auto.
@@ -1265,24 +1261,24 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.
  Qed.
 
  Theorem spec_power_posc x p:
-   [[power_pos x p]] = [[x]] ^ nat_of_P p.
+   [[power_pos x p]] = [[x]] ^ Pos.to_nat p.
  Proof.
  unfold to_Qc.
- apply trans_equal with (!! ([x]^Zpos p)).
+ transitivity (!! ([x]^Zpos p)).
  unfold Q2Qc.
  apply Qc_decomp; intros _ _; unfold this.
  apply Qred_complete; apply spec_power_pos; auto.
- induction p using Pind.
+ induction p using Pos.peano_ind.
  simpl; ring.
- rewrite nat_of_P_succ_morphism; simpl Qcpower.
+ rewrite Pos2Nat.inj_succ; simpl Qcpower.
  rewrite <- IHp; clear IHp.
  unfold Qcmult, Q2Qc.
  apply Qc_decomp; intros _ _; unfold this.
  apply Qred_complete.
- setoid_replace ([x] ^ ' Psucc p)%Q with ([x] * [x] ^ ' p)%Q.
+ setoid_replace ([x] ^ ' Pos.succ p)%Q with ([x] * [x] ^ ' p)%Q.
  apply Qmult_comp; apply Qeq_sym; apply Qred_correct.
  simpl.
- rewrite Pplus_one_succ_l.
+ rewrite <- Pos.add_1_l.
  rewrite Qpower_plus_positive; simpl; apply Qeq_refl.
  Qed.
 
diff --git a/theories/Numbers/Rational/SpecViaQ/QSig.v b/theories/Numbers/Rational/SpecViaQ/QSig.v
index 0fea26df..e199c713 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-2012     *)
 (*   \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..be585871
--- /dev/null
+++ b/theories/PArith/BinPos.v
@@ -0,0 +1,2134 @@
+(* -*- coding: utf-8 -*- *)
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+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 <+ UsualMinMaxDecProperties.
+
+Ltac order := Private_Tac.order.
+
+(** 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 IsNul := Pos.IsNul (only parsing).
+Notation IsPos := Pos.IsPos (only parsing).
+Notation IsNeg := Pos.IsNeg (only parsing).
+
+Notation Psucc := Pos.succ (compat "8.3").
+Notation Pplus := Pos.add (compat "8.3").
+Notation Pplus_carry := Pos.add_carry (compat "8.3").
+Notation Ppred := Pos.pred (compat "8.3").
+Notation Piter_op := Pos.iter_op (compat "8.3").
+Notation Piter_op_succ := Pos.iter_op_succ (compat "8.3").
+Notation Pmult_nat := (Pos.iter_op plus) (compat "8.3").
+Notation nat_of_P := Pos.to_nat (compat "8.3").
+Notation P_of_succ_nat := Pos.of_succ_nat (compat "8.3").
+Notation Pdouble_minus_one := Pos.pred_double (compat "8.3").
+Notation positive_mask := Pos.mask (compat "8.3").
+Notation positive_mask_rect := Pos.mask_rect (compat "8.3").
+Notation positive_mask_ind := Pos.mask_ind (compat "8.3").
+Notation positive_mask_rec := Pos.mask_rec (compat "8.3").
+Notation Pdouble_plus_one_mask := Pos.succ_double_mask (compat "8.3").
+Notation Pdouble_mask := Pos.double_mask (compat "8.3").
+Notation Pdouble_minus_two := Pos.double_pred_mask (compat "8.3").
+Notation Pminus_mask := Pos.sub_mask (compat "8.3").
+Notation Pminus_mask_carry := Pos.sub_mask_carry (compat "8.3").
+Notation Pminus := Pos.sub (compat "8.3").
+Notation Pmult := Pos.mul (compat "8.3").
+Notation iter_pos := @Pos.iter (compat "8.3").
+Notation Ppow := Pos.pow (compat "8.3").
+Notation Pdiv2 := Pos.div2 (compat "8.3").
+Notation Pdiv2_up := Pos.div2_up (compat "8.3").
+Notation Psize := Pos.size_nat (compat "8.3").
+Notation Psize_pos := Pos.size (compat "8.3").
+Notation Pcompare := Pos.compare_cont (compat "8.3").
+Notation Plt := Pos.lt (compat "8.3").
+Notation Pgt := Pos.gt (compat "8.3").
+Notation Ple := Pos.le (compat "8.3").
+Notation Pge := Pos.ge (compat "8.3").
+Notation Pmin := Pos.min (compat "8.3").
+Notation Pmax := Pos.max (compat "8.3").
+Notation Peqb := Pos.eqb (compat "8.3").
+Notation positive_eq_dec := Pos.eq_dec (compat "8.3").
+Notation xI_succ_xO := Pos.xI_succ_xO (compat "8.3").
+Notation Psucc_discr := Pos.succ_discr (compat "8.3").
+Notation Psucc_o_double_minus_one_eq_xO :=
+ Pos.succ_pred_double (compat "8.3").
+Notation Pdouble_minus_one_o_succ_eq_xI :=
+ Pos.pred_double_succ (compat "8.3").
+Notation xO_succ_permute := Pos.double_succ (compat "8.3").
+Notation double_moins_un_xO_discr :=
+ Pos.pred_double_xO_discr (compat "8.3").
+Notation Psucc_not_one := Pos.succ_not_1 (compat "8.3").
+Notation Ppred_succ := Pos.pred_succ (compat "8.3").
+Notation Psucc_pred := Pos.succ_pred_or (compat "8.3").
+Notation Psucc_inj := Pos.succ_inj (compat "8.3").
+Notation Pplus_carry_spec := Pos.add_carry_spec (compat "8.3").
+Notation Pplus_comm := Pos.add_comm (compat "8.3").
+Notation Pplus_succ_permute_r := Pos.add_succ_r (compat "8.3").
+Notation Pplus_succ_permute_l := Pos.add_succ_l (compat "8.3").
+Notation Pplus_no_neutral := Pos.add_no_neutral (compat "8.3").
+Notation Pplus_carry_plus := Pos.add_carry_add (compat "8.3").
+Notation Pplus_reg_r := Pos.add_reg_r (compat "8.3").
+Notation Pplus_reg_l := Pos.add_reg_l (compat "8.3").
+Notation Pplus_carry_reg_r := Pos.add_carry_reg_r (compat "8.3").
+Notation Pplus_carry_reg_l := Pos.add_carry_reg_l (compat "8.3").
+Notation Pplus_assoc := Pos.add_assoc (compat "8.3").
+Notation Pplus_xO := Pos.add_xO (compat "8.3").
+Notation Pplus_xI_double_minus_one := Pos.add_xI_pred_double (compat "8.3").
+Notation Pplus_xO_double_minus_one := Pos.add_xO_pred_double (compat "8.3").
+Notation Pplus_diag := Pos.add_diag (compat "8.3").
+Notation PeanoView := Pos.PeanoView (compat "8.3").
+Notation PeanoOne := Pos.PeanoOne (compat "8.3").
+Notation PeanoSucc := Pos.PeanoSucc (compat "8.3").
+Notation PeanoView_rect := Pos.PeanoView_rect (compat "8.3").
+Notation PeanoView_ind := Pos.PeanoView_ind (compat "8.3").
+Notation PeanoView_rec := Pos.PeanoView_rec (compat "8.3").
+Notation peanoView_xO := Pos.peanoView_xO (compat "8.3").
+Notation peanoView_xI := Pos.peanoView_xI (compat "8.3").
+Notation peanoView := Pos.peanoView (compat "8.3").
+Notation PeanoView_iter := Pos.PeanoView_iter (compat "8.3").
+Notation eq_dep_eq_positive := Pos.eq_dep_eq_positive (compat "8.3").
+Notation PeanoViewUnique := Pos.PeanoViewUnique (compat "8.3").
+Notation Prect := Pos.peano_rect (compat "8.3").
+Notation Prect_succ := Pos.peano_rect_succ (compat "8.3").
+Notation Prect_base := Pos.peano_rect_base (compat "8.3").
+Notation Prec := Pos.peano_rec (compat "8.3").
+Notation Pind := Pos.peano_ind (compat "8.3").
+Notation Pcase := Pos.peano_case (compat "8.3").
+Notation Pmult_1_r := Pos.mul_1_r (compat "8.3").
+Notation Pmult_Sn_m := Pos.mul_succ_l (compat "8.3").
+Notation Pmult_xO_permute_r := Pos.mul_xO_r (compat "8.3").
+Notation Pmult_xI_permute_r := Pos.mul_xI_r (compat "8.3").
+Notation Pmult_comm := Pos.mul_comm (compat "8.3").
+Notation Pmult_plus_distr_l := Pos.mul_add_distr_l (compat "8.3").
+Notation Pmult_plus_distr_r := Pos.mul_add_distr_r (compat "8.3").
+Notation Pmult_assoc := Pos.mul_assoc (compat "8.3").
+Notation Pmult_xI_mult_xO_discr := Pos.mul_xI_mul_xO_discr (compat "8.3").
+Notation Pmult_xO_discr := Pos.mul_xO_discr (compat "8.3").
+Notation Pmult_reg_r := Pos.mul_reg_r (compat "8.3").
+Notation Pmult_reg_l := Pos.mul_reg_l (compat "8.3").
+Notation Pmult_1_inversion_l := Pos.mul_eq_1_l (compat "8.3").
+Notation Psquare_xO := Pos.square_xO (compat "8.3").
+Notation Psquare_xI := Pos.square_xI (compat "8.3").
+Notation iter_pos_swap_gen := Pos.iter_swap_gen (compat "8.3").
+Notation iter_pos_swap := Pos.iter_swap (compat "8.3").
+Notation iter_pos_succ := Pos.iter_succ (compat "8.3").
+Notation iter_pos_plus := Pos.iter_add (compat "8.3").
+Notation iter_pos_invariant := Pos.iter_invariant (compat "8.3").
+Notation Ppow_1_r := Pos.pow_1_r (compat "8.3").
+Notation Ppow_succ_r := Pos.pow_succ_r (compat "8.3").
+Notation Peqb_refl := Pos.eqb_refl (compat "8.3").
+Notation Peqb_eq := Pos.eqb_eq (compat "8.3").
+Notation Pcompare_refl_id := Pos.compare_cont_refl (compat "8.3").
+Notation Pcompare_eq_iff := Pos.compare_eq_iff (compat "8.3").
+Notation Pcompare_Gt_Lt := Pos.compare_cont_Gt_Lt (compat "8.3").
+Notation Pcompare_eq_Lt := Pos.compare_lt_iff (compat "8.3").
+Notation Pcompare_Lt_Gt := Pos.compare_cont_Lt_Gt (compat "8.3").
+
+Notation Pcompare_antisym := Pos.compare_cont_antisym (compat "8.3").
+Notation ZC1 := Pos.gt_lt (compat "8.3").
+Notation ZC2 := Pos.lt_gt (compat "8.3").
+Notation Pcompare_spec := Pos.compare_spec (compat "8.3").
+Notation Pcompare_p_Sp := Pos.lt_succ_diag_r (compat "8.3").
+Notation Pcompare_succ_succ := Pos.compare_succ_succ (compat "8.3").
+Notation Pcompare_1 := Pos.nlt_1_r (compat "8.3").
+Notation Plt_1 := Pos.nlt_1_r (compat "8.3").
+Notation Plt_1_succ := Pos.lt_1_succ (compat "8.3").
+Notation Plt_lt_succ := Pos.lt_lt_succ (compat "8.3").
+Notation Plt_irrefl := Pos.lt_irrefl (compat "8.3").
+Notation Plt_trans := Pos.lt_trans (compat "8.3").
+Notation Plt_ind := Pos.lt_ind (compat "8.3").
+Notation Ple_lteq := Pos.le_lteq (compat "8.3").
+Notation Ple_refl := Pos.le_refl (compat "8.3").
+Notation Ple_lt_trans := Pos.le_lt_trans (compat "8.3").
+Notation Plt_le_trans := Pos.lt_le_trans (compat "8.3").
+Notation Ple_trans := Pos.le_trans (compat "8.3").
+Notation Plt_succ_r := Pos.lt_succ_r (compat "8.3").
+Notation Ple_succ_l := Pos.le_succ_l (compat "8.3").
+Notation Pplus_compare_mono_l := Pos.add_compare_mono_l (compat "8.3").
+Notation Pplus_compare_mono_r := Pos.add_compare_mono_r (compat "8.3").
+Notation Pplus_lt_mono_l := Pos.add_lt_mono_l (compat "8.3").
+Notation Pplus_lt_mono_r := Pos.add_lt_mono_r (compat "8.3").
+Notation Pplus_lt_mono := Pos.add_lt_mono (compat "8.3").
+Notation Pplus_le_mono_l := Pos.add_le_mono_l (compat "8.3").
+Notation Pplus_le_mono_r := Pos.add_le_mono_r (compat "8.3").
+Notation Pplus_le_mono := Pos.add_le_mono (compat "8.3").
+Notation Pmult_compare_mono_l := Pos.mul_compare_mono_l (compat "8.3").
+Notation Pmult_compare_mono_r := Pos.mul_compare_mono_r (compat "8.3").
+Notation Pmult_lt_mono_l := Pos.mul_lt_mono_l (compat "8.3").
+Notation Pmult_lt_mono_r := Pos.mul_lt_mono_r (compat "8.3").
+Notation Pmult_lt_mono := Pos.mul_lt_mono (compat "8.3").
+Notation Pmult_le_mono_l := Pos.mul_le_mono_l (compat "8.3").
+Notation Pmult_le_mono_r := Pos.mul_le_mono_r (compat "8.3").
+Notation Pmult_le_mono := Pos.mul_le_mono (compat "8.3").
+Notation Plt_plus_r := Pos.lt_add_r (compat "8.3").
+Notation Plt_not_plus_l := Pos.lt_not_add_l (compat "8.3").
+Notation Ppow_gt_1 := Pos.pow_gt_1 (compat "8.3").
+Notation Ppred_mask := Pos.pred_mask (compat "8.3").
+Notation Pminus_mask_succ_r := Pos.sub_mask_succ_r (compat "8.3").
+Notation Pminus_mask_carry_spec := Pos.sub_mask_carry_spec (compat "8.3").
+Notation Pminus_succ_r := Pos.sub_succ_r (compat "8.3").
+Notation Pminus_mask_diag := Pos.sub_mask_diag (compat "8.3").
+
+Notation Pplus_minus_eq := Pos.add_sub (compat "8.3").
+Notation Pmult_minus_distr_l := Pos.mul_sub_distr_l (compat "8.3").
+Notation Pminus_lt_mono_l := Pos.sub_lt_mono_l (compat "8.3").
+Notation Pminus_compare_mono_l := Pos.sub_compare_mono_l (compat "8.3").
+Notation Pminus_compare_mono_r := Pos.sub_compare_mono_r (compat "8.3").
+Notation Pminus_lt_mono_r := Pos.sub_lt_mono_r (compat "8.3").
+Notation Pminus_decr := Pos.sub_decr (compat "8.3").
+Notation Pminus_xI_xI := Pos.sub_xI_xI (compat "8.3").
+Notation Pplus_minus_assoc := Pos.add_sub_assoc (compat "8.3").
+Notation Pminus_plus_distr := Pos.sub_add_distr (compat "8.3").
+Notation Pminus_minus_distr := Pos.sub_sub_distr (compat "8.3").
+Notation Pminus_mask_Lt := Pos.sub_mask_neg (compat "8.3").
+Notation Pminus_Lt := Pos.sub_lt (compat "8.3").
+Notation Pminus_Eq := Pos.sub_diag (compat "8.3").
+Notation Psize_monotone := Pos.size_nat_monotone (compat "8.3").
+Notation Psize_pos_gt := Pos.size_gt (compat "8.3").
+Notation Psize_pos_le := Pos.size_le (compat "8.3").
+
+(** 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 : Pos.succ p = p + 1.
+Proof (eq_sym (Pos.add_1_r p)).
+Lemma Pplus_one_succ_l p : Pos.succ p = 1 + p.
+Proof (eq_sym (Pos.add_1_l p)).
+Lemma Pcompare_refl p : Pos.compare_cont p p Eq = Eq.
+Proof (Pos.compare_cont_refl p Eq).
+Lemma Pcompare_Eq_eq : forall p q, Pos.compare_cont p q Eq = Eq -> p = q.
+Proof Pos.compare_eq.
+Lemma ZC4 p q : Pos.compare_cont p q Eq = CompOpp (Pos.compare_cont q p Eq).
+Proof (Pos.compare_antisym q p).
+Lemma Ppred_minus p : Pos.pred p = p - 1.
+Proof (eq_sym (Pos.sub_1_r p)).
+
+Lemma Pminus_mask_Gt p q :
+  p > q ->
+  exists h : positive,
+   Pos.sub_mask p q = IsPos h /\
+   q + h = p /\ (h = 1 \/ Pos.sub_mask_carry p q = IsPos (Pos.pred 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..4beeea31
--- /dev/null
+++ b/theories/PArith/BinPosDef.v
@@ -0,0 +1,562 @@
+(* -*- coding: utf-8 -*- *)
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(**********************************************************************)
+(** * 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 *)
+
+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..9d294026 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-2012     *)
 (*   \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..4aae6271 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-2012     *)
 (*   \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..31e88a40
--- /dev/null
+++ b/theories/PArith/Pnat.v
@@ -0,0 +1,484 @@
+(* -*- coding: utf-8 -*- *)
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+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 peano_ind; 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 (compat "8.3").
+Notation Pplus_plus := Pos2Nat.inj_add (compat "8.3").
+Notation Pmult_mult := Pos2Nat.inj_mul (compat "8.3").
+Notation Pcompare_nat_compare := Pos2Nat.inj_compare (compat "8.3").
+Notation nat_of_P_xH := Pos2Nat.inj_1 (compat "8.3").
+Notation nat_of_P_xO := Pos2Nat.inj_xO (compat "8.3").
+Notation nat_of_P_xI := Pos2Nat.inj_xI (compat "8.3").
+Notation nat_of_P_is_S := Pos2Nat.is_succ (compat "8.3").
+Notation nat_of_P_pos := Pos2Nat.is_pos (compat "8.3").
+Notation nat_of_P_inj_iff := Pos2Nat.inj_iff (compat "8.3").
+Notation nat_of_P_inj := Pos2Nat.inj (compat "8.3").
+Notation Plt_lt := Pos2Nat.inj_lt (compat "8.3").
+Notation Pgt_gt := Pos2Nat.inj_gt (compat "8.3").
+Notation Ple_le := Pos2Nat.inj_le (compat "8.3").
+Notation Pge_ge := Pos2Nat.inj_ge (compat "8.3").
+Notation Pminus_minus := Pos2Nat.inj_sub (compat "8.3").
+Notation iter_nat_of_P := @Pos2Nat.inj_iter (compat "8.3").
+
+Notation nat_of_P_of_succ_nat := SuccNat2Pos.id_succ (compat "8.3").
+Notation P_of_succ_nat_of_P := Pos2SuccNat.id_succ (compat "8.3").
+
+Notation nat_of_P_succ_morphism := Pos2Nat.inj_succ (compat "8.3").
+Notation nat_of_P_plus_morphism := Pos2Nat.inj_add (compat "8.3").
+Notation nat_of_P_mult_morphism := Pos2Nat.inj_mul (compat "8.3").
+Notation nat_of_P_compare_morphism := Pos2Nat.inj_compare (compat "8.3").
+Notation lt_O_nat_of_P := Pos2Nat.is_pos (compat "8.3").
+Notation ZL4 := Pos2Nat.is_succ (compat "8.3").
+Notation nat_of_P_o_P_of_succ_nat_eq_succ := SuccNat2Pos.id_succ (compat "8.3").
+Notation P_of_succ_nat_o_nat_of_P_eq_succ := Pos2SuccNat.id_succ (compat "8.3").
+Notation pred_o_P_of_succ_nat_o_nat_of_P_eq_id := Pos2SuccNat.pred_id (compat "8.3").
+
+Lemma nat_of_P_minus_morphism p q :
+ Pos.compare_cont p q Eq = Gt ->
+  Pos.to_nat (p - q) = Pos.to_nat p - Pos.to_nat q.
+Proof (fun H => Pos2Nat.inj_sub p q (Pos.gt_lt _ _ H)).
+
+Lemma nat_of_P_lt_Lt_compare_morphism p q :
+ Pos.compare_cont p q Eq = Lt -> Pos.to_nat p < Pos.to_nat q.
+Proof (proj1 (Pos2Nat.inj_lt p q)).
+
+Lemma nat_of_P_gt_Gt_compare_morphism p q :
+ Pos.compare_cont p q Eq = Gt -> Pos.to_nat p > Pos.to_nat q.
+Proof (proj1 (Pos2Nat.inj_gt p q)).
+
+Lemma nat_of_P_lt_Lt_compare_complement_morphism p q :
+ Pos.to_nat p < Pos.to_nat q -> Pos.compare_cont p q Eq = Lt.
+Proof (proj2 (Pos2Nat.inj_lt p q)).
+
+Definition nat_of_P_gt_Gt_compare_complement_morphism p q :
+ Pos.to_nat p > Pos.to_nat q -> Pos.compare_cont p q Eq = Gt.
+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 (Pos.succ 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 (Pos.add_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..22436de6 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-2012     *)
 (*   \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. *)
 
@@ -31,7 +29,7 @@ Hint Unfold compose.
 Notation " g ∘ f " := (compose g f)
   (at level 40, left associativity) : program_scope.
 
-Open Local Scope program_scope.
+Local Open Scope program_scope.
 
 (** The non-dependent function space between [A] and [B]. *)
 
@@ -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..dcf09251 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-2012     *)
 (*   \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..323e80cc 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-2012     *)
 (*   \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 := unfold block in *.
 
 (** 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,8 @@ Ltac simplify_eqs :=
 
 Ltac simplify_IH_hyps := repeat
   match goal with
-    | [ hyp : context [ block _ ] |- _ ] => specialize_eqs hyp ; unfold block in hyp
+    | [ hyp : context [ block _ ] |- _ ] => 
+      specialize_eqs hyp
   end.
 
 (** We split substitution tactics in the two directions depending on which 
@@ -285,27 +275,33 @@ 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),
-  (x = y -> B) -> (existT P p x = existT P p y -> B).
-Proof. intros. apply X. apply inj_pair2. exact H. Defined.
+Definition conditional_eq {A} (x y : A) := eq x y.
 
-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).
+Lemma simplification_existT2 A (P : A -> Type) B (p : A) (x y : P p) :
+  (x = y -> B) -> (conditional_eq (existT P p x) (existT P p y) -> B).
+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) :
+  (p = q -> conditional_eq (existT P p x) (existT P q y) -> B) -> (existT P p x = existT P q y -> B).
+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 +316,22 @@ 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 _) -> _ =>
-      refine (simplification_existT2 _ _ _ _ _ _ _) ||
-        match goal with
-          | H : p = q |- _ => intro
-          | _ => refine (simplification_existT1 _ _ _ _ _ _ _ _)
-        end
+    | eq (existT _ _ _) (existT _ _ _) -> _ =>
+        refine (simplification_existT1 _ _ _ _ _ _ _ _)
+    | conditional_eq (existT _ _ _) (existT _ _ _) -> _ =>
+        refine (simplification_existT2 _ _ _ _ _ _ _) ||
+               (unfold conditional_eq; intro)
     | ?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
@@ -399,25 +382,34 @@ Ltac is_introduced H :=
   end.
 
 Tactic Notation "intro_block" hyp(H) :=
-  (is_introduced H ; block_goal ; revert_until H) ||
+  (is_introduced H ; block_goal ; revert_until H ; block_goal) ||
     (let H' := fresh H in intros until H' ; block_goal) || (intros ; block_goal).
 
 Tactic Notation "intro_block_id" ident(H) :=
-  (is_introduced H ; block_goal ; revert_until H) ||
+  (is_introduced H ; block_goal ; revert_until H; block_goal) ||
     (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 unblock_dep_elim :=
+  match goal with
+    | |- block ?T => 
+      match T with context [ block _ ] => 
+        change T ; intros ; unblock_goal
+      end
+    | _ => unblock_goal
+  end.
+
+Ltac simpl_dep_elim := simplify_dep_elim ; simplify_IH_hyps ; unblock_dep_elim.
 
 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 ; simpl_dep_elim.
 
 (** To dependent elimination on some hyp. *)
 
@@ -433,26 +425,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 ;
+  (try revert_until H ; block_goal) ; generalize_eqs H ; tac H ; simpl_dep_elim.
 
 (** 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 +459,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..be8d9a47 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-2012     *)
 (*   \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..34c27ed8 100644
--- a/theories/Program/Subset.v
+++ b/theories/Program/Subset.v
@@ -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-2012     *)
 (*   \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.
 Require Import Coq.Program.Equality.
 
-Open Local Scope program_scope.
+Local Open Scope program_scope.
 
 (** The following tactics implement a poor-man's solution for proof-irrelevance: it tries to
    factorize every proof of the same proposition in a goal so that equality of such proofs becomes trivial. *)
@@ -108,7 +106,7 @@ Ltac rewrite_match_eq H :=
     [ |- ?T ] =>
     match T with
       context [ match_eq ?A ?B ?t ?f ] =>
-      rewrite (match_eq_rewrite A B t f (exist _ _ (sym_eq H)))
+      rewrite (match_eq_rewrite A B t f (exist _ _ (eq_sym H)))
     end
   end.
 
diff --git a/theories/Program/Syntax.v b/theories/Program/Syntax.v
index 582bc461..a2948074 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-2012     *)
 (*   \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..9aba9f53 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-2012     *)
 (*   \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; 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..94e88d57 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-2012     *)
 (*   \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..6a030c7f 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-2012     *)
 (*   \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. *)
 
@@ -14,7 +12,7 @@ Require Import Coq.Init.Wf.
 Require Import Coq.Program.Utils.
 Require Import ProofIrrelevance.
 
-Open Local Scope program_scope.
+Local Open Scope program_scope.
 
 Section Well_founded.
   Variable A : Type.
@@ -54,7 +52,7 @@ Section Well_founded.
 
   Lemma Fix_eq : forall x:A, Fix_sub x = F_sub x (fun (y:A|R y x) => Fix_sub (proj1_sig y)).
   Proof.
-    intro x; unfold Fix_sub in |- *.
+    intro x; unfold Fix_sub.
     rewrite <- (Fix_F_eq ).
     apply F_ext; intros.
     apply Fix_F_inv.
diff --git a/theories/QArith/QArith.v b/theories/QArith/QArith.v
index 2255cd41..5d36ff12 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-2012     *)
 (*   \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..cf5bb3f2 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-2012     *)
 (*   \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,16 +18,16 @@ 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.
+Ltac simpl_mult := rewrite ?Pos2Z.inj_mul.
 
 (** [a#b] denotes the fraction [a] over [b]. *)
 
 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,84 +46,77 @@ 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.
 Notation "p ?= q" := (Qcompare p q) : Q_scope.
 
-Lemma Qeq_alt : forall p q, (p == q) <-> (p ?= q) = Eq.
+Lemma Qeq_alt p q : (p == q) <-> (p ?= q) = Eq.
 Proof.
-unfold Qeq, Qcompare; intros; split; intros.
-rewrite H; apply Zcompare_refl.
-apply Zcompare_Eq_eq; auto.
+symmetry. apply Z.compare_eq_iff.
 Qed.
 
-Lemma Qlt_alt : forall p q, (p<q) <-> (p?=q = Lt).
+Lemma Qlt_alt p q : (p<q) <-> (p?=q = Lt).
 Proof.
-unfold Qlt, Qcompare, Zlt; split; auto.
+reflexivity.
 Qed.
 
-Lemma Qgt_alt : forall p q, (p>q) <-> (p?=q = Gt).
+Lemma Qgt_alt p q : (p>q) <-> (p?=q = Gt).
 Proof.
-unfold Qlt, Qcompare, Zlt.
-intros; rewrite Zcompare_Gt_Lt_antisym; split; auto.
+symmetry. apply Z.gt_lt_iff.
 Qed.
 
-Lemma Qle_alt : forall p q, (p<=q) <-> (p?=q <> Gt).
+Lemma Qle_alt p q : (p<=q) <-> (p?=q <> Gt).
 Proof.
-unfold Qle, Qcompare, Zle; split; auto.
+reflexivity.
 Qed.
 
-Lemma Qge_alt : forall p q, (p>=q) <-> (p?=q <> Lt).
+Lemma Qge_alt p q : (p>=q) <-> (p?=q <> Lt).
 Proof.
-unfold Qle, Qcompare, Zle.
-split; intros; contradict H.
-rewrite Zcompare_Gt_Lt_antisym; auto.
-rewrite Zcompare_Gt_Lt_antisym in H; auto.
+symmetry. apply Z.ge_le_iff.
 Qed.
 
 Hint Unfold Qeq Qlt Qle : qarith.
 Hint Extern 5 (?X1 <> ?X2) => intro; discriminate: qarith.
 
-Lemma Qcompare_antisym : forall x y, CompOpp (x ?= y) = (y ?= x).
+Lemma Qcompare_antisym x y : CompOpp (x ?= y) = (y ?= x).
 Proof.
- unfold "?=". intros. apply Zcompare_antisym.
+ symmetry. apply Z.compare_antisym.
 Qed.
 
-Lemma Qcompare_spec : forall x y, CompSpec Qeq Qlt x y (x ?= y).
+Lemma Qcompare_spec x y : CompareSpec (x==y) (x<y) (y<x) (x ?= y).
 Proof.
- intros.
- destruct (x ?= y) as [ ]_eqn:H; constructor; auto.
- rewrite Qeq_alt; auto.
- rewrite Qlt_alt, <- Qcompare_antisym, H; auto.
+ unfold Qeq, Qlt, Qcompare. case Z.compare_spec; now constructor.
 Qed.
 
 (** * Properties of equality. *)
 
-Theorem Qeq_refl : forall x, x == x.
+Theorem Qeq_refl x : x == x.
 Proof.
  auto with qarith.
 Qed.
 
-Theorem Qeq_sym : forall x y, x == y -> y == x.
+Theorem Qeq_sym x y : x == y -> y == x.
 Proof.
  auto with qarith.
 Qed.
 
-Theorem Qeq_trans : forall x y z, x == y -> y == z -> x == z.
+Theorem Qeq_trans x y z : x == y -> y == z -> x == z.
 Proof.
-unfold Qeq; intros.
-apply Zmult_reg_l with (QDen y).
-auto with qarith.
-transitivity (Qnum x * QDen y * QDen z)%Z; try ring.
-rewrite H.
-transitivity (Qnum y * QDen z * QDen x)%Z; try ring.
-rewrite H0; ring.
+unfold Qeq; intros XY YZ.
+apply Z.mul_reg_r with (QDen y); [auto with qarith|].
+now rewrite Z.mul_shuffle0, XY, Z.mul_shuffle0, YZ, Z.mul_shuffle0.
 Qed.
 
-Hint Resolve Qeq_refl : qarith.
-Hint Resolve Qeq_sym : qarith.
-Hint Resolve Qeq_trans : qarith.
+Hint Immediate Qeq_sym : qarith.
+Hint Resolve Qeq_refl Qeq_trans : qarith.
 
 (** In a word, [Qeq] is a setoid equality. *)
 
@@ -134,50 +125,48 @@ Proof. split; red; eauto with qarith. Qed.
 
 (** Furthermore, this equality is decidable: *)
 
-Theorem Qeq_dec : forall x y, {x==y} + {~ x==y}.
+Theorem Qeq_dec x y : {x==y} + {~ x==y}.
 Proof.
- intros; case (Z_eq_dec (Qnum x * QDen y) (Qnum y * QDen x)); auto.
+ apply Z.eq_dec.
 Defined.
 
 Definition Qeq_bool x y :=
   (Zeq_bool (Qnum x * QDen y) (Qnum y * QDen x))%Z.
 
 Definition Qle_bool x y :=
-  (Zle_bool (Qnum x * QDen y) (Qnum y * QDen x))%Z.
+  (Z.leb (Qnum x * QDen y) (Qnum y * QDen x))%Z.
 
-Lemma Qeq_bool_iff : forall x y, Qeq_bool x y = true <-> x == y.
+Lemma Qeq_bool_iff x y : Qeq_bool x y = true <-> x == y.
 Proof.
-  unfold Qeq_bool, Qeq; intros.
   symmetry; apply Zeq_is_eq_bool.
 Qed.
 
-Lemma Qeq_bool_eq : forall x y, Qeq_bool x y = true -> x == y.
+Lemma Qeq_bool_eq x y : Qeq_bool x y = true -> x == y.
 Proof.
-  intros; rewrite <- Qeq_bool_iff; auto.
+  apply Qeq_bool_iff.
 Qed.
 
-Lemma Qeq_eq_bool : forall x y, x == y -> Qeq_bool x y = true.
+Lemma Qeq_eq_bool x y : x == y -> Qeq_bool x y = true.
 Proof.
-  intros; rewrite Qeq_bool_iff; auto.
+  apply Qeq_bool_iff.
 Qed.
 
-Lemma Qeq_bool_neq : forall x y, Qeq_bool x y = false -> ~ x == y.
+Lemma Qeq_bool_neq x y : Qeq_bool x y = false -> ~ x == y.
 Proof.
-  intros x y H; rewrite <- Qeq_bool_iff, H; discriminate.
+  rewrite <- Qeq_bool_iff. now intros ->.
 Qed.
 
-Lemma Qle_bool_iff : forall x y, Qle_bool x y = true <-> x <= y.
+Lemma Qle_bool_iff x y : Qle_bool x y = true <-> x <= y.
 Proof.
-  unfold Qle_bool, Qle; intros.
   symmetry; apply Zle_is_le_bool.
 Qed.
 
-Lemma Qle_bool_imp_le : forall x y, Qle_bool x y = true -> x <= y.
+Lemma Qle_bool_imp_le x y : Qle_bool x y = true -> x <= y.
 Proof.
-  intros; rewrite <- Qle_bool_iff; auto.
+  apply Qle_bool_iff.
 Qed.
 
-Theorem Qnot_eq_sym : forall x y, ~x == y -> ~y == x.
+Theorem Qnot_eq_sym x y : ~x == y -> ~y == x.
 Proof.
  auto with qarith.
 Qed.
@@ -218,12 +207,9 @@ Infix "/" := Qdiv : Q_scope.
 
 Notation " ' x " := (Zpos x) (at level 20, no associativity) : Z_scope.
 
-Lemma Qmake_Qdiv : forall a b, a#b==inject_Z a/inject_Z ('b).
+Lemma Qmake_Qdiv a b : a#b==inject_Z a/inject_Z ('b).
 Proof.
-intros a b.
-unfold Qeq.
-simpl.
-ring.
+unfold Qeq. simpl. ring.
 Qed.
 
 (** * Setoid compatibility results *)
@@ -276,17 +262,13 @@ Instance Qinv_comp : Proper (Qeq==>Qeq) Qinv.
 Proof.
   unfold Qeq, Qinv; simpl.
   Open Scope Z_scope.
-  intros (p1, p2) (q1, q2); simpl.
-  case p1; simpl.
-  intros.
-  assert (q1 = 0).
-  elim (Zmult_integral q1 ('p2)); auto with zarith.
-  intros; discriminate.
-  subst; auto.
-  case q1; simpl; intros; try discriminate.
-  rewrite (Pmult_comm p2 p); rewrite (Pmult_comm q2 p0); auto.
-  case q1; simpl; intros; try discriminate.
-  rewrite (Pmult_comm p2 p); rewrite (Pmult_comm q2 p0); auto.
+  intros (p1, p2) (q1, q2) EQ; simpl in *.
+  destruct q1; simpl in *.
+  - apply Z.mul_eq_0 in EQ. destruct EQ; now subst.
+  - destruct p1; simpl in *; try discriminate.
+    now rewrite Pos.mul_comm, <- EQ, Pos.mul_comm.
+  - destruct p1; simpl in *; try discriminate.
+    now rewrite Pos.mul_comm, <- EQ, Pos.mul_comm.
   Close Scope Z_scope.
 Qed.
 
@@ -363,7 +345,7 @@ Qed.
 Lemma Qplus_0_r : forall x, x+0 == x.
 Proof.
   intros (x1, x2); unfold Qeq, Qplus; simpl.
-  rewrite Pmult_comm; simpl; ring.
+  rewrite Pos.mul_comm; simpl; ring.
 Qed.
 
 (** Commutativity of addition: *)
@@ -371,7 +353,7 @@ Qed.
 Theorem Qplus_comm : forall x y, x+y == y+x.
 Proof.
   intros (x1, x2); unfold Qeq, Qplus; simpl.
-  intros; rewrite Pmult_comm; ring.
+  intros; rewrite Pos.mul_comm; ring.
 Qed.
 
 
@@ -387,6 +369,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] *)
 
@@ -394,7 +396,7 @@ Qed.
 
 Theorem Qmult_assoc : forall n m p, n*(m*p)==(n*m)*p.
 Proof.
-  intros; red; simpl; rewrite Pmult_assoc; ring.
+  intros; red; simpl; rewrite Pos.mul_assoc; ring.
 Qed.
 
 (** multiplication and zero *)
@@ -419,15 +421,15 @@ Qed.
 Theorem Qmult_1_r : forall n, n*1==n.
 Proof.
   intro; red; simpl.
-  rewrite Zmult_1_r with (n := Qnum n).
-  rewrite Pmult_comm; simpl; trivial.
+  rewrite Z.mul_1_r with (n := Qnum n).
+  rewrite Pos.mul_comm; simpl; trivial.
 Qed.
 
 (** Commutativity of multiplication *)
 
 Theorem Qmult_comm : forall x y, x*y==y*x.
 Proof.
-  intros; red; simpl; rewrite Pmult_comm; ring.
+  intros; red; simpl; rewrite Pos.mul_comm; ring.
 Qed.
 
 (** Distributivity over [Qadd] *)
@@ -449,19 +451,32 @@ Qed.
 Theorem Qmult_integral : forall x y, x*y==0 -> x==0 \/ y==0.
 Proof.
   intros (x1,x2) (y1,y2).
-  unfold Qeq, Qmult; simpl; intros.
-  destruct (Zmult_integral (x1*1)%Z (y1*1)%Z); auto.
-  rewrite <- H; ring.
+  unfold Qeq, Qmult; simpl.
+  now rewrite <- Z.mul_eq_0, !Z.mul_1_r.
 Qed.
 
 Theorem Qmult_integral_l : forall x y, ~ x == 0 -> x*y == 0 -> y == 0.
 Proof.
   intros (x1, x2) (y1, y2).
-  unfold Qeq, Qmult; simpl; intros.
-  apply Zmult_integral_l with x1; auto with zarith.
-  rewrite <- H0; ring.
+  unfold Qeq, Qmult; simpl.
+  rewrite !Z.mul_1_r, Z.mul_eq_0. intuition.
 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,14 +515,33 @@ 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.
+Lemma Qle_refl x : x<=x.
 Proof.
   unfold Qle; auto with zarith.
 Qed.
 
-Lemma Qle_antisym : forall x y, x<=y -> y<=x -> x==y.
+Lemma Qle_antisym x y : x<=y -> y<=x -> x==y.
 Proof.
   unfold Qle, Qeq; auto with zarith.
 Qed.
@@ -516,39 +550,46 @@ Lemma Qle_trans : forall x y z, x<=y -> y<=z -> x<=z.
 Proof.
   unfold Qle; intros (x1, x2) (y1, y2) (z1, z2); simpl; intros.
   Open Scope Z_scope.
-  apply Zmult_le_reg_r with ('y2).
-  red; trivial.
-  apply Zle_trans with (y1 * 'x2 * 'z2).
-  replace (x1 * 'z2 * 'y2) with (x1 * 'y2 * 'z2) by ring.
-  apply Zmult_le_compat_r; auto with zarith.
-  replace (y1 * 'x2 * 'z2) with (y1 * 'z2 * 'x2) by ring.
-  replace (z1 * 'x2 * 'y2) with (z1 * 'y2 * 'x2) by ring.
-  apply Zmult_le_compat_r; auto with zarith.
+  apply Z.mul_le_mono_pos_r with ('y2); [easy|].
+  apply Z.le_trans with (y1 * 'x2 * 'z2).
+  - rewrite Z.mul_shuffle0. now apply Z.mul_le_mono_pos_r.
+  - rewrite Z.mul_shuffle0, (Z.mul_shuffle0 z1).
+    now apply Z.mul_le_mono_pos_r.
   Close Scope Z_scope.
 Qed.
 
 Hint Resolve Qle_trans : qarith.
 
-Lemma Qlt_irrefl : forall x, ~x<x.
+Lemma Qlt_irrefl x : ~x<x.
 Proof.
  unfold Qlt. auto with zarith.
 Qed.
 
-Lemma Qlt_not_eq : forall x y, x<y -> ~ x==y.
+Lemma Qlt_not_eq x y : x<y -> ~ x==y.
 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. simpl. now rewrite !Z.mul_1_r.
+Qed.
+
+Lemma Zlt_Qlt (x y: Z): (x < y)%Z = (inject_Z x < inject_Z y).
+Proof.
+ unfold Qlt. simpl. now rewrite !Z.mul_1_r.
+Qed.
+
+
 (** Large = strict or equal *)
 
-Lemma Qle_lteq : forall x y, x<=y <-> x<y \/ x==y.
+Lemma Qle_lteq x y : x<=y <-> x<y \/ x==y.
 Proof.
- intros.
  rewrite Qeq_alt, Qle_alt, Qlt_alt.
  destruct (x ?= y); intuition; discriminate.
 Qed.
 
-Lemma Qlt_le_weak : forall x y, x<y -> x<=y.
+Lemma Qlt_le_weak x y : x<y -> x<=y.
 Proof.
   unfold Qle, Qlt; auto with zarith.
 Qed.
@@ -557,15 +598,11 @@ Lemma Qle_lt_trans : forall x y z, x<=y -> y<z -> x<z.
 Proof.
   unfold Qle, Qlt; intros (x1, x2) (y1, y2) (z1, z2); simpl; intros.
   Open Scope Z_scope.
-  apply Zgt_lt.
-  apply Zmult_gt_reg_r with ('y2).
-  red; trivial.
-  apply Zgt_le_trans with (y1 * 'x2 * 'z2).
-  replace (y1 * 'x2 * 'z2) with (y1 * 'z2 * 'x2) by ring.
-  replace (z1 * 'x2 * 'y2) with (z1 * 'y2 * 'x2) by ring.
-  apply Zmult_gt_compat_r; auto with zarith.
-  replace (x1 * 'z2 * 'y2) with (x1 * 'y2 * 'z2) by ring.
-  apply Zmult_le_compat_r; auto with zarith.
+  apply Z.mul_lt_mono_pos_r with ('y2); [easy|].
+  apply Z.le_lt_trans with (y1 * 'x2 * 'z2).
+  - rewrite Z.mul_shuffle0. now apply Z.mul_le_mono_pos_r.
+  - rewrite Z.mul_shuffle0, (Z.mul_shuffle0 z1).
+    now apply Z.mul_lt_mono_pos_r.
   Close Scope Z_scope.
 Qed.
 
@@ -573,15 +610,11 @@ Lemma Qlt_le_trans : forall x y z, x<y -> y<=z -> x<z.
 Proof.
   unfold Qle, Qlt; intros (x1, x2) (y1, y2) (z1, z2); simpl; intros.
   Open Scope Z_scope.
-  apply Zgt_lt.
-  apply Zmult_gt_reg_r with ('y2).
-  red; trivial.
-  apply Zle_gt_trans with (y1 * 'x2 * 'z2).
-  replace (y1 * 'x2 * 'z2) with (y1 * 'z2 * 'x2) by ring.
-  replace (z1 * 'x2 * 'y2) with (z1 * 'y2 * 'x2) by ring.
-  apply Zmult_le_compat_r; auto with zarith.
-  replace (x1 * 'z2 * 'y2) with (x1 * 'y2 * 'z2) by ring.
-  apply Zmult_gt_compat_r; auto with zarith.
+  apply Z.mul_lt_mono_pos_r with ('y2); [easy|].
+  apply Z.lt_le_trans with (y1 * 'x2 * 'z2).
+  - rewrite Z.mul_shuffle0. now apply Z.mul_lt_mono_pos_r.
+  - rewrite Z.mul_shuffle0, (Z.mul_shuffle0 z1).
+    now apply Z.mul_le_mono_pos_r.
   Close Scope Z_scope.
 Qed.
 
@@ -616,7 +649,7 @@ Qed.
 
 Lemma Qle_lt_or_eq : forall x y, x<=y -> x<y \/ x==y.
 Proof.
-  unfold Qle, Qlt, Qeq; intros; apply Zle_lt_or_eq; auto.
+  unfold Qle, Qlt, Qeq; intros; now apply Z.lt_eq_cases.
 Qed.
 
 Hint Resolve Qle_not_lt Qlt_not_le Qnot_le_lt Qnot_lt_le
@@ -641,7 +674,7 @@ Defined.
 Lemma Qopp_le_compat : forall p q, p<=q -> -q <= -p.
 Proof.
   intros (a1,a2) (b1,b2); unfold Qle, Qlt; simpl.
-  do 2 rewrite <- Zopp_mult_distr_l; omega.
+  rewrite !Z.mul_opp_l. omega.
 Qed.
 
 Hint Resolve Qopp_le_compat : qarith.
@@ -649,15 +682,13 @@ Hint Resolve Qopp_le_compat : qarith.
 Lemma Qle_minus_iff : forall p q, p <= q <-> 0 <= q+-p.
 Proof.
   intros (x1,x2) (y1,y2); unfold Qle; simpl.
-  rewrite <- Zopp_mult_distr_l.
-  split; omega.
+  rewrite Z.mul_opp_l. omega.
 Qed.
 
 Lemma Qlt_minus_iff : forall p q, p < q <-> 0 < q+-p.
 Proof.
   intros (x1,x2) (y1,y2); unfold Qlt; simpl.
-  rewrite <- Zopp_mult_distr_l.
-  split; omega.
+  rewrite Z.mul_opp_l. omega.
 Qed.
 
 Lemma Qplus_le_compat :
@@ -668,8 +699,8 @@ Proof.
   Open Scope Z_scope.
   intros.
   match goal with |- ?a <= ?b => ring_simplify a b end.
-  rewrite Zplus_comm.
-  apply Zplus_le_compat.
+  rewrite Z.add_comm.
+  apply Z.add_le_mono.
   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.
@@ -677,42 +708,117 @@ 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 Z.add_comm.
+  apply Z.add_le_lt_mono.
+  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.
+  do 2 (apply Z.mul_lt_mono_pos_r;try easy).
+  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.
   Open Scope Z_scope.
   intros; 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.
-  apply Zmult_le_compat_r; auto with zarith.
+  rewrite Z.mul_shuffle1, (Z.mul_shuffle1 b1).
+  apply Z.mul_le_mono_nonneg_r; auto with zarith.
   Close Scope Z_scope.
 Qed.
 
-Lemma Qmult_lt_0_le_reg_r : forall x y z, 0 <  z  -> x*z <= y*z -> x <= y.
+Lemma Qmult_lt_0_le_reg_r : forall x y z, 0 < z  -> x*z <= y*z -> x <= y.
 Proof.
   intros (a1,a2) (b1,b2) (c1,c2); unfold Qle, Qlt; simpl.
   Open Scope Z_scope.
   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.
-  intros; apply Zmult_le_reg_r with (c1*'c2); auto with zarith.
+  rewrite Z.mul_shuffle1, (Z.mul_shuffle1 b1).
+  intros LT LE.
+  apply Z.mul_le_mono_pos_r in LE; trivial.
+  apply Z.mul_pos_pos; [omega|easy].
   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.
   Open Scope Z_scope.
   intros; 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.
-  apply Zmult_lt_compat_r; auto with zarith.
-  apply Zmult_lt_0_compat.
-  omega.
-  compute; auto.
+  rewrite Z.mul_shuffle1, (Z.mul_shuffle1 b1).
+  apply Z.mul_lt_mono_pos_r; auto with zarith.
+  apply Z.mul_pos_pos; [omega|reflexivity].
   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.
+ rewrite Z.mul_shuffle1, (Z.mul_shuffle1 b1).
+ intro LT. rewrite <- Z.mul_lt_mono_pos_r. reflexivity.
+ apply Z.mul_pos_pos; [omega|reflexivity].
+ 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..e146da25 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-2012     *)
 (*   \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..50aee530 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -11,7 +11,7 @@ Require Export Qreduction.
 
 Hint Resolve Qlt_le_weak : qarith.
 
-Definition Qabs (x:Q) := let (n,d):=x in (Zabs n#d).
+Definition Qabs (x:Q) := let (n,d):=x in (Z.abs n#d).
 
 Lemma Qabs_case : forall (x:Q) (P : Q -> Type), (0 <= x -> P x) -> (x <= 0 -> P (- x)) -> P (Qabs x).
 Proof.
@@ -26,9 +26,9 @@ intros [xn xd] [yn yd] H.
 simpl.
 unfold Qeq in *.
 simpl in *.
-change (' yd)%Z with (Zabs (' yd)).
-change (' xd)%Z with (Zabs (' xd)).
-repeat rewrite <- Zabs_Zmult.
+change (' yd)%Z with (Z.abs (' yd)).
+change (' xd)%Z with (Z.abs (' xd)).
+repeat rewrite <- Z.abs_mul.
 congruence.
 Qed.
 
@@ -61,7 +61,7 @@ auto.
 apply (Qopp_le_compat x 0).
 Qed.
 
-Lemma Zabs_Qabs : forall n d, (Zabs n#d)==Qabs (n#d).
+Lemma Zabs_Qabs : forall n d, (Z.abs n#d)==Qabs (n#d).
 Proof.
 intros [|n|n]; reflexivity.
 Qed.
@@ -85,21 +85,28 @@ intros [xn xd] [yn yd].
 unfold Qplus.
 unfold Qle.
 simpl.
-apply Zmult_le_compat_r;auto with *.
-change (' yd)%Z with (Zabs (' yd)).
-change (' xd)%Z with (Zabs (' xd)).
-repeat rewrite <- Zabs_Zmult.
-apply Zabs_triangle.
+apply Z.mul_le_mono_nonneg_r;auto with *.
+change (' yd)%Z with (Z.abs (' yd)).
+change (' xd)%Z with (Z.abs (' xd)).
+repeat rewrite <- Z.abs_mul.
+apply Z.abs_triangle.
 Qed.
 
 Lemma Qabs_Qmult : forall a b, Qabs (a*b) == (Qabs a)*(Qabs b).
 Proof.
 intros [an ad] [bn bd].
 simpl.
-rewrite Zabs_Zmult.
+rewrite Z.abs_mul.
 reflexivity.
 Qed.
 
+Lemma Qabs_Qminus x y: Qabs (x - y) = Qabs (y - x).
+Proof.
+ unfold Qminus, Qopp. simpl.
+ rewrite Pos.mul_comm, <- Z.abs_opp.
+ 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..d1160cbe 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-2012     *)
 (*   \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,43 +18,43 @@ 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 :
-  forall q:Q, Zgcd (Qnum q) (QDen q) = 1%Z -> Qred q = q.
+  forall q:Q, Z.gcd (Qnum q) (QDen q) = 1%Z -> Qred q = q.
 Proof.
   unfold Qred; intros (a,b); simpl.
-  generalize (Zggcd_gcd a ('b)) (Zggcd_correct_divisors a ('b)).
+  generalize (Z.ggcd_gcd a ('b)) (Z.ggcd_correct_divisors a ('b)).
   intros.
   rewrite H1 in H; clear H1.
-  destruct (Zggcd a ('b)) as (g,(aa,bb)); simpl in *; subst.
+  destruct (Z.ggcd a ('b)) as (g,(aa,bb)); simpl in *; subst.
   destruct H0.
-  rewrite Zmult_1_l in H, H0.
+  rewrite Z.mul_1_l in H, H0.
   subst; simpl; auto.
 Qed.
 
 Lemma Qred_identity2 :
-  forall q:Q, Qred q = q -> Zgcd (Qnum q) (QDen q) = 1%Z.
+  forall q:Q, Qred q = q -> Z.gcd (Qnum q) (QDen q) = 1%Z.
 Proof.
   unfold Qred; intros (a,b); simpl.
-  generalize (Zggcd_gcd a ('b)) (Zggcd_correct_divisors a ('b)) (Zgcd_is_pos a ('b)).
+  generalize (Z.ggcd_gcd a ('b)) (Z.ggcd_correct_divisors a ('b)) (Z.gcd_nonneg a ('b)).
   intros.
   rewrite <- H; rewrite <- H in H1; clear H.
-  destruct (Zggcd a ('b)) as (g,(aa,bb)); simpl in *; subst.
+  destruct (Z.ggcd a ('b)) as (g,(aa,bb)); simpl in *; subst.
   injection H2; intros; clear H2.
   destruct H0.
   clear H0 H3.
   destruct g as [|g|g]; destruct bb as [|bb|bb]; simpl in *; try discriminate.
   f_equal.
-  apply Pmult_reg_r with bb.
+  apply Pos.mul_reg_r with bb.
   injection H2; intros.
   rewrite <- H0.
   rewrite H; simpl; auto.
   elim H1; auto.
 Qed.
 
-Lemma Qred_iff : forall q:Q, Qred q = q <-> Zgcd (Qnum q) (QDen q) = 1%Z.
+Lemma Qred_iff : forall q:Q, Qred q = q <-> Z.gcd (Qnum q) (QDen q) = 1%Z.
 Proof.
   split; intros.
   apply Qred_identity2; auto.
@@ -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.
 
@@ -492,7 +488,7 @@ Definition Qc_eq_bool (x y : Qc) :=
 
 Lemma Qc_eq_bool_correct : forall x y : Qc, Qc_eq_bool x y = true -> x=y.
 Proof.
-  intros x y; unfold Qc_eq_bool in |- *; case (Qc_eq_dec x y); simpl in |- *; auto.
+  intros x y; unfold Qc_eq_bool; case (Qc_eq_dec x y); simpl; auto.
   intros _ H; inversion H.
 Qed.
 
diff --git a/theories/QArith/Qfield.v b/theories/QArith/Qfield.v
index 81d59714..3e162cdc 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-2012     *)
 (*   \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.
@@ -40,7 +38,7 @@ Proof.
   exact Hp.
 Qed.
 
-Lemma Qpower_theory : power_theory 1 Qmult Qeq Z_of_N Qpower.
+Lemma Qpower_theory : power_theory 1 Qmult Qeq Z.of_N Qpower.
 Proof.
 constructor.
 intros r [|n];
@@ -68,7 +66,7 @@ Ltac Qpow_tac t :=
   match t with
   | Z0 => N0
   | Zpos ?n => Ncst (Npos n)
-  | Z_of_N ?n => Ncst n
+  | Z.of_N ?n => Ncst n
   | NtoZ ?n => Ncst n
   | _ => NotConstant
   end.
diff --git a/theories/QArith/Qminmax.v b/theories/QArith/Qminmax.v
index a458fc6e..2b6c3980 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-2012     *)
 (*   \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..5d494c7c 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -101,10 +101,9 @@ Lemma Qpower_plus_positive : forall a n m, Qpower_positive a (n+m) == (Qpower_po
 Proof.
 intros a n m.
 unfold Qpower_positive.
-apply pow_pos_Pplus.
+apply pow_pos_add.
 apply Q_Setoid.
 apply Qmult_comp.
-apply Qmult_comm.
 apply Qmult_assoc.
 Qed.
 
@@ -114,21 +113,18 @@ intros a [|n|n]; simpl; try reflexivity.
 symmetry; apply Qinv_involutive.
 Qed.
 
-Lemma Qpower_minus_positive : forall a (n m:positive), (Pcompare n m Eq=Gt)%positive -> Qpower_positive a (n-m)%positive == (Qpower_positive a n)/(Qpower_positive a m).
+Lemma Qpower_minus_positive : forall a (n m:positive),
+  (m < n)%positive ->
+  Qpower_positive a (n-m)%positive == (Qpower_positive a n)/(Qpower_positive a m).
 Proof.
 intros a n m H.
-destruct (Qeq_dec a 0).
- rewrite q.
- repeat rewrite Qpower_positive_0.
- reflexivity.
-rewrite <- (Qdiv_mult_l (Qpower_positive a (n - m)) (Qpower_positive a m)) by
- (apply Qpower_not_0_positive; assumption).
-apply Qdiv_comp;[|reflexivity].
-rewrite Qmult_comm.
-rewrite <- Qpower_plus_positive.
-rewrite Pplus_minus.
-reflexivity.
-assumption.
+destruct (Qeq_dec a 0) as [EQ|NEQ].
+- now rewrite EQ, !Qpower_positive_0.
+- rewrite <- (Qdiv_mult_l (Qpower_positive a (n - m)) (Qpower_positive a m)) by
+   (now apply Qpower_not_0_positive).
+  f_equiv.
+  rewrite <- Qpower_plus_positive.
+  now rewrite Pos.sub_add.
 Qed.
 
 Lemma Qpower_plus : forall a n m, ~a==0 -> a^(n+m) == a^n*a^m.
@@ -136,12 +132,10 @@ 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;
  assumption.
 Qed.
 
@@ -158,13 +152,14 @@ apply Qpower_plus.
 assumption.
 Qed.
 
-Lemma Qpower_mult_positive : forall a n m, Qpower_positive a (n*m) == Qpower_positive (Qpower_positive a n) m.
+Lemma Qpower_mult_positive : forall a n m,
+  Qpower_positive a (n*m) == Qpower_positive (Qpower_positive a n) m.
 Proof.
 intros a n m.
-induction n using Pind.
+induction n using Pos.peano_ind.
  reflexivity.
-rewrite Pmult_Sn_m.
-rewrite Pplus_one_succ_l.
+rewrite Pos.mul_succ_l.
+rewrite <- Pos.add_1_l.
 do 2 rewrite Qpower_plus_positive.
 rewrite IHn.
 rewrite Qmult_power_positive.
@@ -184,11 +179,11 @@ Qed.
 Lemma Zpower_Qpower : forall (a n:Z), (0<=n)%Z -> inject_Z (a^n) == (inject_Z a)^n.
 Proof.
 intros a [|n|n] H;[reflexivity| |elim H; reflexivity].
-induction n using Pind.
+induction n using Pos.peano_ind.
  replace (a^1)%Z with a by ring.
  ring.
-rewrite Zpos_succ_morphism.
-unfold Zsucc.
+rewrite Pos2Z.inj_succ.
+unfold Z.succ.
 rewrite Zpower_exp; auto with *; try discriminate.
 rewrite Qpower_plus' by discriminate.
 rewrite <- IHn by discriminate.
@@ -209,31 +204,20 @@ setoid_replace (0+ - a) with (-a) in A by ring.
 apply Qmult_le_0_compat; assumption.
 Qed.
 
-Theorem Qpower_decomp: forall p x y,
-  Qpower_positive (x #y) p == x ^ Zpos p # (Z2P ((Zpos y) ^ Zpos p)).
-Proof.
-induction p; intros; unfold Qmult; simpl.
-(* xI *)
-rewrite IHp, xI_succ_xO, <-Pplus_diag, Pplus_one_succ_l.
-repeat rewrite Zpower_pos_is_exp.
-red; unfold Qmult, Qnum, Qden, Zpower.
-repeat rewrite Zpos_mult_morphism.
-repeat rewrite Z2P_correct.
-repeat rewrite Zpower_pos_1_r; ring.
-apply Zpower_pos_pos; red; auto.
-repeat apply Zmult_lt_0_compat; red; auto;
- apply Zpower_pos_pos; red; auto.
-(* xO *)
-rewrite IHp, <-Pplus_diag.
-repeat rewrite Zpower_pos_is_exp.
-red; unfold Qmult, Qnum, Qden, Zpower.
-repeat rewrite Zpos_mult_morphism.
-repeat rewrite Z2P_correct; try ring.
-apply Zpower_pos_pos; red; auto.
-repeat apply Zmult_lt_0_compat; auto;
- apply Zpower_pos_pos; red; auto.
-(* xO *)
-unfold Qmult; simpl.
-red; simpl; rewrite Zpower_pos_1_r;
- rewrite Zpos_mult_morphism; ring.
+Theorem Qpower_decomp p x y :
+  Qpower_positive (x#y) p = x ^ Zpos p # (y ^ p).
+Proof.
+induction p; intros; simpl Qpower_positive; rewrite ?IHp.
+- (* xI *)
+  unfold Qmult, Qnum, Qden. f_equal.
+  + now rewrite <- Z.pow_twice_r, <- Z.pow_succ_r.
+  + apply Pos2Z.inj; rewrite !Pos2Z.inj_mul, !Pos2Z.inj_pow.
+    now rewrite <- Z.pow_twice_r, <- Z.pow_succ_r.
+- (* xO *)
+  unfold Qmult, Qnum, Qden. f_equal.
+  + now rewrite <- Z.pow_twice_r.
+  + apply Pos2Z.inj; rewrite !Pos2Z.inj_mul, !Pos2Z.inj_pow.
+    now rewrite <- Z.pow_twice_r.
+- (* xO *)
+  now rewrite Z.pow_1_r, Pos.pow_1_r.
 Qed.
diff --git a/theories/QArith/Qreals.v b/theories/QArith/Qreals.v
index 8a0ebcff..0c7a22bf 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-2012     *)
 (*   \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.
 
@@ -23,7 +21,7 @@ Hint Resolve IZR_nz Rmult_integral_contrapositive.
 
 Lemma eqR_Qeq : forall x y : Q, Q2R x = Q2R y -> x==y.
 Proof.
-unfold Qeq, Q2R in |- *; intros (x1, x2) (y1, y2); unfold Qnum, Qden in |- *;
+unfold Qeq, Q2R; intros (x1, x2) (y1, y2); unfold Qnum, Qden;
  intros.
 apply eq_IZR.
 do 2 rewrite mult_IZR.
@@ -38,24 +36,24 @@ Qed.
 
 Lemma Qeq_eqR : forall x y : Q, x==y -> Q2R x = Q2R y.
 Proof.
-unfold Qeq, Q2R in |- *; intros (x1, x2) (y1, y2); unfold Qnum, Qden in |- *;
+unfold Qeq, Q2R; intros (x1, x2) (y1, y2); unfold Qnum, Qden;
  intros.
 set (X1 := IZR x1) in *; assert (X2nz := IZR_nz x2);
  set (X2 := IZR (Zpos x2)) in *.
 set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2);
  set (Y2 := IZR (Zpos y2)) in *.
 assert ((X1 * Y2)%R = (Y1 * X2)%R).
- unfold X1, X2, Y1, Y2 in |- *; do 2 rewrite <- mult_IZR.
+ unfold X1, X2, Y1, Y2; do 2 rewrite <- mult_IZR.
  apply IZR_eq; auto.
 clear H.
 field_simplify_eq; auto.
 ring_simplify X1 Y2 (Y2 * X1)%R.
-rewrite H0 in |- *;  ring.
+rewrite H0;  ring.
 Qed.
 
 Lemma Rle_Qle : forall x y : Q, (Q2R x <= Q2R y)%R -> x<=y.
 Proof.
-unfold Qle, Q2R in |- *; intros (x1, x2) (y1, y2); unfold Qnum, Qden in |- *;
+unfold Qle, Q2R; intros (x1, x2) (y1, y2); unfold Qnum, Qden;
  intros.
 apply le_IZR.
 do 2 rewrite mult_IZR.
@@ -67,37 +65,37 @@ replace (X1 * Y2)%R with (X1 * / X2 * (X2 * Y2))%R; try (field; auto).
 replace (Y1 * X2)%R with (Y1 * / Y2 * (X2 * Y2))%R; try (field; auto).
 apply Rmult_le_compat_r; auto.
 apply Rmult_le_pos.
-unfold X2 in |- *; replace 0%R with (IZR 0); auto; apply IZR_le;
+unfold X2; replace 0%R with (IZR 0); auto; apply IZR_le;
  auto with zarith.
-unfold Y2 in |- *; replace 0%R with (IZR 0); auto; apply IZR_le;
+unfold Y2; replace 0%R with (IZR 0); auto; apply IZR_le;
  auto with zarith.
 Qed.
 
 Lemma Qle_Rle : forall x y : Q, x<=y -> (Q2R x <= Q2R y)%R.
 Proof.
-unfold Qle, Q2R in |- *; intros (x1, x2) (y1, y2); unfold Qnum, Qden in |- *;
+unfold Qle, Q2R; intros (x1, x2) (y1, y2); unfold Qnum, Qden;
  intros.
 set (X1 := IZR x1) in *; assert (X2nz := IZR_nz x2);
  set (X2 := IZR (Zpos x2)) in *.
 set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2);
  set (Y2 := IZR (Zpos y2)) in *.
 assert (X1 * Y2 <= Y1 * X2)%R.
- unfold X1, X2, Y1, Y2 in |- *; do 2 rewrite <- mult_IZR.
+ unfold X1, X2, Y1, Y2; do 2 rewrite <- mult_IZR.
  apply IZR_le; auto.
 clear H.
 replace (X1 * / X2)%R with (X1 * Y2 * (/ X2 * / Y2))%R; try (field; auto).
 replace (Y1 * / Y2)%R with (Y1 * X2 * (/ X2 * / Y2))%R; try (field; auto).
 apply Rmult_le_compat_r; auto.
 apply Rmult_le_pos; apply Rlt_le; apply Rinv_0_lt_compat.
-unfold X2 in |- *; replace 0%R with (IZR 0); auto; apply IZR_lt; red in |- *;
+unfold X2; replace 0%R with (IZR 0); auto; apply IZR_lt; red;
  auto with zarith.
-unfold Y2 in |- *; replace 0%R with (IZR 0); auto; apply IZR_lt; red in |- *;
+unfold Y2; replace 0%R with (IZR 0); auto; apply IZR_lt; red;
  auto with zarith.
 Qed.
 
 Lemma Rlt_Qlt : forall x y : Q, (Q2R x < Q2R y)%R -> x<y.
 Proof.
-unfold Qlt, Q2R in |- *; intros (x1, x2) (y1, y2); unfold Qnum, Qden in |- *;
+unfold Qlt, Q2R; intros (x1, x2) (y1, y2); unfold Qnum, Qden;
  intros.
 apply lt_IZR.
 do 2 rewrite mult_IZR.
@@ -109,38 +107,38 @@ replace (X1 * Y2)%R with (X1 * / X2 * (X2 * Y2))%R; try (field; auto).
 replace (Y1 * X2)%R with (Y1 * / Y2 * (X2 * Y2))%R; try (field; auto).
 apply Rmult_lt_compat_r; auto.
 apply Rmult_lt_0_compat.
-unfold X2 in |- *; replace 0%R with (IZR 0); auto; apply IZR_lt; red in |- *;
+unfold X2; replace 0%R with (IZR 0); auto; apply IZR_lt; red;
  auto with zarith.
-unfold Y2 in |- *; replace 0%R with (IZR 0); auto; apply IZR_lt; red in |- *;
+unfold Y2; replace 0%R with (IZR 0); auto; apply IZR_lt; red;
  auto with zarith.
 Qed.
 
 Lemma Qlt_Rlt : forall x y : Q, x<y -> (Q2R x < Q2R y)%R.
 Proof.
-unfold Qlt, Q2R in |- *; intros (x1, x2) (y1, y2); unfold Qnum, Qden in |- *;
+unfold Qlt, Q2R; intros (x1, x2) (y1, y2); unfold Qnum, Qden;
  intros.
 set (X1 := IZR x1) in *; assert (X2nz := IZR_nz x2);
  set (X2 := IZR (Zpos x2)) in *.
 set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2);
  set (Y2 := IZR (Zpos y2)) in *.
 assert (X1 * Y2 < Y1 * X2)%R.
- unfold X1, X2, Y1, Y2 in |- *; do 2 rewrite <- mult_IZR.
+ unfold X1, X2, Y1, Y2; do 2 rewrite <- mult_IZR.
  apply IZR_lt; auto.
 clear H.
 replace (X1 * / X2)%R with (X1 * Y2 * (/ X2 * / Y2))%R; try (field; auto).
 replace (Y1 * / Y2)%R with (Y1 * X2 * (/ X2 * / Y2))%R; try (field; auto).
 apply Rmult_lt_compat_r; auto.
 apply Rmult_lt_0_compat; apply Rinv_0_lt_compat.
-unfold X2 in |- *; replace 0%R with (IZR 0); auto; apply IZR_lt; red in |- *;
+unfold X2; replace 0%R with (IZR 0); auto; apply IZR_lt; red;
  auto with zarith.
-unfold Y2 in |- *; replace 0%R with (IZR 0); auto; apply IZR_lt; red in |- *;
+unfold Y2; replace 0%R with (IZR 0); auto; apply IZR_lt; red;
  auto with zarith.
 Qed.
 
 Lemma Q2R_plus : forall x y : Q, Q2R (x+y) = (Q2R x + Q2R y)%R.
 Proof.
-unfold Qplus, Qeq, Q2R in |- *; intros (x1, x2) (y1, y2);
- unfold Qden, Qnum in |- *.
+unfold Qplus, Qeq, Q2R; intros (x1, x2) (y1, y2);
+ unfold Qden, Qnum.
 simpl_mult.
 rewrite plus_IZR.
 do 3 rewrite mult_IZR.
@@ -149,8 +147,8 @@ Qed.
 
 Lemma Q2R_mult : forall x y : Q, Q2R (x*y) = (Q2R x * Q2R y)%R.
 Proof.
-unfold Qmult, Qeq, Q2R in |- *; intros (x1, x2) (y1, y2);
- unfold Qden, Qnum in |- *.
+unfold Qmult, Qeq, Q2R; intros (x1, x2) (y1, y2);
+ unfold Qden, Qnum.
 simpl_mult.
 do 2 rewrite mult_IZR.
 field; auto.
@@ -158,24 +156,24 @@ Qed.
 
 Lemma Q2R_opp : forall x : Q, Q2R (- x) = (- Q2R x)%R.
 Proof.
-unfold Qopp, Qeq, Q2R in |- *; intros (x1, x2); unfold Qden, Qnum in |- *.
+unfold Qopp, Qeq, Q2R; intros (x1, x2); unfold Qden, Qnum.
 rewrite Ropp_Ropp_IZR.
 field; auto.
 Qed.
 
 Lemma Q2R_minus : forall x y : Q, Q2R (x-y) = (Q2R x - Q2R y)%R.
-unfold Qminus in |- *; intros; rewrite Q2R_plus; rewrite Q2R_opp; auto.
+unfold Qminus; intros; rewrite Q2R_plus; rewrite Q2R_opp; auto.
 Qed.
 
 Lemma Q2R_inv : forall x : Q, ~ x==0 -> Q2R (/x) = (/ Q2R x)%R.
 Proof.
-unfold Qinv, Q2R, Qeq in |- *; intros (x1, x2); unfold Qden, Qnum in |- *.
+unfold Qinv, Q2R, Qeq; intros (x1, x2); unfold Qden, Qnum.
 case x1.
-simpl in |- *; intros; elim H; trivial.
+simpl; intros; elim H; trivial.
 intros; field; auto.
 intros;
-  change (IZR (Zneg x2)) with (- IZR (' x2))%R in |- *;
-  change (IZR (Zneg p)) with (- IZR (' p))%R in |- *;
+  change (IZR (Zneg x2)) with (- IZR (' x2))%R;
+  change (IZR (Zneg p)) with (- IZR (' p))%R;
   field; (*auto 8 with real.*)
   repeat split; auto; auto with real.
 Qed.
@@ -183,7 +181,7 @@ Qed.
 Lemma Q2R_div :
  forall x y : Q, ~ y==0 -> Q2R (x/y) = (Q2R x / Q2R y)%R.
 Proof.
-unfold Qdiv, Rdiv in |- *.
+unfold Qdiv, Rdiv.
 intros; rewrite Q2R_mult.
 rewrite Q2R_inv; auto.
 Qed.
@@ -207,7 +205,7 @@ Qed.
 Let ex2 : forall x y : Q, ~ y==0 -> (x/y)*y == x.
 intros; QField.
 intro; apply H; apply eqR_Qeq.
-rewrite H0; unfold Q2R in |- *; simpl in |- *; field; auto with real.
+rewrite H0; unfold Q2R; simpl; 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..3b3a30eb 100644
--- a/theories/QArith/Qreduction.v
+++ b/theories/QArith/Qreduction.v
@@ -1,65 +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-2012     *)
 (*   \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.
 Require Import Znumtheory.
 
-(** First, a function that (tries to) build a positive back from a Z. *)
-
-Definition Z2P (z : Z) :=
-  match z with
-  | Z0 => 1%positive
-  | Zpos p => p
-  | Zneg p => p
-  end.
-
-Lemma Z2P_correct : forall z : Z, (0 < z)%Z -> Zpos (Z2P z) = z.
-Proof.
- simple destruct z; simpl in |- *; auto; intros; discriminate.
-Qed.
-
-Lemma Z2P_correct2 : forall z : Z, 0%Z <> z -> Zpos (Z2P z) = Zabs z.
-Proof.
- simple destruct z; simpl in |- *; auto; intros; elim H; auto.
-Qed.
+Notation Z2P := Z.to_pos (compat "8.3").
+Notation Z2P_correct := Z2Pos.id (compat "8.3").
 
-(** Simplification of fractions using [Zgcd].
+(** Simplification of fractions using [Z.gcd].
   This version can compute within Coq. *)
 
 Definition Qred (q:Q) :=
   let (q1,q2) := q in
-  let (r1,r2) := snd (Zggcd q1 ('q2))
-  in r1#(Z2P r2).
+  let (r1,r2) := snd (Z.ggcd q1 ('q2))
+  in r1#(Z.to_pos r2).
 
 Lemma Qred_correct : forall q, (Qred q) == q.
 Proof.
   unfold Qred, Qeq; intros (n,d); simpl.
-  generalize (Zggcd_gcd n ('d)) (Zgcd_is_pos n ('d))
-    (Zgcd_is_gcd n ('d)) (Zggcd_correct_divisors n ('d)).
-  destruct (Zggcd n (Zpos d)) as (g,(nn,dd)); simpl.
+  generalize (Z.ggcd_gcd n ('d)) (Z.gcd_nonneg n ('d))
+    (Z.ggcd_correct_divisors n ('d)).
+  destruct (Z.ggcd 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 Z2Pos.id. ring.
+  rewrite <- (Z.mul_pos_cancel_l g); [now rewrite <- Hd | omega].
   Close Scope Z_scope.
 Qed.
 
@@ -68,71 +42,54 @@ Proof.
   intros (a,b) (c,d).
   unfold Qred, Qeq in *; simpl in *.
   Open Scope Z_scope.
-  generalize (Zggcd_gcd a ('b)) (Zgcd_is_gcd a ('b))
-    (Zgcd_is_pos a ('b)) (Zggcd_correct_divisors a ('b)).
-  destruct (Zggcd a (Zpos b)) as (g,(aa,bb)).
-  generalize (Zggcd_gcd c ('d)) (Zgcd_is_gcd c ('d))
-    (Zgcd_is_pos c ('d)) (Zggcd_correct_divisors c ('d)).
-  destruct (Zggcd c (Zpos d)) as (g',(cc,dd)).
-  simpl.
-  intro H; rewrite <- H; clear H.
-  intros Hg'1 Hg'2 (Hg'3,Hg'4).
-  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.
+  intros H.
+  generalize (Z.ggcd_gcd a ('b)) (Zgcd_is_gcd a ('b))
+    (Z.gcd_nonneg a ('b)) (Z.ggcd_correct_divisors a ('b)).
+  destruct (Z.ggcd a (Zpos b)) as (g,(aa,bb)).
+  simpl. intros <- Hg1 Hg2 (Hg3,Hg4).
+  assert (Hg0 : g <> 0) by (intro; now subst g).
+  generalize (Z.ggcd_gcd c ('d)) (Zgcd_is_gcd c ('d))
+    (Z.gcd_nonneg c ('d)) (Z.ggcd_correct_divisors c ('d)).
+  destruct (Z.ggcd c (Zpos d)) as (g',(cc,dd)).
+  simpl. intros <- Hg'1 Hg'2 (Hg'3,Hg'4).
+  assert (Hg'0 : g' <> 0) by (intro; now subst g').
+
   elim (rel_prime_cross_prod aa bb cc dd).
-  congruence.
-  unfold rel_prime in |- *.
-  (*rel_prime*)
-  constructor.
-  exists aa; auto with zarith.
-  exists bb; auto with zarith.
-  intros.
-  inversion Hg1.
-  destruct (H6 (g*x)).
-  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.
-  (* /rel_prime *)
-  unfold rel_prime in |- *.
-  (* rel_prime *)
-  constructor.
-  exists cc; auto with zarith.
-  exists dd; auto with zarith.
-  intros.
-  inversion Hg'1.
-  destruct (H6 (g'*x)).
-  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.
-    (* /rel_prime *)
-  assert (0<bb); [|auto with zarith].
-  apply Zmult_gt_0_lt_0_reg_r with g.
-  omega.
-  rewrite Zmult_comm.
-  rewrite <- Hg4; compute; auto.
-  assert (0<dd); [|auto with zarith].
-  apply Zmult_gt_0_lt_0_reg_r with g'.
-  omega.
-  rewrite Zmult_comm.
-  rewrite <- Hg'4; compute; auto.
-  apply Zmult_reg_l with (g'*g).
-  intro H2; elim (Zmult_integral _ _ H2); auto.
-  replace (g'*g*(aa*dd)) with ((g*aa)*(g'*dd)); [|ring].
-  replace (g'*g*(bb*cc)) with ((g'*cc)*(g*bb)); [|ring].
-  rewrite <- Hg3; rewrite <- Hg4; rewrite <- Hg'3; rewrite <- Hg'4; auto.
+  - congruence.
+  - (*rel_prime*)
+    constructor.
+    * exists aa; auto with zarith.
+    * exists bb; auto with zarith.
+    * intros x Ha Hb.
+      destruct Hg1 as (Hg11,Hg12,Hg13).
+      destruct (Hg13 (g*x)) as (x',Hx).
+      { rewrite Hg3.
+        destruct Ha as (xa,Hxa); exists xa; rewrite Hxa; ring. }
+      { rewrite Hg4.
+        destruct Hb as (xb,Hxb); exists xb; rewrite Hxb; ring. }
+      exists x'.
+      apply Z.mul_reg_l with g; auto. rewrite Hx at 1; ring.
+  - (* rel_prime *)
+    constructor.
+    * exists cc; auto with zarith.
+    * exists dd; auto with zarith.
+    * intros x Hc Hd.
+      inversion Hg'1 as (Hg'11,Hg'12,Hg'13).
+      destruct (Hg'13 (g'*x)) as (x',Hx).
+      { rewrite Hg'3.
+        destruct Hc as (xc,Hxc); exists xc; rewrite Hxc; ring. }
+      { rewrite Hg'4.
+        destruct Hd as (xd,Hxd); exists xd; rewrite Hxd; ring. }
+      exists x'.
+      apply Z.mul_reg_l with g'; auto. rewrite Hx at 1; ring.
+  - apply Z.lt_gt.
+    rewrite <- (Z.mul_pos_cancel_l g); [now rewrite <- Hg4 | omega].
+  - apply Z.lt_gt.
+    rewrite <- (Z.mul_pos_cancel_l g'); [now rewrite <- Hg'4 | omega].
+  - apply Z.mul_reg_l with (g*g').
+    * rewrite Z.mul_eq_0. now destruct 1.
+    * rewrite Z.mul_shuffle1, <- Hg3, <- Hg'4.
+      now rewrite Z.mul_shuffle1, <- Hg'3, <- Hg4, H, Z.mul_comm.
   Close Scope Z_scope.
 Qed.
 
@@ -149,39 +106,39 @@ Definition Qminus' x y := Qred (Qminus x y).
 
 Lemma Qplus'_correct : forall p q : Q, (Qplus' p q)==(Qplus p q).
 Proof.
-  intros; unfold Qplus' in |- *; apply Qred_correct; auto.
+  intros; unfold Qplus'; apply Qred_correct; auto.
 Qed.
 
 Lemma Qmult'_correct : forall p q : Q, (Qmult' p q)==(Qmult p q).
 Proof.
-  intros; unfold Qmult' in |- *; apply Qred_correct; auto.
+  intros; unfold Qmult'; apply Qred_correct; auto.
 Qed.
 
 Lemma Qminus'_correct : forall p q : Q, (Qminus' p q)==(Qminus p q).
 Proof.
-  intros; unfold Qminus' in |- *; apply Qred_correct; auto.
+  intros; unfold Qminus'; apply Qred_correct; auto.
 Qed.
 
 Add Morphism Qplus' : Qplus'_comp.
 Proof.
-  intros; unfold Qplus' in |- *.
-  rewrite H; rewrite H0; auto with qarith.
+  intros; unfold Qplus'.
+  rewrite H, H0; auto with qarith.
 Qed.
 
 Add Morphism Qmult' : Qmult'_comp.
-  intros; unfold Qmult' in |- *.
-  rewrite H; rewrite H0; auto with qarith.
+  intros; unfold Qmult'.
+  rewrite H, H0; auto with qarith.
 Qed.
 
 Add Morphism Qminus' : Qminus'_comp.
-  intros; unfold Qminus' in |- *.
-  rewrite H; rewrite H0; auto with qarith.
+  intros; unfold Qminus'.
+  rewrite H, H0; auto with qarith.
 Qed.
 
 Lemma Qred_opp: forall q, Qred (-q) = - (Qred q).
 Proof.
   intros (x, y); unfold Qred; simpl.
-  rewrite Zggcd_opp; case Zggcd; intros p1 (p2, p3); simpl.
+  rewrite Z.ggcd_opp; case Z.ggcd; intros p1 (p2, p3); simpl.
   unfold Qopp; auto.
 Qed.
 
@@ -190,4 +147,3 @@ Theorem Qred_compare: forall x y,
 Proof.
   intros x y; apply Qcompare_comp; apply Qeq_sym; apply Qred_correct.
 Qed.
-
diff --git a/theories/QArith/Qring.v b/theories/QArith/Qring.v
index 173136b8..39e023cf 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-2012     *)
 (*   \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..be328c27 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -11,16 +11,16 @@ Require Import QArith.
 Lemma Qopp_lt_compat: forall p q : Q, p < q -> - q < - p.
 Proof.
 intros (a1,a2) (b1,b2); unfold Qle, Qlt; simpl.
-do 2 rewrite <- Zopp_mult_distr_l; omega.
+rewrite !Z.mul_opp_l; omega.
 Qed.
 
 Hint Resolve Qopp_lt_compat : qarith.
 
 (************)
 
-Coercion Local inject_Z : Z >-> Q.
+Local Coercion inject_Z : Z >-> Q.
 
-Definition Qfloor (x:Q) := let (n,d) := x in Zdiv n (Zpos d).
+Definition Qfloor (x:Q) := let (n,d) := x in Z.div n (Zpos d).
 Definition Qceiling (x:Q) := (-(Qfloor (-x)))%Z.
 
 Lemma Qfloor_Z : forall z:Z, Qfloor z = z.
@@ -46,7 +46,7 @@ simpl.
 unfold Qle.
 simpl.
 replace (n*1)%Z with n by ring.
-rewrite Zmult_comm.
+rewrite Z.mul_comm.
 apply Z_mult_div_ge.
 auto with *.
 Qed.
@@ -81,7 +81,7 @@ ring_simplify.
 replace (n / ' d * ' d + ' d)%Z with
   (('d * (n / 'd) + n mod 'd) + 'd - n mod 'd)%Z by ring.
 rewrite <- Z_div_mod_eq; auto with*.
-rewrite <- Zlt_plus_swap.
+rewrite <- Z.lt_add_lt_sub_r.
 destruct (Z_mod_lt n ('d)); auto with *.
 Qed.
 
@@ -107,7 +107,7 @@ unfold Qle in *.
 simpl in *.
 rewrite <- (Zdiv_mult_cancel_r xn ('xd) ('yd)); auto with *.
 rewrite <- (Zdiv_mult_cancel_r yn ('yd) ('xd)); auto with *.
-rewrite (Zmult_comm ('yd) ('xd)).
+rewrite (Z.mul_comm ('yd) ('xd)).
 apply Z_div_le; auto with *.
 Qed.
 
@@ -125,7 +125,7 @@ Hint Resolve Qceiling_resp_le : qarith.
 Add Morphism Qfloor with signature Qeq ==> eq as Qfloor_comp.
 Proof.
 intros x y H.
-apply Zle_antisym.
+apply Z.le_antisymm.
  auto with *.
 symmetry in H; auto with *.
 Qed.
@@ -133,7 +133,18 @@ Qed.
 Add Morphism Qceiling with signature Qeq ==> eq as Qceiling_comp.
 Proof.
 intros x y H.
-apply Zle_antisym.
+apply Z.le_antisymm.
  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, Z.mul_0_r.
+  now rewrite Z.mul_1_r.
+ rewrite <- Z.opp_eq_mul_m1.
+ rewrite <- (Z.opp_involutive (Zpos p)).
+ now rewrite Zdiv_opp_opp.
+Qed.
diff --git a/theories/Reals/Alembert.v b/theories/Reals/Alembert.v
index 092eafa3..13b33301 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-2012     *)
 (*   \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.
@@ -15,7 +13,7 @@ Require Import SeqProp.
 Require Import PartSum.
 Require Import Max.
 
-Open Local Scope R_scope.
+Local Open Scope R_scope.
 
 (***************************************************)
 (* Various versions of the criterion of D'Alembert *)
@@ -33,23 +31,23 @@ Proof.
       { l:R | Un_cv (fun N:nat => sum_f_R0 An N) l }).
   intro X; apply X.
   apply completeness.
-  unfold Un_cv in H0; unfold bound in |- *; cut (0 < / 2);
+  unfold Un_cv in H0; unfold bound; cut (0 < / 2);
     [ intro | apply Rinv_0_lt_compat; prove_sup0 ].
   elim (H0 (/ 2) H1); intros.
   exists (sum_f_R0 An x + 2 * An (S x)).
-  unfold is_upper_bound in |- *; intros; unfold EUn in H3; elim H3; intros.
+  unfold is_upper_bound; intros; unfold EUn in H3; elim H3; intros.
   rewrite H4; assert (H5 := lt_eq_lt_dec x1 x).
   elim H5; intros.
   elim a; intro.
   replace (sum_f_R0 An x) with
     (sum_f_R0 An x1 + sum_f_R0 (fun i:nat => An (S x1 + i)%nat) (x - S x1)).
-  pattern (sum_f_R0 An x1) at 1 in |- *; rewrite <- Rplus_0_r;
+  pattern (sum_f_R0 An x1) at 1; rewrite <- Rplus_0_r;
     rewrite Rplus_assoc; apply Rplus_le_compat_l.
   left; apply Rplus_lt_0_compat.
   apply tech1; intros; apply H.
   apply Rmult_lt_0_compat; [ prove_sup0 | apply H ].
-  symmetry  in |- *; apply tech2; assumption.
-  rewrite b; pattern (sum_f_R0 An x) at 1 in |- *; rewrite <- Rplus_0_r;
+  symmetry ; apply tech2; assumption.
+  rewrite b; pattern (sum_f_R0 An x) at 1; rewrite <- Rplus_0_r;
     apply Rplus_le_compat_l.
   left; apply Rmult_lt_0_compat; [ prove_sup0 | apply H ].
   replace (sum_f_R0 An x1) with
@@ -66,14 +64,14 @@ Proof.
   left; apply H.
   rewrite tech3.
   replace (1 - / 2) with (/ 2).
-  unfold Rdiv in |- *; rewrite Rinv_involutive.
-  pattern 2 at 3 in |- *; rewrite <- Rmult_1_r; rewrite <- (Rmult_comm 2);
+  unfold Rdiv; rewrite Rinv_involutive.
+  pattern 2 at 3; rewrite <- Rmult_1_r; rewrite <- (Rmult_comm 2);
     apply Rmult_le_compat_l.
   left; prove_sup0.
   left; apply Rplus_lt_reg_r with ((/ 2) ^ S (x1 - S x)).
   replace ((/ 2) ^ S (x1 - S x) + (1 - (/ 2) ^ S (x1 - S x))) with 1;
     [ idtac | ring ].
-  rewrite <- (Rplus_comm 1); pattern 1 at 1 in |- *; rewrite <- Rplus_0_r;
+  rewrite <- (Rplus_comm 1); pattern 1 at 1; rewrite <- Rplus_0_r;
     apply Rplus_lt_compat_l.
   apply pow_lt; apply Rinv_0_lt_compat; prove_sup0.
   discrR.
@@ -82,14 +80,14 @@ Proof.
   ring.
   discrR.
   discrR.
-  pattern 1 at 3 in |- *; replace 1 with (/ 1);
+  pattern 1 at 3; replace 1 with (/ 1);
     [ apply tech7; discrR | apply Rinv_1 ].
   replace (An (S x)) with (An (S x + 0)%nat).
   apply (tech6 (fun i:nat => An (S x + i)%nat) (/ 2)).
   left; apply Rinv_0_lt_compat; prove_sup0.
   intro; cut (forall n:nat, (n >= x)%nat -> An (S n) < / 2 * An n).
   intro; replace (S x + S i)%nat with (S (S x + i)).
-  apply H6; unfold ge in |- *; apply tech8.
+  apply H6; unfold ge; apply tech8.
   apply INR_eq; rewrite S_INR; do 2 rewrite plus_INR; do 2 rewrite S_INR; ring.
   intros; unfold R_dist in H2; apply Rmult_lt_reg_l with (/ An n).
   apply Rinv_0_lt_compat; apply H.
@@ -98,20 +96,20 @@ Proof.
   rewrite Rmult_1_r;
     replace (An (S n) * / An n) with (Rabs (Rabs (An (S n) / An n) - 0)).
   apply H2; assumption.
-  unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r;
+  unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r;
     rewrite Rabs_Rabsolu; rewrite Rabs_right.
-  unfold Rdiv in |- *; reflexivity.
-  left; unfold Rdiv in |- *; change (0 < An (S n) * / An n) in |- *;
+  unfold Rdiv; reflexivity.
+  left; unfold Rdiv; change (0 < An (S n) * / An n);
     apply Rmult_lt_0_compat; [ apply H | apply Rinv_0_lt_compat; apply H ].
-  red in |- *; intro; assert (H8 := H n); rewrite H7 in H8;
+  red; intro; assert (H8 := H n); rewrite H7 in H8;
     elim (Rlt_irrefl _ H8).
   replace (S x + 0)%nat with (S x); [ reflexivity | ring ].
-  symmetry  in |- *; apply tech2; assumption.
-  exists (sum_f_R0 An 0); unfold EUn in |- *; exists 0%nat; reflexivity.
+  symmetry ; apply tech2; assumption.
+  exists (sum_f_R0 An 0); unfold EUn; exists 0%nat; reflexivity.
   intro X; elim X; intros.
-  exists x; apply tech10;
-    [ unfold Un_growing in |- *; intro; rewrite tech5;
-      pattern (sum_f_R0 An n) at 1 in |- *; rewrite <- Rplus_0_r;
+  exists x; apply Un_cv_crit_lub;
+    [ unfold Un_growing; intro; rewrite tech5;
+      pattern (sum_f_R0 An n) at 1; rewrite <- Rplus_0_r;
 	apply Rplus_le_compat_l; left; apply H
       | apply p ].
 Defined.
@@ -133,14 +131,14 @@ Proof.
   assert (H6 := Alembert_C1 Wn H2 H4).
   elim H5; intros.
   elim H6; intros.
-  exists (x - x0); unfold Un_cv in |- *; unfold Un_cv in p;
+  exists (x - x0); unfold Un_cv; unfold Un_cv in p;
     unfold Un_cv in p0; intros; cut (0 < eps / 2).
   intro; elim (p (eps / 2) H8); clear p; intros.
   elim (p0 (eps / 2) H8); clear p0; intros.
   set (N := max x1 x2).
   exists N; intros;
     replace (sum_f_R0 An n) with (sum_f_R0 Vn n - sum_f_R0 Wn n).
-  unfold R_dist in |- *;
+  unfold R_dist;
     replace (sum_f_R0 Vn n - sum_f_R0 Wn n - (x - x0)) with
       (sum_f_R0 Vn n - x + - (sum_f_R0 Wn n - x0)); [ idtac | ring ];
       apply Rle_lt_trans with
@@ -148,29 +146,29 @@ Proof.
   apply Rabs_triang.
   rewrite Rabs_Ropp; apply Rlt_le_trans with (eps / 2 + eps / 2).
   apply Rplus_lt_compat.
-  unfold R_dist in H9; apply H9; unfold ge in |- *; apply le_trans with N;
-    [ unfold N in |- *; apply le_max_l | assumption ].
-  unfold R_dist in H10; apply H10; unfold ge in |- *; apply le_trans with N;
-    [ unfold N in |- *; apply le_max_r | assumption ].
-  right; symmetry  in |- *; apply double_var.
-  symmetry  in |- *; apply tech11; intro; unfold Vn, Wn in |- *;
-    unfold Rdiv in |- *; do 2 rewrite <- (Rmult_comm (/ 2));
+  unfold R_dist in H9; apply H9; unfold ge; apply le_trans with N;
+    [ unfold N; apply le_max_l | assumption ].
+  unfold R_dist in H10; apply H10; unfold ge; apply le_trans with N;
+    [ unfold N; apply le_max_r | assumption ].
+  right; symmetry ; apply double_var.
+  symmetry ; apply tech11; intro; unfold Vn, Wn;
+    unfold Rdiv; do 2 rewrite <- (Rmult_comm (/ 2));
       apply Rmult_eq_reg_l with 2.
   rewrite Rmult_minus_distr_l; repeat rewrite <- Rmult_assoc;
     rewrite <- Rinv_r_sym.
   ring.
   discrR.
   discrR.
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+  unfold Rdiv; apply Rmult_lt_0_compat;
     [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
   cut (forall n:nat, / 2 * Rabs (An n) <= Wn n <= 3 * / 2 * Rabs (An n)).
   intro; cut (forall n:nat, / Wn n <= 2 * / Rabs (An n)).
   intro; cut (forall n:nat, Wn (S n) / Wn n <= 3 * Rabs (An (S n) / An n)).
-  intro; unfold Un_cv in |- *; intros; unfold Un_cv in H0; cut (0 < eps / 3).
+  intro; unfold Un_cv; intros; unfold Un_cv in H0; cut (0 < eps / 3).
   intro; elim (H0 (eps / 3) H8); intros.
   exists x; intros.
   assert (H11 := H9 n H10).
-  unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
+  unfold R_dist; unfold Rminus; rewrite Ropp_0;
     rewrite Rplus_0_r; rewrite Rabs_Rabsolu; unfold R_dist in H11;
       unfold Rminus in H11; rewrite Ropp_0 in H11; rewrite Rplus_0_r in H11;
 	rewrite Rabs_Rabsolu in H11; rewrite Rabs_right.
@@ -181,13 +179,13 @@ Proof.
   rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym; [ idtac | discrR ];
     rewrite Rmult_1_l; rewrite <- (Rmult_comm eps); unfold Rdiv in H11;
       exact H11.
-  left; change (0 < Wn (S n) / Wn n) in |- *; unfold Rdiv in |- *;
+  left; change (0 < Wn (S n) / Wn n); unfold Rdiv;
     apply Rmult_lt_0_compat.
   apply H2.
   apply Rinv_0_lt_compat; apply H2.
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+  unfold Rdiv; apply Rmult_lt_0_compat;
     [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
-  intro; unfold Rdiv in |- *; rewrite Rabs_mult; rewrite <- Rmult_assoc;
+  intro; unfold Rdiv; rewrite Rabs_mult; rewrite <- Rmult_assoc;
     replace 3 with (2 * (3 * / 2));
       [ idtac | rewrite <- Rmult_assoc; apply Rinv_r_simpl_m; discrR ];
       apply Rle_trans with (Wn (S n) * 2 * / Rabs (An n)).
@@ -220,32 +218,32 @@ Proof.
   rewrite Rmult_1_l; elim (H4 n); intros; assumption.
   discrR.
   apply Rabs_no_R0; apply H.
-  red in |- *; intro; assert (H6 := H2 n); rewrite H5 in H6;
+  red; intro; assert (H6 := H2 n); rewrite H5 in H6;
     elim (Rlt_irrefl _ H6).
   intro; split.
-  unfold Wn in |- *; unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2));
+  unfold Wn; unfold Rdiv; rewrite <- (Rmult_comm (/ 2));
     apply Rmult_le_compat_l.
   left; apply Rinv_0_lt_compat; prove_sup0.
-  pattern (Rabs (An n)) at 1 in |- *; rewrite <- Rplus_0_r; rewrite double;
-    unfold Rminus in |- *; rewrite Rplus_assoc; apply Rplus_le_compat_l.
+  pattern (Rabs (An n)) at 1; rewrite <- Rplus_0_r; rewrite double;
+    unfold Rminus; rewrite Rplus_assoc; apply Rplus_le_compat_l.
   apply Rplus_le_reg_l with (An n).
   rewrite Rplus_0_r; rewrite (Rplus_comm (An n)); rewrite Rplus_assoc;
     rewrite Rplus_opp_l; rewrite Rplus_0_r; apply RRle_abs.
-  unfold Wn in |- *; unfold Rdiv in |- *; repeat rewrite <- (Rmult_comm (/ 2));
+  unfold Wn; unfold Rdiv; repeat rewrite <- (Rmult_comm (/ 2));
     repeat rewrite Rmult_assoc; apply Rmult_le_compat_l.
   left; apply Rinv_0_lt_compat; prove_sup0.
-  unfold Rminus in |- *; rewrite double;
+  unfold Rminus; rewrite double;
     replace (3 * Rabs (An n)) with (Rabs (An n) + Rabs (An n) + Rabs (An n));
       [ idtac | ring ]; repeat rewrite Rplus_assoc; repeat apply Rplus_le_compat_l.
   rewrite <- Rabs_Ropp; apply RRle_abs.
   cut (forall n:nat, / 2 * Rabs (An n) <= Vn n <= 3 * / 2 * Rabs (An n)).
   intro; cut (forall n:nat, / Vn n <= 2 * / Rabs (An n)).
   intro; cut (forall n:nat, Vn (S n) / Vn n <= 3 * Rabs (An (S n) / An n)).
-  intro; unfold Un_cv in |- *; intros; unfold Un_cv in H1; cut (0 < eps / 3).
+  intro; unfold Un_cv; intros; unfold Un_cv in H1; cut (0 < eps / 3).
   intro; elim (H0 (eps / 3) H7); intros.
   exists x; intros.
   assert (H10 := H8 n H9).
-  unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
+  unfold R_dist; unfold Rminus; rewrite Ropp_0;
     rewrite Rplus_0_r; rewrite Rabs_Rabsolu; unfold R_dist in H10;
       unfold Rminus in H10; rewrite Ropp_0 in H10; rewrite Rplus_0_r in H10;
 	rewrite Rabs_Rabsolu in H10; rewrite Rabs_right.
@@ -256,13 +254,13 @@ Proof.
   rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym; [ idtac | discrR ];
     rewrite Rmult_1_l; rewrite <- (Rmult_comm eps); unfold Rdiv in H10;
       exact H10.
-  left; change (0 < Vn (S n) / Vn n) in |- *; unfold Rdiv in |- *;
+  left; change (0 < Vn (S n) / Vn n); unfold Rdiv;
     apply Rmult_lt_0_compat.
   apply H1.
   apply Rinv_0_lt_compat; apply H1.
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+  unfold Rdiv; apply Rmult_lt_0_compat;
     [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
-  intro; unfold Rdiv in |- *; rewrite Rabs_mult; rewrite <- Rmult_assoc;
+  intro; unfold Rdiv; rewrite Rabs_mult; rewrite <- Rmult_assoc;
     replace 3 with (2 * (3 * / 2));
       [ idtac | rewrite <- Rmult_assoc; apply Rinv_r_simpl_m; discrR ];
       apply Rle_trans with (Vn (S n) * 2 * / Rabs (An n)).
@@ -295,44 +293,44 @@ Proof.
   rewrite Rmult_1_l; elim (H3 n); intros; assumption.
   discrR.
   apply Rabs_no_R0; apply H.
-  red in |- *; intro; assert (H5 := H1 n); rewrite H4 in H5;
+  red; intro; assert (H5 := H1 n); rewrite H4 in H5;
     elim (Rlt_irrefl _ H5).
   intro; split.
-  unfold Vn in |- *; unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2));
+  unfold Vn; unfold Rdiv; rewrite <- (Rmult_comm (/ 2));
     apply Rmult_le_compat_l.
   left; apply Rinv_0_lt_compat; prove_sup0.
-  pattern (Rabs (An n)) at 1 in |- *; rewrite <- Rplus_0_r; rewrite double;
+  pattern (Rabs (An n)) at 1; rewrite <- Rplus_0_r; rewrite double;
     rewrite Rplus_assoc; apply Rplus_le_compat_l.
   apply Rplus_le_reg_l with (- An n); rewrite Rplus_0_r;
     rewrite <- (Rplus_comm (An n)); rewrite <- Rplus_assoc;
       rewrite Rplus_opp_l; rewrite Rplus_0_l; rewrite <- Rabs_Ropp;
 	apply RRle_abs.
-  unfold Vn in |- *; unfold Rdiv in |- *; repeat rewrite <- (Rmult_comm (/ 2));
+  unfold Vn; unfold Rdiv; repeat rewrite <- (Rmult_comm (/ 2));
     repeat rewrite Rmult_assoc; apply Rmult_le_compat_l.
   left; apply Rinv_0_lt_compat; prove_sup0.
-  unfold Rminus in |- *; rewrite double;
+  unfold Rminus; rewrite double;
     replace (3 * Rabs (An n)) with (Rabs (An n) + Rabs (An n) + Rabs (An n));
       [ idtac | ring ]; repeat rewrite Rplus_assoc; repeat apply Rplus_le_compat_l;
 	apply RRle_abs.
-  intro; unfold Wn in |- *; unfold Rdiv in |- *; rewrite <- (Rmult_0_r (/ 2));
+  intro; unfold Wn; unfold Rdiv; rewrite <- (Rmult_0_r (/ 2));
     rewrite <- (Rmult_comm (/ 2)); apply Rmult_lt_compat_l.
   apply Rinv_0_lt_compat; prove_sup0.
-  apply Rplus_lt_reg_r with (An n); rewrite Rplus_0_r; unfold Rminus in |- *;
+  apply Rplus_lt_reg_r with (An n); rewrite Rplus_0_r; unfold Rminus;
     rewrite (Rplus_comm (An n)); rewrite Rplus_assoc;
       rewrite Rplus_opp_l; rewrite Rplus_0_r;
 	apply Rle_lt_trans with (Rabs (An n)).
   apply RRle_abs.
-  rewrite double; pattern (Rabs (An n)) at 1 in |- *; rewrite <- Rplus_0_r;
+  rewrite double; pattern (Rabs (An n)) at 1; rewrite <- Rplus_0_r;
     apply Rplus_lt_compat_l; apply Rabs_pos_lt; apply H.
-  intro; unfold Vn in |- *; unfold Rdiv in |- *; rewrite <- (Rmult_0_r (/ 2));
+  intro; unfold Vn; unfold Rdiv; rewrite <- (Rmult_0_r (/ 2));
     rewrite <- (Rmult_comm (/ 2)); apply Rmult_lt_compat_l.
   apply Rinv_0_lt_compat; prove_sup0.
-  apply Rplus_lt_reg_r with (- An n); rewrite Rplus_0_r; unfold Rminus in |- *;
+  apply Rplus_lt_reg_r with (- An n); rewrite Rplus_0_r; unfold Rminus;
     rewrite (Rplus_comm (- An n)); rewrite Rplus_assoc;
       rewrite Rplus_opp_r; rewrite Rplus_0_r;
 	apply Rle_lt_trans with (Rabs (An n)).
   rewrite <- Rabs_Ropp; apply RRle_abs.
-  rewrite double; pattern (Rabs (An n)) at 1 in |- *; rewrite <- Rplus_0_r;
+  rewrite double; pattern (Rabs (An n)) at 1; rewrite <- Rplus_0_r;
     apply Rplus_lt_compat_l; apply Rabs_pos_lt; apply H.
 Defined.
 
@@ -349,11 +347,11 @@ Proof.
   intro; assert (H4 := Alembert_C2 Bn H2 H3).
   elim H4; intros.
   exists x0; unfold Bn in p; apply tech12; assumption.
-  unfold Un_cv in |- *; intros; unfold Un_cv in H1; cut (0 < eps / Rabs x).
+  unfold Un_cv; intros; unfold Un_cv in H1; cut (0 < eps / Rabs x).
   intro; elim (H1 (eps / Rabs x) H4); intros.
-  exists x0; intros; unfold R_dist in |- *; unfold Rminus in |- *;
+  exists x0; intros; unfold R_dist; unfold Rminus;
     rewrite Ropp_0; rewrite Rplus_0_r; rewrite Rabs_Rabsolu;
-      unfold Bn in |- *;
+      unfold Bn;
 	replace (An (S n) * x ^ S n / (An n * x ^ n)) with (An (S n) / An n * x).
   rewrite Rabs_mult; apply Rmult_lt_reg_l with (/ Rabs x).
   apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption.
@@ -362,22 +360,22 @@ Proof.
   rewrite Rmult_1_l; rewrite <- (Rmult_comm eps); unfold Rdiv in H5;
     replace (Rabs (An (S n) / An n)) with (R_dist (Rabs (An (S n) * / An n)) 0).
   apply H5; assumption.
-  unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
-    rewrite Rplus_0_r; rewrite Rabs_Rabsolu; unfold Rdiv in |- *;
+  unfold R_dist; unfold Rminus; rewrite Ropp_0;
+    rewrite Rplus_0_r; rewrite Rabs_Rabsolu; unfold Rdiv;
       reflexivity.
   apply Rabs_no_R0; assumption.
   replace (S n) with (n + 1)%nat; [ idtac | ring ]; rewrite pow_add;
-    unfold Rdiv in |- *; rewrite Rinv_mult_distr.
+    unfold Rdiv; rewrite Rinv_mult_distr.
   replace (An (n + 1)%nat * (x ^ n * x ^ 1) * (/ An n * / x ^ n)) with
     (An (n + 1)%nat * x ^ 1 * / An n * (x ^ n * / x ^ n));
     [ idtac | ring ]; rewrite <- Rinv_r_sym.
-  simpl in |- *; ring.
+  simpl; ring.
   apply pow_nonzero; assumption.
   apply H0.
   apply pow_nonzero; assumption.
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+  unfold Rdiv; apply Rmult_lt_0_compat;
     [ assumption | apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption ].
-  intro; unfold Bn in |- *; apply prod_neq_R0;
+  intro; unfold Bn; apply prod_neq_R0;
     [ apply H0 | apply pow_nonzero; assumption ].
 Defined.
 
@@ -385,14 +383,14 @@ Lemma AlembertC3_step2 :
   forall (An:nat -> R) (x:R), x = 0 -> { l:R | Pser An x l }.
 Proof.
   intros; exists (An 0%nat).
-  unfold Pser in |- *; unfold infinite_sum in |- *; intros; exists 0%nat; intros;
+  unfold Pser; unfold infinite_sum; intros; exists 0%nat; intros;
     replace (sum_f_R0 (fun n0:nat => An n0 * x ^ n0) n) with (An 0%nat).
-  unfold R_dist in |- *; unfold Rminus in |- *; rewrite Rplus_opp_r;
+  unfold R_dist; unfold Rminus; rewrite Rplus_opp_r;
     rewrite Rabs_R0; assumption.
   induction  n as [| n Hrecn].
-  simpl in |- *; ring.
+  simpl; ring.
   rewrite tech5; rewrite Hrecn;
-    [ rewrite H; simpl in |- *; ring | unfold ge in |- *; apply le_O_n ].
+    [ rewrite H; simpl; ring | unfold ge; apply le_O_n ].
 Qed.
 
 (** A useful criterion of convergence for power series *)
@@ -406,11 +404,11 @@ Proof.
   elim s; intro.
   cut (x <> 0).
   intro; apply AlembertC3_step1; assumption.
-  red in |- *; intro; rewrite H1 in a; elim (Rlt_irrefl _ a).
+  red; intro; rewrite H1 in a; elim (Rlt_irrefl _ a).
   apply AlembertC3_step2; assumption.
   cut (x <> 0).
   intro; apply AlembertC3_step1; assumption.
-  red in |- *; intro; rewrite H1 in r; elim (Rlt_irrefl _ r).
+  red; intro; rewrite H1 in r; elim (Rlt_irrefl _ r).
 Defined.
 
 Lemma Alembert_C4 :
@@ -430,8 +428,8 @@ Proof.
   elim H1; intros.
   elim H2; intros.
   elim H4; intros.
-  unfold bound in |- *; exists (sum_f_R0 An x0 + / (1 - x) * An (S x0)).
-  unfold is_upper_bound in |- *; intros; unfold EUn in H6.
+  unfold bound; exists (sum_f_R0 An x0 + / (1 - x) * An (S x0)).
+  unfold is_upper_bound; intros; unfold EUn in H6.
   elim H6; intros.
   rewrite H7.
   assert (H8 := lt_eq_lt_dec x2 x0).
@@ -439,7 +437,7 @@ Proof.
   elim a; intro.
   replace (sum_f_R0 An x0) with
     (sum_f_R0 An x2 + sum_f_R0 (fun i:nat => An (S x2 + i)%nat) (x0 - S x2)).
-  pattern (sum_f_R0 An x2) at 1 in |- *; rewrite <- Rplus_0_r.
+  pattern (sum_f_R0 An x2) at 1; rewrite <- Rplus_0_r.
   rewrite Rplus_assoc; apply Rplus_le_compat_l.
   left; apply Rplus_lt_0_compat.
   apply tech1.
@@ -448,8 +446,8 @@ Proof.
   apply Rinv_0_lt_compat; apply Rplus_lt_reg_r with x; rewrite Rplus_0_r;
     replace (x + (1 - x)) with 1; [ elim H3; intros; assumption | ring ].
   apply H.
-  symmetry  in |- *; apply tech2; assumption.
-  rewrite b; pattern (sum_f_R0 An x0) at 1 in |- *; rewrite <- Rplus_0_r;
+  symmetry ; apply tech2; assumption.
+  rewrite b; pattern (sum_f_R0 An x0) at 1; rewrite <- Rplus_0_r;
     apply Rplus_le_compat_l.
   left; apply Rmult_lt_0_compat.
   apply Rinv_0_lt_compat; apply Rplus_lt_reg_r with x; rewrite Rplus_0_r;
@@ -467,7 +465,7 @@ Proof.
   rewrite <- (Rmult_comm (An (S x0))); apply Rmult_le_compat_l.
   left; apply H.
   rewrite tech3.
-  unfold Rdiv in |- *; apply Rmult_le_reg_l with (1 - x).
+  unfold Rdiv; apply Rmult_le_reg_l with (1 - x).
   apply Rplus_lt_reg_r with x; rewrite Rplus_0_r.
   replace (x + (1 - x)) with 1; [ elim H3; intros; assumption | ring ].
   do 2 rewrite (Rmult_comm (1 - x)).
@@ -475,17 +473,17 @@ Proof.
   rewrite Rmult_1_r; apply Rplus_le_reg_l with (x ^ S (x2 - S x0)).
   replace (x ^ S (x2 - S x0) + (1 - x ^ S (x2 - S x0))) with 1;
     [ idtac | ring ].
-  rewrite <- (Rplus_comm 1); pattern 1 at 1 in |- *; rewrite <- Rplus_0_r;
+  rewrite <- (Rplus_comm 1); pattern 1 at 1; rewrite <- Rplus_0_r;
     apply Rplus_le_compat_l.
   left; apply pow_lt.
   apply Rle_lt_trans with k.
   elim Hyp; intros; assumption.
   elim H3; intros; assumption.
   apply Rminus_eq_contra.
-  red in |- *; intro.
+  red; intro.
   elim H3; intros.
   rewrite H10 in H12; elim (Rlt_irrefl _ H12).
-  red in |- *; intro.
+  red; intro.
   elim H3; intros.
   rewrite H10 in H12; elim (Rlt_irrefl _ H12).
   replace (An (S x0)) with (An (S x0 + 0)%nat).
@@ -498,7 +496,7 @@ Proof.
   intro.
   replace (S x0 + S i)%nat with (S (S x0 + i)).
   apply H9.
-  unfold ge in |- *.
+  unfold ge.
   apply tech8.
   apply INR_eq; rewrite S_INR; do 2 rewrite plus_INR; do 2 rewrite S_INR;
     ring.
@@ -512,21 +510,21 @@ Proof.
   replace (An (S n) * / An n) with (Rabs (An (S n) / An n)).
   apply H5; assumption.
   rewrite Rabs_right.
-  unfold Rdiv in |- *; reflexivity.
-  left; unfold Rdiv in |- *; change (0 < An (S n) * / An n) in |- *;
+  unfold Rdiv; reflexivity.
+  left; unfold Rdiv; change (0 < An (S n) * / An n);
     apply Rmult_lt_0_compat.
   apply H.
   apply Rinv_0_lt_compat; apply H.
-  red in |- *; intro.
+  red; intro.
   assert (H11 := H n).
   rewrite H10 in H11; elim (Rlt_irrefl _ H11).
   replace (S x0 + 0)%nat with (S x0); [ reflexivity | ring ].
-  symmetry  in |- *; apply tech2; assumption.
-  exists (sum_f_R0 An 0); unfold EUn in |- *; exists 0%nat; reflexivity.
+  symmetry ; apply tech2; assumption.
+  exists (sum_f_R0 An 0); unfold EUn; exists 0%nat; reflexivity.
   intro X; elim X; intros.
-  exists x; apply tech10;
-    [ unfold Un_growing in |- *; intro; rewrite tech5;
-      pattern (sum_f_R0 An n) at 1 in |- *; rewrite <- Rplus_0_r;
+  exists x; apply Un_cv_crit_lub;
+    [ unfold Un_growing; intro; rewrite tech5;
+      pattern (sum_f_R0 An n) at 1; rewrite <- Rplus_0_r;
 	apply Rplus_le_compat_l; left; apply H
       | apply p ].
 Qed.
@@ -553,9 +551,9 @@ Proof.
   apply (Alembert_C4 (fun i:nat => Rabs (An i)) k).
   assumption.
   intro; apply Rabs_pos_lt; apply H0.
-  unfold Un_cv in |- *.
+  unfold Un_cv.
   unfold Un_cv in H1.
-  unfold Rdiv in |- *.
+  unfold Rdiv.
   intros.
   elim (H1 eps H2); intros.
   exists x; intros.
@@ -592,22 +590,22 @@ Lemma Alembert_C6 :
   elim s; intro.
   eapply Alembert_C5 with (k * Rabs x).
   split.
-  unfold Rdiv in |- *; apply Rmult_le_pos.
+  unfold Rdiv; apply Rmult_le_pos.
   left; assumption.
   left; apply Rabs_pos_lt.
-  red in |- *; intro; rewrite H3 in a; elim (Rlt_irrefl _ a).
+  red; intro; rewrite H3 in a; elim (Rlt_irrefl _ a).
   apply Rmult_lt_reg_l with (/ k).
   apply Rinv_0_lt_compat; assumption.
   rewrite <- Rmult_assoc.
   rewrite <- Rinv_l_sym.
   rewrite Rmult_1_l.
   rewrite Rmult_1_r; assumption.
-  red in |- *; intro; rewrite H3 in H; elim (Rlt_irrefl _ H).
+  red; intro; rewrite H3 in H; elim (Rlt_irrefl _ H).
   intro; apply prod_neq_R0.
   apply H0.
   apply pow_nonzero.
-  red in |- *; intro; rewrite H3 in a; elim (Rlt_irrefl _ a).
-  unfold Un_cv in |- *; unfold Un_cv in H1.
+  red; intro; rewrite H3 in a; elim (Rlt_irrefl _ a).
+  unfold Un_cv; unfold Un_cv in H1.
   intros.
   cut (0 < eps / Rabs x).
   intro.
@@ -615,7 +613,7 @@ Lemma Alembert_C6 :
   exists x0.
   intros.
   replace (An (S n) * x ^ S n / (An n * x ^ n)) with (An (S n) / An n * x).
-  unfold R_dist in |- *.
+  unfold R_dist.
   rewrite Rabs_mult.
   replace (Rabs (An (S n) / An n) * Rabs x - k * Rabs x) with
     (Rabs x * (Rabs (An (S n) / An n) - k)); [ idtac | ring ].
@@ -623,18 +621,18 @@ Lemma Alembert_C6 :
   rewrite Rabs_Rabsolu.
   apply Rmult_lt_reg_l with (/ Rabs x).
   apply Rinv_0_lt_compat; apply Rabs_pos_lt.
-  red in |- *; intro; rewrite H7 in a; elim (Rlt_irrefl _ a).
+  red; intro; rewrite H7 in a; elim (Rlt_irrefl _ a).
   rewrite <- Rmult_assoc.
   rewrite <- Rinv_l_sym.
   rewrite Rmult_1_l.
   rewrite <- (Rmult_comm eps).
   unfold R_dist in H5.
-  unfold Rdiv in |- *; unfold Rdiv in H5; apply H5; assumption.
+  unfold Rdiv; unfold Rdiv in H5; apply H5; assumption.
   apply Rabs_no_R0.
-  red in |- *; intro; rewrite H7 in a; elim (Rlt_irrefl _ a).
-  unfold Rdiv in |- *; replace (S n) with (n + 1)%nat; [ idtac | ring ].
+  red; intro; rewrite H7 in a; elim (Rlt_irrefl _ a).
+  unfold Rdiv; replace (S n) with (n + 1)%nat; [ idtac | ring ].
   rewrite pow_add.
-  simpl in |- *.
+  simpl.
   rewrite Rmult_1_r.
   rewrite Rinv_mult_distr.
   replace (An (n + 1)%nat * (x ^ n * x) * (/ An n * / x ^ n)) with
@@ -643,46 +641,46 @@ Lemma Alembert_C6 :
   rewrite <- Rinv_r_sym.
   rewrite Rmult_1_r; reflexivity.
   apply pow_nonzero.
-  red in |- *; intro; rewrite H7 in a; elim (Rlt_irrefl _ a).
+  red; intro; rewrite H7 in a; elim (Rlt_irrefl _ a).
   apply H0.
   apply pow_nonzero.
-  red in |- *; intro; rewrite H7 in a; elim (Rlt_irrefl _ a).
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+  red; intro; rewrite H7 in a; elim (Rlt_irrefl _ a).
+  unfold Rdiv; apply Rmult_lt_0_compat.
   assumption.
   apply Rinv_0_lt_compat; apply Rabs_pos_lt.
-  red in |- *; intro H7; rewrite H7 in a; elim (Rlt_irrefl _ a).
+  red; intro H7; rewrite H7 in a; elim (Rlt_irrefl _ a).
   exists (An 0%nat).
-  unfold Un_cv in |- *.
+  unfold Un_cv.
   intros.
   exists 0%nat.
   intros.
-  unfold R_dist in |- *.
+  unfold R_dist.
   replace (sum_f_R0 (fun i:nat => An i * x ^ i) n) with (An 0%nat).
-  unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption.
+  unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption.
   induction  n as [| n Hrecn].
-  simpl in |- *; ring.
+  simpl; ring.
   rewrite tech5.
   rewrite <- Hrecn.
-  rewrite b; simpl in |- *; ring.
-  unfold ge in |- *; apply le_O_n.
+  rewrite b; simpl; ring.
+  unfold ge; apply le_O_n.
   eapply Alembert_C5 with (k * Rabs x).
   split.
-  unfold Rdiv in |- *; apply Rmult_le_pos.
+  unfold Rdiv; apply Rmult_le_pos.
   left; assumption.
   left; apply Rabs_pos_lt.
-  red in |- *; intro; rewrite H3 in r; elim (Rlt_irrefl _ r).
+  red; intro; rewrite H3 in r; elim (Rlt_irrefl _ r).
   apply Rmult_lt_reg_l with (/ k).
   apply Rinv_0_lt_compat; assumption.
   rewrite <- Rmult_assoc.
   rewrite <- Rinv_l_sym.
   rewrite Rmult_1_l.
   rewrite Rmult_1_r; assumption.
-  red in |- *; intro; rewrite H3 in H; elim (Rlt_irrefl _ H).
+  red; intro; rewrite H3 in H; elim (Rlt_irrefl _ H).
   intro; apply prod_neq_R0.
   apply H0.
   apply pow_nonzero.
-  red in |- *; intro; rewrite H3 in r; elim (Rlt_irrefl _ r).
-  unfold Un_cv in |- *; unfold Un_cv in H1.
+  red; intro; rewrite H3 in r; elim (Rlt_irrefl _ r).
+  unfold Un_cv; unfold Un_cv in H1.
   intros.
   cut (0 < eps / Rabs x).
   intro.
@@ -690,7 +688,7 @@ Lemma Alembert_C6 :
   exists x0.
   intros.
   replace (An (S n) * x ^ S n / (An n * x ^ n)) with (An (S n) / An n * x).
-  unfold R_dist in |- *.
+  unfold R_dist.
   rewrite Rabs_mult.
   replace (Rabs (An (S n) / An n) * Rabs x - k * Rabs x) with
     (Rabs x * (Rabs (An (S n) / An n) - k)); [ idtac | ring ].
@@ -698,18 +696,18 @@ Lemma Alembert_C6 :
   rewrite Rabs_Rabsolu.
   apply Rmult_lt_reg_l with (/ Rabs x).
   apply Rinv_0_lt_compat; apply Rabs_pos_lt.
-  red in |- *; intro; rewrite H7 in r; elim (Rlt_irrefl _ r).
+  red; intro; rewrite H7 in r; elim (Rlt_irrefl _ r).
   rewrite <- Rmult_assoc.
   rewrite <- Rinv_l_sym.
   rewrite Rmult_1_l.
   rewrite <- (Rmult_comm eps).
   unfold R_dist in H5.
-  unfold Rdiv in |- *; unfold Rdiv in H5; apply H5; assumption.
+  unfold Rdiv; unfold Rdiv in H5; apply H5; assumption.
   apply Rabs_no_R0.
-  red in |- *; intro; rewrite H7 in r; elim (Rlt_irrefl _ r).
-  unfold Rdiv in |- *; replace (S n) with (n + 1)%nat; [ idtac | ring ].
+  red; intro; rewrite H7 in r; elim (Rlt_irrefl _ r).
+  unfold Rdiv; replace (S n) with (n + 1)%nat; [ idtac | ring ].
   rewrite pow_add.
-  simpl in |- *.
+  simpl.
   rewrite Rmult_1_r.
   rewrite Rinv_mult_distr.
   replace (An (n + 1)%nat * (x ^ n * x) * (/ An n * / x ^ n)) with
@@ -718,12 +716,12 @@ Lemma Alembert_C6 :
   rewrite <- Rinv_r_sym.
   rewrite Rmult_1_r; reflexivity.
   apply pow_nonzero.
-  red in |- *; intro; rewrite H7 in r; elim (Rlt_irrefl _ r).
+  red; intro; rewrite H7 in r; elim (Rlt_irrefl _ r).
   apply H0.
   apply pow_nonzero.
-  red in |- *; intro; rewrite H7 in r; elim (Rlt_irrefl _ r).
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+  red; intro; rewrite H7 in r; elim (Rlt_irrefl _ r).
+  unfold Rdiv; apply Rmult_lt_0_compat.
   assumption.
   apply Rinv_0_lt_compat; apply Rabs_pos_lt.
-  red in |- *; intro H7; rewrite H7 in r; elim (Rlt_irrefl _ r).
+  red; intro H7; rewrite H7 in r; elim (Rlt_irrefl _ r).
 Qed.
diff --git a/theories/Reals/AltSeries.v b/theories/Reals/AltSeries.v
index cab14704..69f29781 100644
--- a/theories/Reals/AltSeries.v
+++ b/theories/Reals/AltSeries.v
@@ -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-2012     *)
 (*   \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.
 Require Import SeqProp.
 Require Import PartSum.
 Require Import Max.
-Open Local Scope R_scope.
+Local Open Scope R_scope.
 
 (**********)
 (** * Formalization of alternated series *)
@@ -26,13 +24,13 @@ Lemma CV_ALT_step0 :
     Un_decreasing Un ->
     Un_growing (fun N:nat => sum_f_R0 (tg_alt Un) (S (2 * N))).
 Proof.
-  intros; unfold Un_growing in |- *; intro.
+  intros; unfold Un_growing; intro.
   cut ((2 * S n)%nat = S (S (2 * n))).
   intro; rewrite H0.
   do 4 rewrite tech5; repeat rewrite Rplus_assoc; apply Rplus_le_compat_l.
-  pattern (tg_alt Un (S (2 * n))) at 1 in |- *; rewrite <- Rplus_0_r.
+  pattern (tg_alt Un (S (2 * n))) at 1; rewrite <- Rplus_0_r.
   apply Rplus_le_compat_l.
-  unfold tg_alt in |- *; rewrite <- H0; rewrite pow_1_odd; rewrite pow_1_even;
+  unfold tg_alt; rewrite <- H0; rewrite pow_1_odd; rewrite pow_1_even;
     rewrite Rmult_1_l.
   apply Rplus_le_reg_l with (Un (S (2 * S n))).
   rewrite Rplus_0_r;
@@ -48,12 +46,12 @@ Lemma CV_ALT_step1 :
     Un_decreasing Un ->
     Un_decreasing (fun N:nat => sum_f_R0 (tg_alt Un) (2 * N)).
 Proof.
-  intros; unfold Un_decreasing in |- *; intro.
+  intros; unfold Un_decreasing; intro.
   cut ((2 * S n)%nat = S (S (2 * n))).
   intro; rewrite H0; do 2 rewrite tech5; repeat rewrite Rplus_assoc.
-  pattern (sum_f_R0 (tg_alt Un) (2 * n)) at 2 in |- *; rewrite <- Rplus_0_r.
+  pattern (sum_f_R0 (tg_alt Un) (2 * n)) at 2; rewrite <- Rplus_0_r.
   apply Rplus_le_compat_l.
-  unfold tg_alt in |- *; rewrite <- H0; rewrite pow_1_odd; rewrite pow_1_even;
+  unfold tg_alt; rewrite <- H0; rewrite pow_1_odd; rewrite pow_1_even;
     rewrite Rmult_1_l.
   apply Rplus_le_reg_l with (Un (S (2 * n))).
   rewrite Rplus_0_r;
@@ -72,7 +70,7 @@ Lemma CV_ALT_step2 :
     sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * N)) <= 0.
 Proof.
   intros; induction  N as [| N HrecN].
-  simpl in |- *; unfold tg_alt in |- *; simpl in |- *; rewrite Rmult_1_r.
+  simpl; unfold tg_alt; simpl; rewrite Rmult_1_r.
   replace (-1 * -1 * Un 2%nat) with (Un 2%nat); [ idtac | ring ].
   apply Rplus_le_reg_l with (Un 1%nat); rewrite Rplus_0_r.
   replace (Un 1%nat + (-1 * Un 1%nat + Un 2%nat)) with (Un 2%nat);
@@ -80,10 +78,10 @@ Proof.
   cut (S (2 * S N) = S (S (S (2 * N)))).
   intro; rewrite H1; do 2 rewrite tech5.
   apply Rle_trans with (sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * N))).
-  pattern (sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * N))) at 2 in |- *;
+  pattern (sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * N))) at 2;
     rewrite <- Rplus_0_r.
   rewrite Rplus_assoc; apply Rplus_le_compat_l.
-  unfold tg_alt in |- *; rewrite <- H1.
+  unfold tg_alt; rewrite <- H1.
   rewrite pow_1_odd.
   cut (S (S (2 * S N)) = (2 * S (S N))%nat).
   intro; rewrite H2; rewrite pow_1_even; rewrite Rmult_1_l; rewrite <- H2.
@@ -104,7 +102,7 @@ Lemma CV_ALT_step3 :
     positivity_seq Un -> sum_f_R0 (fun i:nat => tg_alt Un (S i)) N <= 0.
 Proof.
   intros; induction  N as [| N HrecN].
-  simpl in |- *; unfold tg_alt in |- *; simpl in |- *; rewrite Rmult_1_r.
+  simpl; unfold tg_alt; simpl; rewrite Rmult_1_r.
   apply Rplus_le_reg_l with (Un 1%nat).
   rewrite Rplus_0_r; replace (Un 1%nat + -1 * Un 1%nat) with 0;
     [ apply H0 | ring ].
@@ -114,10 +112,10 @@ Proof.
   rewrite H3; apply CV_ALT_step2; assumption.
   rewrite H3; rewrite tech5.
   apply Rle_trans with (sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * x))).
-  pattern (sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * x))) at 2 in |- *;
+  pattern (sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * x))) at 2;
     rewrite <- Rplus_0_r.
   apply Rplus_le_compat_l.
-  unfold tg_alt in |- *; simpl in |- *.
+  unfold tg_alt; simpl.
   replace (x + (x + 0))%nat with (2 * x)%nat; [ idtac | ring ].
   rewrite pow_1_even.
   replace (-1 * (-1 * (-1 * 1)) * Un (S (S (S (2 * x))))) with
@@ -135,15 +133,15 @@ Lemma CV_ALT_step4 :
     positivity_seq Un ->
     has_ub (fun N:nat => sum_f_R0 (tg_alt Un) (S (2 * N))).
 Proof.
-  intros; unfold has_ub in |- *; unfold bound in |- *.
+  intros; unfold has_ub; unfold bound.
   exists (Un 0%nat).
-  unfold is_upper_bound in |- *; intros; elim H1; intros.
+  unfold is_upper_bound; intros; elim H1; intros.
   rewrite H2; rewrite decomp_sum.
   replace (tg_alt Un 0) with (Un 0%nat).
-  pattern (Un 0%nat) at 2 in |- *; rewrite <- Rplus_0_r.
+  pattern (Un 0%nat) at 2; rewrite <- Rplus_0_r.
   apply Rplus_le_compat_l.
   apply CV_ALT_step3; assumption.
-  unfold tg_alt in |- *; simpl in |- *; ring.
+  unfold tg_alt; simpl; ring.
   apply lt_O_Sn.
 Qed.
 
@@ -161,11 +159,11 @@ Proof.
   assert (X := growing_cv _ H2 H3).
   elim X; intros.
   exists x.
-  unfold Un_cv in |- *; unfold R_dist in |- *; unfold Un_cv in H1;
+  unfold Un_cv; unfold R_dist; unfold Un_cv in H1;
     unfold R_dist in H1; unfold Un_cv in p; unfold R_dist in p.
   intros; cut (0 < eps / 2);
     [ intro
-      | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+      | unfold Rdiv; apply Rmult_lt_0_compat;
 	[ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ].
   elim (H1 (eps / 2) H5); intros N2 H6.
   elim (p (eps / 2) H5); intros N1 H7.
@@ -182,32 +180,32 @@ Proof.
   apply Rabs_triang.
   rewrite (double_var eps); apply Rplus_lt_compat.
   rewrite H12; apply H7; assumption.
-  rewrite Rabs_Ropp; unfold tg_alt in |- *; rewrite Rabs_mult;
+  rewrite Rabs_Ropp; unfold tg_alt; rewrite Rabs_mult;
     rewrite pow_1_abs; rewrite Rmult_1_l; unfold Rminus in H6;
       rewrite Ropp_0 in H6; rewrite <- (Rplus_0_r (Un (S n)));
 	apply H6.
-  unfold ge in |- *; apply le_trans with n.
-  apply le_trans with N; [ unfold N in |- *; apply le_max_r | assumption ].
+  unfold ge; apply le_trans with n.
+  apply le_trans with N; [ unfold N; apply le_max_r | assumption ].
   apply le_n_Sn.
   rewrite tech5; ring.
   rewrite H12; apply Rlt_trans with (eps / 2).
   apply H7; assumption.
-  unfold Rdiv in |- *; apply Rmult_lt_reg_l with 2.
+  unfold Rdiv; apply Rmult_lt_reg_l with 2.
   prove_sup0.
   rewrite (Rmult_comm 2); rewrite Rmult_assoc; rewrite <- Rinv_l_sym;
     [ rewrite Rmult_1_r | discrR ].
   rewrite double.
-  pattern eps at 1 in |- *; rewrite <- (Rplus_0_r eps); apply Rplus_lt_compat_l;
+  pattern eps at 1; rewrite <- (Rplus_0_r eps); apply Rplus_lt_compat_l;
     assumption.
   elim H10; intro; apply le_double.
   rewrite <- H11; apply le_trans with N.
-  unfold N in |- *; apply le_trans with (S (2 * N1));
+  unfold N; apply le_trans with (S (2 * N1));
     [ apply le_n_Sn | apply le_max_l ].
   assumption.
   apply lt_n_Sm_le.
   rewrite <- H11.
   apply lt_le_trans with N.
-  unfold N in |- *; apply lt_le_trans with (S (2 * N1)).
+  unfold N; apply lt_le_trans with (S (2 * N1)).
   apply lt_n_Sn.
   apply le_max_l.
   assumption.
@@ -224,7 +222,7 @@ Theorem alternated_series :
 Proof.
   intros; apply CV_ALT.
   assumption.
-  unfold positivity_seq in |- *; apply decreasing_ineq; assumption.
+  unfold positivity_seq; apply decreasing_ineq; assumption.
   assumption.
 Qed.
 
@@ -245,31 +243,31 @@ Proof.
   apply (decreasing_ineq (fun N:nat => sum_f_R0 (tg_alt Un) (2 * N))).
   apply CV_ALT_step1; assumption.
   assumption.
-  unfold Un_cv in |- *; unfold R_dist in |- *; unfold Un_cv in H1;
+  unfold Un_cv; unfold R_dist; unfold Un_cv in H1;
     unfold R_dist in H1; intros.
   elim (H1 eps H2); intros.
   exists x; intros.
   apply H3.
-  unfold ge in |- *; apply le_trans with (2 * n)%nat.
+  unfold ge; apply le_trans with (2 * n)%nat.
   apply le_trans with n.
   assumption.
   assert (H5 := mult_O_le n 2).
   elim H5; intro.
   cut (0%nat <> 2%nat);
-    [ intro; elim H7; symmetry  in |- *; assumption | discriminate ].
+    [ intro; elim H7; symmetry ; assumption | discriminate ].
   assumption.
   apply le_n_Sn.
-  unfold Un_cv in |- *; unfold R_dist in |- *; unfold Un_cv in H1;
+  unfold Un_cv; unfold R_dist; unfold Un_cv in H1;
     unfold R_dist in H1; intros.
   elim (H1 eps H2); intros.
   exists x; intros.
   apply H3.
-  unfold ge in |- *; apply le_trans with n.
+  unfold ge; apply le_trans with n.
   assumption.
   assert (H5 := mult_O_le n 2).
   elim H5; intro.
   cut (0%nat <> 2%nat);
-    [ intro; elim H7; symmetry  in |- *; assumption | discriminate ].
+    [ intro; elim H7; symmetry ; assumption | discriminate ].
   assumption.
 Qed.
 
@@ -281,13 +279,13 @@ Definition PI_tg (n:nat) := / INR (2 * n + 1).
 
 Lemma PI_tg_pos : forall n:nat, 0 <= PI_tg n.
 Proof.
-  intro; unfold PI_tg in |- *; left; apply Rinv_0_lt_compat; apply lt_INR_0;
+  intro; unfold PI_tg; left; apply Rinv_0_lt_compat; apply lt_INR_0;
     replace (2 * n + 1)%nat with (S (2 * n)); [ apply lt_O_Sn | ring ].
 Qed.
 
 Lemma PI_tg_decreasing : Un_decreasing PI_tg.
 Proof.
-  unfold PI_tg, Un_decreasing in |- *; intro.
+  unfold PI_tg, Un_decreasing; intro.
   apply Rmult_le_reg_l with (INR (2 * n + 1)).
   apply lt_INR_0.
   replace (2 * n + 1)%nat with (S (2 * n)); [ apply lt_O_Sn | ring ].
@@ -308,7 +306,7 @@ Qed.
 
 Lemma PI_tg_cv : Un_cv PI_tg 0.
 Proof.
-  unfold Un_cv in |- *; unfold R_dist in |- *; intros.
+  unfold Un_cv; unfold R_dist; intros.
   cut (0 < 2 * eps);
     [ intro | apply Rmult_lt_0_compat; [ prove_sup0 | assumption ] ].
   assert (H1 := archimed (/ (2 * eps))).
@@ -318,9 +316,9 @@ Proof.
   cut (0 < N)%nat.
   intro; exists N; intros.
   cut (0 < n)%nat.
-  intro; unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r;
+  intro; unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r;
     rewrite Rabs_right.
-  unfold PI_tg in |- *; apply Rlt_trans with (/ INR (2 * n)).
+  unfold PI_tg; apply Rlt_trans with (/ INR (2 * n)).
   apply Rmult_lt_reg_l with (INR (2 * n)).
   apply lt_INR_0.
   replace (2 * n)%nat with (n + n)%nat; [ idtac | ring ].
@@ -339,27 +337,27 @@ Proof.
     [ discriminate | ring ].
   replace n with (S (pred n)).
   apply not_O_INR; discriminate.
-  symmetry  in |- *; apply S_pred with 0%nat.
+  symmetry ; apply S_pred with 0%nat.
   assumption.
   apply Rle_lt_trans with (/ INR (2 * N)).
   apply Rmult_le_reg_l with (INR (2 * N)).
   rewrite mult_INR; apply Rmult_lt_0_compat;
-    [ simpl in |- *; prove_sup0 | apply lt_INR_0; assumption ].
+    [ simpl; prove_sup0 | apply lt_INR_0; assumption ].
   rewrite <- Rinv_r_sym.
   apply Rmult_le_reg_l with (INR (2 * n)).
   rewrite mult_INR; apply Rmult_lt_0_compat;
-    [ simpl in |- *; prove_sup0 | apply lt_INR_0; assumption ].
+    [ simpl; prove_sup0 | apply lt_INR_0; assumption ].
   rewrite (Rmult_comm (INR (2 * n))); rewrite Rmult_assoc;
     rewrite <- Rinv_l_sym.
   do 2 rewrite Rmult_1_r; apply le_INR.
   apply (fun m n p:nat => mult_le_compat_l p n m); assumption.
   replace n with (S (pred n)).
   apply not_O_INR; discriminate.
-  symmetry  in |- *; apply S_pred with 0%nat.
+  symmetry ; apply S_pred with 0%nat.
   assumption.
   replace N with (S (pred N)).
   apply not_O_INR; discriminate.
-  symmetry  in |- *; apply S_pred with 0%nat.
+  symmetry ; apply S_pred with 0%nat.
   assumption.
   rewrite mult_INR.
   rewrite Rinv_mult_distr.
@@ -376,17 +374,17 @@ Proof.
     replace (/ (2 * eps) * (INR N * (2 * eps))) with
       (INR N * (2 * eps * / (2 * eps))); [ idtac | ring ].
   rewrite <- Rinv_r_sym.
-  rewrite Rmult_1_r; replace (INR N) with (IZR (Z_of_nat N)).
+  rewrite Rmult_1_r; replace (INR N) with (IZR (Z.of_nat N)).
   rewrite <- H4.
   elim H1; intros; assumption.
-  symmetry  in |- *; apply INR_IZR_INZ.
+  symmetry ; apply INR_IZR_INZ.
   apply prod_neq_R0;
-    [ discrR | red in |- *; intro; rewrite H8 in H; elim (Rlt_irrefl _ H) ].
+    [ discrR | red; intro; rewrite H8 in H; elim (Rlt_irrefl _ H) ].
   apply not_O_INR.
-  red in |- *; intro; rewrite H8 in H5; elim (lt_irrefl _ H5).
+  red; intro; rewrite H8 in H5; elim (lt_irrefl _ H5).
   replace (INR 2) with 2; [ discrR | reflexivity ].
   apply not_O_INR.
-  red in |- *; intro; rewrite H8 in H5; elim (lt_irrefl _ H5).
+  red; intro; rewrite H8 in H5; elim (lt_irrefl _ H5).
   apply Rle_ge; apply PI_tg_pos.
   apply lt_le_trans with N; assumption.
   elim H1; intros H5 _.
@@ -401,7 +399,7 @@ Proof.
   elim (Rlt_irrefl _ (Rlt_trans _ _ _ H7 H5)).
   elim (lt_n_O _ b).
   apply le_IZR.
-  simpl in |- *.
+  simpl.
   left; apply Rlt_trans with (/ (2 * eps)).
   apply Rinv_0_lt_compat; assumption.
   elim H1; intros; assumption.
@@ -416,41 +414,41 @@ Proof.
 Qed.
 
 (** Now, PI is defined *)
-Definition PI : R := 4 * (let (a,_) := exist_PI in a).
+Definition Alt_PI : R := 4 * (let (a,_) := exist_PI in a).
 
 (** We can get an approximation of PI with the following inequality *)
-Lemma PI_ineq :
+Lemma Alt_PI_ineq :
   forall N:nat,
-    sum_f_R0 (tg_alt PI_tg) (S (2 * N)) <= PI / 4 <=
+    sum_f_R0 (tg_alt PI_tg) (S (2 * N)) <= Alt_PI / 4 <=
     sum_f_R0 (tg_alt PI_tg) (2 * N).
 Proof.
   intro; apply alternated_series_ineq.
   apply PI_tg_decreasing.
   apply PI_tg_cv.
-  unfold PI in |- *; case exist_PI; intro.
+  unfold Alt_PI; case exist_PI; intro.
   replace (4 * x / 4) with x.
   trivial.
-  unfold Rdiv in |- *; rewrite (Rmult_comm 4); rewrite Rmult_assoc;
+  unfold Rdiv; rewrite (Rmult_comm 4); rewrite Rmult_assoc;
     rewrite <- Rinv_r_sym; [ rewrite Rmult_1_r; reflexivity | discrR ].
 Qed.
 
-Lemma PI_RGT_0 : 0 < PI.
+Lemma Alt_PI_RGT_0 : 0 < Alt_PI.
 Proof.
-  assert (H := PI_ineq 0).
+  assert (H := Alt_PI_ineq 0).
   apply Rmult_lt_reg_l with (/ 4).
   apply Rinv_0_lt_compat; prove_sup0.
   rewrite Rmult_0_r; rewrite Rmult_comm.
   elim H; clear H; intros H _.
   unfold Rdiv in H;
     apply Rlt_le_trans with (sum_f_R0 (tg_alt PI_tg) (S (2 * 0))).
-  simpl in |- *; unfold tg_alt in |- *; simpl in |- *; rewrite Rmult_1_l;
+  simpl; unfold tg_alt; simpl; rewrite Rmult_1_l;
     rewrite Rmult_1_r; apply Rplus_lt_reg_r with (PI_tg 1).
   rewrite Rplus_0_r;
     replace (PI_tg 1 + (PI_tg 0 + -1 * PI_tg 1)) with (PI_tg 0);
-      [ unfold PI_tg in |- * | ring ].
-  simpl in |- *; apply Rinv_lt_contravar.
+      [ unfold PI_tg | ring ].
+  simpl; apply Rinv_lt_contravar.
   rewrite Rmult_1_l; replace (2 + 1) with 3; [ prove_sup0 | ring ].
-  rewrite Rplus_comm; pattern 1 at 1 in |- *; rewrite <- Rplus_0_r;
+  rewrite Rplus_comm; pattern 1 at 1; rewrite <- Rplus_0_r;
     apply Rplus_lt_compat_l; prove_sup0.
   assumption.
 Qed.
diff --git a/theories/Reals/ArithProp.v b/theories/Reals/ArithProp.v
index c378a2e2..c817bdfa 100644
--- a/theories/Reals/ArithProp.v
+++ b/theories/Reals/ArithProp.v
@@ -1,25 +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-2012     *)
 (*   \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.
 Require Import Div2.
 Require Import ArithRing.
 
-Open Local Scope Z_scope.
-Open Local Scope R_scope.
+Local Open Scope Z_scope.
+Local Open Scope R_scope.
 
 Lemma minus_neq_O : forall n i:nat, (i < n)%nat -> (n - i)%nat <> 0%nat.
 Proof.
-  intros; red in |- *; intro.
+  intros; red; intro.
   cut (forall n m:nat, (m <= n)%nat -> (n - m)%nat = 0%nat -> n = m).
   intro; assert (H2 := H1 _ _ (lt_le_weak _ _ H) H0); rewrite H2 in H;
     elim (lt_irrefl _ H).
@@ -29,11 +27,11 @@ Proof.
       forall n0 m:nat, (m <= n0)%nat -> (n0 - m)%nat = 0%nat -> n0 = m).
   intro; apply H1.
   apply nat_double_ind.
-  unfold R in |- *; intros; inversion H2; reflexivity.
-  unfold R in |- *; intros; simpl in H3; assumption.
-  unfold R in |- *; intros; simpl in H4; assert (H5 := le_S_n _ _ H3);
+  unfold R; intros; inversion H2; reflexivity.
+  unfold R; intros; simpl in H3; assumption.
+  unfold R; intros; simpl in H4; assert (H5 := le_S_n _ _ H3);
     assert (H6 := H2 H5 H4); rewrite H6; reflexivity.
-  unfold R in |- *; intros; apply H1; assumption.
+  unfold R; intros; apply H1; assumption.
 Qed.
 
 Lemma le_minusni_n : forall n i:nat, (i <= n)%nat -> (n - i <= n)%nat.
@@ -43,20 +41,20 @@ Proof.
     ((forall m n:nat, R m n) -> forall n i:nat, (i <= n)%nat -> (n - i <= n)%nat).
   intro; apply H.
   apply nat_double_ind.
-  unfold R in |- *; intros; simpl in |- *; apply le_n.
-  unfold R in |- *; intros; simpl in |- *; apply le_n.
-  unfold R in |- *; intros; simpl in |- *; apply le_trans with n.
+  unfold R; intros; simpl; apply le_n.
+  unfold R; intros; simpl; apply le_n.
+  unfold R; intros; simpl; apply le_trans with n.
   apply H0; apply le_S_n; assumption.
   apply le_n_Sn.
-  unfold R in |- *; intros; apply H; assumption.
+  unfold R; intros; apply H; assumption.
 Qed.
 
 Lemma lt_minus_O_lt : forall m n:nat, (m < n)%nat -> (0 < n - m)%nat.
 Proof.
-  intros n m; pattern n, m in |- *; apply nat_double_ind;
+  intros n m; pattern n, m; apply nat_double_ind;
     [ intros; rewrite <- minus_n_O; assumption
       | intros; elim (lt_n_O _ H)
-      | intros; simpl in |- *; apply H; apply lt_S_n; assumption ].
+      | intros; simpl; apply H; apply lt_S_n; assumption ].
 Qed.
 
 Lemma even_odd_cor :
@@ -75,7 +73,7 @@ Proof.
   apply H3; assumption.
   right.
   apply H4; assumption.
-  unfold double in |- *;ring.
+  unfold double;ring.
 Qed.
 
   (* 2m <= 2n => m<=n *)
@@ -107,9 +105,9 @@ Proof.
   exists (x - IZR k0 * y).
   split.
   ring.
-  unfold k0 in |- *; case (Rcase_abs y); intro.
-  assert (H0 := archimed (x / - y)); rewrite <- Z_R_minus; simpl in |- *;
-    unfold Rminus in |- *.
+  unfold k0; case (Rcase_abs y); intro.
+  assert (H0 := archimed (x / - y)); rewrite <- Z_R_minus; simpl;
+    unfold Rminus.
   replace (- ((1 + - IZR (up (x / - y))) * y)) with
     ((IZR (up (x / - y)) - 1) * y); [ idtac | ring ].
   split.
@@ -120,7 +118,7 @@ Proof.
   rewrite Rmult_assoc; repeat rewrite Ropp_mult_distr_r_reverse;
     rewrite <- Rinv_r_sym; [ rewrite Rmult_1_r | assumption ].
   apply Rplus_le_reg_l with (IZR (up (x / - y)) - x / - y).
-  rewrite Rplus_0_r; unfold Rdiv in |- *; pattern (/ - y) at 4 in |- *;
+  rewrite Rplus_0_r; unfold Rdiv; pattern (/ - y) at 4;
     rewrite <- Ropp_inv_permute; [ idtac | assumption ].
   replace
     (IZR (up (x * / - y)) - x * - / y +
@@ -140,11 +138,11 @@ Proof.
   replace (IZR (up (x / - y)) - 1 + (- (x * / y) + - (IZR (up (x / - y)) - 1)))
     with (- (x * / y)); [ idtac | ring ].
   rewrite <- Ropp_mult_distr_r_reverse; rewrite (Ropp_inv_permute _ H); elim H0;
-    unfold Rdiv in |- *; intros H1 _; exact H1.
+    unfold Rdiv; intros H1 _; exact H1.
   apply Ropp_neq_0_compat; assumption.
-  assert (H0 := archimed (x / y)); rewrite <- Z_R_minus; simpl in |- *;
+  assert (H0 := archimed (x / y)); rewrite <- Z_R_minus; simpl;
     cut (0 < y).
-  intro; unfold Rminus in |- *;
+  intro; unfold Rminus;
     replace (- ((IZR (up (x / y)) + -1) * y)) with ((1 - IZR (up (x / y))) * y);
       [ idtac | ring ].
   split.
@@ -154,7 +152,7 @@ Proof.
     rewrite Rmult_assoc; rewrite <- Rinv_r_sym;
       [ rewrite Rmult_1_r | assumption ];
       apply Rplus_le_reg_l with (IZR (up (x / y)) - x / y);
-	rewrite Rplus_0_r; unfold Rdiv in |- *;
+	rewrite Rplus_0_r; unfold Rdiv;
 	  replace
 	    (IZR (up (x * / y)) - x * / y + (x * / y + (1 - IZR (up (x * / y))))) with
 	    1; [ idtac | ring ]; elim H0; intros _ H2; unfold Rdiv in H2;
@@ -168,12 +166,12 @@ Proof.
 	replace (IZR (up (x / y)) - 1 + 1) with (IZR (up (x / y)));
 	  [ idtac | ring ];
 	  replace (IZR (up (x / y)) - 1 + (x * / y + (1 - IZR (up (x / y))))) with
-	    (x * / y); [ idtac | ring ]; elim H0; unfold Rdiv in |- *;
+	    (x * / y); [ idtac | ring ]; elim H0; unfold Rdiv;
 	      intros H2 _; exact H2.
   case (total_order_T 0 y); intro.
   elim s; intro.
   assumption.
-  elim H; symmetry  in |- *; exact b.
+  elim H; symmetry ; exact b.
   assert (H1 := Rge_le _ _ r); elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 r0)).
 Qed.
 
diff --git a/theories/Reals/Binomial.v b/theories/Reals/Binomial.v
index 55c30aec..ad076c48 100644
--- a/theories/Reals/Binomial.v
+++ b/theories/Reals/Binomial.v
@@ -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-2012     *)
 (*   \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.
-Open Local Scope R_scope.
+Local Open Scope R_scope.
 
 Definition C (n p:nat) : R :=
   INR (fact n) / (INR (fact p) * INR (fact (n - p))).
 
 Lemma pascal_step1 : forall n i:nat, (i <= n)%nat -> C n i = C n (n - i).
 Proof.
-  intros; unfold C in |- *; replace (n - (n - i))%nat with i.
+  intros; unfold C; replace (n - (n - i))%nat with i.
   rewrite Rmult_comm.
   reflexivity.
   apply plus_minus; rewrite plus_comm; apply le_plus_minus; assumption.
@@ -28,10 +26,10 @@ Lemma pascal_step2 :
   forall n i:nat,
     (i <= n)%nat -> C (S n) i = INR (S n) / INR (S n - i) * C n i.
 Proof.
-  intros; unfold C in |- *; replace (S n - i)%nat with (S (n - i)).
+  intros; unfold C; replace (S n - i)%nat with (S (n - i)).
   cut (forall n:nat, fact (S n) = (S n * fact n)%nat).
   intro; repeat rewrite H0.
-  unfold Rdiv in |- *; repeat rewrite mult_INR; repeat rewrite Rinv_mult_distr.
+  unfold Rdiv; repeat rewrite mult_INR; repeat rewrite Rinv_mult_distr.
   ring.
   apply INR_fact_neq_0.
   apply INR_fact_neq_0.
@@ -48,13 +46,13 @@ Qed.
 Lemma pascal_step3 :
   forall n i:nat, (i < n)%nat -> C n (S i) = INR (n - i) / INR (S i) * C n i.
 Proof.
-  intros; unfold C in |- *.
+  intros; unfold C.
   cut (forall n:nat, fact (S n) = (S n * fact n)%nat).
   intro.
   cut ((n - i)%nat = S (n - S i)).
   intro.
-  pattern (n - i)%nat at 2 in |- *; rewrite H1.
-  repeat rewrite H0; unfold Rdiv in |- *; repeat rewrite mult_INR;
+  pattern (n - i)%nat at 2; rewrite H1.
+  repeat rewrite H0; unfold Rdiv; repeat rewrite mult_INR;
     repeat rewrite Rinv_mult_distr.
   rewrite <- H1; rewrite (Rmult_comm (/ INR (n - i)));
     repeat rewrite Rmult_assoc; rewrite (Rmult_comm (INR (n - i)));
@@ -70,7 +68,7 @@ Proof.
   apply prod_neq_R0; [ apply not_O_INR; discriminate | apply INR_fact_neq_0 ].
   apply INR_fact_neq_0.
   rewrite minus_Sn_m.
-  simpl in |- *; reflexivity.
+  simpl; reflexivity.
   apply lt_le_S; assumption.
   intro; reflexivity.
 Qed.
@@ -97,13 +95,13 @@ Proof.
   rewrite <- minus_Sn_m.
   cut ((n - (n - i))%nat = i).
   intro; rewrite H0; reflexivity.
-  symmetry  in |- *; apply plus_minus.
+  symmetry ; apply plus_minus.
   rewrite plus_comm; rewrite le_plus_minus_r.
   reflexivity.
   apply lt_le_weak; assumption.
   apply le_minusni_n; apply lt_le_weak; assumption.
   apply lt_le_weak; assumption.
-  unfold Rdiv in |- *.
+  unfold Rdiv.
   repeat rewrite S_INR.
   rewrite minus_INR.
   cut (INR i + 1 <> 0).
@@ -127,18 +125,18 @@ Lemma binomial :
     (x + y) ^ n = sum_f_R0 (fun i:nat => C n i * x ^ i * y ^ (n - i)) n.
 Proof.
   intros; induction  n as [| n Hrecn].
-  unfold C in |- *; simpl in |- *; unfold Rdiv in |- *;
+  unfold C; simpl; unfold Rdiv;
     repeat rewrite Rmult_1_r; rewrite Rinv_1; ring.
-  pattern (S n) at 1 in |- *; replace (S n) with (n + 1)%nat; [ idtac | ring ].
+  pattern (S n) at 1; replace (S n) with (n + 1)%nat; [ idtac | ring ].
   rewrite pow_add; rewrite Hrecn.
-  replace ((x + y) ^ 1) with (x + y); [ idtac | simpl in |- *; ring ].
+  replace ((x + y) ^ 1) with (x + y); [ idtac | simpl; ring ].
   rewrite tech5.
   cut (forall p:nat, C p p = 1).
   cut (forall p:nat, C p 0 = 1).
   intros; rewrite H0; rewrite <- minus_n_n; rewrite Rmult_1_l.
-  replace (y ^ 0) with 1; [ rewrite Rmult_1_r | simpl in |- *; reflexivity ].
+  replace (y ^ 0) with 1; [ rewrite Rmult_1_r | simpl; reflexivity ].
   induction  n as [| n Hrecn0].
-  simpl in |- *; do 2 rewrite H; ring.
+  simpl; do 2 rewrite H; ring.
   (* N >= 1 *)
   set (N := S n).
   rewrite Rmult_plus_distr_l.
@@ -160,7 +158,7 @@ Proof.
   rewrite (Rplus_comm (sum_f_R0 An n)).
   repeat rewrite Rplus_assoc.
   rewrite <- tech5.
-  fold N in |- *.
+  fold N.
   set (Cn := fun i:nat => C N i * x ^ i * y ^ (S N - i)).
   cut (forall i:nat, (i < N)%nat -> Cn (S i) = Bn i).
   intro; replace (sum_f_R0 Bn n) with (sum_f_R0 (fun i:nat => Cn (S i)) n).
@@ -168,42 +166,42 @@ Proof.
   rewrite <- Rplus_assoc; rewrite (decomp_sum Cn N).
   replace (pred N) with n.
   ring.
-  unfold N in |- *; simpl in |- *; reflexivity.
-  unfold N in |- *; apply lt_O_Sn.
-  unfold Cn in |- *; rewrite H; simpl in |- *; ring.
+  unfold N; simpl; reflexivity.
+  unfold N; apply lt_O_Sn.
+  unfold Cn; rewrite H; simpl; ring.
   apply sum_eq.
   intros; apply H1.
-  unfold N in |- *; apply le_lt_trans with n; [ assumption | apply lt_n_Sn ].
-  intros; unfold Bn, Cn in |- *.
+  unfold N; apply le_lt_trans with n; [ assumption | apply lt_n_Sn ].
+  intros; unfold Bn, Cn.
   replace (S N - S i)%nat with (N - i)%nat; reflexivity.
-  unfold An in |- *; fold N in |- *; rewrite <- minus_n_n; rewrite H0;
-    simpl in |- *; ring.
+  unfold An; fold N; rewrite <- minus_n_n; rewrite H0;
+    simpl; ring.
   apply sum_eq.
-  intros; unfold An, Bn in |- *; replace (S N - S i)%nat with (N - i)%nat;
+  intros; unfold An, Bn; replace (S N - S i)%nat with (N - i)%nat;
     [ idtac | reflexivity ].
   rewrite <- pascal;
     [ ring
-      | apply le_lt_trans with n; [ assumption | unfold N in |- *; apply lt_n_Sn ] ].
-  unfold N in |- *; reflexivity.
-  unfold N in |- *; apply lt_O_Sn.
+      | apply le_lt_trans with n; [ assumption | unfold N; apply lt_n_Sn ] ].
+  unfold N; reflexivity.
+  unfold N; apply lt_O_Sn.
   rewrite <- (Rmult_comm y); rewrite scal_sum; apply sum_eq.
   intros; replace (S N - i)%nat with (S (N - i)).
   replace (S (N - i)) with (N - i + 1)%nat; [ idtac | ring ].
-  rewrite pow_add; replace (y ^ 1) with y; [ idtac | simpl in |- *; ring ];
+  rewrite pow_add; replace (y ^ 1) with y; [ idtac | simpl; ring ];
     ring.
   apply minus_Sn_m; assumption.
   rewrite <- (Rmult_comm x); rewrite scal_sum; apply sum_eq.
   intros; replace (S i) with (i + 1)%nat; [ idtac | ring ]; rewrite pow_add;
-    replace (x ^ 1) with x; [ idtac | simpl in |- *; ring ];
+    replace (x ^ 1) with x; [ idtac | simpl; ring ];
       ring.
-  intro; unfold C in |- *.
+  intro; unfold C.
   replace (INR (fact 0)) with 1; [ idtac | reflexivity ].
   replace (p - 0)%nat with p; [ idtac | apply minus_n_O ].
-  rewrite Rmult_1_l; unfold Rdiv in |- *; rewrite <- Rinv_r_sym;
+  rewrite Rmult_1_l; unfold Rdiv; rewrite <- Rinv_r_sym;
     [ reflexivity | apply INR_fact_neq_0 ].
-  intro; unfold C in |- *.
+  intro; unfold C.
   replace (p - p)%nat with 0%nat; [ idtac | apply minus_n_n ].
   replace (INR (fact 0)) with 1; [ idtac | reflexivity ].
-  rewrite Rmult_1_r; unfold Rdiv in |- *; rewrite <- Rinv_r_sym;
+  rewrite Rmult_1_r; unfold Rdiv; rewrite <- Rinv_r_sym;
     [ reflexivity | apply INR_fact_neq_0 ].
 Qed.
diff --git a/theories/Reals/Cauchy_prod.v b/theories/Reals/Cauchy_prod.v
index 1a2e5eca..f6a48adc 100644
--- a/theories/Reals/Cauchy_prod.v
+++ b/theories/Reals/Cauchy_prod.v
@@ -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-2012     *)
 (*   \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.
 Require Import PartSum.
-Open Local Scope R_scope.
+Local Open Scope R_scope.
 
   (**********)
 Lemma sum_N_predN :
@@ -23,7 +21,7 @@ Proof.
   replace N with (S (pred N)).
   rewrite tech5.
   reflexivity.
-  symmetry  in |- *; apply S_pred with 0%nat; assumption.
+  symmetry ; apply S_pred with 0%nat; assumption.
 Qed.
 
   (**********)
@@ -53,7 +51,7 @@ Proof.
   elim (lt_irrefl _ H).
   cut (N = 0%nat \/ (0 < N)%nat).
   intro; elim H0; intro.
-  rewrite H1; simpl in |- *; ring.
+  rewrite H1; simpl; ring.
   replace (pred (S N)) with (S (pred N)).
   do 5 rewrite tech5.
   rewrite Rmult_plus_distr_r; rewrite Rmult_plus_distr_l; rewrite (HrecN H1).
@@ -68,7 +66,7 @@ Proof.
       repeat rewrite Rplus_assoc; apply Rplus_eq_compat_l.
   rewrite <- minus_n_n; cut (N = 1%nat \/ (2 <= N)%nat).
   intro; elim H2; intro.
-  rewrite H3; simpl in |- *; ring.
+  rewrite H3; simpl; ring.
   replace
     (sum_f_R0
       (fun k:nat =>
@@ -149,7 +147,7 @@ Proof.
       (pred (pred N))).
   repeat rewrite Rplus_assoc; apply Rplus_eq_compat_l.
   replace (pred (N - pred N)) with 0%nat.
-  simpl in |- *; rewrite <- minus_n_O.
+  simpl; rewrite <- minus_n_O.
   replace (S (pred N)) with N.
   replace (sum_f_R0 (fun k:nat => An (S N) * Bn (S k)) (pred (pred N))) with
     (sum_f_R0 (fun k:nat => Bn (S k) * An (S N)) (pred (pred N))).
@@ -163,11 +161,11 @@ Proof.
   apply S_pred with 0%nat; assumption.
   replace (N - pred N)%nat with 1%nat.
   reflexivity.
-  pattern N at 1 in |- *; replace N with (S (pred N)).
+  pattern N at 1; replace N with (S (pred N)).
   rewrite <- minus_Sn_m.
   rewrite <- minus_n_n; reflexivity.
   apply le_n.
-  symmetry  in |- *; apply S_pred with 0%nat; assumption.
+  symmetry ; apply S_pred with 0%nat; assumption.
   apply sum_eq; intros;
     rewrite
       (sum_N_predN (fun l:nat => An (S (S (l + i))) * Bn (N - l)%nat)
@@ -261,7 +259,7 @@ Proof.
   apply le_n.
   apply (fun p n m:nat => plus_le_reg_l n m p) with 1%nat.
   rewrite le_plus_minus_r.
-  simpl in |- *; assumption.
+  simpl; assumption.
   apply le_trans with 2%nat; [ apply le_n_Sn | assumption ].
   apply le_trans with 2%nat; [ apply le_n_Sn | assumption ].
   simpl; ring.
@@ -276,7 +274,7 @@ Proof.
   apply le_trans with (pred (pred N)).
   assumption.
   apply le_pred_n.
-  symmetry  in |- *; apply S_pred with 0%nat; assumption.
+  symmetry ; apply S_pred with 0%nat; assumption.
   apply INR_eq; rewrite S_INR; rewrite plus_INR; reflexivity.
   apply le_trans with (pred (pred N)).
   assumption.
@@ -429,7 +427,7 @@ Proof.
   apply le_trans with (pred (pred N)).
   assumption.
   apply le_pred_n.
-  symmetry  in |- *; apply S_pred with 0%nat; assumption.
+  symmetry ; apply S_pred with 0%nat; assumption.
   apply INR_eq; rewrite S_INR; rewrite plus_INR; simpl; ring.
   apply le_trans with (pred (pred N)).
   assumption.
@@ -443,11 +441,11 @@ Proof.
   inversion H1.
   left; reflexivity.
   right; apply le_n_S; assumption.
-  simpl in |- *.
+  simpl.
   replace (S (pred N)) with N.
   reflexivity.
   apply S_pred with 0%nat; assumption.
-  simpl in |- *.
+  simpl.
   cut ((N - pred N)%nat = 1%nat).
   intro; rewrite H2; reflexivity.
   rewrite pred_of_minus.
@@ -455,7 +453,7 @@ Proof.
   simpl; ring.
   apply lt_le_S; assumption.
   rewrite <- pred_of_minus; apply le_pred_n.
-  simpl in |- *; symmetry  in |- *; apply S_pred with 0%nat; assumption.
+  simpl; symmetry ; apply S_pred with 0%nat; assumption.
   inversion H.
   left; reflexivity.
   right; apply lt_le_trans with 1%nat; [ apply lt_n_Sn | exact H1 ].
diff --git a/theories/Reals/Cos_plus.v b/theories/Reals/Cos_plus.v
index 32480b0b..c296d427 100644
--- a/theories/Reals/Cos_plus.v
+++ b/theories/Reals/Cos_plus.v
@@ -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-2012     *)
 (*   \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.
 Require Import Rtrigo_def.
 Require Import Cos_rel.
 Require Import Max.
-Open Local Scope nat_scope.
-Open Local Scope R_scope.
+Local Open Scope nat_scope.
+Local Open Scope R_scope.
 
 Definition Majxy (x y:R) (n:nat) : R :=
   Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (4 * S n) / INR (fact n).
@@ -31,23 +29,23 @@ Proof.
   intro.
   assert (H1 := cv_speed_pow_fact C0).
   unfold Un_cv in H1; unfold R_dist in H1.
-  unfold Un_cv in |- *; unfold R_dist in |- *; intros.
+  unfold Un_cv; unfold R_dist; intros.
   cut (0 < eps / C0);
     [ intro
-      | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+      | unfold Rdiv; apply Rmult_lt_0_compat;
 	[ assumption | apply Rinv_0_lt_compat; assumption ] ].
   elim (H1 (eps / C0) H3); intros N0 H4.
   exists N0; intros.
   replace (Majxy x y n) with (C0 ^ S n / INR (fact n)).
-  simpl in |- *.
+  simpl.
   apply Rmult_lt_reg_l with (Rabs (/ C0)).
   apply Rabs_pos_lt.
   apply Rinv_neq_0_compat.
-  red in |- *; intro; rewrite H6 in H0; elim (Rlt_irrefl _ H0).
+  red; intro; rewrite H6 in H0; elim (Rlt_irrefl _ H0).
   rewrite <- Rabs_mult.
-  unfold Rminus in |- *; rewrite Rmult_plus_distr_l.
+  unfold Rminus; rewrite Rmult_plus_distr_l.
   rewrite Ropp_0; rewrite Rmult_0_r.
-  unfold Rdiv in |- *; repeat rewrite <- Rmult_assoc.
+  unfold Rdiv; repeat rewrite <- Rmult_assoc.
   rewrite <- Rinv_l_sym.
   rewrite Rmult_1_l.
   rewrite (Rabs_right (/ C0)).
@@ -56,15 +54,15 @@ Proof.
     [ idtac | ring ].
   unfold Rdiv in H4; apply H4; assumption.
   apply Rle_ge; left; apply Rinv_0_lt_compat; assumption.
-  red in |- *; intro; rewrite H6 in H0; elim (Rlt_irrefl _ H0).
-  unfold Majxy in |- *.
-  unfold C0 in |- *.
+  red; intro; rewrite H6 in H0; elim (Rlt_irrefl _ H0).
+  unfold Majxy.
+  unfold C0.
   rewrite pow_mult.
-  unfold C in |- *; reflexivity.
-  unfold C0 in |- *; apply pow_lt; assumption.
+  unfold C; reflexivity.
+  unfold C0; apply pow_lt; assumption.
   apply Rlt_le_trans with 1.
   apply Rlt_0_1.
-  unfold C in |- *.
+  unfold C.
   apply RmaxLess1.
 Qed.
 
@@ -74,7 +72,7 @@ Lemma reste1_maj :
 Proof.
   intros.
   set (C := Rmax 1 (Rmax (Rabs x) (Rabs y))).
-  unfold Reste1 in |- *.
+  unfold Reste1.
   apply Rle_trans with
     (sum_f_R0
       (fun k:nat =>
@@ -122,7 +120,7 @@ Proof.
           C ^ (2 * S (N + k))) (pred (N - k))) (pred N)).
   apply sum_Rle; intros.
   apply sum_Rle; intros.
-  unfold Rdiv in |- *; repeat rewrite Rabs_mult.
+  unfold Rdiv; repeat rewrite Rabs_mult.
   do 2 rewrite pow_1_abs.
   do 2 rewrite Rmult_1_l.
   rewrite (Rabs_right (/ INR (fact (2 * S (n0 + n))))).
@@ -144,7 +142,7 @@ Proof.
   apply pow_incr.
   split.
   apply Rabs_pos.
-  unfold C in |- *.
+  unfold C.
   apply Rle_trans with (Rmax (Rabs x) (Rabs y)); apply RmaxLess2.
   apply Rle_trans with (C ^ (2 * S (n0 + n)) * C ^ (2 * (N - n0))).
   do 2 rewrite <- (Rmult_comm (C ^ (2 * (N - n0)))).
@@ -152,11 +150,11 @@ Proof.
   apply pow_le.
   apply Rle_trans with 1.
   left; apply Rlt_0_1.
-  unfold C in |- *; apply RmaxLess1.
+  unfold C; apply RmaxLess1.
   apply pow_incr.
   split.
   apply Rabs_pos.
-  unfold C in |- *; apply Rle_trans with (Rmax (Rabs x) (Rabs y)).
+  unfold C; apply Rle_trans with (Rmax (Rabs x) (Rabs y)).
   apply RmaxLess1.
   apply RmaxLess2.
   right.
@@ -205,7 +203,7 @@ Proof.
   left; apply Rinv_0_lt_compat.
   rewrite mult_INR; apply Rmult_lt_0_compat; apply INR_fact_lt_0.
   apply Rle_pow.
-  unfold C in |- *; apply RmaxLess1.
+  unfold C; apply RmaxLess1.
   replace (4 * N)%nat with (2 * (2 * N))%nat; [ idtac | ring ].
   apply (fun m n p:nat => mult_le_compat_l p n m).
   replace (2 * N)%nat with (S (N + pred N)).
@@ -225,33 +223,33 @@ Proof.
   apply pow_le.
   left; apply Rlt_le_trans with 1.
   apply Rlt_0_1.
-  unfold C in |- *; apply RmaxLess1.
+  unfold C; apply RmaxLess1.
   replace (/ INR (fact (2 * S (n0 + n)) * fact (2 * (N - n0)))) with
     (Binomial.C (2 * S (N + n)) (2 * S (n0 + n)) / INR (fact (2 * S (N + n)))).
   apply Rle_trans with
     (Binomial.C (2 * S (N + n)) (S (N + n)) / INR (fact (2 * S (N + n)))).
-  unfold Rdiv in |- *;
+  unfold Rdiv;
     do 2 rewrite <- (Rmult_comm (/ INR (fact (2 * S (N + n))))).
   apply Rmult_le_compat_l.
   left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
   apply C_maj.
   omega.
   right.
-  unfold Rdiv in |- *; rewrite Rmult_comm.
-  unfold Binomial.C in |- *.
-  unfold Rdiv in |- *; repeat rewrite <- Rmult_assoc.
+  unfold Rdiv; rewrite Rmult_comm.
+  unfold Binomial.C.
+  unfold Rdiv; repeat rewrite <- Rmult_assoc.
   rewrite <- Rinv_l_sym.
   rewrite Rmult_1_l.
   replace (2 * S (N + n) - S (N + n))%nat with (S (N + n)).
   rewrite Rinv_mult_distr.
-  unfold Rsqr in |- *; reflexivity.
+  unfold Rsqr; reflexivity.
   apply INR_fact_neq_0.
   apply INR_fact_neq_0.
   omega.
   apply INR_fact_neq_0.
-  unfold Rdiv in |- *; rewrite Rmult_comm.
-  unfold Binomial.C in |- *.
-  unfold Rdiv in |- *; repeat rewrite <- Rmult_assoc.
+  unfold Rdiv; rewrite Rmult_comm.
+  unfold Binomial.C.
+  unfold Rdiv; repeat rewrite <- Rmult_assoc.
   rewrite <- Rinv_l_sym.
   rewrite Rmult_1_l.
   replace (2 * S (N + n) - 2 * S (n0 + n))%nat with (2 * (N - n0))%nat.
@@ -273,17 +271,17 @@ Proof.
   apply pow_le.
   left; apply Rlt_le_trans with 1.
   apply Rlt_0_1.
-  unfold C in |- *; apply RmaxLess1.
+  unfold C; apply RmaxLess1.
   apply Rle_trans with (Rsqr (/ INR (fact (S (N + n)))) * INR N).
   apply Rmult_le_compat_l.
   apply Rle_0_sqr.
   apply le_INR.
   omega.
-  rewrite Rmult_comm; unfold Rdiv in |- *; apply Rmult_le_compat_l.
+  rewrite Rmult_comm; unfold Rdiv; apply Rmult_le_compat_l.
   apply pos_INR.
   apply Rle_trans with (/ INR (fact (S (N + n)))).
-  pattern (/ INR (fact (S (N + n)))) at 2 in |- *; rewrite <- Rmult_1_r.
-  unfold Rsqr in |- *.
+  pattern (/ INR (fact (S (N + n)))) at 2; rewrite <- Rmult_1_r.
+  unfold Rsqr.
   apply Rmult_le_compat_l.
   left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
   apply Rmult_le_reg_l with (INR (fact (S (N + n)))).
@@ -315,14 +313,14 @@ Proof.
   rewrite sum_cte.
   apply Rle_trans with (C ^ (4 * N) / INR (fact (pred N))).
   rewrite <- (Rmult_comm (C ^ (4 * N))).
-  unfold Rdiv in |- *; rewrite Rmult_assoc; apply Rmult_le_compat_l.
+  unfold Rdiv; rewrite Rmult_assoc; apply Rmult_le_compat_l.
   apply pow_le.
   left; apply Rlt_le_trans with 1.
   apply Rlt_0_1.
-  unfold C in |- *; apply RmaxLess1.
+  unfold C; apply RmaxLess1.
   cut (S (pred N) = N).
   intro; rewrite H0.
-  pattern N at 2 in |- *; rewrite <- H0.
+  pattern N at 2; rewrite <- H0.
   do 2 rewrite fact_simpl.
   rewrite H0.
   repeat rewrite mult_INR.
@@ -331,7 +329,7 @@ Proof.
   repeat rewrite <- Rmult_assoc.
   rewrite <- Rinv_r_sym.
   rewrite Rmult_1_l.
-  pattern (/ INR (fact (pred N))) at 2 in |- *; rewrite <- Rmult_1_r.
+  pattern (/ INR (fact (pred N))) at 2; rewrite <- Rmult_1_r.
   rewrite Rmult_assoc.
   apply Rmult_le_compat_l.
   left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
@@ -342,19 +340,19 @@ Proof.
   apply le_INR; apply le_n_Sn.
   apply not_O_INR; discriminate.
   apply not_O_INR.
-  red in |- *; intro; rewrite H1 in H; elim (lt_irrefl _ H).
+  red; intro; rewrite H1 in H; elim (lt_irrefl _ H).
   apply not_O_INR.
-  red in |- *; intro; rewrite H1 in H; elim (lt_irrefl _ H).
+  red; intro; rewrite H1 in H; elim (lt_irrefl _ H).
   apply INR_fact_neq_0.
   apply not_O_INR; discriminate.
   apply prod_neq_R0.
   apply not_O_INR.
-  red in |- *; intro; rewrite H1 in H; elim (lt_irrefl _ H).
+  red; intro; rewrite H1 in H; elim (lt_irrefl _ H).
   apply INR_fact_neq_0.
-  symmetry  in |- *; apply S_pred with 0%nat; assumption.
+  symmetry ; apply S_pred with 0%nat; assumption.
   right.
-  unfold Majxy in |- *.
-  unfold C in |- *.
+  unfold Majxy.
+  unfold C.
   replace (S (pred N)) with N.
   reflexivity.
   apply S_pred with 0%nat; assumption.
@@ -365,7 +363,7 @@ Lemma reste2_maj :
 Proof.
   intros.
   set (C := Rmax 1 (Rmax (Rabs x) (Rabs y))).
-  unfold Reste2 in |- *.
+  unfold Reste2.
   apply Rle_trans with
     (sum_f_R0
       (fun k:nat =>
@@ -417,7 +415,7 @@ Proof.
 	    pred N)).
   apply sum_Rle; intros.
   apply sum_Rle; intros.
-  unfold Rdiv in |- *; repeat rewrite Rabs_mult.
+  unfold Rdiv; repeat rewrite Rabs_mult.
   do 2 rewrite pow_1_abs.
   do 2 rewrite Rmult_1_l.
   rewrite (Rabs_right (/ INR (fact (2 * S (n0 + n) + 1)))).
@@ -439,7 +437,7 @@ Proof.
   apply pow_incr.
   split.
   apply Rabs_pos.
-  unfold C in |- *.
+  unfold C.
   apply Rle_trans with (Rmax (Rabs x) (Rabs y)); apply RmaxLess2.
   apply Rle_trans with (C ^ (2 * S (n0 + n) + 1) * C ^ (2 * (N - n0) + 1)).
   do 2 rewrite <- (Rmult_comm (C ^ (2 * (N - n0) + 1))).
@@ -447,11 +445,11 @@ Proof.
   apply pow_le.
   apply Rle_trans with 1.
   left; apply Rlt_0_1.
-  unfold C in |- *; apply RmaxLess1.
+  unfold C; apply RmaxLess1.
   apply pow_incr.
   split.
   apply Rabs_pos.
-  unfold C in |- *; apply Rle_trans with (Rmax (Rabs x) (Rabs y)).
+  unfold C; apply Rle_trans with (Rmax (Rabs x) (Rabs y)).
   apply RmaxLess1.
   apply RmaxLess2.
   right.
@@ -479,7 +477,7 @@ Proof.
   left; apply Rinv_0_lt_compat.
   rewrite mult_INR; apply Rmult_lt_0_compat; apply INR_fact_lt_0.
   apply Rle_pow.
-  unfold C in |- *; apply RmaxLess1.
+  unfold C; apply RmaxLess1.
   replace (4 * S N)%nat with (2 * (2 * S N))%nat; [ idtac | ring ].
   apply (fun m n p:nat => mult_le_compat_l p n m).
   replace (2 * S N)%nat with (S (S (N + N))).
@@ -502,14 +500,14 @@ Proof.
   apply pow_le.
   left; apply Rlt_le_trans with 1.
   apply Rlt_0_1.
-  unfold C in |- *; apply RmaxLess1.
+  unfold C; apply RmaxLess1.
   replace (/ INR (fact (2 * S (n0 + n) + 1) * fact (2 * (N - n0) + 1))) with
     (Binomial.C (2 * S (S (N + n))) (2 * S (n0 + n) + 1) /
       INR (fact (2 * S (S (N + n))))).
   apply Rle_trans with
     (Binomial.C (2 * S (S (N + n))) (S (S (N + n))) /
       INR (fact (2 * S (S (N + n))))).
-  unfold Rdiv in |- *;
+  unfold Rdiv;
     do 2 rewrite <- (Rmult_comm (/ INR (fact (2 * S (S (N + n)))))).
   apply Rmult_le_compat_l.
   left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
@@ -520,21 +518,21 @@ Proof.
   ring.
   omega.
   right.
-  unfold Rdiv in |- *; rewrite Rmult_comm.
-  unfold Binomial.C in |- *.
-  unfold Rdiv in |- *; repeat rewrite <- Rmult_assoc.
+  unfold Rdiv; rewrite Rmult_comm.
+  unfold Binomial.C.
+  unfold Rdiv; repeat rewrite <- Rmult_assoc.
   rewrite <- Rinv_l_sym.
   rewrite Rmult_1_l.
   replace (2 * S (S (N + n)) - S (S (N + n)))%nat with (S (S (N + n))).
   rewrite Rinv_mult_distr.
-  unfold Rsqr in |- *; reflexivity.
+  unfold Rsqr; reflexivity.
   apply INR_fact_neq_0.
   apply INR_fact_neq_0.
   omega.
   apply INR_fact_neq_0.
-  unfold Rdiv in |- *; rewrite Rmult_comm.
-  unfold Binomial.C in |- *.
-  unfold Rdiv in |- *; repeat rewrite <- Rmult_assoc.
+  unfold Rdiv; rewrite Rmult_comm.
+  unfold Binomial.C.
+  unfold Rdiv; repeat rewrite <- Rmult_assoc.
   rewrite <- Rinv_l_sym.
   rewrite Rmult_1_l.
   replace (2 * S (S (N + n)) - (2 * S (n0 + n) + 1))%nat with
@@ -558,7 +556,7 @@ Proof.
   apply pow_le.
   left; apply Rlt_le_trans with 1.
   apply Rlt_0_1.
-  unfold C in |- *; apply RmaxLess1.
+  unfold C; apply RmaxLess1.
   apply Rle_trans with (Rsqr (/ INR (fact (S (S (N + n))))) * INR N).
   apply Rmult_le_compat_l.
   apply Rle_0_sqr.
@@ -566,11 +564,11 @@ Proof.
   apply le_INR.
   omega.
   omega.
-  rewrite Rmult_comm; unfold Rdiv in |- *; apply Rmult_le_compat_l.
+  rewrite Rmult_comm; unfold Rdiv; apply Rmult_le_compat_l.
   apply pos_INR.
   apply Rle_trans with (/ INR (fact (S (S (N + n))))).
-  pattern (/ INR (fact (S (S (N + n))))) at 2 in |- *; rewrite <- Rmult_1_r.
-  unfold Rsqr in |- *.
+  pattern (/ INR (fact (S (S (N + n))))) at 2; rewrite <- Rmult_1_r.
+  unfold Rsqr.
   apply Rmult_le_compat_l.
   left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
   apply Rmult_le_reg_l with (INR (fact (S (S (N + n))))).
@@ -601,11 +599,11 @@ Proof.
   rewrite sum_cte.
   apply Rle_trans with (C ^ (4 * S N) / INR (fact N)).
   rewrite <- (Rmult_comm (C ^ (4 * S N))).
-  unfold Rdiv in |- *; rewrite Rmult_assoc; apply Rmult_le_compat_l.
+  unfold Rdiv; rewrite Rmult_assoc; apply Rmult_le_compat_l.
   apply pow_le.
   left; apply Rlt_le_trans with 1.
   apply Rlt_0_1.
-  unfold C in |- *; apply RmaxLess1.
+  unfold C; apply RmaxLess1.
   cut (S (pred N) = N).
   intro; rewrite H0.
   do 2 rewrite fact_simpl.
@@ -644,10 +642,10 @@ Proof.
   apply INR_fact_neq_0.
   apply not_O_INR; discriminate.
   apply prod_neq_R0; [ apply not_O_INR; discriminate | apply INR_fact_neq_0 ].
-  symmetry  in |- *; apply S_pred with 0%nat; assumption.
+  symmetry ; apply S_pred with 0%nat; assumption.
   right.
-  unfold Majxy in |- *.
-  unfold C in |- *.
+  unfold Majxy.
+  unfold C.
   reflexivity.
 Qed.
 
@@ -656,10 +654,10 @@ Proof.
   intros.
   assert (H := Majxy_cv_R0 x y).
   unfold Un_cv in H; unfold R_dist in H.
-  unfold Un_cv in |- *; unfold R_dist in |- *; intros.
+  unfold Un_cv; unfold R_dist; intros.
   elim (H eps H0); intros N0 H1.
   exists (S N0); intros.
-  unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r.
+  unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r.
   apply Rle_lt_trans with (Rabs (Majxy x y (pred n))).
   rewrite (Rabs_right (Majxy x y (pred n))).
   apply reste1_maj.
@@ -667,8 +665,8 @@ Proof.
   apply lt_O_Sn.
   assumption.
   apply Rle_ge.
-  unfold Majxy in |- *.
-  unfold Rdiv in |- *; apply Rmult_le_pos.
+  unfold Majxy.
+  unfold Rdiv; apply Rmult_le_pos.
   apply pow_le.
   apply Rle_trans with 1.
   left; apply Rlt_0_1.
@@ -676,7 +674,7 @@ Proof.
   left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
   replace (Majxy x y (pred n)) with (Majxy x y (pred n) - 0); [ idtac | ring ].
   apply H1.
-  unfold ge in |- *; apply le_S_n.
+  unfold ge; apply le_S_n.
   replace (S (pred n)) with n.
   assumption.
   apply S_pred with 0%nat.
@@ -688,10 +686,10 @@ Proof.
   intros.
   assert (H := Majxy_cv_R0 x y).
   unfold Un_cv in H; unfold R_dist in H.
-  unfold Un_cv in |- *; unfold R_dist in |- *; intros.
+  unfold Un_cv; unfold R_dist; intros.
   elim (H eps H0); intros N0 H1.
   exists (S N0); intros.
-  unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r.
+  unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r.
   apply Rle_lt_trans with (Rabs (Majxy x y n)).
   rewrite (Rabs_right (Majxy x y n)).
   apply reste2_maj.
@@ -699,8 +697,8 @@ Proof.
   apply lt_O_Sn.
   assumption.
   apply Rle_ge.
-  unfold Majxy in |- *.
-  unfold Rdiv in |- *; apply Rmult_le_pos.
+  unfold Majxy.
+  unfold Rdiv; apply Rmult_le_pos.
   apply pow_le.
   apply Rle_trans with 1.
   left; apply Rlt_0_1.
@@ -708,7 +706,7 @@ Proof.
   left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
   replace (Majxy x y n) with (Majxy x y n - 0); [ idtac | ring ].
   apply H1.
-  unfold ge in |- *; apply le_trans with (S N0).
+  unfold ge; apply le_trans with (S N0).
   apply le_n_Sn.
   exact H2.
 Qed.
@@ -716,7 +714,7 @@ Qed.
 Lemma reste_cv_R0 : forall x y:R, Un_cv (Reste x y) 0.
 Proof.
   intros.
-  unfold Reste in |- *.
+  unfold Reste.
   set (An := fun n:nat => Reste2 x y n).
   set (Bn := fun n:nat => Reste1 x y (S n)).
   cut
@@ -725,21 +723,21 @@ Proof.
   intro.
   apply H.
   apply CV_minus.
-  unfold An in |- *.
+  unfold An.
   replace (fun n:nat => Reste2 x y n) with (Reste2 x y).
   apply reste2_cv_R0.
   reflexivity.
-  unfold Bn in |- *.
+  unfold Bn.
   assert (H0 := reste1_cv_R0 x y).
   unfold Un_cv in H0; unfold R_dist in H0.
-  unfold Un_cv in |- *; unfold R_dist in |- *; intros.
+  unfold Un_cv; unfold R_dist; intros.
   elim (H0 eps H1); intros N0 H2.
   exists N0; intros.
   apply H2.
-  unfold ge in |- *; apply le_trans with (S N0).
+  unfold ge; apply le_trans with (S N0).
   apply le_n_Sn.
   apply le_n_S; assumption.
-  unfold An, Bn in |- *.
+  unfold An, Bn.
   intro.
   replace 0 with (0 - 0); [ idtac | ring ].
   exact H.
@@ -753,7 +751,7 @@ Proof.
   intros.
   apply UL_sequence with (C1 x y); assumption.
   apply C1_cvg.
-  unfold Un_cv in |- *; unfold R_dist in |- *.
+  unfold Un_cv; unfold R_dist.
   intros.
   assert (H0 := A1_cvg x).
   assert (H1 := A1_cvg y).
@@ -766,7 +764,7 @@ Proof.
   unfold R_dist in H4; unfold R_dist in H5; unfold R_dist in H6.
   cut (0 < eps / 3);
     [ intro
-      | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+      | unfold Rdiv; apply Rmult_lt_0_compat;
 	[ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ].
   elim (H4 (eps / 3) H7); intros N1 H8.
   elim (H5 (eps / 3) H7); intros N2 H9.
@@ -790,8 +788,8 @@ Proof.
   replace eps with (eps / 3 + (eps / 3 + eps / 3)).
   apply Rplus_lt_compat.
   apply H8.
-  unfold ge in |- *; apply le_trans with N.
-  unfold N in |- *.
+  unfold ge; apply le_trans with N.
+  unfold N.
   apply le_trans with (max N1 N2).
   apply le_max_l.
   apply le_trans with (max (max N1 N2) N3).
@@ -806,12 +804,12 @@ Proof.
   rewrite <- Rabs_Ropp.
   rewrite Ropp_minus_distr.
   apply H9.
-  unfold ge in |- *; apply le_trans with (max N1 N2).
+  unfold ge; apply le_trans with (max N1 N2).
   apply le_max_r.
   apply le_S_n.
   rewrite <- H12.
   apply le_trans with N.
-  unfold N in |- *.
+  unfold N.
   apply le_n_S.
   apply le_trans with (max (max N1 N2) N3).
   apply le_max_l.
@@ -819,35 +817,35 @@ Proof.
   assumption.
   replace (Reste x y (pred n)) with (Reste x y (pred n) - 0).
   apply H10.
-  unfold ge in |- *.
+  unfold ge.
   apply le_S_n.
   rewrite <- H12.
   apply le_trans with N.
-  unfold N in |- *.
+  unfold N.
   apply le_n_S.
   apply le_trans with (max (max N1 N2) N3).
   apply le_max_r.
   apply le_n_Sn.
   assumption.
   ring.
-  pattern eps at 4 in |- *; replace eps with (3 * (eps / 3)).
+  pattern eps at 4; replace eps with (3 * (eps / 3)).
   ring.
-  unfold Rdiv in |- *.
+  unfold Rdiv.
   rewrite <- Rmult_assoc.
   apply Rinv_r_simpl_m.
   discrR.
   apply lt_le_trans with (pred N).
-  unfold N in |- *; simpl in |- *; apply lt_O_Sn.
+  unfold N; simpl; apply lt_O_Sn.
   apply le_S_n.
   rewrite <- H12.
   replace (S (pred N)) with N.
   assumption.
-  unfold N in |- *; simpl in |- *; reflexivity.
+  unfold N; simpl; reflexivity.
   cut (0 < N)%nat.
   intro.
   cut (0 < n)%nat.
   intro.
   apply S_pred with 0%nat; assumption.
   apply lt_le_trans with N; assumption.
-  unfold N in |- *; apply lt_O_Sn.
+  unfold N; apply lt_O_Sn.
 Qed.
diff --git a/theories/Reals/Cos_rel.v b/theories/Reals/Cos_rel.v
index dec5abd3..9c7472fe 100644
--- a/theories/Reals/Cos_rel.v
+++ b/theories/Reals/Cos_rel.v
@@ -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-2012     *)
 (*   \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.
 Require Import Rtrigo_def.
-Open Local Scope R_scope.
+Local Open Scope R_scope.
 
 Definition A1 (x:R) (N:nat) : R :=
   sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * x ^ (2 * k)) N.
@@ -52,7 +50,7 @@ Theorem cos_plus_form :
    (0 < n)%nat ->
    A1 x (S n) * A1 y (S n) - B1 x n * B1 y n + Reste x y n = C1 x y (S n).
 intros.
-unfold A1, B1 in |- *.
+unfold A1, B1.
 rewrite
  (cauchy_finite (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * x ^ (2 * k))
     (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * y ^ (2 * k)) (
@@ -62,7 +60,7 @@ rewrite
     (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * x ^ (2 * k + 1))
     (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * y ^ (2 * k + 1)) n H)
  .
-unfold Reste in |- *.
+unfold Reste.
 replace
  (sum_f_R0
     (fun k:nat =>
@@ -121,13 +119,13 @@ replace
             ((-1) ^ (k - p) / INR (fact (2 * (k - p) + 1)) *
              y ^ (2 * (k - p) + 1))) k) n) with (sum_f_R0 sin_nnn (S n)).
 rewrite <- sum_plus.
-unfold C1 in |- *.
+unfold C1.
 apply sum_eq; intros.
 induction  i as [| i Hreci].
-simpl in |- *.
-unfold C in |- *; simpl in |- *.
+simpl.
+unfold C; simpl.
 field; discrR.
-unfold sin_nnn in |- *.
+unfold sin_nnn.
 rewrite <- Rmult_plus_distr_l.
 apply Rmult_eq_compat_l.
 rewrite binomial.
@@ -143,13 +141,13 @@ replace
  (sum_f_R0 (fun l:nat => Wn (S (2 * l))) i).
 apply sum_decomposition.
 apply sum_eq; intros.
-unfold Wn in |- *.
+unfold Wn.
 apply Rmult_eq_compat_l.
 replace (2 * S i - S (2 * i0))%nat with (S (2 * (i - i0))).
 reflexivity.
 omega.
 apply sum_eq; intros.
-unfold Wn in |- *.
+unfold Wn.
 apply Rmult_eq_compat_l.
 replace (2 * S i - 2 * i0)%nat with (2 * (S i - i0))%nat.
 reflexivity.
@@ -179,11 +177,11 @@ change (pred (S n)) with n.
    (* replace (pred (S n)) with n; [ idtac | reflexivity ]. *)
 apply sum_eq; intros.
 rewrite Rmult_comm.
-unfold sin_nnn in |- *.
+unfold sin_nnn.
 rewrite scal_sum.
 rewrite scal_sum.
 apply sum_eq; intros.
-unfold Rdiv in |- *.
+unfold Rdiv.
 (*repeat rewrite Rmult_assoc.*)
 (* rewrite (Rmult_comm (/ INR (fact (2 * S i)))). *)
 repeat rewrite <- Rmult_assoc.
@@ -195,13 +193,13 @@ replace (S (2 * i0)) with (2 * i0 + 1)%nat; [ idtac | ring ].
 replace (S (2 * (i - i0))) with (2 * (i - i0) + 1)%nat; [ idtac | ring ].
 replace ((-1) ^ S i) with (-1 * (-1) ^ i0 * (-1) ^ (i - i0)).
 ring.
-simpl in |- *.
-pattern i at 2 in |- *; replace i with (i0 + (i - i0))%nat.
+simpl.
+pattern i at 2; replace i with (i0 + (i - i0))%nat.
 rewrite pow_add.
 ring.
-symmetry  in |- *; apply le_plus_minus; assumption.
-unfold C in |- *.
-unfold Rdiv in |- *; repeat rewrite <- Rmult_assoc.
+symmetry ; apply le_plus_minus; assumption.
+unfold C.
+unfold Rdiv; repeat rewrite <- Rmult_assoc.
 rewrite <- Rinv_l_sym.
 rewrite Rmult_1_l.
 rewrite Rinv_mult_distr.
@@ -219,7 +217,7 @@ apply lt_O_Sn.
 apply sum_eq; intros.
 rewrite scal_sum.
 apply sum_eq; intros.
-unfold Rdiv in |- *.
+unfold Rdiv.
 repeat rewrite <- Rmult_assoc.
 rewrite <- (Rmult_comm (/ INR (fact (2 * i)))).
 repeat rewrite <- Rmult_assoc.
@@ -227,12 +225,12 @@ replace (/ INR (fact (2 * i)) * C (2 * i) (2 * i0)) with
  (/ INR (fact (2 * i0)) * / INR (fact (2 * (i - i0)))).
 replace ((-1) ^ i) with ((-1) ^ i0 * (-1) ^ (i - i0)).
 ring.
-pattern i at 2 in |- *; replace i with (i0 + (i - i0))%nat.
+pattern i at 2; replace i with (i0 + (i - i0))%nat.
 rewrite pow_add.
 ring.
-symmetry  in |- *; apply le_plus_minus; assumption.
-unfold C in |- *.
-unfold Rdiv in |- *; repeat rewrite <- Rmult_assoc.
+symmetry ; apply le_plus_minus; assumption.
+unfold C.
+unfold Rdiv; repeat rewrite <- Rmult_assoc.
 rewrite <- Rinv_l_sym.
 rewrite Rmult_1_l.
 rewrite Rinv_mult_distr.
@@ -242,12 +240,12 @@ omega.
 apply INR_fact_neq_0.
 apply INR_fact_neq_0.
 apply INR_fact_neq_0.
-unfold Reste2 in |- *; apply sum_eq; intros.
+unfold Reste2; apply sum_eq; intros.
 apply sum_eq; intros.
-unfold Rdiv in |- *; ring.
-unfold Reste1 in |- *; apply sum_eq; intros.
+unfold Rdiv; ring.
+unfold Reste1; apply sum_eq; intros.
 apply sum_eq; intros.
-unfold Rdiv in |- *; ring.
+unfold Rdiv; ring.
 apply lt_O_Sn.
 Qed.
 
@@ -268,10 +266,10 @@ unfold R_dist in p.
 cut (cos x = x0).
 intro.
 rewrite H0.
-unfold Un_cv in |- *; unfold R_dist in |- *; intros.
+unfold Un_cv; unfold R_dist; intros.
 elim (p eps H1); intros.
 exists x1; intros.
-unfold A1 in |- *.
+unfold A1.
 replace
  (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * x ^ (2 * k)) n) with
  (sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i)) * (x * x) ^ i) n).
@@ -281,9 +279,9 @@ intros.
 replace ((x * x) ^ i) with (x ^ (2 * i)).
 reflexivity.
 apply pow_sqr.
-unfold cos in |- *.
+unfold cos.
 case (exist_cos (Rsqr x)).
-unfold Rsqr in |- *; intros.
+unfold Rsqr; intros.
 unfold cos_in in p_i.
 unfold cos_in in c.
 apply uniqueness_sum with (fun i:nat => cos_n i * (x * x) ^ i); assumption.
@@ -300,10 +298,10 @@ unfold R_dist in p.
 cut (cos (x + y) = x0).
 intro.
 rewrite H0.
-unfold Un_cv in |- *; unfold R_dist in |- *; intros.
+unfold Un_cv; unfold R_dist; intros.
 elim (p eps H1); intros.
 exists x1; intros.
-unfold C1 in |- *.
+unfold C1.
 replace
  (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * (x + y) ^ (2 * k)) n)
  with
@@ -315,9 +313,9 @@ intros.
 replace (((x + y) * (x + y)) ^ i) with ((x + y) ^ (2 * i)).
 reflexivity.
 apply pow_sqr.
-unfold cos in |- *.
+unfold cos.
 case (exist_cos (Rsqr (x + y))).
-unfold Rsqr in |- *; intros.
+unfold Rsqr; intros.
 unfold cos_in in p_i.
 unfold cos_in in c.
 apply uniqueness_sum with (fun i:nat => cos_n i * ((x + y) * (x + y)) ^ i);
@@ -329,17 +327,17 @@ intro.
 case (Req_dec x 0); intro.
 rewrite H.
 rewrite sin_0.
-unfold B1 in |- *.
-unfold Un_cv in |- *; unfold R_dist in |- *; intros; exists 0%nat; intros.
+unfold B1.
+unfold Un_cv; unfold R_dist; intros; exists 0%nat; intros.
 replace
  (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * 0 ^ (2 * k + 1))
     n) with 0.
-unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption.
+unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption.
 induction  n as [| n Hrecn].
-simpl in |- *; ring.
+simpl; ring.
 rewrite tech5; rewrite <- Hrecn.
-simpl in |- *; ring.
-unfold ge in |- *; apply le_O_n.
+simpl; ring.
+unfold ge; apply le_O_n.
 assert (H0 := exist_sin (x * x)).
 elim H0; intros.
 assert (p_i := p).
@@ -349,14 +347,14 @@ unfold R_dist in p.
 cut (sin x = x * x0).
 intro.
 rewrite H1.
-unfold Un_cv in |- *; unfold R_dist in |- *; intros.
+unfold Un_cv; unfold R_dist; intros.
 cut (0 < eps / Rabs x);
  [ intro
- | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+ | unfold Rdiv; apply Rmult_lt_0_compat;
     [ assumption | apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption ] ].
 elim (p (eps / Rabs x) H3); intros.
 exists x1; intros.
-unfold B1 in |- *.
+unfold B1.
 replace
  (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * x ^ (2 * k + 1))
     n) with
@@ -382,11 +380,11 @@ apply sum_eq.
 intros.
 rewrite pow_add.
 rewrite pow_sqr.
-simpl in |- *.
+simpl.
 ring.
-unfold sin in |- *.
+unfold sin.
 case (exist_sin (Rsqr x)).
-unfold Rsqr in |- *; intros.
+unfold Rsqr; intros.
 unfold sin_in in p_i.
 unfold sin_in in s.
 assert
diff --git a/theories/Reals/DiscrR.v b/theories/Reals/DiscrR.v
index 2cdc121f..1ec399d1 100644
--- a/theories/Reals/DiscrR.v
+++ b/theories/Reals/DiscrR.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-2012     *)
 (*   \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.
+Local Open Scope R_scope.
 
 Lemma Rlt_R0_R2 : 0 < 2.
 change 2 with (INR 2); apply lt_INR_0; apply lt_O_Sn.
@@ -23,7 +21,7 @@ intros; rewrite H; reflexivity.
 Qed.
 
 Lemma IZR_neq : forall z1 z2:Z, z1 <> z2 -> IZR z1 <> IZR z2.
-intros; red in |- *; intro; elim H; apply eq_IZR; assumption.
+intros; red; intro; elim H; apply eq_IZR; assumption.
 Qed.
 
 Ltac discrR :=
@@ -47,7 +45,7 @@ Ltac prove_sup0 :=
       repeat
        (apply Rmult_lt_0_compat || apply Rplus_lt_pos;
          try apply Rlt_0_1 || apply Rlt_R0_R2)
-  |  |- (?X1 > 0) => change (0 < X1) in |- *; prove_sup0
+  |  |- (?X1 > 0) => change (0 < X1); prove_sup0
   end.
 
 Ltac omega_sup :=
@@ -61,7 +59,7 @@ Ltac omega_sup :=
 
 Ltac prove_sup :=
   match goal with
-  |  |- (?X1 > ?X2) => change (X2 < X1) in |- *; prove_sup
+  |  |- (?X1 > ?X2) => change (X2 < X1); prove_sup
   |  |- (0 < ?X1) => prove_sup0
   |  |- (- ?X1 < 0) => rewrite <- Ropp_0; prove_sup
   |  |- (- ?X1 < - ?X2) => apply Ropp_lt_gt_contravar; prove_sup
diff --git a/theories/Reals/Exp_prop.v b/theories/Reals/Exp_prop.v
index 75ea4755..b65ab045 100644
--- a/theories/Reals/Exp_prop.v
+++ b/theories/Reals/Exp_prop.v
@@ -1,33 +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-2012     *)
 (*   \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.
-Require Import Rtrigo.
+Require Import Rtrigo1.
 Require Import Ranalysis1.
 Require Import PSeries_reg.
 Require Import Div2.
 Require Import Even.
 Require Import Max.
-Open Local Scope nat_scope.
-Open Local Scope R_scope.
+Local Open Scope nat_scope.
+Local Open Scope R_scope.
 
 Definition E1 (x:R) (N:nat) : R :=
   sum_f_R0 (fun k:nat => / INR (fact k) * x ^ k) N.
 
 Lemma E1_cvg : forall x:R, Un_cv (E1 x) (exp x).
 Proof.
-  intro; unfold exp in |- *; unfold projT1 in |- *.
+  intro; unfold exp; unfold projT1.
   case (exist_exp x); intro.
-  unfold exp_in, Un_cv in |- *; unfold infinite_sum, E1 in |- *; trivial.
+  unfold exp_in, Un_cv; unfold infinite_sum, E1; trivial.
 Qed.
 
 Definition Reste_E (x y:R) (N:nat) : R :=
@@ -43,14 +41,14 @@ Lemma exp_form :
   forall (x y:R) (n:nat),
     (0 < n)%nat -> E1 x n * E1 y n - Reste_E x y n = E1 (x + y) n.
 Proof.
-  intros; unfold E1 in |- *.
+  intros; unfold E1.
   rewrite cauchy_finite.
-  unfold Reste_E in |- *; unfold Rminus in |- *; rewrite Rplus_assoc;
+  unfold Reste_E; unfold Rminus; rewrite Rplus_assoc;
     rewrite Rplus_opp_r; rewrite Rplus_0_r; apply sum_eq;
       intros.
   rewrite binomial.
   rewrite scal_sum; apply sum_eq; intros.
-  unfold C in |- *; unfold Rdiv in |- *; repeat rewrite Rmult_assoc;
+  unfold C; unfold Rdiv; repeat rewrite Rmult_assoc;
     rewrite (Rmult_comm (INR (fact i))); repeat rewrite Rmult_assoc;
       rewrite <- Rinv_l_sym.
   rewrite Rmult_1_r; rewrite Rinv_mult_distr.
@@ -66,27 +64,13 @@ Definition maj_Reste_E (x y:R) (N:nat) : R :=
   (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (2 * N) /
     Rsqr (INR (fact (div2 (pred N))))).
 
-Lemma Rle_Rinv : forall x y:R, 0 < x -> 0 < y -> x <= y -> / y <= / x.
-Proof.
-  intros; apply Rmult_le_reg_l with x.
-  apply H.
-  rewrite <- Rinv_r_sym.
-  apply Rmult_le_reg_l with y.
-  apply H0.
-  rewrite Rmult_1_r; rewrite Rmult_comm; rewrite Rmult_assoc;
-    rewrite <- Rinv_l_sym.
-  rewrite Rmult_1_r; apply H1.
-  red in |- *; intro; rewrite H2 in H0; elim (Rlt_irrefl _ H0).
-  red in |- *; intro; rewrite H2 in H; elim (Rlt_irrefl _ H).
-Qed.
-
 (**********)
 Lemma div2_double : forall N:nat, div2 (2 * N) = N.
 Proof.
   intro; induction  N as [| N HrecN].
   reflexivity.
   replace (2 * S N)%nat with (S (S (2 * N))).
-  simpl in |- *; simpl in HrecN; rewrite HrecN; reflexivity.
+  simpl; simpl in HrecN; rewrite HrecN; reflexivity.
   ring.
 Qed.
 
@@ -95,7 +79,7 @@ Proof.
   intro; induction  N as [| N HrecN].
   reflexivity.
   replace (2 * S N)%nat with (S (S (2 * N))).
-  simpl in |- *; simpl in HrecN; rewrite HrecN; reflexivity.
+  simpl; simpl in HrecN; rewrite HrecN; reflexivity.
   ring.
 Qed.
 
@@ -109,7 +93,7 @@ Proof.
   elim H2; intro.
   rewrite <- (even_div2 _ a); apply HrecN; assumption.
   rewrite <- (odd_div2 _ b); apply lt_O_Sn.
-  rewrite H1; simpl in |- *; apply lt_O_Sn.
+  rewrite H1; simpl; apply lt_O_Sn.
   inversion H.
   right; reflexivity.
   left; apply lt_le_trans with 2%nat; [ apply lt_n_Sn | apply H1 ].
@@ -126,7 +110,7 @@ Proof.
       (fun k:nat =>
         sum_f_R0 (fun l:nat => / Rsqr (INR (fact (div2 (S N)))))
         (pred (N - k))) (pred N)).
-  unfold Reste_E in |- *.
+  unfold Reste_E.
   apply Rle_trans with
     (sum_f_R0
       (fun k:nat =>
@@ -205,25 +189,25 @@ Proof.
   apply Rabs_pos.
   apply Rle_trans with (Rmax (Rabs x) (Rabs y)).
   apply RmaxLess1.
-  unfold M in |- *; apply RmaxLess2.
+  unfold M; apply RmaxLess2.
   apply Rle_trans with (M ^ S (n0 + n) * M ^ (N - n0)).
   apply Rmult_le_compat_l.
   apply pow_le; apply Rle_trans with 1.
   left; apply Rlt_0_1.
-  unfold M in |- *; apply RmaxLess1.
+  unfold M; apply RmaxLess1.
   apply pow_incr; split.
   apply Rabs_pos.
   apply Rle_trans with (Rmax (Rabs x) (Rabs y)).
   apply RmaxLess2.
-  unfold M in |- *; apply RmaxLess2.
+  unfold M; apply RmaxLess2.
   rewrite <- pow_add; replace (S (n0 + n) + (N - n0))%nat with (N + S n)%nat.
   apply Rle_pow.
-  unfold M in |- *; apply RmaxLess1.
+  unfold M; apply RmaxLess1.
   replace (2 * N)%nat with (N + N)%nat; [ idtac | ring ].
   apply plus_le_compat_l.
   replace N with (S (pred N)).
   apply le_n_S; apply H0.
-  symmetry  in |- *; apply S_pred with 0%nat; apply H.
+  symmetry ; apply S_pred with 0%nat; apply H.
   apply INR_eq; do 2 rewrite plus_INR; do 2 rewrite S_INR; rewrite plus_INR;
     rewrite minus_INR.
   ring.
@@ -262,7 +246,7 @@ Proof.
   apply pow_le.
   apply Rle_trans with 1.
   left; apply Rlt_0_1.
-  unfold M in |- *; apply RmaxLess1.
+  unfold M; apply RmaxLess1.
   assert (H2 := even_odd_cor N).
   elim H2; intros N0 H3.
   elim H3; intro.
@@ -278,9 +262,9 @@ Proof.
   apply le_n_Sn.
   replace (/ INR (fact n0) * / INR (fact (N - n0))) with
   (C N n0 / INR (fact N)).
-  pattern N at 1 in |- *; rewrite H4.
+  pattern N at 1; rewrite H4.
   apply Rle_trans with (C N N0 / INR (fact N)).
-  unfold Rdiv in |- *; do 2 rewrite <- (Rmult_comm (/ INR (fact N))).
+  unfold Rdiv; do 2 rewrite <- (Rmult_comm (/ INR (fact N))).
   apply Rmult_le_compat_l.
   left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
   rewrite H4.
@@ -310,7 +294,7 @@ Proof.
   apply le_pred_n.
   replace (C N N0 / INR (fact N)) with (/ Rsqr (INR (fact N0))).
   rewrite H4; rewrite div2_S_double; right; reflexivity.
-  unfold Rsqr, C, Rdiv in |- *.
+  unfold Rsqr, C, Rdiv.
   repeat rewrite Rinv_mult_distr.
   rewrite (Rmult_comm (INR (fact N))).
   repeat rewrite Rmult_assoc.
@@ -318,7 +302,7 @@ Proof.
   rewrite Rmult_1_r; replace (N - N0)%nat with N0.
   ring.
   replace N with (N0 + N0)%nat.
-  symmetry  in |- *; apply minus_plus.
+  symmetry ; apply minus_plus.
   rewrite H4.
   ring.
   apply INR_fact_neq_0.
@@ -326,7 +310,7 @@ Proof.
   apply INR_fact_neq_0.
   apply INR_fact_neq_0.
   apply INR_fact_neq_0.
-  unfold C, Rdiv in |- *.
+  unfold C, Rdiv.
   rewrite (Rmult_comm (INR (fact N))).
   repeat rewrite Rmult_assoc.
   rewrite <- Rinv_r_sym.
@@ -338,7 +322,7 @@ Proof.
   replace (/ INR (fact (S n0)) * / INR (fact (N - n0))) with
   (C (S N) (S n0) / INR (fact (S N))).
   apply Rle_trans with (C (S N) (S N0) / INR (fact (S N))).
-  unfold Rdiv in |- *; do 2 rewrite <- (Rmult_comm (/ INR (fact (S N)))).
+  unfold Rdiv; do 2 rewrite <- (Rmult_comm (/ INR (fact (S N)))).
   apply Rmult_le_compat_l.
   left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
   cut (S N = (2 * S N0)%nat).
@@ -373,7 +357,7 @@ Proof.
   replace (C (S N) (S N0) / INR (fact (S N))) with (/ Rsqr (INR (fact (S N0)))).
   rewrite H5; rewrite div2_double.
   right; reflexivity.
-  unfold Rsqr, C, Rdiv in |- *.
+  unfold Rsqr, C, Rdiv.
   repeat rewrite Rinv_mult_distr.
   replace (S N - S N0)%nat with (S N0).
   rewrite (Rmult_comm (INR (fact (S N)))).
@@ -382,14 +366,14 @@ Proof.
   rewrite Rmult_1_r; reflexivity.
   apply INR_fact_neq_0.
   replace (S N) with (S N0 + S N0)%nat.
-  symmetry  in |- *; apply minus_plus.
+  symmetry ; apply minus_plus.
   rewrite H5; ring.
   apply INR_fact_neq_0.
   apply INR_fact_neq_0.
   apply INR_fact_neq_0.
   apply INR_fact_neq_0.
   rewrite H4; ring.
-  unfold C, Rdiv in |- *.
+  unfold C, Rdiv.
   rewrite (Rmult_comm (INR (fact (S N)))).
   rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
   rewrite Rmult_1_r; rewrite Rinv_mult_distr.
@@ -397,8 +381,8 @@ Proof.
   apply INR_fact_neq_0.
   apply INR_fact_neq_0.
   apply INR_fact_neq_0.
-  unfold maj_Reste_E in |- *.
-  unfold Rdiv in |- *; rewrite (Rmult_comm 4).
+  unfold maj_Reste_E.
+  unfold Rdiv; rewrite (Rmult_comm 4).
   rewrite Rmult_assoc.
   apply Rmult_le_compat_l.
   apply pow_le.
@@ -449,7 +433,7 @@ Proof.
   cut (INR N <= INR (2 * div2 (S N))).
   intro; apply Rmult_le_reg_l with (Rsqr (INR (div2 (S N)))).
   apply Rsqr_pos_lt.
-  apply not_O_INR; red in |- *; intro.
+  apply not_O_INR; red; intro.
   cut (1 < S N)%nat.
   intro; assert (H4 := div2_not_R0 _ H3).
   rewrite H2 in H4; elim (lt_n_O _ H4).
@@ -472,17 +456,17 @@ Proof.
   apply lt_INR_0; apply div2_not_R0.
   apply lt_n_S; apply H.
   cut (1 < S N)%nat.
-  intro; unfold Rsqr in |- *; apply prod_neq_R0; apply not_O_INR; intro;
+  intro; unfold Rsqr; apply prod_neq_R0; apply not_O_INR; intro;
     assert (H4 := div2_not_R0 _ H2); rewrite H3 in H4;
       elim (lt_n_O _ H4).
   apply lt_n_S; apply H.
   assert (H1 := even_odd_cor N).
   elim H1; intros N0 H2.
   elim H2; intro.
-  pattern N at 2 in |- *; rewrite H3.
+  pattern N at 2; rewrite H3.
   rewrite div2_S_double.
   right; rewrite H3; reflexivity.
-  pattern N at 2 in |- *; rewrite H3.
+  pattern N at 2; rewrite H3.
   replace (S (S (2 * N0))) with (2 * S N0)%nat.
   rewrite div2_double.
   rewrite H3.
@@ -491,12 +475,12 @@ Proof.
   rewrite Rmult_plus_distr_l.
   apply Rplus_le_compat_l.
   rewrite Rmult_1_r.
-  simpl in |- *.
-  pattern 1 at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left;
+  simpl.
+  pattern 1 at 1; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left;
     apply Rlt_0_1.
   ring.
-  unfold Rsqr in |- *; apply prod_neq_R0; apply INR_fact_neq_0.
-  unfold Rsqr in |- *; apply prod_neq_R0; apply not_O_INR; discriminate.
+  unfold Rsqr; apply prod_neq_R0; apply INR_fact_neq_0.
+  unfold Rsqr; apply prod_neq_R0; apply not_O_INR; discriminate.
   assert (H0 := even_odd_cor N).
   elim H0; intros N0 H1.
   elim H1; intro.
@@ -522,15 +506,15 @@ Qed.
 Lemma maj_Reste_cv_R0 : forall x y:R, Un_cv (maj_Reste_E x y) 0.
 Proof.
   intros; assert (H := Majxy_cv_R0 x y).
-  unfold Un_cv in H; unfold Un_cv in |- *; intros.
+  unfold Un_cv in H; unfold Un_cv; intros.
   cut (0 < eps / 4);
     [ intro
-      | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+      | unfold Rdiv; apply Rmult_lt_0_compat;
         [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ].
   elim (H _ H1); intros N0 H2.
   exists (max (2 * S N0) 2); intros.
-  unfold R_dist in H2; unfold R_dist in |- *; rewrite Rminus_0_r;
-    unfold Majxy in H2; unfold maj_Reste_E in |- *.
+  unfold R_dist in H2; unfold R_dist; rewrite Rminus_0_r;
+    unfold Majxy in H2; unfold maj_Reste_E.
   rewrite Rabs_right.
   apply Rle_lt_trans with
     (4 *
@@ -538,7 +522,7 @@ Proof.
         INR (fact (div2 (pred n))))).
   apply Rmult_le_compat_l.
   left; prove_sup0.
-  unfold Rdiv, Rsqr in |- *; rewrite Rinv_mult_distr.
+  unfold Rdiv, Rsqr; rewrite Rinv_mult_distr.
   rewrite (Rmult_comm (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (2 * n)));
     rewrite
       (Rmult_comm (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (4 * S (div2 (pred n)))))
@@ -546,7 +530,7 @@ Proof.
   left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
   apply Rle_trans with (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (2 * n)).
   rewrite Rmult_comm;
-    pattern (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (2 * n)) at 2 in |- *;
+    pattern (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (2 * n)) at 2;
       rewrite <- Rmult_1_r; apply Rmult_le_compat_l.
   apply pow_le; apply Rle_trans with 1.
   left; apply Rlt_0_1.
@@ -600,11 +584,11 @@ Proof.
   (Rabs
     (Rmax 1 (Rmax (Rabs x) (Rabs y)) ^ (4 * S (div2 (pred n))) /
       INR (fact (div2 (pred n))) - 0)).
-  apply H2; unfold ge in |- *.
+  apply H2; unfold ge.
   cut (2 * S N0 <= n)%nat.
   intro; apply le_S_n.
   apply INR_le; apply Rmult_le_reg_l with (INR 2).
-  simpl in |- *; prove_sup0.
+  simpl; prove_sup0.
   do 2 rewrite <- mult_INR; apply le_INR.
   apply le_trans with n.
   apply H4.
@@ -622,12 +606,12 @@ Proof.
   apply S_pred with 0%nat; apply H8.
   replace (2 * N1)%nat with (S (S (2 * pred N1))).
   reflexivity.
-  pattern N1 at 2 in |- *; replace N1 with (S (pred N1)).
+  pattern N1 at 2; replace N1 with (S (pred N1)).
   ring.
-  symmetry  in |- *; apply S_pred with 0%nat; apply H8.
+  symmetry ; apply S_pred with 0%nat; apply H8.
   apply INR_lt.
   apply Rmult_lt_reg_l with (INR 2).
-  simpl in |- *; prove_sup0.
+  simpl; prove_sup0.
   rewrite Rmult_0_r; rewrite <- mult_INR.
   apply lt_INR_0.
   rewrite <- H7.
@@ -648,7 +632,7 @@ Proof.
   apply H3.
   rewrite Rminus_0_r; apply Rabs_right.
   apply Rle_ge.
-  unfold Rdiv in |- *; repeat apply Rmult_le_pos.
+  unfold Rdiv; apply Rmult_le_pos.
   apply pow_le.
   apply Rle_trans with 1.
   left; apply Rlt_0_1.
@@ -656,7 +640,7 @@ Proof.
   left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
   discrR.
   apply Rle_ge.
-  unfold Rdiv in |- *; apply Rmult_le_pos.
+  unfold Rdiv; apply Rmult_le_pos.
   left; prove_sup0.
   apply Rmult_le_pos.
   apply pow_le.
@@ -670,9 +654,9 @@ Qed.
 Lemma Reste_E_cv : forall x y:R, Un_cv (Reste_E x y) 0.
 Proof.
   intros; assert (H := maj_Reste_cv_R0 x y).
-  unfold Un_cv in H; unfold Un_cv in |- *; intros; elim (H _ H0); intros.
+  unfold Un_cv in H; unfold Un_cv; intros; elim (H _ H0); intros.
   exists (max x0 1); intros.
-  unfold R_dist in |- *; rewrite Rminus_0_r.
+  unfold R_dist; rewrite Rminus_0_r.
   apply Rle_lt_trans with (maj_Reste_E x y n).
   apply Reste_E_maj.
   apply lt_le_trans with 1%nat.
@@ -682,10 +666,10 @@ Proof.
   apply H2.
   replace (maj_Reste_E x y n) with (R_dist (maj_Reste_E x y n) 0).
   apply H1.
-  unfold ge in |- *; apply le_trans with (max x0 1).
+  unfold ge; apply le_trans with (max x0 1).
   apply le_max_l.
   apply H2.
-  unfold R_dist in |- *; rewrite Rminus_0_r; apply Rabs_right.
+  unfold R_dist; rewrite Rminus_0_r; apply Rabs_right.
   apply Rle_ge; apply Rle_trans with (Rabs (Reste_E x y n)).
   apply Rabs_pos.
   apply Reste_E_maj.
@@ -706,13 +690,13 @@ Proof.
   apply H1.
   assert (H2 := CV_mult _ _ _ _ H0 H).
   assert (H3 := CV_minus _ _ _ _ H2 (Reste_E_cv x y)).
-  unfold Un_cv in |- *; unfold Un_cv in H3; intros.
+  unfold Un_cv; unfold Un_cv in H3; intros.
   elim (H3 _ H4); intros.
   exists (S x0); intros.
   rewrite <- (exp_form x y n).
   rewrite Rminus_0_r in H5.
   apply H5.
-  unfold ge in |- *; apply le_trans with (S x0).
+  unfold ge; apply le_trans with (S x0).
   apply le_n_Sn.
   apply H6.
   apply lt_le_trans with (S x0).
@@ -726,15 +710,15 @@ Proof.
   intros; set (An := fun N:nat => / INR (fact N) * x ^ N).
   cut (Un_cv (fun n:nat => sum_f_R0 An n) (exp x)).
   intro; apply Rlt_le_trans with (sum_f_R0 An 0).
-  unfold An in |- *; simpl in |- *; rewrite Rinv_1; rewrite Rmult_1_r;
+  unfold An; simpl; rewrite Rinv_1; rewrite Rmult_1_r;
     apply Rlt_0_1.
   apply sum_incr.
   assumption.
-  intro; unfold An in |- *; left; apply Rmult_lt_0_compat.
+  intro; unfold An; left; apply Rmult_lt_0_compat.
   apply Rinv_0_lt_compat; apply INR_fact_lt_0.
   apply (pow_lt _ n H).
-  unfold exp in |- *; unfold projT1 in |- *; case (exist_exp x); intro.
-  unfold exp_in in |- *; unfold infinite_sum, Un_cv in |- *; trivial.
+  unfold exp; unfold projT1; case (exist_exp x); intro.
+  unfold exp_in; unfold infinite_sum, Un_cv; trivial.
 Qed.
 
 (**********)
@@ -745,12 +729,12 @@ Proof.
   apply (exp_pos_pos _ a).
   rewrite <- b; rewrite exp_0; apply Rlt_0_1.
   replace (exp x) with (1 / exp (- x)).
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+  unfold Rdiv; apply Rmult_lt_0_compat.
   apply Rlt_0_1.
   apply Rinv_0_lt_compat; apply exp_pos_pos.
   apply (Ropp_0_gt_lt_contravar _ r).
   cut (exp (- x) <> 0).
-  intro; unfold Rdiv in |- *; apply Rmult_eq_reg_l with (exp (- x)).
+  intro; unfold Rdiv; apply Rmult_eq_reg_l with (exp (- x)).
   rewrite Rmult_1_l; rewrite <- Rinv_r_sym.
   rewrite <- exp_plus.
   rewrite Rplus_opp_l; rewrite exp_0; reflexivity.
@@ -758,7 +742,7 @@ Proof.
   apply H.
   assert (H := exp_plus x (- x)).
   rewrite Rplus_opp_r in H; rewrite exp_0 in H.
-  red in |- *; intro; rewrite H0 in H.
+  red; intro; rewrite H0 in H.
   rewrite Rmult_0_r in H.
   elim R1_neq_R0; assumption.
 Qed.
@@ -766,7 +750,7 @@ Qed.
 (* ((exp h)-1)/h -> 0 quand h->0 *)
 Lemma derivable_pt_lim_exp_0 : derivable_pt_lim exp 0 1.
 Proof.
-  unfold derivable_pt_lim in |- *; intros.
+  unfold derivable_pt_lim; intros.
   set (fn := fun (N:nat) (x:R) => x ^ N / INR (fact (S N))).
   cut (CVN_R fn).
   intro; cut (forall x:R, { l:R | Un_cv (fun N:nat => SP fn N x) l }).
@@ -784,41 +768,41 @@ Proof.
   replace 1 with (SFL fn cv 0).
   apply H5.
   split.
-  unfold D_x, no_cond in |- *; split.
+  unfold D_x, no_cond; split.
   trivial.
-  apply (sym_not_eq H6).
+  apply (not_eq_sym H6).
   rewrite Rminus_0_r; apply H7.
-  unfold SFL in |- *.
+  unfold SFL.
   case (cv 0); intros.
   eapply UL_sequence.
   apply u.
-  unfold Un_cv, SP in |- *.
+  unfold Un_cv, SP.
   intros; exists 1%nat; intros.
-  unfold R_dist in |- *; rewrite decomp_sum.
+  unfold R_dist; rewrite decomp_sum.
   rewrite (Rplus_comm (fn 0%nat 0)).
   replace (fn 0%nat 0) with 1.
-  unfold Rminus in |- *; rewrite Rplus_assoc; rewrite Rplus_opp_r;
+  unfold Rminus; rewrite Rplus_assoc; rewrite Rplus_opp_r;
     rewrite Rplus_0_r.
   replace (sum_f_R0 (fun i:nat => fn (S i) 0) (pred n)) with 0.
   rewrite Rabs_R0; apply H8.
-  symmetry  in |- *; apply sum_eq_R0; intros.
-  unfold fn in |- *.
-  simpl in |- *.
-  unfold Rdiv in |- *; do 2 rewrite Rmult_0_l; reflexivity.
-  unfold fn in |- *; simpl in |- *.
-  unfold Rdiv in |- *; rewrite Rinv_1; rewrite Rmult_1_r; reflexivity.
+  symmetry ; apply sum_eq_R0; intros.
+  unfold fn.
+  simpl.
+  unfold Rdiv; do 2 rewrite Rmult_0_l; reflexivity.
+  unfold fn; simpl.
+  unfold Rdiv; rewrite Rinv_1; rewrite Rmult_1_r; reflexivity.
   apply lt_le_trans with 1%nat; [ apply lt_n_Sn | apply H9 ].
-  unfold SFL, exp in |- *.
+  unfold SFL, exp.
   case (cv h); case (exist_exp h); simpl; intros.
   eapply UL_sequence.
   apply u.
-  unfold Un_cv in |- *; intros.
+  unfold Un_cv; intros.
   unfold exp_in in e.
   unfold infinite_sum in e.
   cut (0 < eps0 * Rabs h).
   intro; elim (e _ H9); intros N0 H10.
   exists N0; intros.
-  unfold R_dist in |- *.
+  unfold R_dist.
   apply Rmult_lt_reg_l with (Rabs h).
   apply Rabs_pos_lt; assumption.
   rewrite <- Rabs_mult.
@@ -829,47 +813,47 @@ Proof.
   (sum_f_R0 (fun i:nat => / INR (fact i) * h ^ i) (S n) - x).
   rewrite (Rmult_comm (Rabs h)).
   apply H10.
-  unfold ge in |- *.
+  unfold ge.
   apply le_trans with (S N0).
   apply le_n_Sn.
   apply le_n_S; apply H11.
   rewrite decomp_sum.
   replace (/ INR (fact 0) * h ^ 0) with 1.
-  unfold Rminus in |- *.
+  unfold Rminus.
   rewrite Ropp_plus_distr.
   rewrite Ropp_involutive.
   rewrite <- (Rplus_comm (- x)).
   rewrite <- (Rplus_comm (- x + 1)).
   rewrite Rplus_assoc; repeat apply Rplus_eq_compat_l.
   replace (pred (S n)) with n; [ idtac | reflexivity ].
-  unfold SP in |- *.
+  unfold SP.
   rewrite scal_sum.
   apply sum_eq; intros.
-  unfold fn in |- *.
+  unfold fn.
   replace (h ^ S i) with (h * h ^ i).
-  unfold Rdiv in |- *; ring.
-  simpl in |- *; ring.
-  simpl in |- *; rewrite Rinv_1; rewrite Rmult_1_r; reflexivity.
+  unfold Rdiv; ring.
+  simpl; ring.
+  simpl; rewrite Rinv_1; rewrite Rmult_1_r; reflexivity.
   apply lt_O_Sn.
-  unfold Rdiv in |- *.
+  unfold Rdiv.
   rewrite <- Rmult_assoc.
-  symmetry  in |- *; apply Rinv_r_simpl_m.
+  symmetry ; apply Rinv_r_simpl_m.
   assumption.
   apply Rmult_lt_0_compat.
   apply H8.
   apply Rabs_pos_lt; assumption.
   apply SFL_continuity; assumption.
-  intro; unfold fn in |- *.
+  intro; unfold fn.
   replace (fun x:R => x ^ n / INR (fact (S n))) with
   (pow_fct n / fct_cte (INR (fact (S n))))%F; [ idtac | reflexivity ].
   apply continuity_div.
   apply derivable_continuous; apply (derivable_pow n).
   apply derivable_continuous; apply derivable_const.
-  intro; unfold fct_cte in |- *; apply INR_fact_neq_0.
+  intro; unfold fct_cte; apply INR_fact_neq_0.
   apply (CVN_R_CVS _ X).
   assert (H0 := Alembert_exp).
-  unfold CVN_R in |- *.
-  intro; unfold CVN_r in |- *.
+  unfold CVN_R.
+  intro; unfold CVN_r.
   exists (fun N:nat => r ^ N / INR (fact (S N))).
   cut
     { l:R |
@@ -881,10 +865,10 @@ Proof.
   exists x; intros.
   split.
   apply p.
-  unfold Boule in |- *; intros.
+  unfold Boule; intros.
   rewrite Rminus_0_r in H1.
-  unfold fn in |- *.
-  unfold Rdiv in |- *; rewrite Rabs_mult.
+  unfold fn.
+  unfold Rdiv; rewrite Rabs_mult.
   cut (0 < INR (fact (S n))).
   intro.
   rewrite (Rabs_right (/ INR (fact (S n)))).
@@ -899,14 +883,14 @@ Proof.
   cut ((r:R) <> 0).
   intro; apply Alembert_C2.
   intro; apply Rabs_no_R0.
-  unfold Rdiv in |- *; apply prod_neq_R0.
+  unfold Rdiv; apply prod_neq_R0.
   apply pow_nonzero; assumption.
   apply Rinv_neq_0_compat; apply INR_fact_neq_0.
   unfold Un_cv in H0.
-  unfold Un_cv in |- *; intros.
+  unfold Un_cv; intros.
   cut (0 < eps0 / r);
     [ intro
-      | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+      | unfold Rdiv; apply Rmult_lt_0_compat;
         [ assumption | apply Rinv_0_lt_compat; apply (cond_pos r) ] ].
   elim (H0 _ H3); intros N0 H4.
   exists N0; intros.
@@ -915,7 +899,7 @@ Proof.
   assert (H6 := H4 _ hyp_sn).
   unfold R_dist in H6; rewrite Rminus_0_r in H6.
   rewrite Rabs_Rabsolu in H6.
-  unfold R_dist in |- *; rewrite Rminus_0_r.
+  unfold R_dist; rewrite Rminus_0_r.
   rewrite Rabs_Rabsolu.
   replace
   (Rabs (r ^ S n / INR (fact (S (S n)))) / Rabs (r ^ n / INR (fact (S n))))
@@ -929,7 +913,7 @@ Proof.
   apply H6.
   assumption.
   apply Rle_ge; left; apply (cond_pos r).
-  unfold Rdiv in |- *.
+  unfold Rdiv.
   repeat rewrite Rabs_mult.
   repeat rewrite Rabs_Rinv.
   rewrite Rinv_mult_distr.
@@ -942,7 +926,7 @@ Proof.
   rewrite (Rmult_comm r).
   rewrite <- Rmult_assoc; rewrite <- (Rmult_comm (INR (fact (S n)))).
   apply Rmult_eq_compat_l.
-  simpl in |- *.
+  simpl.
   rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
   ring.
   apply pow_nonzero; assumption.
@@ -955,10 +939,10 @@ Proof.
   apply Rinv_neq_0_compat; apply Rabs_no_R0; apply INR_fact_neq_0.
   apply INR_fact_neq_0.
   apply INR_fact_neq_0.
-  unfold ge in |- *; apply le_trans with n.
+  unfold ge; apply le_trans with n.
   apply H5.
   apply le_n_Sn.
-  assert (H1 := cond_pos r); red in |- *; intro; rewrite H2 in H1;
+  assert (H1 := cond_pos r); red; intro; rewrite H2 in H1;
     elim (Rlt_irrefl _ H1).
 Qed.
 
@@ -966,10 +950,10 @@ Qed.
 Lemma derivable_pt_lim_exp : forall x:R, derivable_pt_lim exp x (exp x).
 Proof.
   intro; assert (H0 := derivable_pt_lim_exp_0).
-  unfold derivable_pt_lim in H0; unfold derivable_pt_lim in |- *; intros.
+  unfold derivable_pt_lim in H0; unfold derivable_pt_lim; intros.
   cut (0 < eps / exp x);
     [ intro
-      | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+      | unfold Rdiv; apply Rmult_lt_0_compat;
         [ apply H | apply Rinv_0_lt_compat; apply exp_pos ] ].
   elim (H0 _ H1); intros del H2.
   exists del; intros.
@@ -983,11 +967,11 @@ Proof.
   rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
   rewrite Rmult_1_l; rewrite <- (Rmult_comm eps).
   apply H5.
-  assert (H6 := exp_pos x); red in |- *; intro; rewrite H7 in H6;
+  assert (H6 := exp_pos x); red; intro; rewrite H7 in H6;
     elim (Rlt_irrefl _ H6).
   apply Rle_ge; left; apply exp_pos.
   rewrite Rmult_minus_distr_l.
-  rewrite Rmult_1_r; unfold Rdiv in |- *; rewrite <- Rmult_assoc;
+  rewrite Rmult_1_r; unfold Rdiv; rewrite <- Rmult_assoc;
     rewrite Rmult_minus_distr_l.
   rewrite Rmult_1_r; rewrite exp_plus; reflexivity.
 Qed.
diff --git a/theories/Reals/Integration.v b/theories/Reals/Integration.v
index 3199a4f8..d7b3ab04 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-2012     *)
 (*   \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..c45d1c5f 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-2012     *)
 (*   \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.
@@ -19,9 +17,9 @@ Open Scope R_scope.
 Lemma RLegacyTheory : Ring_Theory Rplus Rmult 1 0 Ropp (fun x y:R => false).
   split.
   exact Rplus_comm.
-  symmetry  in |- *; apply Rplus_assoc.
+  symmetry ; apply Rplus_assoc.
   exact Rmult_comm.
-  symmetry  in |- *; apply Rmult_assoc.
+  symmetry ; apply Rmult_assoc.
   intro; apply Rplus_0_l.
   intro; apply Rmult_1_l.
   exact Rplus_opp_r.
diff --git a/theories/Reals/MVT.v b/theories/Reals/MVT.v
index 36bbb405..2ee22b6d 100644
--- a/theories/Reals/MVT.v
+++ b/theories/Reals/MVT.v
@@ -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-2012     *)
 (*   \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.
 Require Import Rtopology.
-Open Local Scope R_scope.
+Local Open Scope R_scope.
 
 (* The Mean Value Theorem *)
 Theorem MVT :
@@ -57,13 +55,13 @@ Proof.
   split.
   apply Rmult_lt_reg_l with 2.
   prove_sup0.
-  unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+  unfold Rdiv; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
     rewrite <- Rinv_r_sym.
   rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; apply H.
   discrR.
   apply Rmult_lt_reg_l with 2.
   prove_sup0.
-  unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+  unfold Rdiv; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
     rewrite <- Rinv_r_sym.
   rewrite Rmult_1_l; rewrite Rplus_comm; rewrite double;
     apply Rplus_lt_compat_l; apply H.
@@ -105,7 +103,7 @@ Proof.
   inversion H13.
   apply H14.
   rewrite H8 in H10; rewrite <- H14 in H10; elim H10; reflexivity.
-  intros; unfold h in |- *;
+  intros; unfold h;
     replace
     (derive_pt (fun y:R => (g b - g a) * f y - (f b - f a) * g y) c (X c P))
     with
@@ -117,11 +115,11 @@ Proof.
   rewrite derive_pt_minus; do 2 rewrite derive_pt_mult;
     do 2 rewrite derive_pt_const; do 2 rewrite Rmult_0_l;
       do 2 rewrite Rplus_0_l; reflexivity.
-  unfold h in |- *; ring.
-  intros; unfold h in |- *;
+  unfold h; ring.
+  intros; unfold h;
     change
       (continuity_pt ((fct_cte (g b - g a) * f)%F - (fct_cte (f b - f a) * g)%F)
-        c) in |- *.
+        c).
   apply continuity_pt_minus; apply continuity_pt_mult.
   apply derivable_continuous_pt; apply derivable_const.
   apply H0; apply H3.
@@ -130,7 +128,7 @@ Proof.
   intros;
     change
       (derivable_pt ((fct_cte (g b - g a) * f)%F - (fct_cte (f b - f a) * g)%F)
-        c) in |- *.
+        c).
   apply derivable_pt_minus; apply derivable_pt_mult.
   apply derivable_pt_const.
   apply (pr1 _ H3).
@@ -180,7 +178,7 @@ Proof.
   cut (derive_pt id x (X2 x x0) = 1).
   cut (derive_pt f x (X0 x x0) = f' x).
   intros; rewrite H4 in H3; rewrite H5 in H3; unfold id in H3;
-    rewrite Rmult_1_r in H3; rewrite Rmult_comm; symmetry  in |- *;
+    rewrite Rmult_1_r in H3; rewrite Rmult_comm; symmetry ;
       assumption.
   apply derive_pt_eq_0; apply H0; elim x0; intros; split; left; assumption.
   apply derive_pt_eq_0; apply derivable_pt_lim_id.
@@ -190,7 +188,7 @@ Proof.
   intros; apply derivable_pt_id.
   intros; apply derivable_continuous_pt; apply X; assumption.
   intros; elim H1; intros; apply X; split; left; assumption.
-  intros; unfold derivable_pt in |- *; exists (f' c); apply H0;
+  intros; unfold derivable_pt; exists (f' c); apply H0;
     apply H1.
 Qed.
 
@@ -223,7 +221,7 @@ Proof.
     unfold id in H6; unfold Rminus in H6; rewrite Rplus_opp_r in H6;
       rewrite Rmult_0_l in H6; apply Rmult_eq_reg_l with (b - a);
         [ rewrite Rmult_0_r; apply H6
-          | apply Rminus_eq_contra; red in |- *; intro; rewrite H7 in H0;
+          | apply Rminus_eq_contra; red; intro; rewrite H7 in H0;
             elim (Rlt_irrefl _ H0) ].
 Qed.
 
@@ -233,7 +231,7 @@ Lemma nonneg_derivative_1 :
     (forall x:R, 0 <= derive_pt f x (pr x)) -> increasing f.
 Proof.
   intros.
-  unfold increasing in |- *.
+  unfold increasing.
   intros.
   case (total_order_T x y); intro.
   elim s; intro.
@@ -270,12 +268,12 @@ Proof.
   intro; decompose [and] H8; intros; generalize (H7 (delta / 2) H9 H12);
     cut ((f (x + delta / 2) - f x) / (delta / 2) <= 0).
   intro; cut (0 < - ((f (x + delta / 2) - f x) / (delta / 2) - l)).
-  intro; unfold Rabs in |- *;
+  intro; unfold Rabs;
     case (Rcase_abs ((f (x + delta / 2) - f x) / (delta / 2) - l)).
   intros;
     generalize
       (Rplus_lt_compat_r (- l) (- ((f (x + delta / 2) - f x) / (delta / 2) - l))
-        (l / 2) H14); unfold Rminus in |- *.
+        (l / 2) H14); unfold Rminus.
   replace (l / 2 + - l) with (- (l / 2)).
   replace (- ((f (x + delta / 2) + - f x) / (delta / 2) + - l) + - l) with
   (- ((f (x + delta / 2) + - f x) / (delta / 2))).
@@ -292,7 +290,7 @@ Proof.
     (Rlt_irrefl 0
       (Rlt_le_trans 0 ((f (x + delta / 2) - f x) / (delta / 2)) 0 H17 H10)).
   ring.
-  pattern l at 3 in |- *; rewrite double_var.
+  pattern l at 3; rewrite double_var.
   ring.
   intros.
   generalize
@@ -305,22 +303,22 @@ Proof.
         H15)).
   replace (- ((f (x + delta / 2) - f x) / (delta / 2) - l)) with
   ((f x - f (x + delta / 2)) / (delta / 2) + l).
-  unfold Rminus in |- *.
+  unfold Rminus.
   apply Rplus_le_lt_0_compat.
-  unfold Rdiv in |- *; apply Rmult_le_pos.
+  unfold Rdiv; apply Rmult_le_pos.
   cut (x <= x + delta * / 2).
   intro; generalize (H0 x (x + delta * / 2) H13); intro;
     generalize
       (Rplus_le_compat_l (- f (x + delta / 2)) (f (x + delta / 2)) (f x) H14);
       rewrite Rplus_opp_l; rewrite Rplus_comm; intro; assumption.
-  pattern x at 1 in |- *; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l;
+  pattern x at 1; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l;
     left; assumption.
   left; apply Rinv_0_lt_compat; assumption.
   assumption.
   rewrite Ropp_minus_distr.
-  unfold Rminus in |- *.
+  unfold Rminus.
   rewrite (Rplus_comm l).
-  unfold Rdiv in |- *.
+  unfold Rdiv.
   rewrite <- Ropp_mult_distr_l_reverse.
   rewrite Ropp_plus_distr.
   rewrite Ropp_involutive.
@@ -331,38 +329,38 @@ Proof.
   rewrite <- Ropp_0.
   apply Ropp_ge_le_contravar.
   apply Rle_ge.
-  unfold Rdiv in |- *; apply Rmult_le_pos.
+  unfold Rdiv; apply Rmult_le_pos.
   cut (x <= x + delta * / 2).
   intro; generalize (H0 x (x + delta * / 2) H10); intro.
   generalize
     (Rplus_le_compat_l (- f (x + delta / 2)) (f (x + delta / 2)) (f x) H13);
     rewrite Rplus_opp_l; rewrite Rplus_comm; intro; assumption.
-  pattern x at 1 in |- *; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l;
+  pattern x at 1; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l;
     left; assumption.
   left; apply Rinv_0_lt_compat; assumption.
-  unfold Rdiv in |- *; rewrite <- Ropp_mult_distr_l_reverse.
+  unfold Rdiv; rewrite <- Ropp_mult_distr_l_reverse.
   rewrite Ropp_minus_distr.
   reflexivity.
   split.
-  unfold Rdiv in |- *; apply prod_neq_R0.
-  generalize (cond_pos delta); intro; red in |- *; intro H9; rewrite H9 in H8;
+  unfold Rdiv; apply prod_neq_R0.
+  generalize (cond_pos delta); intro; red; intro H9; rewrite H9 in H8;
     elim (Rlt_irrefl 0 H8).
   apply Rinv_neq_0_compat; discrR.
   split.
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+  unfold Rdiv; apply Rmult_lt_0_compat;
     [ apply (cond_pos delta) | apply Rinv_0_lt_compat; prove_sup0 ].
   rewrite Rabs_right.
-  unfold Rdiv in |- *; apply Rmult_lt_reg_l with 2.
+  unfold Rdiv; apply Rmult_lt_reg_l with 2.
   prove_sup0.
   rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym.
-  rewrite Rmult_1_l; rewrite double; pattern (pos delta) at 1 in |- *;
+  rewrite Rmult_1_l; rewrite double; pattern (pos delta) at 1;
     rewrite <- Rplus_0_r.
   apply Rplus_lt_compat_l; apply (cond_pos delta).
   discrR.
-  apply Rle_ge; unfold Rdiv in |- *; left; apply Rmult_lt_0_compat.
+  apply Rle_ge; unfold Rdiv; left; apply Rmult_lt_0_compat.
   apply (cond_pos delta).
   apply Rinv_0_lt_compat; prove_sup0.
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+  unfold Rdiv; apply Rmult_lt_0_compat;
     [ apply H4 | apply Rinv_0_lt_compat; prove_sup0 ].
 Qed.
 
@@ -370,7 +368,7 @@ Qed.
 Lemma increasing_decreasing_opp :
   forall f:R -> R, increasing f -> decreasing (- f)%F.
 Proof.
-  unfold increasing, decreasing, opp_fct in |- *; intros; generalize (H x y H0);
+  unfold increasing, decreasing, opp_fct; intros; generalize (H x y H0);
     intro; apply Ropp_ge_le_contravar; apply Rle_ge; assumption.
 Qed.
 
@@ -383,8 +381,8 @@ Proof.
   cut (forall h:R, - - f h = f h).
   intro.
   generalize (increasing_decreasing_opp (- f)%F).
-  unfold decreasing in |- *.
-  unfold opp_fct in |- *.
+  unfold decreasing.
+  unfold opp_fct.
   intros.
   rewrite <- (H0 x); rewrite <- (H0 y).
   apply H1.
@@ -412,7 +410,7 @@ Lemma positive_derivative :
     (forall x:R, 0 < derive_pt f x (pr x)) -> strict_increasing f.
 Proof.
   intros.
-  unfold strict_increasing in |- *.
+  unfold strict_increasing.
   intros.
   apply Rplus_lt_reg_r with (- f x).
   rewrite Rplus_opp_l; rewrite Rplus_comm.
@@ -431,7 +429,7 @@ Qed.
 Lemma strictincreasing_strictdecreasing_opp :
   forall f:R -> R, strict_increasing f -> strict_decreasing (- f)%F.
 Proof.
-  unfold strict_increasing, strict_decreasing, opp_fct in |- *; intros;
+  unfold strict_increasing, strict_decreasing, opp_fct; intros;
     generalize (H x y H0); intro; apply Ropp_lt_gt_contravar;
       assumption.
 Qed.
@@ -445,7 +443,7 @@ Proof.
   cut (forall h:R, - - f h = f h).
   intros.
   generalize (strictincreasing_strictdecreasing_opp (- f)%F).
-  unfold strict_decreasing, opp_fct in |- *.
+  unfold strict_decreasing, opp_fct.
   intros.
   rewrite <- (H0 x).
   rewrite <- (H0 y).
@@ -472,8 +470,8 @@ Proof.
   intros.
   unfold constant in H.
   apply derive_pt_eq_0.
-  intros; exists (mkposreal 1 Rlt_0_1); simpl in |- *; intros.
-  rewrite (H x (x + h)); unfold Rminus in |- *; unfold Rdiv in |- *;
+  intros; exists (mkposreal 1 Rlt_0_1); simpl; intros.
+  rewrite (H x (x + h)); unfold Rminus; unfold Rdiv;
     rewrite Rplus_opp_r; rewrite Rmult_0_l; rewrite Rplus_opp_r;
       rewrite Rabs_R0; assumption.
 Qed.
@@ -482,13 +480,13 @@ Qed.
 Lemma increasing_decreasing :
   forall f:R -> R, increasing f -> decreasing f -> constant f.
 Proof.
-  unfold increasing, decreasing, constant in |- *; intros;
+  unfold increasing, decreasing, constant; intros;
     case (Rtotal_order x y); intro.
   generalize (Rlt_le x y H1); intro;
     apply (Rle_antisym (f x) (f y) (H x y H2) (H0 x y H2)).
   elim H1; intro.
   rewrite H2; reflexivity.
-  generalize (Rlt_le y x H2); intro; symmetry  in |- *;
+  generalize (Rlt_le y x H2); intro; symmetry ;
     apply (Rle_antisym (f y) (f x) (H y x H3) (H0 y x H3)).
 Qed.
 
@@ -504,7 +502,7 @@ Proof.
   assert (H2 := nonneg_derivative_1 f pr H0).
   assert (H3 := nonpos_derivative_1 f pr H1).
   apply increasing_decreasing; assumption.
-  intro; right; symmetry  in |- *; apply (H x).
+  intro; right; symmetry ; apply (H x).
   intro; right; apply (H x).
 Qed.
 
@@ -603,7 +601,7 @@ Proof.
   elim H4; intros.
   split; left; assumption.
   rewrite b0.
-  unfold Rminus in |- *; do 2 rewrite Rplus_opp_r.
+  unfold Rminus; do 2 rewrite Rplus_opp_r.
   rewrite Rmult_0_r; right; reflexivity.
   elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)).
 Qed.
@@ -650,7 +648,7 @@ Lemma null_derivative_loc :
     (forall (x:R) (P:a < x < b), derive_pt f x (pr x P) = 0) ->
     constant_D_eq f (fun x:R => a <= x <= b) (f a).
 Proof.
-  intros; unfold constant_D_eq in |- *; intros; case (total_order_T a b); intro.
+  intros; unfold constant_D_eq; intros; case (total_order_T a b); intro.
   elim s; intro.
   assert (H2 : forall y:R, a < y < x -> derivable_pt id y).
   intros; apply derivable_pt_id.
@@ -676,7 +674,7 @@ Proof.
   assert (H12 : derive_pt id x0 (H2 x0 x1) = 1).
   apply derive_pt_eq_0; apply derivable_pt_lim_id.
   rewrite H11 in H9; rewrite H12 in H9; rewrite Rmult_0_r in H9;
-    rewrite Rmult_1_r in H9; apply Rminus_diag_uniq; symmetry  in |- *;
+    rewrite Rmult_1_r in H9; apply Rminus_diag_uniq; symmetry ;
       assumption.
   rewrite H1; reflexivity.
   assert (H2 : x = a).
@@ -693,15 +691,15 @@ Lemma antiderivative_Ucte :
     antiderivative f g2 a b ->
     exists c : R, (forall x:R, a <= x <= b -> g1 x = g2 x + c).
 Proof.
-  unfold antiderivative in |- *; intros; elim H; clear H; intros; elim H0;
+  unfold antiderivative; intros; elim H; clear H; intros; elim H0;
     clear H0; intros H0 _; exists (g1 a - g2 a); intros;
       assert (H3 : forall x:R, a <= x <= b -> derivable_pt g1 x).
-  intros; unfold derivable_pt in |- *; exists (f x0); elim (H x0 H3);
-    intros; eapply derive_pt_eq_1; symmetry  in |- *;
+  intros; unfold derivable_pt; exists (f x0); elim (H x0 H3);
+    intros; eapply derive_pt_eq_1; symmetry ;
       apply H4.
   assert (H4 : forall x:R, a <= x <= b -> derivable_pt g2 x).
-  intros; unfold derivable_pt in |- *; exists (f x0);
-    elim (H0 x0 H4); intros; eapply derive_pt_eq_1; symmetry  in |- *;
+  intros; unfold derivable_pt; exists (f x0);
+    elim (H0 x0 H4); intros; eapply derive_pt_eq_1; symmetry ;
       apply H5.
   assert (H5 : forall x:R, a < x < b -> derivable_pt (g1 - g2) x).
   intros; elim H5; intros; apply derivable_pt_minus;
@@ -715,7 +713,7 @@ Proof.
   assert (H9 : a <= x0 <= b).
   split; left; assumption.
   apply derivable_pt_lim_minus; [ elim (H _ H9) | elim (H0 _ H9) ]; intros;
-    eapply derive_pt_eq_1; symmetry  in |- *; apply H10.
+    eapply derive_pt_eq_1; symmetry ; apply H10.
   assert (H8 := null_derivative_loc (g1 - g2)%F a b H5 H6 H7);
     unfold constant_D_eq in H8; assert (H9 := H8 _ H2);
       unfold minus_fct in H9; rewrite <- H9; ring.
diff --git a/theories/Reals/Machin.v b/theories/Reals/Machin.v
new file mode 100644
index 00000000..6b91719d
--- /dev/null
+++ b/theories/Reals/Machin.v
@@ -0,0 +1,168 @@
+Require Import Fourier.
+Require Import Rbase.
+Require Import Rtrigo1.
+Require Import Ranalysis_reg.
+Require Import Rfunctions.
+Require Import AltSeries.
+Require Import Rseries.
+Require Import SeqProp.
+Require Import PartSum.
+Require Import Ratan.
+
+Local Open Scope R_scope.
+
+(* Proving a few formulas in the style of John Machin to compute Pi *)
+
+Definition atan_sub u v := (u - v)/(1 + u * v).
+
+Lemma atan_sub_correct :
+ forall u v, 1 + u * v <> 0 -> -PI/2 < atan u - atan v < PI/2 ->
+   -PI/2 < atan (atan_sub u v) < PI/2 ->
+   atan u = atan v + atan (atan_sub u v).
+intros u v pn0 uvint aint.
+assert (cos (atan u) <> 0).
+ destruct (atan_bound u); apply Rgt_not_eq, cos_gt_0; auto.
+ rewrite <- Ropp_div; assumption.
+assert (cos (atan v) <> 0).
+ destruct (atan_bound v); apply Rgt_not_eq, cos_gt_0; auto.
+ rewrite <- Ropp_div; assumption.
+assert (t : forall a b c, a - b = c -> a = b + c) by (intros; subst; field).
+apply t, tan_is_inj; clear t; try assumption.
+rewrite tan_minus; auto.
+  rewrite !atan_right_inv; reflexivity.
+apply Rgt_not_eq, cos_gt_0; rewrite <- ?Ropp_div; tauto.
+rewrite !atan_right_inv; assumption.
+Qed.
+
+Lemma tech : forall x y , -1 <= x <= 1 -> -1 < y < 1 -> 
+  -PI/2 < atan x - atan y < PI/2.
+assert (ut := PI_RGT_0).
+intros x y [xm1 x1] [ym1 y1].
+assert (-(PI/4) <= atan x).
+ destruct xm1 as [xm1 | xm1].
+  rewrite <- atan_1, <- atan_opp; apply Rlt_le, atan_increasing.
+  assumption.
+ solve[rewrite <- xm1, atan_opp, atan_1; apply Rle_refl].
+assert (-(PI/4) < atan y).
+ rewrite <- atan_1, <- atan_opp; apply atan_increasing.
+ assumption.
+assert (atan x <= PI/4).
+ destruct x1 as [x1 | x1].
+  rewrite <- atan_1; apply Rlt_le, atan_increasing.
+  assumption.
+ solve[rewrite x1, atan_1; apply Rle_refl].
+assert (atan y < PI/4).
+  rewrite <- atan_1; apply atan_increasing.
+  assumption.
+rewrite Ropp_div; split; fourier.
+Qed.
+
+(* A simple formula, reasonably efficient. *)
+Lemma Machin_2_3 : PI/4 = atan(/2) + atan(/3).
+assert (utility : 0 < PI/2) by (apply PI2_RGT_0).
+rewrite <- atan_1.
+rewrite (atan_sub_correct 1 (/2)).
+   apply f_equal, f_equal; unfold atan_sub; field.
+  apply Rgt_not_eq; fourier.
+ apply tech; try split; try fourier.
+apply atan_bound.
+Qed.
+
+Lemma Machin_4_5_239 : PI/4 = 4 * atan (/5) - atan(/239).
+rewrite <- atan_1.
+rewrite (atan_sub_correct 1 (/5));
+ [ | apply Rgt_not_eq; fourier | apply tech; try split; fourier |
+     apply atan_bound ].
+replace (4 * atan (/5) - atan (/239)) with
+  (atan (/5) + (atan (/5) + (atan (/5) + (atan (/5) + -
+     atan (/239))))) by ring.
+apply f_equal.
+replace (atan_sub 1 (/5)) with (2/3) by
+  (unfold atan_sub; field).
+rewrite (atan_sub_correct (2/3) (/5));
+ [apply f_equal | apply Rgt_not_eq; fourier | apply tech; try split; fourier |
+     apply atan_bound ].
+replace (atan_sub (2/3) (/5)) with (7/17)  by
+  (unfold atan_sub; field).
+rewrite (atan_sub_correct (7/17) (/5));
+ [apply f_equal | apply Rgt_not_eq; fourier | apply tech; try split; fourier |
+     apply atan_bound ].
+replace (atan_sub (7/17) (/5)) with (9/46) by
+  (unfold atan_sub; field).
+rewrite (atan_sub_correct (9/46) (/5));
+ [apply f_equal | apply Rgt_not_eq; fourier | apply tech; try split; fourier |
+     apply atan_bound ].
+rewrite <- atan_opp; apply f_equal.
+unfold atan_sub; field.
+Qed.
+
+Lemma Machin_2_3_7 : PI/4 = 2 * atan(/3) + (atan (/7)).
+rewrite <- atan_1.
+rewrite (atan_sub_correct 1 (/3));
+ [ | apply Rgt_not_eq; fourier | apply tech; try split; fourier |
+     apply atan_bound ].
+replace (2 * atan (/3) + atan (/7)) with
+  (atan (/3) + (atan (/3) + atan (/7))) by ring.
+apply f_equal.
+replace (atan_sub 1 (/3)) with (/2) by
+  (unfold atan_sub; field).
+rewrite (atan_sub_correct (/2) (/3));
+ [apply f_equal | apply Rgt_not_eq; fourier | apply tech; try split; fourier |
+     apply atan_bound ].
+apply f_equal; unfold atan_sub; field.
+Qed.
+
+(* More efficient way to compute approximations of PI. *)
+
+Definition PI_2_3_7_tg n := 
+  2 * Ratan_seq (/3) n + Ratan_seq (/7) n.
+
+Lemma PI_2_3_7_ineq :
+  forall N : nat,
+    sum_f_R0 (tg_alt PI_2_3_7_tg) (S (2 * N)) <= PI / 4 <=
+    sum_f_R0 (tg_alt PI_2_3_7_tg) (2 * N).
+Proof.
+assert (dec3 : 0 <= /3 <= 1) by (split; fourier).
+assert (dec7 : 0 <= /7 <= 1) by (split; fourier).
+assert (decr : Un_decreasing PI_2_3_7_tg).
+ apply Ratan_seq_decreasing in dec3.
+ apply Ratan_seq_decreasing in dec7.
+ intros n; apply Rplus_le_compat.
+  apply Rmult_le_compat_l; [ fourier | exact (dec3 n)].
+ exact (dec7 n).
+assert (cv : Un_cv PI_2_3_7_tg 0).
+ apply Ratan_seq_converging in dec3.
+ apply Ratan_seq_converging in dec7.
+ intros eps ep.
+ assert (ep' : 0 < eps /3) by fourier.
+ destruct (dec3 _ ep') as [N1 Pn1]; destruct (dec7 _ ep') as [N2 Pn2].
+ exists (N1 + N2)%nat; intros n Nn.
+ unfold PI_2_3_7_tg.
+ rewrite <- (Rplus_0_l 0).
+ apply Rle_lt_trans with
+    (1 := R_dist_plus (2 * Ratan_seq (/3) n) 0 (Ratan_seq (/7) n) 0).
+ replace eps with (2 * eps/3 + eps/3) by field.
+ apply Rplus_lt_compat.
+  unfold R_dist, Rminus, Rdiv.
+  rewrite <- (Rmult_0_r 2), <- Ropp_mult_distr_r_reverse.
+  rewrite <- Rmult_plus_distr_l, Rabs_mult, (Rabs_pos_eq 2);[|fourier].
+  rewrite Rmult_assoc; apply Rmult_lt_compat_l;[fourier | ].
+   apply (Pn1 n); omega.
+  apply (Pn2 n); omega.
+rewrite Machin_2_3_7.
+rewrite !atan_eq_ps_atan; try (split; fourier).
+unfold ps_atan; destruct (in_int (/3)); destruct (in_int (/7));
+  try match goal with id : ~ _ |- _ => case id; split; fourier end.
+destruct (ps_atan_exists_1 (/3)) as [v3 Pv3].
+destruct (ps_atan_exists_1 (/7)) as [v7 Pv7].
+assert (main : Un_cv (sum_f_R0 (tg_alt PI_2_3_7_tg)) (2 * v3 + v7)).
+ assert (main :Un_cv (fun n => 2 * sum_f_R0 (tg_alt (Ratan_seq (/3))) n +
+                        sum_f_R0 (tg_alt (Ratan_seq (/7))) n) (2 * v3 + v7)).
+  apply CV_plus;[ | assumption].
+  apply CV_mult;[ | assumption].
+  exists 0%nat; intros; rewrite R_dist_eq; assumption.
+ apply Un_cv_ext with (2 := main).
+ intros n; rewrite scal_sum, <- plus_sum; apply sum_eq; intros.
+ rewrite Rmult_comm; unfold PI_2_3_7_tg, tg_alt; field.
+intros N; apply (alternated_series_ineq _ _ _ decr cv main).
+Qed.
diff --git a/theories/Reals/NewtonInt.v b/theories/Reals/NewtonInt.v
index 79060771..67e353ee 100644
--- a/theories/Reals/NewtonInt.v
+++ b/theories/Reals/NewtonInt.v
@@ -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-2012     *)
 (*   \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.
-Require Import Rtrigo.
+Require Import Rtrigo1.
 Require Import Ranalysis.
-Open Local Scope R_scope.
+Local Open Scope R_scope.
 
 (*******************************************)
 (*            Newton's Integral            *)
@@ -30,8 +28,8 @@ Lemma FTCN_step1 :
   forall (f:Differential) (a b:R),
     Newton_integrable (fun x:R => derive_pt f x (cond_diff f x)) a b.
 Proof.
-  intros f a b; unfold Newton_integrable in |- *; exists (d1 f);
-    unfold antiderivative in |- *; intros; case (Rle_dec a b);
+  intros f a b; unfold Newton_integrable; exists (d1 f);
+    unfold antiderivative; intros; case (Rle_dec a b);
       intro;
         [ left; split; [ intros; exists (cond_diff f x); reflexivity | assumption ]
           | right; split;
@@ -44,26 +42,26 @@ Lemma FTC_Newton :
     NewtonInt (fun x:R => derive_pt f x (cond_diff f x)) a b
     (FTCN_step1 f a b) = f b - f a.
 Proof.
-  intros; unfold NewtonInt in |- *; reflexivity.
+  intros; unfold NewtonInt; reflexivity.
 Qed.
 
 (* $\int_a^a f$ exists forall a:R and f:R->R *)
 Lemma NewtonInt_P1 : forall (f:R -> R) (a:R), Newton_integrable f a a.
 Proof.
-  intros f a; unfold Newton_integrable in |- *;
+  intros f a; unfold Newton_integrable;
     exists (fct_cte (f a) * id)%F; left;
-      unfold antiderivative in |- *; split.
+      unfold antiderivative; split.
   intros; assert (H1 : derivable_pt (fct_cte (f a) * id) x).
   apply derivable_pt_mult.
   apply derivable_pt_const.
   apply derivable_pt_id.
   exists H1; assert (H2 : x = a).
   elim H; intros; apply Rle_antisym; assumption.
-  symmetry  in |- *; apply derive_pt_eq_0;
+  symmetry ; apply derive_pt_eq_0;
     replace (f x) with (0 * id x + fct_cte (f a) x * 1);
     [ apply (derivable_pt_lim_mult (fct_cte (f a)) id x);
       [ apply derivable_pt_lim_const | apply derivable_pt_lim_id ]
-      | unfold id, fct_cte in |- *; rewrite H2; ring ].
+      | unfold id, fct_cte; rewrite H2; ring ].
   right; reflexivity.
 Defined.
 
@@ -71,8 +69,8 @@ Defined.
 Lemma NewtonInt_P2 :
   forall (f:R -> R) (a:R), NewtonInt f a a (NewtonInt_P1 f a) = 0.
 Proof.
-  intros; unfold NewtonInt in |- *; simpl in |- *;
-    unfold mult_fct, fct_cte, id in |- *; ring.
+  intros; unfold NewtonInt; simpl;
+    unfold mult_fct, fct_cte, id; ring.
 Qed.
 
 (* If $\int_a^b f$ exists, then $\int_b^a f$ exists too *)
@@ -80,7 +78,7 @@ Lemma NewtonInt_P3 :
   forall (f:R -> R) (a b:R) (X:Newton_integrable f a b),
     Newton_integrable f b a.
 Proof.
-  unfold Newton_integrable in |- *; intros; elim X; intros g H;
+  unfold Newton_integrable; intros; elim X; intros g H;
     exists g; tauto.
 Defined.
 
@@ -90,7 +88,7 @@ Lemma NewtonInt_P4 :
     NewtonInt f a b pr = - NewtonInt f b a (NewtonInt_P3 f a b pr).
 Proof.
   intros; unfold Newton_integrable in pr; elim pr; intros; elim p; intro.
-  unfold NewtonInt in |- *;
+  unfold NewtonInt;
     case
     (NewtonInt_P3 f a b
       (exist
@@ -108,7 +106,7 @@ Proof.
   assert (H4 : a <= b <= b).
   split; [ assumption | right; reflexivity ].
   assert (H5 := H2 _ H3); assert (H6 := H2 _ H4); rewrite H5; rewrite H6; ring.
-  unfold NewtonInt in |- *;
+  unfold NewtonInt;
     case
     (NewtonInt_P3 f a b
       (exist
@@ -134,37 +132,37 @@ Lemma NewtonInt_P5 :
     Newton_integrable g a b ->
     Newton_integrable (fun x:R => l * f x + g x) a b.
 Proof.
-  unfold Newton_integrable in |- *; intros f g l a b X X0;
+  unfold Newton_integrable; intros f g l a b X X0;
     elim X; intros; elim X0; intros;
       exists (fun y:R => l * x y + x0 y).
   elim p; intro.
   elim p0; intro.
-  left; unfold antiderivative in |- *; unfold antiderivative in H, H0; elim H;
+  left; unfold antiderivative; unfold antiderivative in H, H0; elim H;
     clear H; intros; elim H0; clear H0; intros H0 _.
   split.
   intros; elim (H _ H2); elim (H0 _ H2); intros.
   assert (H5 : derivable_pt (fun y:R => l * x y + x0 y) x1).
   reg.
-  exists H5; symmetry  in |- *; reg; rewrite <- H3; rewrite <- H4; reflexivity.
+  exists H5; symmetry ; reg; rewrite <- H3; rewrite <- H4; reflexivity.
   assumption.
   unfold antiderivative in H, H0; elim H; elim H0; intros; elim H4; intro.
   elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H5 H2)).
-  left; rewrite <- H5; unfold antiderivative in |- *; split.
+  left; rewrite <- H5; unfold antiderivative; split.
   intros; elim H6; intros; assert (H9 : x1 = a).
   apply Rle_antisym; assumption.
   assert (H10 : a <= x1 <= b).
-  split; right; [ symmetry  in |- *; assumption | rewrite <- H5; assumption ].
+  split; right; [ symmetry ; assumption | rewrite <- H5; assumption ].
   assert (H11 : b <= x1 <= a).
-  split; right; [ rewrite <- H5; symmetry  in |- *; assumption | assumption ].
+  split; right; [ rewrite <- H5; symmetry ; assumption | assumption ].
   assert (H12 : derivable_pt x x1).
-  unfold derivable_pt in |- *; exists (f x1); elim (H3 _ H10); intros;
-    eapply derive_pt_eq_1; symmetry  in |- *; apply H12.
+  unfold derivable_pt; exists (f x1); elim (H3 _ H10); intros;
+    eapply derive_pt_eq_1; symmetry ; apply H12.
   assert (H13 : derivable_pt x0 x1).
-  unfold derivable_pt in |- *; exists (g x1); elim (H1 _ H11); intros;
-    eapply derive_pt_eq_1; symmetry  in |- *; apply H13.
+  unfold derivable_pt; exists (g x1); elim (H1 _ H11); intros;
+    eapply derive_pt_eq_1; symmetry ; apply H13.
   assert (H14 : derivable_pt (fun y:R => l * x y + x0 y) x1).
   reg.
-  exists H14; symmetry  in |- *; reg.
+  exists H14; symmetry ; reg.
   assert (H15 : derive_pt x0 x1 H13 = g x1).
   elim (H1 _ H11); intros; rewrite H15; apply pr_nu.
   assert (H16 : derive_pt x x1 H12 = f x1).
@@ -174,34 +172,34 @@ Proof.
   elim p0; intro.
   unfold antiderivative in H, H0; elim H; elim H0; intros; elim H4; intro.
   elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H5 H2)).
-  left; rewrite H5; unfold antiderivative in |- *; split.
+  left; rewrite H5; unfold antiderivative; split.
   intros; elim H6; intros; assert (H9 : x1 = a).
   apply Rle_antisym; assumption.
   assert (H10 : a <= x1 <= b).
-  split; right; [ symmetry  in |- *; assumption | rewrite H5; assumption ].
+  split; right; [ symmetry ; assumption | rewrite H5; assumption ].
   assert (H11 : b <= x1 <= a).
-  split; right; [ rewrite H5; symmetry  in |- *; assumption | assumption ].
+  split; right; [ rewrite H5; symmetry ; assumption | assumption ].
   assert (H12 : derivable_pt x x1).
-  unfold derivable_pt in |- *; exists (f x1); elim (H3 _ H11); intros;
-    eapply derive_pt_eq_1; symmetry  in |- *; apply H12.
+  unfold derivable_pt; exists (f x1); elim (H3 _ H11); intros;
+    eapply derive_pt_eq_1; symmetry ; apply H12.
   assert (H13 : derivable_pt x0 x1).
-  unfold derivable_pt in |- *; exists (g x1); elim (H1 _ H10); intros;
-    eapply derive_pt_eq_1; symmetry  in |- *; apply H13.
+  unfold derivable_pt; exists (g x1); elim (H1 _ H10); intros;
+    eapply derive_pt_eq_1; symmetry ; apply H13.
   assert (H14 : derivable_pt (fun y:R => l * x y + x0 y) x1).
   reg.
-  exists H14; symmetry  in |- *; reg.
+  exists H14; symmetry ; reg.
   assert (H15 : derive_pt x0 x1 H13 = g x1).
   elim (H1 _ H10); intros; rewrite H15; apply pr_nu.
   assert (H16 : derive_pt x x1 H12 = f x1).
   elim (H3 _ H11); intros; rewrite H16; apply pr_nu.
   rewrite H15; rewrite H16; ring.
   right; reflexivity.
-  right; unfold antiderivative in |- *; unfold antiderivative in H, H0; elim H;
+  right; unfold antiderivative; unfold antiderivative in H, H0; elim H;
     clear H; intros; elim H0; clear H0; intros H0 _; split.
   intros; elim (H _ H2); elim (H0 _ H2); intros.
   assert (H5 : derivable_pt (fun y:R => l * x y + x0 y) x1).
   reg.
-  exists H5; symmetry  in |- *; reg; rewrite <- H3; rewrite <- H4; reflexivity.
+  exists H5; symmetry ; reg; rewrite <- H3; rewrite <- H4; reflexivity.
   assumption.
 Defined.
 
@@ -212,12 +210,12 @@ Lemma antiderivative_P1 :
     antiderivative g G a b ->
     antiderivative (fun x:R => l * f x + g x) (fun x:R => l * F x + G x) a b.
 Proof.
-  unfold antiderivative in |- *; intros; elim H; elim H0; clear H H0; intros;
+  unfold antiderivative; intros; elim H; elim H0; clear H H0; intros;
     split.
   intros; elim (H _ H3); elim (H1 _ H3); intros.
   assert (H6 : derivable_pt (fun x:R => l * F x + G x) x).
   reg.
-  exists H6; symmetry  in |- *; reg; rewrite <- H4; rewrite <- H5; ring.
+  exists H6; symmetry ; reg; rewrite <- H4; rewrite <- H5; ring.
   assumption.
 Qed.
 
@@ -228,7 +226,7 @@ Lemma NewtonInt_P6 :
     NewtonInt (fun x:R => l * f x + g x) a b (NewtonInt_P5 f g l a b pr1 pr2) =
     l * NewtonInt f a b pr1 + NewtonInt g a b pr2.
 Proof.
-  intros f g l a b pr1 pr2; unfold NewtonInt in |- *;
+  intros f g l a b pr1 pr2; unfold NewtonInt;
     case (NewtonInt_P5 f g l a b pr1 pr2); intros; case pr1;
       intros; case pr2; intros; case (total_order_T a b);
         intro.
@@ -279,7 +277,7 @@ Lemma antiderivative_P2 :
         | right _ => F1 x + (F0 b - F1 b)
       end) a c.
 Proof.
-  unfold antiderivative in |- *; intros; elim H; clear H; intros; elim H0;
+  unfold antiderivative; intros; elim H; clear H; intros; elim H0;
     clear H0; intros; split.
   2: apply Rle_trans with b; assumption.
   intros; elim H3; clear H3; intros; case (total_order_T x b); intro.
@@ -295,25 +293,25 @@ Proof.
             | left _ => F0 x
             | right _ => F1 x + (F0 b - F1 b)
           end) x (f x)).
-  unfold derivable_pt_lim in |- *; assert (H7 : derive_pt F0 x x0 = f x).
-  symmetry  in |- *; assumption.
+  unfold derivable_pt_lim; assert (H7 : derive_pt F0 x x0 = f x).
+  symmetry ; assumption.
   assert (H8 := derive_pt_eq_1 F0 x (f x) x0 H7); unfold derivable_pt_lim in H8;
     intros; elim (H8 _ H9); intros; set (D := Rmin x1 (b - x)).
   assert (H11 : 0 < D).
-  unfold D in |- *; unfold Rmin in |- *; case (Rle_dec x1 (b - x)); intro.
+  unfold D; unfold Rmin; case (Rle_dec x1 (b - x)); intro.
   apply (cond_pos x1).
   apply Rlt_Rminus; assumption.
   exists (mkposreal _ H11); intros; case (Rle_dec x b); intro.
   case (Rle_dec (x + h) b); intro.
   apply H10.
   assumption.
-  apply Rlt_le_trans with D; [ assumption | unfold D in |- *; apply Rmin_l ].
+  apply Rlt_le_trans with D; [ assumption | unfold D; apply Rmin_l ].
   elim n; left; apply Rlt_le_trans with (x + D).
   apply Rplus_lt_compat_l; apply Rle_lt_trans with (Rabs h).
   apply RRle_abs.
   apply H13.
   apply Rplus_le_reg_l with (- x); rewrite <- Rplus_assoc; rewrite Rplus_opp_l;
-    rewrite Rplus_0_l; rewrite Rplus_comm; unfold D in |- *;
+    rewrite Rplus_0_l; rewrite Rplus_comm; unfold D;
       apply Rmin_r.
   elim n; left; assumption.
   assert
@@ -324,16 +322,16 @@ Proof.
           | left _ => F0 x
           | right _ => F1 x + (F0 b - F1 b)
         end) x).
-  unfold derivable_pt in |- *; exists (f x); apply H7.
-  exists H8; symmetry  in |- *; apply derive_pt_eq_0; apply H7.
+  unfold derivable_pt; exists (f x); apply H7.
+  exists H8; symmetry ; apply derive_pt_eq_0; apply H7.
   assert (H5 : a <= x <= b).
   split; [ assumption | right; assumption ].
   assert (H6 : b <= x <= c).
-  split; [ right; symmetry  in |- *; assumption | assumption ].
+  split; [ right; symmetry ; assumption | assumption ].
   elim (H _ H5); elim (H0 _ H6); intros; assert (H9 : derive_pt F0 x x1 = f x).
-  symmetry  in |- *; assumption.
+  symmetry ; assumption.
   assert (H10 : derive_pt F1 x x0 = f x).
-  symmetry  in |- *; assumption.
+  symmetry ; assumption.
   assert (H11 := derive_pt_eq_1 F0 x (f x) x1 H9);
     assert (H12 := derive_pt_eq_1 F1 x (f x) x0 H10);
       assert
@@ -344,21 +342,21 @@ Proof.
               | left _ => F0 x
               | right _ => F1 x + (F0 b - F1 b)
             end) x (f x)).
-  unfold derivable_pt_lim in |- *; unfold derivable_pt_lim in H11, H12; intros;
+  unfold derivable_pt_lim; unfold derivable_pt_lim in H11, H12; intros;
     elim (H11 _ H13); elim (H12 _ H13); intros; set (D := Rmin x2 x3);
       assert (H16 : 0 < D).
-  unfold D in |- *; unfold Rmin in |- *; case (Rle_dec x2 x3); intro.
+  unfold D; unfold Rmin; case (Rle_dec x2 x3); intro.
   apply (cond_pos x2).
   apply (cond_pos x3).
   exists (mkposreal _ H16); intros; case (Rle_dec x b); intro.
   case (Rle_dec (x + h) b); intro.
   apply H15.
   assumption.
-  apply Rlt_le_trans with D; [ assumption | unfold D in |- *; apply Rmin_r ].
+  apply Rlt_le_trans with D; [ assumption | unfold D; apply Rmin_r ].
   replace (F1 (x + h) + (F0 b - F1 b) - F0 x) with (F1 (x + h) - F1 x).
   apply H14.
   assumption.
-  apply Rlt_le_trans with D; [ assumption | unfold D in |- *; apply Rmin_l ].
+  apply Rlt_le_trans with D; [ assumption | unfold D; apply Rmin_l ].
   rewrite b0; ring.
   elim n; right; assumption.
   assert
@@ -369,8 +367,8 @@ Proof.
           | left _ => F0 x
           | right _ => F1 x + (F0 b - F1 b)
         end) x).
-  unfold derivable_pt in |- *; exists (f x); apply H13.
-  exists H14; symmetry  in |- *; apply derive_pt_eq_0; apply H13.
+  unfold derivable_pt; exists (f x); apply H13.
+  exists H14; symmetry ; apply derive_pt_eq_0; apply H13.
   assert (H5 : b <= x <= c).
   split; [ left; assumption | assumption ].
   assert (H6 := H0 _ H5); elim H6; clear H6; intros;
@@ -382,12 +380,12 @@ Proof.
             | left _ => F0 x
             | right _ => F1 x + (F0 b - F1 b)
           end) x (f x)).
-  unfold derivable_pt_lim in |- *; assert (H7 : derive_pt F1 x x0 = f x).
-  symmetry  in |- *; assumption.
+  unfold derivable_pt_lim; assert (H7 : derive_pt F1 x x0 = f x).
+  symmetry ; assumption.
   assert (H8 := derive_pt_eq_1 F1 x (f x) x0 H7); unfold derivable_pt_lim in H8;
     intros; elim (H8 _ H9); intros; set (D := Rmin x1 (x - b));
       assert (H11 : 0 < D).
-  unfold D in |- *; unfold Rmin in |- *; case (Rle_dec x1 (x - b)); intro.
+  unfold D; unfold Rmin; case (Rle_dec x1 (x - b)); intro.
   apply (cond_pos x1).
   apply Rlt_Rminus; assumption.
   exists (mkposreal _ H11); intros; case (Rle_dec x b); intro.
@@ -401,13 +399,13 @@ Proof.
   rewrite <- Rabs_Ropp; apply RRle_abs.
   apply Rlt_le_trans with D.
   apply H13.
-  unfold D in |- *; apply Rmin_r.
+  unfold D; apply Rmin_r.
   replace (F1 (x + h) + (F0 b - F1 b) - (F1 x + (F0 b - F1 b))) with
   (F1 (x + h) - F1 x); [ idtac | ring ]; apply H10.
   assumption.
   apply Rlt_le_trans with D.
   assumption.
-  unfold D in |- *; apply Rmin_l.
+  unfold D; apply Rmin_l.
   assert
     (H8 :
       derivable_pt
@@ -416,8 +414,8 @@ Proof.
           | left _ => F0 x
           | right _ => F1 x + (F0 b - F1 b)
         end) x).
-  unfold derivable_pt in |- *; exists (f x); apply H7.
-  exists H8; symmetry  in |- *; apply derive_pt_eq_0; apply H7.
+  unfold derivable_pt; exists (f x); apply H7.
+  exists H8; symmetry ; apply derive_pt_eq_0; apply H7.
 Qed.
 
 Lemma antiderivative_P3 :
@@ -429,15 +427,15 @@ Proof.
   intros; unfold antiderivative in H, H0; elim H; clear H; elim H0; clear H0;
     intros; case (total_order_T a c); intro.
   elim s; intro.
-  right; unfold antiderivative in |- *; split.
+  right; unfold antiderivative; split.
   intros; apply H1; elim H3; intros; split;
     [ assumption | apply Rle_trans with c; assumption ].
   left; assumption.
-  right; unfold antiderivative in |- *; split.
+  right; unfold antiderivative; split.
   intros; apply H1; elim H3; intros; split;
     [ assumption | apply Rle_trans with c; assumption ].
   right; assumption.
-  left; unfold antiderivative in |- *; split.
+  left; unfold antiderivative; split.
   intros; apply H; elim H3; intros; split;
     [ assumption | apply Rle_trans with a; assumption ].
   left; assumption.
@@ -452,15 +450,15 @@ Proof.
   intros; unfold antiderivative in H, H0; elim H; clear H; elim H0; clear H0;
     intros; case (total_order_T c b); intro.
   elim s; intro.
-  right; unfold antiderivative in |- *; split.
+  right; unfold antiderivative; split.
   intros; apply H1; elim H3; intros; split;
     [ apply Rle_trans with c; assumption | assumption ].
   left; assumption.
-  right; unfold antiderivative in |- *; split.
+  right; unfold antiderivative; split.
   intros; apply H1; elim H3; intros; split;
     [ apply Rle_trans with c; assumption | assumption ].
   right; assumption.
-  left; unfold antiderivative in |- *; split.
+  left; unfold antiderivative; split.
   intros; apply H; elim H3; intros; split;
     [ apply Rle_trans with b; assumption | assumption ].
   left; assumption.
@@ -473,7 +471,7 @@ Lemma NewtonInt_P7 :
     Newton_integrable f a b ->
     Newton_integrable f b c -> Newton_integrable f a c.
 Proof.
-  unfold Newton_integrable in |- *; intros f a b c Hab Hbc X X0; elim X;
+  unfold Newton_integrable; intros f a b c Hab Hbc X X0; elim X;
     clear X; intros F0 H0; elim X0; clear X0; intros F1 H1;
       set
         (g :=
@@ -481,7 +479,7 @@ Proof.
             match Rle_dec x b with
               | left _ => F0 x
               | right _ => F1 x + (F0 b - F1 b)
-            end); exists g; left; unfold g in |- *;
+            end); exists g; left; unfold g;
         apply antiderivative_P2.
   elim H0; intro.
   assumption.
@@ -506,7 +504,7 @@ Proof.
   case (total_order_T b c); intro.
   elim s0; intro.
 (* a<b & b<c *)
-  unfold Newton_integrable in |- *;
+  unfold Newton_integrable;
     exists
       (fun x:R =>
         match Rle_dec x b with
@@ -525,7 +523,7 @@ Proof.
 (* a<b & b>c *)
   case (total_order_T a c); intro.
   elim s0; intro.
-  unfold Newton_integrable in |- *; exists F0.
+  unfold Newton_integrable; exists F0.
   left.
   elim H1; intro.
   unfold antiderivative in H; elim H; clear H; intros _ H.
@@ -539,7 +537,7 @@ Proof.
   unfold antiderivative in H2; elim H2; clear H2; intros _ H2.
   elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 a0)).
   rewrite b0; apply NewtonInt_P1.
-  unfold Newton_integrable in |- *; exists F1.
+  unfold Newton_integrable; exists F1.
   right.
   elim H1; intro.
   unfold antiderivative in H; elim H; clear H; intros _ H.
@@ -559,7 +557,7 @@ Proof.
 (* a>b & b<c *)
   case (total_order_T a c); intro.
   elim s0; intro.
-  unfold Newton_integrable in |- *; exists F1.
+  unfold Newton_integrable; exists F1.
   left.
   elim H1; intro.
 (*****************)
@@ -574,7 +572,7 @@ Proof.
   unfold antiderivative in H; elim H; clear H; intros _ H.
   elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H a0)).
   rewrite b0; apply NewtonInt_P1.
-  unfold Newton_integrable in |- *; exists F0.
+  unfold Newton_integrable; exists F0.
   right.
   elim H0; intro.
   unfold antiderivative in H; elim H; clear H; intros _ H.
@@ -603,7 +601,7 @@ Lemma NewtonInt_P9 :
     NewtonInt f a c (NewtonInt_P8 f a b c pr1 pr2) =
     NewtonInt f a b pr1 + NewtonInt f b c pr2.
 Proof.
-  intros; unfold NewtonInt in |- *.
+  intros; unfold NewtonInt.
   case (NewtonInt_P8 f a b c pr1 pr2); intros.
   case pr1; intros.
   case pr2; intros.
@@ -643,7 +641,7 @@ Proof.
   elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H a0)).
 (* a<b & b=c *)
   rewrite <- b0.
-  unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rplus_0_r.
+  unfold Rminus; rewrite Rplus_opp_r; rewrite Rplus_0_r.
   rewrite <- b0 in o.
   elim o0; intro.
   elim o; intro.
@@ -761,7 +759,7 @@ Proof.
   elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 a0)).
 (* a>b & b=c *)
   rewrite <- b0.
-  unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rplus_0_r.
+  unfold Rminus; rewrite Rplus_opp_r; rewrite Rplus_0_r.
   rewrite <- b0 in o.
   elim o0; intro.
   unfold antiderivative in H; elim H; clear H; intros _ H.
diff --git a/theories/Reals/PSeries_reg.v b/theories/Reals/PSeries_reg.v
index e7182312..d4d91137 100644
--- a/theories/Reals/PSeries_reg.v
+++ b/theories/Reals/PSeries_reg.v
@@ -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-2012     *)
 (*   \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.
 Require Import Ranalysis1.
 Require Import Max.
 Require Import Even.
-Open Local Scope R_scope.
+Local Open Scope R_scope.
 
 Definition Boule (x:R) (r:posreal) (y:R) : Prop := Rabs (y - x) < r.
 
@@ -46,7 +44,7 @@ Lemma CVN_CVU :
     (cv:forall x:R, {l:R | Un_cv (fun N:nat => SP fn N x) l })
     (r:posreal), CVN_r fn r -> CVU (fun n:nat => SP fn n) (SFL fn cv) 0 r.
 Proof.
-  intros; unfold CVU in |- *; intros.
+  intros; unfold CVU; intros.
   unfold CVN_r in X.
   elim X; intros An X0.
   elim X0; intros s H0.
@@ -60,7 +58,7 @@ Proof.
     rewrite Ropp_minus_distr';
       rewrite (Rabs_right (s - sum_f_R0 (fun k:nat => Rabs (An k)) n)).
   eapply sum_maj1.
-  unfold SFL in |- *; case (cv y); intro.
+  unfold SFL; case (cv y); intro.
   trivial.
   apply H1.
   intro; elim H0; intros.
@@ -71,7 +69,7 @@ Proof.
   apply H8; apply H6.
   apply Rle_ge;
     apply Rplus_le_reg_l with (sum_f_R0 (fun k:nat => Rabs (An k)) n).
-  rewrite Rplus_0_r; unfold Rminus in |- *; rewrite (Rplus_comm s);
+  rewrite Rplus_0_r; unfold Rminus; rewrite (Rplus_comm s);
     rewrite <- Rplus_assoc; rewrite Rplus_opp_r; rewrite Rplus_0_l;
       apply sum_incr.
   apply H1.
@@ -79,10 +77,10 @@ Proof.
   unfold R_dist in H4; unfold Rminus in H4; rewrite Ropp_0 in H4.
   assert (H7 := H4 n H5).
   rewrite Rplus_0_r in H7; apply H7.
-  unfold Un_cv in H1; unfold Un_cv in |- *; intros.
+  unfold Un_cv in H1; unfold Un_cv; intros.
   elim (H1 _ H3); intros.
   exists x; intros.
-  unfold R_dist in |- *; unfold R_dist in H4.
+  unfold R_dist; unfold R_dist in H4.
   rewrite Rminus_0_r; apply H4; assumption.
 Qed.
 
@@ -93,13 +91,13 @@ Lemma CVU_continuity :
     (forall (n:nat) (y:R), Boule x r y -> continuity_pt (fn n) y) ->
     forall y:R, Boule x r y -> continuity_pt f y.
 Proof.
-  intros; unfold continuity_pt in |- *; unfold continue_in in |- *;
-    unfold limit1_in in |- *; unfold limit_in in |- *;
-      simpl in |- *; unfold R_dist in |- *; intros.
+  intros; unfold continuity_pt; unfold continue_in;
+    unfold limit1_in; unfold limit_in;
+      simpl; unfold R_dist; intros.
   unfold CVU in H.
   cut (0 < eps / 3);
     [ intro
-      | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+      | unfold Rdiv; apply Rmult_lt_0_compat;
         [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ].
   elim (H _ H3); intros N0 H4.
   assert (H5 := H0 N0 y H1).
@@ -112,7 +110,7 @@ Proof.
   set (del := Rmin del1 del2).
   exists del; intros.
   split.
-  unfold del in |- *; unfold Rmin in |- *; case (Rle_dec del1 del2); intro.
+  unfold del; unfold Rmin; case (Rle_dec del1 del2); intro.
   apply (cond_pos del1).
   elim H8; intros; assumption.
   intros;
@@ -132,27 +130,27 @@ Proof.
   elim H9; intros.
   apply Rlt_le_trans with del.
   assumption.
-  unfold del in |- *; apply Rmin_l.
+  unfold del; apply Rmin_l.
   elim H8; intros.
   apply H11.
   split.
   elim H9; intros; assumption.
   elim H9; intros; apply Rlt_le_trans with del.
   assumption.
-  unfold del in |- *; apply Rmin_r.
+  unfold del; apply Rmin_r.
   rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr'; apply H4.
   apply le_n.
   assumption.
   apply Rmult_eq_reg_l with 3.
-  do 2 rewrite Rmult_plus_distr_l; unfold Rdiv in |- *; rewrite <- Rmult_assoc;
+  do 2 rewrite Rmult_plus_distr_l; unfold Rdiv; rewrite <- Rmult_assoc;
     rewrite Rinv_r_simpl_m.
   ring.
   discrR.
   discrR.
   cut (0 < r - Rabs (x - y)).
   intro; exists (mkposreal _ H6).
-  simpl in |- *; intros.
-  unfold Boule in |- *; replace (y + h - x) with (h + (y - x));
+  simpl; intros.
+  unfold Boule; replace (y + h - x) with (h + (y - x));
     [ idtac | ring ]; apply Rle_lt_trans with (Rabs h + Rabs (y - x)).
   apply Rabs_triang.
   apply Rplus_lt_reg_r with (- Rabs (x - y)).
@@ -175,8 +173,8 @@ Lemma continuity_pt_finite_SF :
     continuity_pt (fun y:R => sum_f_R0 (fun k:nat => fn k y) N) x.
 Proof.
   intros; induction  N as [| N HrecN].
-  simpl in |- *; apply (H 0%nat); apply le_n.
-  simpl in |- *;
+  simpl; apply (H 0%nat); apply le_n.
+  simpl;
     replace (fun y:R => sum_f_R0 (fun k:nat => fn k y) N + fn (S N) y) with
     ((fun y:R => sum_f_R0 (fun k:nat => fn k y) N) + (fun y:R => fn (S N) y))%F;
     [ idtac | reflexivity ].
@@ -199,7 +197,7 @@ Proof.
   intros; eapply CVU_continuity.
   apply CVN_CVU.
   apply X.
-  intros; unfold SP in |- *; apply continuity_pt_finite_SF.
+  intros; unfold SP; apply continuity_pt_finite_SF.
   intros; apply H.
   apply H1.
   apply H0.
@@ -210,7 +208,7 @@ Lemma SFL_continuity :
     (cv:forall x:R, { l:R | Un_cv (fun N:nat => SP fn N x) l }),
     CVN_R fn -> (forall n:nat, continuity (fn n)) -> continuity (SFL fn cv).
 Proof.
-  intros; unfold continuity in |- *; intro.
+  intros; unfold continuity; intro.
   cut (0 < Rabs x + 1);
     [ intro | apply Rplus_le_lt_0_compat; [ apply Rabs_pos | apply Rlt_0_1 ] ].
   cut (Boule 0 (mkposreal _ H0) x).
@@ -218,8 +216,8 @@ Proof.
   apply X.
   intros; apply (H n y).
   apply H1.
-  unfold Boule in |- *; simpl in |- *; rewrite Rminus_0_r;
-    pattern (Rabs x) at 1 in |- *; rewrite <- Rplus_0_r;
+  unfold Boule; simpl; rewrite Rminus_0_r;
+    pattern (Rabs x) at 1; rewrite <- Rplus_0_r;
       apply Rplus_lt_compat_l; apply Rlt_0_1.
 Qed.
 
@@ -229,10 +227,10 @@ Lemma CVN_R_CVS :
     CVN_R fn -> forall x:R, { l:R | Un_cv (fun N:nat => SP fn N x) l }.
 Proof.
   intros; apply R_complete.
-  unfold SP in |- *; set (An := fun N:nat => fn N x).
-  change (Cauchy_crit_series An) in |- *.
+  unfold SP; set (An := fun N:nat => fn N x).
+  change (Cauchy_crit_series An).
   apply cauchy_abs.
-  unfold Cauchy_crit_series in |- *; apply CV_Cauchy.
+  unfold Cauchy_crit_series; apply CV_Cauchy.
   unfold CVN_R in X; cut (0 < Rabs x + 1).
   intro; assert (H0 := X (mkposreal _ H)).
   unfold CVN_r in H0; elim H0; intros Bn H1.
@@ -241,13 +239,13 @@ Proof.
   apply Rseries_CV_comp with Bn.
   intro; split.
   apply Rabs_pos.
-  unfold An in |- *; apply H4; unfold Boule in |- *; simpl in |- *;
+  unfold An; apply H4; unfold Boule; simpl;
     rewrite Rminus_0_r.
-  pattern (Rabs x) at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
+  pattern (Rabs x) at 1; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
     apply Rlt_0_1.
   exists l.
   cut (forall n:nat, 0 <= Bn n).
-  intro; unfold Un_cv in H3; unfold Un_cv in |- *; intros.
+  intro; unfold Un_cv in H3; unfold Un_cv; intros.
   elim (H3 _ H6); intros.
   exists x0; intros.
   replace (sum_f_R0 Bn n) with (sum_f_R0 (fun k:nat => Rabs (Bn k)) n).
@@ -255,8 +253,8 @@ Proof.
   apply sum_eq; intros; apply Rabs_right; apply Rle_ge; apply H5.
   intro; apply Rle_trans with (Rabs (An n)).
   apply Rabs_pos.
-  unfold An in |- *; apply H4; unfold Boule in |- *; simpl in |- *;
-    rewrite Rminus_0_r; pattern (Rabs x) at 1 in |- *;
+  unfold An; apply H4; unfold Boule; simpl;
+    rewrite Rminus_0_r; pattern (Rabs x) at 1;
       rewrite <- Rplus_0_r; apply Rplus_lt_compat_l; apply Rlt_0_1.
   apply Rplus_le_lt_0_compat; [ apply Rabs_pos | apply Rlt_0_1 ].
 Qed.
diff --git a/theories/Reals/PartSum.v b/theories/Reals/PartSum.v
index b2a0e574..d765cf78 100644
--- a/theories/Reals/PartSum.v
+++ b/theories/Reals/PartSum.v
@@ -1,27 +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-2012     *)
 (*   \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.
 Require Import Rcomplete.
 Require Import Max.
-Open Local Scope R_scope.
+Local Open Scope R_scope.
 
 Lemma tech1 :
   forall (An:nat -> R) (N:nat),
     (forall n:nat, (n <= N)%nat -> 0 < An n) -> 0 < sum_f_R0 An N.
 Proof.
   intros; induction  N as [| N HrecN].
-  simpl in |- *; apply H; apply le_n.
-  simpl in |- *; apply Rplus_lt_0_compat.
+  simpl; apply H; apply le_n.
+  simpl; apply Rplus_lt_0_compat.
   apply HrecN; intros; apply H; apply le_S; assumption.
   apply H; apply le_n.
 Qed.
@@ -54,7 +52,7 @@ Proof.
   repeat rewrite S_INR; ring.
   apply le_n_S; apply lt_le_weak; assumption.
   apply lt_le_S; assumption.
-  rewrite H1; rewrite <- minus_n_n; simpl in |- *.
+  rewrite H1; rewrite <- minus_n_n; simpl.
   replace (n + 0)%nat with n; [ reflexivity | ring ].
   inversion H.
   right; reflexivity.
@@ -68,7 +66,7 @@ Lemma tech3 :
 Proof.
   intros; cut (1 - k <> 0).
   intro; induction  N as [| N HrecN].
-  simpl in |- *; rewrite Rmult_1_r; unfold Rdiv in |- *; rewrite <- Rinv_r_sym.
+  simpl; rewrite Rmult_1_r; unfold Rdiv; rewrite <- Rinv_r_sym.
   reflexivity.
   apply H0.
   replace (sum_f_R0 (fun i:nat => k ^ i) (S N)) with
@@ -77,15 +75,15 @@ Proof.
     replace ((1 - k ^ S N) / (1 - k) + k ^ S N) with
     ((1 - k ^ S N + (1 - k) * k ^ S N) / (1 - k)).
   apply Rmult_eq_reg_l with (1 - k).
-  unfold Rdiv in |- *; do 2 rewrite <- (Rmult_comm (/ (1 - k)));
+  unfold Rdiv; do 2 rewrite <- (Rmult_comm (/ (1 - k)));
     repeat rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym;
-      [ do 2 rewrite Rmult_1_l; simpl in |- *; ring | apply H0 ].
+      [ do 2 rewrite Rmult_1_l; simpl; ring | apply H0 ].
   apply H0.
-  unfold Rdiv in |- *; rewrite Rmult_plus_distr_r; rewrite (Rmult_comm (1 - k));
+  unfold Rdiv; rewrite Rmult_plus_distr_r; rewrite (Rmult_comm (1 - k));
     repeat rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
   rewrite Rmult_1_r; reflexivity.
   apply H0.
-  apply Rminus_eq_contra; red in |- *; intro; elim H; symmetry  in |- *;
+  apply Rminus_eq_contra; red; intro; elim H; symmetry ;
     assumption.
 Qed.
 
@@ -94,11 +92,11 @@ Lemma tech4 :
     0 <= k -> (forall i:nat, An (S i) < k * An i) -> An N <= An 0%nat * k ^ N.
 Proof.
   intros; induction  N as [| N HrecN].
-  simpl in |- *; right; ring.
+  simpl; right; ring.
   apply Rle_trans with (k * An N).
   left; apply (H0 N).
   replace (S N) with (N + 1)%nat; [ idtac | ring ].
-  rewrite pow_add; simpl in |- *; rewrite Rmult_1_r;
+  rewrite pow_add; simpl; rewrite Rmult_1_r;
     replace (An 0%nat * (k ^ N * k)) with (k * (An 0%nat * k ^ N));
     [ idtac | ring ]; apply Rmult_le_compat_l.
   assumption.
@@ -118,7 +116,7 @@ Lemma tech6 :
     sum_f_R0 An N <= An 0%nat * sum_f_R0 (fun i:nat => k ^ i) N.
 Proof.
   intros; induction  N as [| N HrecN].
-  simpl in |- *; right; ring.
+  simpl; right; ring.
   apply Rle_trans with (An 0%nat * sum_f_R0 (fun i:nat => k ^ i) N + An (S N)).
   rewrite tech5; do 2 rewrite <- (Rplus_comm (An (S N)));
     apply Rplus_le_compat_l.
@@ -129,13 +127,13 @@ Qed.
 
 Lemma tech7 : forall r1 r2:R, r1 <> 0 -> r2 <> 0 -> r1 <> r2 -> / r1 <> / r2.
 Proof.
-  intros; red in |- *; intro.
+  intros; red; intro.
   assert (H3 := Rmult_eq_compat_l r1 _ _ H2).
   rewrite <- Rinv_r_sym in H3; [ idtac | assumption ].
   assert (H4 := Rmult_eq_compat_l r2 _ _ H3).
   rewrite Rmult_1_r in H4; rewrite <- Rmult_assoc in H4.
   rewrite Rinv_r_simpl_m in H4; [ idtac | assumption ].
-  elim H1; symmetry  in |- *; assumption.
+  elim H1; symmetry ; assumption.
 Qed.
 
 Lemma tech11 :
@@ -144,7 +142,7 @@ Lemma tech11 :
     sum_f_R0 An N = sum_f_R0 Bn N - sum_f_R0 Cn N.
 Proof.
   intros; induction  N as [| N HrecN].
-  simpl in |- *; apply H.
+  simpl; apply H.
   do 3 rewrite tech5; rewrite HrecN; rewrite (H (S N)); ring.
 Qed.
 
@@ -153,7 +151,7 @@ Lemma tech12 :
     Un_cv (fun N:nat => sum_f_R0 (fun i:nat => An i * x ^ i) N) l ->
     Pser An x l.
 Proof.
-  intros; unfold Pser in |- *; unfold infinite_sum in |- *; unfold Un_cv in H;
+  intros; unfold Pser; unfold infinite_sum; unfold Un_cv in H;
     assumption.
 Qed.
 
@@ -162,7 +160,7 @@ Lemma scal_sum :
     x * sum_f_R0 An N = sum_f_R0 (fun i:nat => An i * x) N.
 Proof.
   intros; induction  N as [| N HrecN].
-  simpl in |- *; ring.
+  simpl; ring.
   do 2 rewrite tech5.
   rewrite Rmult_plus_distr_l; rewrite <- HrecN; ring.
 Qed.
@@ -181,14 +179,14 @@ Proof.
   do 2 rewrite tech5.
   replace (S (S (pred N))) with (S N).
   rewrite (HrecN H1); ring.
-  rewrite H2; simpl in |- *; reflexivity.
+  rewrite H2; simpl; reflexivity.
   assert (H2 := O_or_S N).
   elim H2; intros.
   elim a; intros.
   rewrite <- p.
-  simpl in |- *; reflexivity.
+  simpl; reflexivity.
   rewrite <- b in H1; elim (lt_irrefl _ H1).
-  rewrite H1; simpl in |- *; reflexivity.
+  rewrite H1; simpl; reflexivity.
   inversion H.
   right; reflexivity.
   left; apply lt_le_trans with 1%nat; [ apply lt_O_Sn | assumption ].
@@ -199,7 +197,7 @@ Lemma plus_sum :
     sum_f_R0 (fun i:nat => An i + Bn i) N = sum_f_R0 An N + sum_f_R0 Bn N.
 Proof.
   intros; induction  N as [| N HrecN].
-  simpl in |- *; ring.
+  simpl; ring.
   do 3 rewrite tech5; rewrite HrecN; ring.
 Qed.
 
@@ -209,7 +207,7 @@ Lemma sum_eq :
     sum_f_R0 An N = sum_f_R0 Bn N.
 Proof.
   intros; induction  N as [| N HrecN].
-  simpl in |- *; apply H; apply le_n.
+  simpl; apply H; apply le_n.
   do 2 rewrite tech5; rewrite HrecN.
   rewrite (H (S N)); [ reflexivity | apply le_n ].
   intros; apply H; apply le_trans with N; [ assumption | apply le_n_Sn ].
@@ -220,7 +218,7 @@ Lemma uniqueness_sum :
   forall (An:nat -> R) (l1 l2:R),
     infinite_sum An l1 -> infinite_sum An l2 -> l1 = l2.
 Proof.
-  unfold infinite_sum in |- *; intros.
+  unfold infinite_sum; intros.
   case (Req_dec l1 l2); intro.
   assumption.
   cut (0 < Rabs ((l1 - l2) / 2)); [ intro | apply Rabs_pos_lt ].
@@ -237,19 +235,19 @@ Proof.
   intro; rewrite H12 in H11; assert (H13 := double_var); unfold Rdiv in H13;
     rewrite <- H13 in H11.
   elim (Rlt_irrefl _ H11).
-  apply Rabs_right; left; change (0 < / 2) in |- *; apply Rinv_0_lt_compat;
+  apply Rabs_right; left; change (0 < / 2); apply Rinv_0_lt_compat;
     cut (0%nat <> 2%nat);
-      [ intro H20; generalize (lt_INR_0 2 (neq_O_lt 2 H20)); unfold INR in |- *;
+      [ intro H20; generalize (lt_INR_0 2 (neq_O_lt 2 H20)); unfold INR;
         intro; assumption
         | discriminate ].
-  unfold R_dist in |- *; rewrite <- (Rabs_Ropp (sum_f_R0 An N - l1));
+  unfold R_dist; rewrite <- (Rabs_Ropp (sum_f_R0 An N - l1));
     rewrite Ropp_minus_distr'.
   replace (l1 - l2) with (l1 - sum_f_R0 An N + (sum_f_R0 An N - l2));
   [ idtac | ring ].
   apply Rabs_triang.
-  unfold ge in |- *; unfold N in |- *; apply le_max_r.
-  unfold ge in |- *; unfold N in |- *; apply le_max_l.
-  unfold Rdiv in |- *; apply prod_neq_R0.
+  unfold ge; unfold N; apply le_max_r.
+  unfold ge; unfold N; apply le_max_l.
+  unfold Rdiv; apply prod_neq_R0.
   apply Rminus_eq_contra; assumption.
   apply Rinv_neq_0_compat; discrR.
 Qed.
@@ -259,7 +257,7 @@ Lemma minus_sum :
     sum_f_R0 (fun i:nat => An i - Bn i) N = sum_f_R0 An N - sum_f_R0 Bn N.
 Proof.
   intros; induction  N as [| N HrecN].
-  simpl in |- *; ring.
+  simpl; ring.
   do 3 rewrite tech5; rewrite HrecN; ring.
 Qed.
 
@@ -270,7 +268,7 @@ Lemma sum_decomposition :
 Proof.
   intros.
   induction  N as [| N HrecN].
-  simpl in |- *; ring.
+  simpl; ring.
   rewrite tech5.
   rewrite (tech5 (fun l:nat => An (S (2 * l))) N).
   replace (2 * S (S N))%nat with (S (S (2 * S N))).
@@ -288,7 +286,7 @@ Lemma sum_Rle :
 Proof.
   intros.
   induction  N as [| N HrecN].
-  simpl in |- *; apply H.
+  simpl; apply H.
   apply le_n.
   do 2 rewrite tech5.
   apply Rle_trans with (sum_f_R0 An N + Bn (S N)).
@@ -308,7 +306,7 @@ Lemma Rsum_abs :
 Proof.
   intros.
   induction  N as [| N HrecN].
-  simpl in |- *.
+  simpl.
   right; reflexivity.
   do 2 rewrite tech5.
   apply Rle_trans with (Rabs (sum_f_R0 An N) + Rabs (An (S N))).
@@ -323,7 +321,7 @@ Lemma sum_cte :
 Proof.
   intros.
   induction  N as [| N HrecN].
-  simpl in |- *; ring.
+  simpl; ring.
   rewrite tech5.
   rewrite HrecN; repeat rewrite S_INR; ring.
 Qed.
@@ -335,7 +333,7 @@ Lemma sum_growing :
 Proof.
   intros.
   induction  N as [| N HrecN].
-  simpl in |- *; apply H.
+  simpl; apply H.
   do 2 rewrite tech5.
   apply Rle_trans with (sum_f_R0 An N + Bn (S N)).
   apply Rplus_le_compat_l; apply H.
@@ -350,7 +348,7 @@ Lemma Rabs_triang_gen :
 Proof.
   intros.
   induction  N as [| N HrecN].
-  simpl in |- *.
+  simpl.
   right; reflexivity.
   do 2 rewrite tech5.
   apply Rle_trans with (Rabs (sum_f_R0 An N) + Rabs (An (S N))).
@@ -366,7 +364,7 @@ Lemma cond_pos_sum :
 Proof.
   intros.
   induction  N as [| N HrecN].
-  simpl in |- *; apply H.
+  simpl; apply H.
   rewrite tech5.
   apply Rplus_le_le_0_compat.
   apply HrecN.
@@ -382,7 +380,7 @@ Lemma cauchy_abs :
   forall An:nat -> R,
     Cauchy_crit_series (fun i:nat => Rabs (An i)) -> Cauchy_crit_series An.
 Proof.
-  unfold Cauchy_crit_series in |- *; unfold Cauchy_crit in |- *.
+  unfold Cauchy_crit_series; unfold Cauchy_crit.
   intros.
   elim (H eps H0); intros.
   exists x.
@@ -402,8 +400,8 @@ Proof.
   elim a; intro.
   rewrite (tech2 An n m); [ idtac | assumption ].
   rewrite (tech2 (fun i:nat => Rabs (An i)) n m); [ idtac | assumption ].
-  unfold R_dist in |- *.
-  unfold Rminus in |- *.
+  unfold R_dist.
+  unfold Rminus.
   do 2 rewrite Ropp_plus_distr.
   do 2 rewrite <- Rplus_assoc.
   do 2 rewrite Rplus_opp_r.
@@ -416,18 +414,18 @@ Proof.
   replace (fun i:nat => Rabs (An (S n + i)%nat)) with
   (fun i:nat => Rabs (Bn i)).
   apply Rabs_triang_gen.
-  unfold Bn in |- *; reflexivity.
+  unfold Bn; reflexivity.
   apply Rle_ge.
   apply cond_pos_sum.
   intro; apply Rabs_pos.
   rewrite b.
-  unfold R_dist in |- *.
-  unfold Rminus in |- *; do 2 rewrite Rplus_opp_r.
+  unfold R_dist.
+  unfold Rminus; do 2 rewrite Rplus_opp_r.
   rewrite Rabs_R0; right; reflexivity.
   rewrite (tech2 An m n); [ idtac | assumption ].
   rewrite (tech2 (fun i:nat => Rabs (An i)) m n); [ idtac | assumption ].
-  unfold R_dist in |- *.
-  unfold Rminus in |- *.
+  unfold R_dist.
+  unfold Rminus.
   do 2 rewrite Rplus_assoc.
   rewrite (Rplus_comm (sum_f_R0 An m)).
   rewrite (Rplus_comm (sum_f_R0 (fun i:nat => Rabs (An i)) m)).
@@ -441,7 +439,7 @@ Proof.
   replace (fun i:nat => Rabs (An (S m + i)%nat)) with
   (fun i:nat => Rabs (Bn i)).
   apply Rabs_triang_gen.
-  unfold Bn in |- *; reflexivity.
+  unfold Bn; reflexivity.
   apply Rle_ge.
   apply cond_pos_sum.
   intro; apply Rabs_pos.
@@ -456,7 +454,7 @@ Proof.
   intros An X.
   elim X; intros.
   unfold Un_cv in p.
-  unfold Cauchy_crit_series in |- *; unfold Cauchy_crit in |- *.
+  unfold Cauchy_crit_series; unfold Cauchy_crit.
   intros.
   cut (0 < eps / 2).
   intro.
@@ -464,7 +462,7 @@ Proof.
   exists x0.
   intros.
   apply Rle_lt_trans with (R_dist (sum_f_R0 An n) x + R_dist (sum_f_R0 An m) x).
-  unfold R_dist in |- *.
+  unfold R_dist.
   replace (sum_f_R0 An n - sum_f_R0 An m) with
   (sum_f_R0 An n - x + - (sum_f_R0 An m - x)); [ idtac | ring ].
   rewrite <- (Rabs_Ropp (sum_f_R0 An m - x)).
@@ -473,8 +471,8 @@ Proof.
   apply Rplus_lt_compat.
   apply H1; assumption.
   apply H1; assumption.
-  right; symmetry  in |- *; apply double_var.
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+  right; symmetry ; apply double_var.
+  unfold Rdiv; apply Rmult_lt_0_compat;
     [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
 Qed.
 
@@ -495,7 +493,7 @@ Lemma sum_eq_R0 :
     (forall n:nat, (n <= N)%nat -> An n = 0) -> sum_f_R0 An N = 0.
 Proof.
   intros; induction  N as [| N HrecN].
-  simpl in |- *; apply H; apply le_n.
+  simpl; apply H; apply le_n.
   rewrite tech5; rewrite HrecN;
     [ rewrite Rplus_0_l; apply H; apply le_n
       | intros; apply H; apply le_trans with N; [ assumption | apply le_n_Sn ] ].
@@ -532,15 +530,15 @@ Proof.
     [ idtac | ring ]; apply Rle_trans with l1.
   left; apply r.
   apply H6.
-  unfold l1 in |- *; apply Rge_le;
+  unfold l1; apply Rge_le;
     apply (growing_prop (fun k:nat => sum_f_R0 An k)).
   apply H1.
-  unfold ge, N0 in |- *; apply le_max_r.
-  unfold ge, N0 in |- *; apply le_max_l.
+  unfold ge, N0; apply le_max_r.
+  unfold ge, N0; apply le_max_l.
   apply Rplus_lt_reg_r with l; rewrite Rplus_0_r;
     replace (l + (l1 - l)) with l1; [ apply r | ring ].
-  unfold Un_growing in |- *; intro; simpl in |- *;
-    pattern (sum_f_R0 An n) at 1 in |- *; rewrite <- Rplus_0_r;
+  unfold Un_growing; intro; simpl;
+    pattern (sum_f_R0 An n) at 1; rewrite <- Rplus_0_r;
       apply Rplus_le_compat_l; apply H0.
 Qed.
 
@@ -574,7 +572,7 @@ Proof.
   apply Rlt_trans with (Rabs l1).
   apply Rmult_lt_reg_l with 2.
   prove_sup0.
-  unfold Rdiv in |- *; rewrite (Rmult_comm 2); rewrite Rmult_assoc;
+  unfold Rdiv; rewrite (Rmult_comm 2); rewrite Rmult_assoc;
     rewrite <- Rinv_l_sym.
   rewrite Rmult_1_r; rewrite double; apply Rplus_lt_compat_l; apply r.
   discrR.
@@ -583,18 +581,18 @@ Proof.
   apply Rplus_lt_reg_r with ((Rabs l1 - l2) / 2 - Rabs (SP fn N x)).
   replace ((Rabs l1 - l2) / 2 - Rabs (SP fn N x) + (Rabs l1 + l2) / 2) with
   (Rabs l1 - Rabs (SP fn N x)).
-  unfold Rminus in |- *; rewrite Rplus_assoc; rewrite Rplus_opp_l;
+  unfold Rminus; rewrite Rplus_assoc; rewrite Rplus_opp_l;
     rewrite Rplus_0_r; apply H7.
-  unfold Rdiv in |- *; rewrite Rmult_plus_distr_r;
+  unfold Rdiv; rewrite Rmult_plus_distr_r;
     rewrite <- (Rmult_comm (/ 2)); rewrite Rmult_minus_distr_l;
-      repeat rewrite (Rmult_comm (/ 2)); pattern (Rabs l1) at 1 in |- *;
-        rewrite double_var; unfold Rdiv in |- *; ring.
+      repeat rewrite (Rmult_comm (/ 2)); pattern (Rabs l1) at 1;
+        rewrite double_var; unfold Rdiv; ring.
   case (Rcase_abs (sum_f_R0 An N - l2)); intro.
   apply Rlt_trans with l2.
   apply (Rminus_lt _ _ r0).
   apply Rmult_lt_reg_l with 2.
   prove_sup0.
-  rewrite (double l2); unfold Rdiv in |- *; rewrite (Rmult_comm 2);
+  rewrite (double l2); unfold Rdiv; rewrite (Rmult_comm 2);
     rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
   rewrite Rmult_1_r; rewrite (Rplus_comm (Rabs l1)); apply Rplus_lt_compat_l;
     apply r.
@@ -602,23 +600,23 @@ Proof.
   rewrite (Rabs_right _ r0) in H6; apply Rplus_lt_reg_r with (- l2).
   replace (- l2 + (Rabs l1 + l2) / 2) with ((Rabs l1 - l2) / 2).
   rewrite Rplus_comm; apply H6.
-  unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2));
+  unfold Rdiv; rewrite <- (Rmult_comm (/ 2));
     rewrite Rmult_minus_distr_l; rewrite Rmult_plus_distr_r;
-      pattern l2 at 2 in |- *; rewrite double_var;
+      pattern l2 at 2; rewrite double_var;
         repeat rewrite (Rmult_comm (/ 2)); rewrite Ropp_plus_distr;
-          unfold Rdiv in |- *; ring.
+          unfold Rdiv; ring.
   apply Rle_lt_trans with (Rabs (SP fn N x - l1)).
   rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr'; apply Rabs_triang_inv2.
-  apply H4; unfold ge, N in |- *; apply le_max_l.
-  apply H5; unfold ge, N in |- *; apply le_max_r.
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+  apply H4; unfold ge, N; apply le_max_l.
+  apply H5; unfold ge, N; apply le_max_r.
+  unfold Rdiv; apply Rmult_lt_0_compat.
   apply Rplus_lt_reg_r with l2.
   rewrite Rplus_0_r; replace (l2 + (Rabs l1 - l2)) with (Rabs l1);
     [ apply r | ring ].
   apply Rinv_0_lt_compat; prove_sup0.
   intros; induction  n0 as [| n0 Hrecn0].
-  unfold SP in |- *; simpl in |- *; apply H1.
-  unfold SP in |- *; simpl in |- *.
+  unfold SP; simpl; apply H1.
+  unfold SP; simpl.
   apply Rle_trans with
     (Rabs (sum_f_R0 (fun k:nat => fn k x) n0) + Rabs (fn (S n0) x)).
   apply Rabs_triang.
diff --git a/theories/Reals/RIneq.v b/theories/Reals/RIneq.v
index f02db3d4..5fc7d8fb 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-2012     *)
 (*   \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        *)
 (*********************************************************)
@@ -54,13 +52,13 @@ Proof. exact Rlt_irrefl. Qed.
 
 Lemma Rlt_not_eq : forall r1 r2, r1 < r2 -> r1 <> r2.
 Proof.
-  red in |- *; intros r1 r2 H H0; apply (Rlt_irrefl r1).
-  pattern r1 at 2 in |- *; rewrite H0; trivial.
+  red; intros r1 r2 H H0; apply (Rlt_irrefl r1).
+  pattern r1 at 2; rewrite H0; trivial.
 Qed.
 
 Lemma Rgt_not_eq : forall r1 r2, r1 > r2 -> r1 <> r2.
 Proof.
-  intros; apply sym_not_eq; apply Rlt_not_eq; auto with real.
+  intros; apply not_eq_sym; apply Rlt_not_eq; auto with real.
 Qed.
 
 (**********)
@@ -104,7 +102,7 @@ Qed.
 
 Lemma Rlt_le : forall r1 r2, r1 < r2 -> r1 <= r2.
 Proof.
-  intros; red in |- *; tauto.
+  intros; red; tauto.
 Qed.
 Hint Resolve Rlt_le: real.
 
@@ -116,14 +114,14 @@ Qed.
 (**********)
 Lemma Rle_ge : forall r1 r2, r1 <= r2 -> r2 >= r1.
 Proof.
-  destruct 1; red in |- *; auto with real.
+  destruct 1; red; auto with real.
 Qed.
 Hint Immediate Rle_ge: real.
 Hint Resolve Rle_ge: rorders.
 
 Lemma Rge_le : forall r1 r2, r1 >= r2 -> r2 <= r1.
 Proof.
-  destruct 1; red in |- *; auto with real.
+  destruct 1; red; auto with real.
 Qed.
 Hint Resolve Rge_le: real.
 Hint Immediate Rge_le: rorders.
@@ -145,7 +143,7 @@ Hint Immediate Rgt_lt: rorders.
 
 Lemma Rnot_le_lt : forall r1 r2, ~ r1 <= r2 -> r2 < r1.
 Proof.
-  intros r1 r2; generalize (Rtotal_order r1 r2); unfold Rle in |- *; tauto.
+  intros r1 r2; generalize (Rtotal_order r1 r2); unfold Rle; tauto.
 Qed.
 Hint Immediate Rnot_le_lt: real.
 
@@ -176,7 +174,7 @@ Proof. eauto using Rnot_gt_ge with rorders. Qed.
 (**********)
 Lemma Rlt_not_le : forall r1 r2, r2 < r1 -> ~ r1 <= r2.
 Proof.
-  generalize Rlt_asym Rlt_dichotomy_converse; unfold Rle in |- *.
+  generalize Rlt_asym Rlt_dichotomy_converse; unfold Rle.
   intuition eauto 3.
 Qed.
 Hint Immediate Rlt_not_le: real.
@@ -194,7 +192,7 @@ Proof. exact Rlt_not_ge. Qed.
 Lemma Rle_not_lt : forall r1 r2, r2 <= r1 -> ~ r1 < r2.
 Proof.
   intros r1 r2. generalize (Rlt_asym r1 r2) (Rlt_dichotomy_converse r1 r2).
-  unfold Rle in |- *; intuition.
+  unfold Rle; intuition.
 Qed.
 
 Lemma Rge_not_lt : forall r1 r2, r1 >= r2 -> ~ r1 < r2.
@@ -209,25 +207,25 @@ Proof. do 2 intro; apply Rge_not_lt. Qed.
 (**********)
 Lemma Req_le : forall r1 r2, r1 = r2 -> r1 <= r2.
 Proof.
-  unfold Rle in |- *; tauto.
+  unfold Rle; tauto.
 Qed.
 Hint Immediate Req_le: real.
 
 Lemma Req_ge : forall r1 r2, r1 = r2 -> r1 >= r2.
 Proof.
-  unfold Rge in |- *; tauto.
+  unfold Rge; tauto.
 Qed.
 Hint Immediate Req_ge: real.
 
 Lemma Req_le_sym : forall r1 r2, r2 = r1 -> r1 <= r2.
 Proof.
-  unfold Rle in |- *; auto.
+  unfold Rle; auto.
 Qed.
 Hint Immediate Req_le_sym: real.
 
 Lemma Req_ge_sym : forall r1 r2, r2 = r1 -> r1 >= r2.
 Proof.
-  unfold Rge in |- *; auto.
+  unfold Rge; auto.
 Qed.
 Hint Immediate Req_ge_sym: real.
 
@@ -242,7 +240,7 @@ Proof. do 2 intro; apply Rlt_asym. Qed.
 
 Lemma Rle_antisym : forall r1 r2, r1 <= r2 -> r2 <= r1 -> r1 = r2.
 Proof.
-  intros r1 r2; generalize (Rlt_asym r1 r2); unfold Rle in |- *; intuition.
+  intros r1 r2; generalize (Rlt_asym r1 r2); unfold Rle; intuition.
 Qed.
 Hint Resolve Rle_antisym: real.
 
@@ -278,8 +276,8 @@ Proof. intros; red; apply Rlt_eq_compat with (r2:=r4) (r4:=r2); auto. Qed.
 
 Lemma Rle_trans : forall r1 r2 r3, r1 <= r2 -> r2 <= r3 -> r1 <= r3.
 Proof.
-  generalize trans_eq Rlt_trans Rlt_eq_compat.
-  unfold Rle in |- *.
+  generalize eq_trans Rlt_trans Rlt_eq_compat.
+  unfold Rle.
   intuition eauto 2.
 Qed.
 
@@ -293,13 +291,13 @@ Proof. eauto using Rlt_trans with rorders. Qed.
 Lemma Rle_lt_trans : forall r1 r2 r3, r1 <= r2 -> r2 < r3 -> r1 < r3.
 Proof.
   generalize Rlt_trans Rlt_eq_compat.
-  unfold Rle in |- *.
+  unfold Rle.
   intuition eauto 2.
 Qed.
 
 Lemma Rlt_le_trans : forall r1 r2 r3, r1 < r2 -> r2 <= r3 -> r1 < r3.
 Proof.
-  generalize Rlt_trans Rlt_eq_compat; unfold Rle in |- *; intuition eauto 2.
+  generalize Rlt_trans Rlt_eq_compat; unfold Rle; intuition eauto 2.
 Qed.
 
 Lemma Rge_gt_trans : forall r1 r2 r3, r1 >= r2 -> r2 > r3 -> r1 > r3.
@@ -432,7 +430,7 @@ Hint Resolve Rplus_eq_reg_l: real.
 (**********)
 Lemma Rplus_0_r_uniq : forall r r1, r + r1 = r -> r1 = 0.
 Proof.
-  intros r b; pattern r at 2 in |- *; replace r with (r + 0); eauto with real.
+  intros r b; pattern r at 2; replace r with (r + 0); eauto with real.
 Qed.
 
 (***********)
@@ -443,7 +441,7 @@ Proof.
     absurd (0 < a + b).
       rewrite H1; auto with real.
       apply Rle_lt_trans with (a + 0).
-        rewrite Rplus_0_r in |- *; assumption.
+        rewrite Rplus_0_r; assumption.
         auto using Rplus_lt_compat_l with real.
     rewrite <- H0, Rplus_0_r in H1; assumption.
 Qed.
@@ -572,14 +570,14 @@ Qed.
 (**********)
 Lemma Rmult_neq_0_reg : forall r1 r2, r1 * r2 <> 0 -> r1 <> 0 /\ r2 <> 0.
 Proof.
-  intros r1 r2 H; split; red in |- *; intro; apply H; auto with real.
+  intros r1 r2 H; split; red; intro; apply H; auto with real.
 Qed.
 
 (**********)
 Lemma Rmult_integral_contrapositive :
   forall r1 r2, r1 <> 0 /\ r2 <> 0 -> r1 * r2 <> 0.
 Proof.
-  red in |- *; intros r1 r2 [H1 H2] H.
+  red; intros r1 r2 [H1 H2] H.
   case (Rmult_integral r1 r2); auto with real.
 Qed.
 Hint Resolve Rmult_integral_contrapositive: real.
@@ -606,12 +604,12 @@ Notation "r ²" := (Rsqr r) (at level 1, format "r ²") : R_scope.
 
 (***********)
 Lemma Rsqr_0 : Rsqr 0 = 0.
-  unfold Rsqr in |- *; auto with real.
+  unfold Rsqr; auto with real.
 Qed.
 
 (***********)
 Lemma Rsqr_0_uniq : forall r, Rsqr r = 0 -> r = 0.
-  unfold Rsqr in |- *; intros; elim (Rmult_integral r r H); trivial.
+  unfold Rsqr; intros; elim (Rmult_integral r r H); trivial.
 Qed.
 
 (*********************************************************)
@@ -649,7 +647,7 @@ Hint Resolve Ropp_involutive: real.
 (*********)
 Lemma Ropp_neq_0_compat : forall r, r <> 0 -> - r <> 0.
 Proof.
-  red in |- *; intros r H H0.
+  red; intros r H H0.
   apply H.
   transitivity (- - r); auto with real.
 Qed.
@@ -722,7 +720,7 @@ Hint Resolve Rminus_diag_eq: real.
 (**********)
 Lemma Rminus_diag_uniq : forall r1 r2, r1 - r2 = 0 -> r1 = r2.
 Proof.
-  intros r1 r2; unfold Rminus in |- *; rewrite Rplus_comm; intro.
+  intros r1 r2; unfold Rminus; rewrite Rplus_comm; intro.
   rewrite <- (Ropp_involutive r2); apply (Rplus_opp_r_uniq (- r2) r1 H).
 Qed.
 Hint Immediate Rminus_diag_uniq: real.
@@ -743,20 +741,20 @@ Hint Resolve Rplus_minus: real.
 (**********)
 Lemma Rminus_eq_contra : forall r1 r2, r1 <> r2 -> r1 - r2 <> 0.
 Proof.
-  red in |- *; intros r1 r2 H H0.
+  red; intros r1 r2 H H0.
   apply H; auto with real.
 Qed.
 Hint Resolve Rminus_eq_contra: real.
 
 Lemma Rminus_not_eq : forall r1 r2, r1 - r2 <> 0 -> r1 <> r2.
 Proof.
-  red in |- *; intros; elim H; apply Rminus_diag_eq; auto.
+  red; intros; elim H; apply Rminus_diag_eq; auto.
 Qed.
 Hint Resolve Rminus_not_eq: real.
 
 Lemma Rminus_not_eq_right : forall r1 r2, r2 - r1 <> 0 -> r1 <> r2.
 Proof.
-  red in |- *; intros; elim H; rewrite H0; ring.
+  red; intros; elim H; rewrite H0; ring.
 Qed.
 Hint Resolve Rminus_not_eq_right: real.
 
@@ -780,7 +778,7 @@ Hint Resolve Rinv_1: real.
 (*********)
 Lemma Rinv_neq_0_compat : forall r, r <> 0 -> / r <> 0.
 Proof.
-  red in |- *; intros; apply R1_neq_R0.
+  red; intros; apply R1_neq_R0.
   replace 1 with (/ r * r); auto with real.
 Qed.
 Hint Resolve Rinv_neq_0_compat: real.
@@ -860,7 +858,7 @@ Proof. do 3 intro; apply Rplus_lt_compat_r. Qed.
 (**********)
 Lemma Rplus_le_compat_l : forall r r1 r2, r1 <= r2 -> r + r1 <= r + r2.
 Proof.
-  unfold Rle in |- *; intros; elim H; intro.
+  unfold Rle; intros; elim H; intro.
   left; apply (Rplus_lt_compat_l r r1 r2 H0).
   right; rewrite <- H0; auto with zarith real.
 Qed.
@@ -872,7 +870,7 @@ Hint Resolve Rplus_ge_compat_l: real.
 (**********)
 Lemma Rplus_le_compat_r : forall r r1 r2, r1 <= r2 -> r1 + r <= r2 + r.
 Proof.
-  unfold Rle in |- *; intros; elim H; intro.
+  unfold Rle; intros; elim H; intro.
   left; apply (Rplus_lt_compat_r r r1 r2 H0).
   right; rewrite <- H0; auto with real.
 Qed.
@@ -933,7 +931,7 @@ Lemma Rplus_lt_0_compat : forall r1 r2, 0 < r1 -> 0 < r2 -> 0 < r1 + r2.
 Proof.
   intros x y; intros; apply Rlt_trans with x;
     [ assumption
-      | pattern x at 1 in |- *; rewrite <- (Rplus_0_r x); apply Rplus_lt_compat_l;
+      | pattern x at 1; rewrite <- (Rplus_0_r x); apply Rplus_lt_compat_l;
         assumption ].
 Qed.
 
@@ -941,7 +939,7 @@ Lemma Rplus_le_lt_0_compat : forall r1 r2, 0 <= r1 -> 0 < r2 -> 0 < r1 + r2.
 Proof.
   intros x y; intros; apply Rle_lt_trans with x;
     [ assumption
-      | pattern x at 1 in |- *; rewrite <- (Rplus_0_r x); apply Rplus_lt_compat_l;
+      | pattern x at 1; rewrite <- (Rplus_0_r x); apply Rplus_lt_compat_l;
         assumption ].
 Qed.
 
@@ -955,7 +953,7 @@ Lemma Rplus_le_le_0_compat : forall r1 r2, 0 <= r1 -> 0 <= r2 -> 0 <= r1 + r2.
 Proof.
   intros x y; intros; apply Rle_trans with x;
     [ assumption
-      | pattern x at 1 in |- *; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l;
+      | pattern x at 1; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l;
         assumption ].
 Qed.
 
@@ -983,7 +981,7 @@ Qed.
 
 Lemma Rplus_le_reg_l : forall r r1 r2, r + r1 <= r + r2 -> r1 <= r2.
 Proof.
-  unfold Rle in |- *; intros; elim H; intro.
+  unfold Rle; intros; elim H; intro.
   left; apply (Rplus_lt_reg_r r r1 r2 H0).
   right; apply (Rplus_eq_reg_l r r1 r2 H0).
 Qed.
@@ -997,7 +995,7 @@ Qed.
 
 Lemma Rplus_gt_reg_l : forall r r1 r2, r + r1 > r + r2 -> r1 > r2.
 Proof.
-  unfold Rgt in |- *; intros; apply (Rplus_lt_reg_r r r2 r1 H).
+  unfold Rgt; intros; apply (Rplus_lt_reg_r r r2 r1 H).
 Qed.
 
 Lemma Rplus_ge_reg_l : forall r r1 r2, r + r1 >= r + r2 -> r1 >= r2.
@@ -1048,7 +1046,7 @@ Qed.
 
 Lemma Ropp_gt_lt_contravar : forall r1 r2, r1 > r2 -> - r1 < - r2.
 Proof.
-  unfold Rgt in |- *; intros.
+  unfold Rgt; intros.
   apply (Rplus_lt_reg_r (r2 + r1)).
   replace (r2 + r1 + - r1) with r2.
   replace (r2 + r1 + - r2) with r1.
@@ -1060,7 +1058,7 @@ Hint Resolve Ropp_gt_lt_contravar.
 
 Lemma Ropp_lt_gt_contravar : forall r1 r2, r1 < r2 -> - r1 > - r2.
 Proof.
-  unfold Rgt in |- *; auto with real.
+  unfold Rgt; auto with real.
 Qed.
 Hint Resolve Ropp_lt_gt_contravar: real.
 
@@ -1185,7 +1183,7 @@ Proof. eauto using Rmult_lt_compat_l with rorders. Qed.
 Lemma Rmult_le_compat_l :
   forall r r1 r2, 0 <= r -> r1 <= r2 -> r * r1 <= r * r2.
 Proof.
-  intros r r1 r2 H H0; destruct H; destruct H0; unfold Rle in |- *;
+  intros r r1 r2 H H0; destruct H; destruct H0; unfold Rle;
     auto with real.
   right; rewrite <- H; do 2 rewrite Rmult_0_l; reflexivity.
 Qed.
@@ -1344,7 +1342,7 @@ Qed.
 (**********)
 Lemma Rle_minus : forall r1 r2, r1 <= r2 -> r1 - r2 <= 0.
 Proof.
-  destruct 1; unfold Rle in |- *; auto with real.
+  destruct 1; unfold Rle; auto with real.
 Qed.
 
 Lemma Rge_minus : forall r1 r2, r1 >= r2 -> r1 - r2 >= 0.
@@ -1358,7 +1356,7 @@ Qed.
 Lemma Rminus_lt : forall r1 r2, r1 - r2 < 0 -> r1 < r2.
 Proof.
   intros; replace r1 with (r1 - r2 + r2).
-  pattern r2 at 3 in |- *; replace r2 with (0 + r2); auto with real.
+  pattern r2 at 3; replace r2 with (0 + r2); auto with real.
   ring.
 Qed.
 
@@ -1374,7 +1372,7 @@ Qed.
 Lemma Rminus_le : forall r1 r2, r1 - r2 <= 0 -> r1 <= r2.
 Proof.
   intros; replace r1 with (r1 - r2 + r2).
-  pattern r2 at 3 in |- *; replace r2 with (0 + r2); auto with real.
+  pattern r2 at 3; replace r2 with (0 + r2); auto with real.
   ring.
 Qed.
 
@@ -1389,7 +1387,7 @@ Qed.
 (**********)
 Lemma tech_Rplus : forall r (s:R), 0 <= r -> 0 < s -> r + s <> 0.
 Proof.
-  intros; apply sym_not_eq; apply Rlt_not_eq.
+  intros; apply not_eq_sym; apply Rlt_not_eq.
   rewrite Rplus_comm; replace 0 with (0 + 0); auto with real.
 Qed.
 Hint Immediate tech_Rplus: real.
@@ -1400,7 +1398,7 @@ Hint Immediate tech_Rplus: real.
 
 Lemma Rle_0_sqr : forall r, 0 <= Rsqr r.
 Proof.
-  intro; case (Rlt_le_dec r 0); unfold Rsqr in |- *; intro.
+  intro; case (Rlt_le_dec r 0); unfold Rsqr; intro.
   replace (r * r) with (- r * - r); auto with real.
   replace 0 with (- r * 0); auto with real.
   replace 0 with (0 * r); auto with real.
@@ -1409,7 +1407,7 @@ Qed.
 (***********)
 Lemma Rlt_0_sqr : forall r, r <> 0 -> 0 < Rsqr r.
 Proof.
-  intros; case (Rdichotomy r 0); trivial; unfold Rsqr in |- *; intro.
+  intros; case (Rdichotomy r 0); trivial; unfold Rsqr; intro.
   replace (r * r) with (- r * - r); auto with real.
   replace 0 with (- r * 0); auto with real.
   replace 0 with (0 * r); auto with real.
@@ -1439,7 +1437,7 @@ Qed.
 Lemma Rlt_0_1 : 0 < 1.
 Proof.
   replace 1 with (Rsqr 1); auto with real.
-  unfold Rsqr in |- *; auto with real.
+  unfold Rsqr; auto with real.
 Qed.
 Hint Resolve Rlt_0_1: real.
 
@@ -1455,7 +1453,7 @@ Qed.
 
 Lemma Rinv_0_lt_compat : forall r, 0 < r -> 0 < / r.
 Proof.
-  intros; apply Rnot_le_lt; red in |- *; intros.
+  intros; apply Rnot_le_lt; red; intros.
   absurd (1 <= 0); auto with real.
   replace 1 with (r * / r); auto with real.
   replace 0 with (r * 0); auto with real.
@@ -1465,7 +1463,7 @@ Hint Resolve Rinv_0_lt_compat: real.
 (*********)
 Lemma Rinv_lt_0_compat : forall r, r < 0 -> / r < 0.
 Proof.
-  intros; apply Rnot_le_lt; red in |- *; intros.
+  intros; apply Rnot_le_lt; red; intros.
   absurd (1 <= 0); auto with real.
   replace 1 with (r * / r); auto with real.
   replace 0 with (r * 0); auto with real.
@@ -1479,8 +1477,8 @@ Proof.
   case (Rmult_neq_0_reg r1 r2); intros; auto with real.
   replace (r1 * r2 * / r2) with r1.
   replace (r1 * r2 * / r1) with r2; trivial.
-  symmetry  in |- *; auto with real.
-  symmetry  in |- *; auto with real.
+  symmetry ; auto with real.
+  symmetry ; auto with real.
 Qed.
 
 Lemma Rinv_1_lt_contravar : forall r1 r2, 1 <= r1 -> r1 < r2 -> / r2 < / r1.
@@ -1497,7 +1495,7 @@ Proof.
   rewrite (Rmult_comm x); rewrite <- Rmult_assoc; rewrite (Rmult_comm y (/ y));
     rewrite Rinv_l; auto with real.
   apply Rlt_dichotomy_converse; right.
-  red in |- *; apply Rlt_trans with (r2 := x); auto with real.
+  red; apply Rlt_trans with (r2 := x); auto with real.
 Qed.
 Hint Resolve Rinv_1_lt_contravar: real.
 
@@ -1510,7 +1508,7 @@ Lemma Rle_lt_0_plus_1 : forall r, 0 <= r -> 0 < r + 1.
 Proof.
   intros.
   apply Rlt_le_trans with 1; auto with real.
-  pattern 1 at 1 in |- *; replace 1 with (0 + 1); auto with real.
+  pattern 1 at 1; replace 1 with (0 + 1); auto with real.
 Qed.
 Hint Resolve Rle_lt_0_plus_1: real.
 
@@ -1518,15 +1516,15 @@ Hint Resolve Rle_lt_0_plus_1: real.
 Lemma Rlt_plus_1 : forall r, r < r + 1.
 Proof.
   intros.
-  pattern r at 1 in |- *; replace r with (r + 0); auto with real.
+  pattern r at 1; replace r with (r + 0); auto with real.
 Qed.
 Hint Resolve Rlt_plus_1: real.
 
 (**********)
 Lemma tech_Rgt_minus : forall r1 r2, 0 < r2 -> r1 > r1 - r2.
 Proof.
-  red in |- *; unfold Rminus in |- *; intros.
-  pattern r1 at 2 in |- *; replace r1 with (r1 + 0); auto with real.
+  red; unfold Rminus; intros.
+  pattern r1 at 2; replace r1 with (r1 + 0); auto with real.
 Qed.
 
 (*********************************************************)
@@ -1542,14 +1540,14 @@ Qed.
 (**********)
 Lemma S_O_plus_INR : forall n:nat, INR (1 + n) = INR 1 + INR n.
 Proof.
-  intro; simpl in |- *; case n; intros; auto with real.
+  intro; simpl; case n; intros; auto with real.
 Qed.
 
 (**********)
 Lemma plus_INR : forall n m:nat, INR (n + m) = INR n + INR m.
 Proof.
   intros n m; induction  n as [| n Hrecn].
-  simpl in |- *; auto with real.
+  simpl; auto with real.
   replace (S n + m)%nat with (S (n + m)); auto with arith.
   repeat rewrite S_INR.
   rewrite Hrecn; ring.
@@ -1559,9 +1557,9 @@ Hint Resolve plus_INR: real.
 (**********)
 Lemma minus_INR : forall n m:nat, (m <= n)%nat -> INR (n - m) = INR n - INR m.
 Proof.
-  intros n m le; pattern m, n in |- *; apply le_elim_rel; auto with real.
+  intros n m le; pattern m, n; apply le_elim_rel; auto with real.
   intros; rewrite <- minus_n_O; auto with real.
-  intros; repeat rewrite S_INR; simpl in |- *.
+  intros; repeat rewrite S_INR; simpl.
   rewrite H0; ring.
 Qed.
 Hint Resolve minus_INR: real.
@@ -1570,8 +1568,8 @@ Hint Resolve minus_INR: real.
 Lemma mult_INR : forall n m:nat, INR (n * m) = INR n * INR m.
 Proof.
   intros n m; induction  n as [| n Hrecn].
-  simpl in |- *; auto with real.
-  intros; repeat rewrite S_INR; simpl in |- *.
+  simpl; auto with real.
+  intros; repeat rewrite S_INR; simpl.
   rewrite plus_INR; rewrite Hrecn; ring.
 Qed.
 Hint Resolve mult_INR: real.
@@ -1599,11 +1597,11 @@ Qed.
 Hint Resolve lt_1_INR: real.
 
 (**********)
-Lemma pos_INR_nat_of_P : forall p:positive, 0 < INR (nat_of_P p).
+Lemma pos_INR_nat_of_P : forall p:positive, 0 < INR (Pos.to_nat p).
 Proof.
   intro; apply lt_0_INR.
-  simpl in |- *; auto with real.
-  apply lt_O_nat_of_P.
+  simpl; auto with real.
+  apply Pos2Nat.is_pos.
 Qed.
 Hint Resolve pos_INR_nat_of_P: real.
 
@@ -1611,7 +1609,7 @@ Hint Resolve pos_INR_nat_of_P: real.
 Lemma pos_INR : forall n:nat, 0 <= INR n.
 Proof.
   intro n; case n.
-  simpl in |- *; auto with real.
+  simpl; auto with real.
   auto with arith real.
 Qed.
 Hint Resolve pos_INR: real.
@@ -1619,10 +1617,10 @@ Hint Resolve pos_INR: real.
 Lemma INR_lt : forall n m:nat, INR n < INR m -> (n < m)%nat.
 Proof.
   double induction n m; intros.
-  simpl in |- *; exfalso; apply (Rlt_irrefl 0); auto.
+  simpl; exfalso; apply (Rlt_irrefl 0); auto.
   auto with arith.
   generalize (pos_INR (S n0)); intro; cut (INR 0 = 0);
-    [ intro H2; rewrite H2 in H0; idtac | simpl in |- *; trivial ].
+    [ intro H2; rewrite H2 in H0; idtac | simpl; trivial ].
   generalize (Rle_lt_trans 0 (INR (S n0)) 0 H1 H0); intro; exfalso;
     apply (Rlt_irrefl 0); auto.
   do 2 rewrite S_INR in H1; cut (INR n1 < INR n0).
@@ -1644,7 +1642,7 @@ Hint Resolve le_INR: real.
 (**********)
 Lemma INR_not_0 : forall n:nat, INR n <> 0 -> n <> 0%nat.
 Proof.
-  red in |- *; intros n H H1.
+  red; intros n H H1.
   apply H.
   rewrite H1; trivial.
 Qed.
@@ -1656,7 +1654,7 @@ Proof.
   intro n; case n.
   intro; absurd (0%nat = 0%nat); trivial.
   intros; rewrite S_INR.
-  apply Rgt_not_eq; red in |- *; auto with real.
+  apply Rgt_not_eq; red; auto with real.
 Qed.
 Hint Resolve not_0_INR: real.
 
@@ -1666,7 +1664,7 @@ Proof.
   case (le_lt_or_eq _ _ H1); intros H2.
   apply Rlt_dichotomy_converse; auto with real.
   exfalso; auto.
-  apply sym_not_eq; apply Rlt_dichotomy_converse; auto with real.
+  apply not_eq_sym; apply Rlt_dichotomy_converse; auto with real.
 Qed.
 Hint Resolve not_INR: real.
 
@@ -1677,7 +1675,7 @@ Proof.
   cut (n <> m).
   intro H3; generalize (not_INR n m H3); intro H4; exfalso; auto.
   omega.
-  symmetry  in |- *; cut (m <> n).
+  symmetry ; cut (m <> n).
   intro H3; generalize (not_INR m n H3); intro H4; exfalso; auto.
   omega.
 Qed.
@@ -1703,92 +1701,86 @@ Hint Resolve not_1_INR: real.
 
 
 (**********)
-Lemma IZN : forall n:Z, (0 <= n)%Z ->  exists m : nat, n = Z_of_nat m.
+Lemma IZN : forall n:Z, (0 <= n)%Z ->  exists m : nat, n = Z.of_nat m.
 Proof.
   intros z; idtac; apply Z_of_nat_complete; assumption.
 Qed.
 
 (**********)
-Lemma INR_IZR_INZ : forall n:nat, INR n = IZR (Z_of_nat n).
+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; rewrite SuccNat2Pos.id_succ;
     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 Pos.compare_spec; intros H; simpl.
+  subst. ring.
+  rewrite Pos2Nat.inj_sub by trivial.
+  rewrite minus_INR by (now apply lt_le_weak, Pos2Nat.inj_lt).
+  ring.
+  rewrite Pos2Nat.inj_sub by trivial.
+  rewrite minus_INR by (now apply lt_le_weak, Pos2Nat.inj_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 Pos2Nat.inj_add; 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;
+  rewrite Z.add_comm; rewrite Rplus_comm; apply plus_IZR_NEG_POS.
+  simpl; intros; rewrite Pos2Nat.inj_add; rewrite plus_INR;
     auto with real.
 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 z t; case z; case t; simpl; auto with real.
+  intros t1 z1; rewrite Pos2Nat.inj_mul; auto with real.
+  intros t1 z1; rewrite Pos2Nat.inj_mul; 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 Pos2Nat.inj_mul; 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 Pos2Nat.inj_mul; auto with real.
   rewrite Rmult_opp_opp; auto with real.
 Qed.
 
-Lemma pow_IZR : forall z n, pow (IZR z) n = IZR (Zpower z (Z_of_nat n)).
+Lemma pow_IZR : forall z n, pow (IZR z) n = IZR (Z.pow 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 SuccNat2Pos.id_succ. unfold Zpower_nat;simpl.
  rewrite mult_IZR.
  induction n;simpl;trivial.
  rewrite mult_IZR;ring[IHn].
 Qed.
 
 (**********)
-Lemma succ_IZR : forall n:Z, IZR (Zsucc n) = IZR n + 1.
+Lemma succ_IZR : forall n:Z, IZR (Z.succ n) = IZR n + 1.
 Proof.
-  intro; change 1 with (IZR 1); unfold Zsucc; apply plus_IZR.
+  intro; change 1 with (IZR 1); unfold Z.succ; apply plus_IZR.
 Qed.
 
 (**********)
 Lemma opp_IZR : forall n:Z, IZR (- n) = - IZR n.
 Proof.
-  intro z; case z; simpl in |- *; auto with real.
+  intro z; case z; simpl; auto with real.
 Qed.
 
 Definition Ropp_Ropp_IZR := opp_IZR.
 
 Lemma minus_IZR : forall n m:Z, IZR (n - m) = IZR n - IZR m.
 Proof.
-  intros; unfold Zminus, Rminus.
+  intros; unfold Z.sub, Rminus.
   rewrite <- opp_IZR.
   apply plus_IZR.
 Qed.
@@ -1796,16 +1788,16 @@ Qed.
 (**********)
 Lemma Z_R_minus : forall n m:Z, IZR n - IZR m = IZR (n - m).
 Proof.
-  intros z1 z2; unfold Rminus in |- *; unfold Zminus in |- *.
-  rewrite <- (Ropp_Ropp_IZR z2); symmetry  in |- *; apply plus_IZR.
+  intros z1 z2; unfold Rminus; unfold Z.sub.
+  rewrite <- (Ropp_Ropp_IZR z2); symmetry ; apply plus_IZR.
 Qed.
 
 (**********)
 Lemma lt_0_IZR : forall n:Z, 0 < IZR n -> (0 < n)%Z.
 Proof.
-  intro z; case z; simpl in |- *; intros.
+  intro z; case z; simpl; intros.
   absurd (0 < 0); auto with real.
-  unfold Zlt in |- *; simpl in |- *; trivial.
+  unfold Z.lt; simpl; trivial.
   case Rlt_not_le with (1 := H).
   replace 0 with (-0); auto with real.
 Qed.
@@ -1813,7 +1805,7 @@ Qed.
 (**********)
 Lemma lt_IZR : forall n m:Z, IZR n < IZR m -> (n < m)%Z.
 Proof.
-  intros z1 z2 H; apply Zlt_0_minus_lt.
+  intros z1 z2 H; apply Z.lt_0_sub.
   apply lt_0_IZR.
   rewrite <- Z_R_minus.
   exact (Rgt_minus (IZR z2) (IZR z1) H).
@@ -1822,10 +1814,10 @@ Qed.
 (**********)
 Lemma eq_IZR_R0 : forall n:Z, IZR n = 0 -> n = 0%Z.
 Proof.
-  intro z; destruct z; simpl in |- *; intros; auto with zarith.
-  case (Rlt_not_eq 0 (INR (nat_of_P p))); auto with real.
-  case (Rlt_not_eq (- INR (nat_of_P p)) 0); auto with real.
-  apply Ropp_lt_gt_0_contravar. unfold Rgt in |- *; apply pos_INR_nat_of_P.
+  intro z; destruct z; simpl; intros; auto with zarith.
+  case (Rlt_not_eq 0 (INR (Pos.to_nat p))); auto with real.
+  case (Rlt_not_eq (- INR (Pos.to_nat p)) 0); auto with real.
+  apply Ropp_lt_gt_0_contravar. unfold Rgt; apply pos_INR_nat_of_P.
 Qed.
 
 (**********)
@@ -1839,23 +1831,23 @@ Qed.
 (**********)
 Lemma not_0_IZR : forall n:Z, n <> 0%Z -> IZR n <> 0.
 Proof.
-  intros z H; red in |- *; intros H0; case H.
+  intros z H; red; intros H0; case H.
   apply eq_IZR; auto.
 Qed.
 
 (*********)
 Lemma le_0_IZR : forall n:Z, 0 <= IZR n -> (0 <= n)%Z.
 Proof.
-  unfold Rle in |- *; intros z [H| H].
-  red in |- *; intro; apply (Zlt_le_weak 0 z (lt_0_IZR z H)); assumption.
+  unfold Rle; intros z [H| H].
+  red; intro; apply (Z.lt_le_incl 0 z (lt_0_IZR z H)); assumption.
   rewrite (eq_IZR_R0 z); auto with zarith real.
 Qed.
 
 (**********)
 Lemma le_IZR : forall n m:Z, IZR n <= IZR m -> (n <= m)%Z.
 Proof.
-  unfold Rle in |- *; intros z1 z2 [H| H].
-  apply (Zlt_le_weak z1 z2); auto with real.
+  unfold Rle; intros z1 z2 [H| H].
+  apply (Z.lt_le_incl z1 z2); auto with real.
   apply lt_IZR; trivial.
   rewrite (eq_IZR z1 z2); auto with zarith real.
 Qed.
@@ -1863,20 +1855,20 @@ Qed.
 (**********)
 Lemma le_IZR_R1 : forall n:Z, IZR n <= 1 -> (n <= 1)%Z.
 Proof.
-  pattern 1 at 1 in |- *; replace 1 with (IZR 1); intros; auto.
+  pattern 1 at 1; replace 1 with (IZR 1); intros; auto.
   apply le_IZR; trivial.
 Qed.
 
 (**********)
 Lemma IZR_ge : forall n m:Z, (n >= m)%Z -> IZR n >= IZR m.
 Proof.
-  intros m n H; apply Rnot_lt_ge; red in |- *; intro.
+  intros m n H; apply Rnot_lt_ge; red; intro.
   generalize (lt_IZR m n H0); intro; omega.
 Qed.
 
 Lemma IZR_le : forall n m:Z, (n <= m)%Z -> IZR n <= IZR m.
 Proof.
-  intros m n H; apply Rnot_gt_le; red in |- *; intro.
+  intros m n H; apply Rnot_gt_le; red; intro.
   unfold Rgt in H0; generalize (lt_IZR n m H0); intro; omega.
 Qed.
 
@@ -1891,10 +1883,10 @@ Qed.
 Lemma one_IZR_lt1 : forall n:Z, -1 < IZR n < 1 -> n = 0%Z.
 Proof.
   intros z [H1 H2].
-  apply Zle_antisym.
-  apply Zlt_succ_le; apply lt_IZR; trivial.
-  replace 0%Z with (Zsucc (-1)); trivial.
-  apply Zlt_le_succ; apply lt_IZR; trivial.
+  apply Z.le_antisymm.
+  apply Z.lt_succ_r; apply lt_IZR; trivial.
+  replace 0%Z with (Z.succ (-1)); trivial.
+  apply Z.le_succ_l; apply lt_IZR; trivial.
 Qed.
 
 Lemma one_IZR_r_R1 :
@@ -1905,10 +1897,10 @@ Proof.
   apply one_IZR_lt1.
   rewrite <- Z_R_minus; split.
   replace (-1) with (r - (r + 1)).
-  unfold Rminus in |- *; apply Rplus_lt_le_compat; auto with real.
+  unfold Rminus; apply Rplus_lt_le_compat; auto with real.
   ring.
   replace 1 with (r + 1 - r).
-  unfold Rminus in |- *; apply Rplus_le_lt_compat; auto with real.
+  unfold Rminus; apply Rplus_le_lt_compat; auto with real.
   ring.
 Qed.
 
@@ -1939,6 +1931,20 @@ Proof.
     apply (Rmult_le_compat_l x 0 y H H0).
 Qed.
 
+Lemma Rle_Rinv : forall x y:R, 0 < x -> 0 < y -> x <= y -> / y <= / x.
+Proof.
+  intros; apply Rmult_le_reg_l with x.
+  apply H.
+  rewrite <- Rinv_r_sym.
+  apply Rmult_le_reg_l with y.
+  apply H0.
+  rewrite Rmult_1_r; rewrite Rmult_comm; rewrite Rmult_assoc;
+    rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r; apply H1.
+  red; intro; rewrite H2 in H0; elim (Rlt_irrefl _ H0).
+  red; intro; rewrite H2 in H; elim (Rlt_irrefl _ H).
+Qed.
+
 Lemma double : forall r1, 2 * r1 = r1 + r1.
 Proof.
   intro; ring.
@@ -1946,10 +1952,10 @@ Qed.
 
 Lemma double_var : forall r1, r1 = r1 / 2 + r1 / 2.
 Proof.
-  intro; rewrite <- double; unfold Rdiv in |- *; rewrite <- Rmult_assoc;
-    symmetry  in |- *; apply Rinv_r_simpl_m.
+  intro; rewrite <- double; unfold Rdiv; rewrite <- Rmult_assoc;
+    symmetry ; apply Rinv_r_simpl_m.
   replace 2 with (INR 2);
-  [ apply not_0_INR; discriminate | unfold INR in |- *; ring ].
+  [ apply not_0_INR; discriminate | unfold INR; ring ].
 Qed.
 
 (*********************************************************)
@@ -1984,22 +1990,22 @@ Proof.
   rewrite (Rplus_comm y); intro H5; apply Rplus_le_reg_l with x; assumption.
   ring.
   replace 2 with (INR 2); [ apply not_0_INR; discriminate | reflexivity ].
-  pattern y at 2 in |- *; replace y with (y / 2 + y / 2).
-  unfold Rminus, Rdiv in |- *.
+  pattern y at 2; replace y with (y / 2 + y / 2).
+  unfold Rminus, Rdiv.
   repeat rewrite Rmult_plus_distr_r.
   ring.
   cut (forall z:R, 2 * z = z + z).
   intro.
   rewrite <- (H4 (y / 2)).
-  unfold Rdiv in |- *.
+  unfold Rdiv.
   rewrite <- Rmult_assoc; apply Rinv_r_simpl_m.
   replace 2 with (INR 2).
   apply not_0_INR.
   discriminate.
-  unfold INR in |- *; reflexivity.
+  unfold INR; reflexivity.
   intro; ring.
   cut (0%nat <> 2%nat);
-    [ intro H0; generalize (lt_0_INR 2 (neq_O_lt 2 H0)); unfold INR in |- *;
+    [ intro H0; generalize (lt_0_INR 2 (neq_O_lt 2 H0)); unfold INR;
       intro; assumption
       | discriminate ].
 Qed.
diff --git a/theories/Reals/RList.v b/theories/Reals/RList.v
index 4e4fb378..6d42434a 100644
--- a/theories/Reals/RList.v
+++ b/theories/Reals/RList.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-2012     *)
 (*   \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.
+Local Open Scope R_scope.
 
 Inductive Rlist : Type :=
 | nil : Rlist
@@ -54,19 +52,19 @@ Proof.
   simpl in H; elim H.
   induction  l as [| r0 l Hrecl0].
   simpl in H; elim H; intro.
-  simpl in |- *; right; assumption.
+  simpl; right; assumption.
   elim H0.
   replace (MaxRlist (cons r (cons r0 l))) with (Rmax r (MaxRlist (cons r0 l))).
   simpl in H; decompose [or] H.
   rewrite H0; apply RmaxLess1.
-  unfold Rmax in |- *; case (Rle_dec r (MaxRlist (cons r0 l))); intro.
-  apply Hrecl; simpl in |- *; tauto.
+  unfold Rmax; case (Rle_dec r (MaxRlist (cons r0 l))); intro.
+  apply Hrecl; simpl; tauto.
   apply Rle_trans with (MaxRlist (cons r0 l));
-    [ apply Hrecl; simpl in |- *; tauto | left; auto with real ].
-  unfold Rmax in |- *; case (Rle_dec r (MaxRlist (cons r0 l))); intro.
-  apply Hrecl; simpl in |- *; tauto.
+    [ apply Hrecl; simpl; tauto | left; auto with real ].
+  unfold Rmax; case (Rle_dec r (MaxRlist (cons r0 l))); intro.
+  apply Hrecl; simpl; tauto.
   apply Rle_trans with (MaxRlist (cons r0 l));
-    [ apply Hrecl; simpl in |- *; tauto | left; auto with real ].
+    [ apply Hrecl; simpl; tauto | left; auto with real ].
   reflexivity.
 Qed.
 
@@ -82,19 +80,19 @@ Proof.
   simpl in H; elim H.
   induction  l as [| r0 l Hrecl0].
   simpl in H; elim H; intro.
-  simpl in |- *; right; symmetry  in |- *; assumption.
+  simpl; right; symmetry ; assumption.
   elim H0.
   replace (MinRlist (cons r (cons r0 l))) with (Rmin r (MinRlist (cons r0 l))).
   simpl in H; decompose [or] H.
   rewrite H0; apply Rmin_l.
-  unfold Rmin in |- *; case (Rle_dec r (MinRlist (cons r0 l))); intro.
+  unfold Rmin; case (Rle_dec r (MinRlist (cons r0 l))); intro.
   apply Rle_trans with (MinRlist (cons r0 l)).
   assumption.
-  apply Hrecl; simpl in |- *; tauto.
-  apply Hrecl; simpl in |- *; tauto.
+  apply Hrecl; simpl; tauto.
+  apply Hrecl; simpl; tauto.
   apply Rle_trans with (MinRlist (cons r0 l)).
   apply Rmin_r.
-  apply Hrecl; simpl in |- *; tauto.
+  apply Hrecl; simpl; tauto.
   reflexivity.
 Qed.
 
@@ -103,7 +101,7 @@ Lemma AbsList_P1 :
 Proof.
   intros; induction  l as [| r l Hrecl].
   elim H.
-  simpl in |- *; simpl in H; elim H; intro.
+  simpl; simpl in H; elim H; intro.
   left; rewrite H0; reflexivity.
   right; apply Hrecl; assumption.
 Qed.
@@ -114,11 +112,11 @@ Proof.
   intros; induction  l as [| r l Hrecl].
   apply Rlt_0_1.
   induction  l as [| r0 l Hrecl0].
-  simpl in |- *; apply H; simpl in |- *; tauto.
+  simpl; apply H; simpl; tauto.
   replace (MinRlist (cons r (cons r0 l))) with (Rmin r (MinRlist (cons r0 l))).
-  unfold Rmin in |- *; case (Rle_dec r (MinRlist (cons r0 l))); intro.
-  apply H; simpl in |- *; tauto.
-  apply Hrecl; intros; apply H; simpl in |- *; simpl in H0; tauto.
+  unfold Rmin; case (Rle_dec r (MinRlist (cons r0 l))); intro.
+  apply H; simpl; tauto.
+  apply Hrecl; intros; apply H; simpl; simpl in H0; tauto.
   reflexivity.
 Qed.
 
@@ -130,10 +128,10 @@ Proof.
   elim H.
   elim H; intro.
   exists r; split.
-  simpl in |- *; tauto.
+  simpl; tauto.
   assumption.
   assert (H1 := Hrecl H0); elim H1; intros; elim H2; clear H2; intros;
-    exists x0; simpl in |- *; simpl in H2; tauto.
+    exists x0; simpl; simpl in H2; tauto.
 Qed.
 
 Lemma MaxRlist_P2 :
@@ -142,9 +140,9 @@ Proof.
   intros; induction  l as [| r l Hrecl].
   simpl in H; elim H; trivial.
   induction  l as [| r0 l Hrecl0].
-  simpl in |- *; left; reflexivity.
-  change (In (Rmax r (MaxRlist (cons r0 l))) (cons r (cons r0 l))) in |- *;
-    unfold Rmax in |- *; case (Rle_dec r (MaxRlist (cons r0 l)));
+  simpl; left; reflexivity.
+  change (In (Rmax r (MaxRlist (cons r0 l))) (cons r (cons r0 l)));
+    unfold Rmax; case (Rle_dec r (MaxRlist (cons r0 l)));
       intro.
   right; apply Hrecl; exists r0; left; reflexivity.
   left; reflexivity.
@@ -166,7 +164,7 @@ Lemma pos_Rl_P1 :
 Proof.
   intros; induction  l as [| r l Hrecl];
     [ elim (lt_n_O _ H)
-      | simpl in |- *; case (Rlength l); [ reflexivity | intro; reflexivity ] ].
+      | simpl; case (Rlength l); [ reflexivity | intro; reflexivity ] ].
 Qed.
 
 Lemma pos_Rl_P2 :
@@ -179,14 +177,14 @@ Proof.
   split; intro.
   elim H; intro.
   exists 0%nat; split;
-    [ simpl in |- *; apply lt_O_Sn | simpl in |- *; apply H0 ].
+    [ simpl; apply lt_O_Sn | simpl; apply H0 ].
   elim Hrecl; intros; assert (H3 := H1 H0); elim H3; intros; elim H4; intros;
     exists (S x0); split;
-      [ simpl in |- *; apply lt_n_S; assumption | simpl in |- *; assumption ].
+      [ simpl; apply lt_n_S; assumption | simpl; assumption ].
   elim H; intros; elim H0; intros; elim (zerop x0); intro.
   rewrite a in H2; simpl in H2; left; assumption.
   right; elim Hrecl; intros; apply H4; assert (H5 : S (pred x0) = x0).
-  symmetry  in |- *; apply S_pred with 0%nat; assumption.
+  symmetry ; apply S_pred with 0%nat; assumption.
   exists (pred x0); split;
     [ simpl in H1; apply lt_S_n; rewrite H5; assumption
       | rewrite <- H5 in H2; simpl in H2; assumption ].
@@ -203,18 +201,18 @@ Proof.
   exists nil; intros; split;
     [ reflexivity | intros; simpl in H0; elim (lt_n_O _ H0) ].
   assert (H0 : In r (cons r l)).
-  simpl in |- *; left; reflexivity.
+  simpl; left; reflexivity.
   assert (H1 := H _ H0);
     assert (H2 : forall x:R, In x l ->  exists y : R, P x y).
-  intros; apply H; simpl in |- *; right; assumption.
+  intros; apply H; simpl; right; assumption.
   assert (H3 := Hrecl H2); elim H1; intros; elim H3; intros; exists (cons x x0);
     intros; elim H5; clear H5; intros; split.
-  simpl in |- *; rewrite H5; reflexivity.
+  simpl; rewrite H5; reflexivity.
   intros; elim (zerop i); intro.
-  rewrite a; simpl in |- *; assumption.
+  rewrite a; simpl; assumption.
   assert (H8 : i = S (pred i)).
   apply S_pred with 0%nat; assumption.
-  rewrite H8; simpl in |- *; apply H6; simpl in H7; apply lt_S_n; rewrite <- H8;
+  rewrite H8; simpl; apply H6; simpl in H7; apply lt_S_n; rewrite <- H8;
     assumption.
 Qed.
 
@@ -273,7 +271,7 @@ Lemma RList_P0 :
 Proof.
   intros; induction  l as [| r l Hrecl];
     [ left; reflexivity
-      | simpl in |- *; case (Rle_dec r a); intro;
+      | simpl; case (Rle_dec r a); intro;
         [ right; reflexivity | left; reflexivity ] ].
 Qed.
 
@@ -281,41 +279,41 @@ Lemma RList_P1 :
   forall (l:Rlist) (a:R), ordered_Rlist l -> ordered_Rlist (insert l a).
 Proof.
   intros; induction  l as [| r l Hrecl].
-  simpl in |- *; unfold ordered_Rlist in |- *; intros; simpl in H0;
+  simpl; unfold ordered_Rlist; intros; simpl in H0;
     elim (lt_n_O _ H0).
-  simpl in |- *; case (Rle_dec r a); intro.
+  simpl; case (Rle_dec r a); intro.
   assert (H1 : ordered_Rlist l).
-  unfold ordered_Rlist in |- *; unfold ordered_Rlist in H; intros;
+  unfold ordered_Rlist; unfold ordered_Rlist in H; intros;
     assert (H1 : (S i < pred (Rlength (cons r l)))%nat);
-      [ simpl in |- *; replace (Rlength l) with (S (pred (Rlength l)));
+      [ simpl; replace (Rlength l) with (S (pred (Rlength l)));
         [ apply lt_n_S; assumption
-          | symmetry  in |- *; apply S_pred with 0%nat; apply neq_O_lt; red in |- *;
+          | symmetry ; apply S_pred with 0%nat; apply neq_O_lt; red;
             intro; rewrite <- H1 in H0; simpl in H0; elim (lt_n_O _ H0) ]
         | apply (H _ H1) ].
-  assert (H2 := Hrecl H1); unfold ordered_Rlist in |- *; intros;
+  assert (H2 := Hrecl H1); unfold ordered_Rlist; intros;
     induction  i as [| i Hreci].
-  simpl in |- *; assert (H3 := RList_P0 l a); elim H3; intro.
+  simpl; assert (H3 := RList_P0 l a); elim H3; intro.
   rewrite H4; assumption.
   induction  l as [| r1 l Hrecl0];
-    [ simpl in |- *; assumption
-      | rewrite H4; apply (H 0%nat); simpl in |- *; apply lt_O_Sn ].
-  simpl in |- *; apply H2; simpl in H0; apply lt_S_n;
+    [ simpl; assumption
+      | rewrite H4; apply (H 0%nat); simpl; apply lt_O_Sn ].
+  simpl; apply H2; simpl in H0; apply lt_S_n;
     replace (S (pred (Rlength (insert l a)))) with (Rlength (insert l a));
     [ assumption
-      | apply S_pred with 0%nat; apply neq_O_lt; red in |- *; intro;
+      | apply S_pred with 0%nat; apply neq_O_lt; red; intro;
         rewrite <- H3 in H0; elim (lt_n_O _ H0) ].
-  unfold ordered_Rlist in |- *; intros; induction  i as [| i Hreci];
-    [ simpl in |- *; auto with real
-      | change (pos_Rl (cons r l) i <= pos_Rl (cons r l) (S i)) in |- *; apply H;
-        simpl in H0; simpl in |- *; apply (lt_S_n _ _ H0) ].
+  unfold ordered_Rlist; intros; induction  i as [| i Hreci];
+    [ simpl; auto with real
+      | change (pos_Rl (cons r l) i <= pos_Rl (cons r l) (S i)); apply H;
+        simpl in H0; simpl; apply (lt_S_n _ _ H0) ].
 Qed.
 
 Lemma RList_P2 :
   forall l1 l2:Rlist, ordered_Rlist l2 -> ordered_Rlist (cons_ORlist l1 l2).
 Proof.
   simple induction l1;
-    [ intros; simpl in |- *; apply H
-      | intros; simpl in |- *; apply H; apply RList_P1; assumption ].
+    [ intros; simpl; apply H
+      | intros; simpl; apply H; apply RList_P1; assumption ].
 Qed.
 
 Lemma RList_P3 :
@@ -326,11 +324,11 @@ Proof.
     [ induction  l as [| r l Hrecl] | induction  l as [| r l Hrecl] ].
   elim H.
   elim H; intro;
-    [ exists 0%nat; split; [ apply H0 | simpl in |- *; apply lt_O_Sn ]
+    [ exists 0%nat; split; [ apply H0 | simpl; apply lt_O_Sn ]
       | elim (Hrecl H0); intros; elim H1; clear H1; intros; exists (S x0); split;
-        [ apply H1 | simpl in |- *; apply lt_n_S; assumption ] ].
+        [ apply H1 | simpl; apply lt_n_S; assumption ] ].
   elim H; intros; elim H0; intros; elim (lt_n_O _ H2).
-  simpl in |- *; elim H; intros; elim H0; clear H0; intros;
+  simpl; elim H; intros; elim H0; clear H0; intros;
     induction  x0 as [| x0 Hrecx0];
       [ left; apply H0
         | right; apply Hrecl; exists x0; split;
@@ -340,10 +338,10 @@ Qed.
 Lemma RList_P4 :
   forall (l1:Rlist) (a:R), ordered_Rlist (cons a l1) -> ordered_Rlist l1.
 Proof.
-  intros; unfold ordered_Rlist in |- *; intros; apply (H (S i)); simpl in |- *;
+  intros; unfold ordered_Rlist; intros; apply (H (S i)); simpl;
     replace (Rlength l1) with (S (pred (Rlength l1)));
     [ apply lt_n_S; assumption
-      | symmetry  in |- *; apply S_pred with 0%nat; apply neq_O_lt; red in |- *;
+      | symmetry ; apply S_pred with 0%nat; apply neq_O_lt; red;
         intro; rewrite <- H1 in H0; elim (lt_n_O _ H0) ].
 Qed.
 
@@ -352,11 +350,11 @@ Lemma RList_P5 :
 Proof.
   intros; induction  l as [| r l Hrecl];
     [ elim H0
-      | simpl in |- *; elim H0; intro;
+      | simpl; elim H0; intro;
         [ rewrite H1; right; reflexivity
           | apply Rle_trans with (pos_Rl l 0);
-            [ apply (H 0%nat); simpl in |- *; induction  l as [| r0 l Hrecl0];
-              [ elim H1 | simpl in |- *; apply lt_O_Sn ]
+            [ apply (H 0%nat); simpl; induction  l as [| r0 l Hrecl0];
+              [ elim H1 | simpl; apply lt_O_Sn ]
               | apply Hrecl; [ eapply RList_P4; apply H | assumption ] ] ] ].
 Qed.
 
@@ -368,13 +366,13 @@ Lemma RList_P6 :
 Proof.
   simple induction l; split; intro.
   intros; right; reflexivity.
-  unfold ordered_Rlist in |- *; intros; simpl in H0; elim (lt_n_O _ H0).
+  unfold ordered_Rlist; intros; simpl in H0; elim (lt_n_O _ H0).
   intros; induction  i as [| i Hreci];
     [ induction  j as [| j Hrecj];
       [ right; reflexivity
-        | simpl in |- *; apply Rle_trans with (pos_Rl r0 0);
-          [ apply (H0 0%nat); simpl in |- *; simpl in H2; apply neq_O_lt;
-            red in |- *; intro; rewrite <- H3 in H2;
+        | simpl; apply Rle_trans with (pos_Rl r0 0);
+          [ apply (H0 0%nat); simpl; simpl in H2; apply neq_O_lt;
+            red; intro; rewrite <- H3 in H2;
               assert (H4 := lt_S_n _ _ H2); elim (lt_n_O _ H4)
             | elim H; intros; apply H3;
               [ apply RList_P4 with r; assumption
@@ -382,12 +380,12 @@ Proof.
                 | simpl in H2; apply lt_S_n; assumption ] ] ]
       | induction  j as [| j Hrecj];
         [ elim (le_Sn_O _ H1)
-          | simpl in |- *; elim H; intros; apply H3;
+          | simpl; elim H; intros; apply H3;
             [ apply RList_P4 with r; assumption
               | apply le_S_n; assumption
               | simpl in H2; apply lt_S_n; assumption ] ] ].
-  unfold ordered_Rlist in |- *; intros; apply H0;
-    [ apply le_n_Sn | simpl in |- *; simpl in H1; apply lt_n_S; assumption ].
+  unfold ordered_Rlist; intros; apply H0;
+    [ apply le_n_Sn | simpl; simpl in H1; apply lt_n_S; assumption ].
 Qed.
 
 Lemma RList_P7 :
@@ -399,11 +397,11 @@ Proof.
       clear H1; intros; assert (H4 := H1 H0); elim H4; clear H4;
         intros; elim H4; clear H4; intros; rewrite H4;
           assert (H6 : Rlength l = S (pred (Rlength l))).
-  apply S_pred with 0%nat; apply neq_O_lt; red in |- *; intro;
+  apply S_pred with 0%nat; apply neq_O_lt; red; intro;
     rewrite <- H6 in H5; elim (lt_n_O _ H5).
   apply H3;
     [ rewrite H6 in H5; apply lt_n_Sm_le; assumption
-      | apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro; rewrite <- H7 in H5;
+      | apply lt_pred_n_n; apply neq_O_lt; red; intro; rewrite <- H7 in H5;
         elim (lt_n_O _ H5) ].
 Qed.
 
@@ -422,7 +420,7 @@ Proof.
           [ left; assumption
             | right; left; assumption
             | right; right; assumption ] ]
-      | simpl in |- *; case (Rle_dec r a); intro;
+      | simpl; case (Rle_dec r a); intro;
         [ simpl in H0; decompose [or] H0;
           [ right; elim (H a x); intros; apply H3; left
             | left
@@ -437,14 +435,14 @@ Proof.
   simple induction l1.
   intros; split; intro;
     [ simpl in H; right; assumption
-      | simpl in |- *; elim H; intro; [ elim H0 | assumption ] ].
+      | simpl; elim H; intro; [ elim H0 | assumption ] ].
   intros; split.
-  simpl in |- *; intros; elim (H (insert l2 r) x); intros; assert (H3 := H1 H0);
+  simpl; intros; elim (H (insert l2 r) x); intros; assert (H3 := H1 H0);
     elim H3; intro;
       [ left; right; assumption
         | elim (RList_P8 l2 r x); intros H5 _; assert (H6 := H5 H4); elim H6; intro;
           [ left; left; assumption | right; assumption ] ].
-  intro; simpl in |- *; elim (H (insert l2 r) x); intros _ H1; apply H1;
+  intro; simpl; elim (H (insert l2 r) x); intros _ H1; apply H1;
     elim H0; intro;
       [ elim H2; intro;
         [ right; elim (RList_P8 l2 r x); intros _ H4; apply H4; left; assumption
@@ -457,8 +455,8 @@ Lemma RList_P10 :
 Proof.
   intros; induction  l as [| r l Hrecl];
     [ reflexivity
-      | simpl in |- *; case (Rle_dec r a); intro;
-        [ simpl in |- *; rewrite Hrecl; reflexivity | reflexivity ] ].
+      | simpl; case (Rle_dec r a); intro;
+        [ simpl; rewrite Hrecl; reflexivity | reflexivity ] ].
 Qed.
 
 Lemma RList_P11 :
@@ -467,7 +465,7 @@ Lemma RList_P11 :
 Proof.
   simple induction l1;
     [ intro; reflexivity
-      | intros; simpl in |- *; rewrite (H (insert l2 r)); rewrite RList_P10;
+      | intros; simpl; rewrite (H (insert l2 r)); rewrite RList_P10;
         apply INR_eq; rewrite S_INR; do 2 rewrite plus_INR;
           rewrite S_INR; ring ].
 Qed.
@@ -479,7 +477,7 @@ Proof.
   simple induction l;
     [ intros; elim (lt_n_O _ H)
       | intros; induction  i as [| i Hreci];
-        [ reflexivity | simpl in |- *; apply H; apply lt_S_n; apply H0 ] ].
+        [ reflexivity | simpl; apply H; apply lt_S_n; apply H0 ] ].
 Qed.
 
 Lemma RList_P13 :
@@ -496,13 +494,13 @@ Proof.
   change
     (pos_Rl (mid_Rlist (cons r1 r2) r) (S i) =
       (pos_Rl (cons r1 r2) i + pos_Rl (cons r1 r2) (S i)) / 2)
-    in |- *; apply H0; simpl in |- *; apply lt_S_n; assumption.
+   ; apply H0; simpl; apply lt_S_n; assumption.
 Qed.
 
 Lemma RList_P14 : forall (l:Rlist) (a:R), Rlength (mid_Rlist l a) = Rlength l.
 Proof.
   simple induction l; intros;
-    [ reflexivity | simpl in |- *; rewrite (H r); reflexivity ].
+    [ reflexivity | simpl; rewrite (H r); reflexivity ].
 Qed.
 
 Lemma RList_P15 :
@@ -513,7 +511,7 @@ Lemma RList_P15 :
 Proof.
   intros; apply Rle_antisym.
   induction  l1 as [| r l1 Hrecl1];
-    [ simpl in |- *; simpl in H1; right; symmetry  in |- *; assumption
+    [ simpl; simpl in H1; right; symmetry ; assumption
       | elim (RList_P9 (cons r l1) l2 (pos_Rl (cons r l1) 0)); intros;
         assert
           (H4 :
@@ -522,7 +520,7 @@ Proof.
             | assert (H5 := H3 H4); apply RList_P5;
               [ apply RList_P2; assumption | assumption ] ] ].
   induction  l1 as [| r l1 Hrecl1];
-    [ simpl in |- *; simpl in H1; right; assumption
+    [ simpl; simpl in H1; right; assumption
       | assert
         (H2 :
           In (pos_Rl (cons_ORlist (cons r l1) l2) 0) (cons_ORlist (cons r l1) l2));
@@ -530,7 +528,7 @@ Proof.
           (RList_P3 (cons_ORlist (cons r l1) l2)
             (pos_Rl (cons_ORlist (cons r l1) l2) 0));
           intros; apply H3; exists 0%nat; split;
-            [ reflexivity | rewrite RList_P11; simpl in |- *; apply lt_O_Sn ]
+            [ reflexivity | rewrite RList_P11; simpl; apply lt_O_Sn ]
           | elim (RList_P9 (cons r l1) l2 (pos_Rl (cons_ORlist (cons r l1) l2) 0));
             intros; assert (H5 := H3 H2); elim H5; intro;
               [ apply RList_P5; assumption
@@ -547,7 +545,7 @@ Lemma RList_P16 :
 Proof.
   intros; apply Rle_antisym.
   induction  l1 as [| r l1 Hrecl1].
-  simpl in |- *; simpl in H1; right; symmetry  in |- *; assumption.
+  simpl; simpl in H1; right; symmetry ; assumption.
   assert
     (H2 :
       In
@@ -559,7 +557,7 @@ Proof.
         (pos_Rl (cons_ORlist (cons r l1) l2)
           (pred (Rlength (cons_ORlist (cons r l1) l2)))));
       intros; apply H3; exists (pred (Rlength (cons_ORlist (cons r l1) l2)));
-        split; [ reflexivity | rewrite RList_P11; simpl in |- *; apply lt_n_Sn ]
+        split; [ reflexivity | rewrite RList_P11; simpl; apply lt_n_Sn ]
       | elim
         (RList_P9 (cons r l1) l2
           (pos_Rl (cons_ORlist (cons r l1) l2)
@@ -567,7 +565,7 @@ Proof.
         intros; assert (H5 := H3 H2); elim H5; intro;
           [ apply RList_P7; assumption | rewrite H1; apply RList_P7; assumption ] ].
   induction  l1 as [| r l1 Hrecl1].
-  simpl in |- *; simpl in H1; right; assumption.
+  simpl; simpl in H1; right; assumption.
   elim
     (RList_P9 (cons r l1) l2 (pos_Rl (cons r l1) (pred (Rlength (cons r l1)))));
     intros;
@@ -575,10 +573,10 @@ Proof.
         (H4 :
           In (pos_Rl (cons r l1) (pred (Rlength (cons r l1)))) (cons r l1) \/
           In (pos_Rl (cons r l1) (pred (Rlength (cons r l1)))) l2);
-        [ left; change (In (pos_Rl (cons r l1) (Rlength l1)) (cons r l1)) in |- *;
+        [ left; change (In (pos_Rl (cons r l1) (Rlength l1)) (cons r l1));
           elim (RList_P3 (cons r l1) (pos_Rl (cons r l1) (Rlength l1)));
             intros; apply H5; exists (Rlength l1); split;
-              [ reflexivity | simpl in |- *; apply lt_n_Sn ]
+              [ reflexivity | simpl; apply lt_n_Sn ]
           | assert (H5 := H3 H4); apply RList_P7;
             [ apply RList_P2; assumption
               | elim
@@ -589,7 +587,7 @@ Proof.
                     (RList_P3 (cons r l1)
                       (pos_Rl (cons r l1) (pred (Rlength (cons r l1)))));
                     intros; apply H9; exists (pred (Rlength (cons r l1)));
-                      split; [ reflexivity | simpl in |- *; apply lt_n_Sn ] ] ].
+                      split; [ reflexivity | simpl; apply lt_n_Sn ] ] ].
 Qed.
 
 Lemma RList_P17 :
@@ -601,14 +599,14 @@ Proof.
   simple induction l1.
   intros; elim H0.
   intros; induction  i as [| i Hreci].
-  simpl in |- *; elim H1; intro;
+  simpl; elim H1; intro;
     [ simpl in H2; rewrite H4 in H2; elim (Rlt_irrefl _ H2)
       | apply RList_P5; [ apply RList_P4 with r; assumption | assumption ] ].
-  simpl in |- *; simpl in H2; elim H1; intro.
+  simpl; simpl in H2; elim H1; intro.
   rewrite H4 in H2; assert (H5 : r <= pos_Rl r0 i);
     [ apply Rle_trans with (pos_Rl r0 0);
-      [ apply (H0 0%nat); simpl in |- *; simpl in H3; apply neq_O_lt;
-        red in |- *; intro; rewrite <- H5 in H3; elim (lt_n_O _ H3)
+      [ apply (H0 0%nat); simpl; simpl in H3; apply neq_O_lt;
+        red; intro; rewrite <- H5 in H3; elim (lt_n_O _ H3)
         | elim (RList_P6 r0); intros; apply H5;
           [ apply RList_P4 with r; assumption
             | apply le_O_n
@@ -620,7 +618,7 @@ Proof.
       | simpl in H3; apply lt_S_n;
         replace (S (pred (Rlength r0))) with (Rlength r0);
         [ apply H3
-          | apply S_pred with 0%nat; apply neq_O_lt; red in |- *; intro;
+          | apply S_pred with 0%nat; apply neq_O_lt; red; intro;
             rewrite <- H5 in H3; elim (lt_n_O _ H3) ] ].
 Qed.
 
@@ -628,7 +626,7 @@ Lemma RList_P18 :
   forall (l:Rlist) (f:R -> R), Rlength (app_Rlist l f) = Rlength l.
 Proof.
   simple induction l; intros;
-    [ reflexivity | simpl in |- *; rewrite H; reflexivity ].
+    [ reflexivity | simpl; rewrite H; reflexivity ].
 Qed.
 
 Lemma RList_P19 :
@@ -668,7 +666,7 @@ Lemma RList_P23 :
     Rlength (cons_Rlist l1 l2) = (Rlength l1 + Rlength l2)%nat.
 Proof.
   simple induction l1;
-    [ intro; reflexivity | intros; simpl in |- *; rewrite H; reflexivity ].
+    [ intro; reflexivity | intros; simpl; rewrite H; reflexivity ].
 Qed.
 
 Lemma RList_P24 :
@@ -687,9 +685,9 @@ Proof.
     [ replace (Rlength r0 + Rlength (cons r1 l2))%nat with
       (S (Rlength r0 + Rlength l2));
       [ reflexivity
-        | simpl in |- *; apply INR_eq; rewrite S_INR; do 2 rewrite plus_INR;
+        | simpl; apply INR_eq; rewrite S_INR; do 2 rewrite plus_INR;
           rewrite S_INR; ring ]
-      | simpl in |- *; apply INR_eq; do 3 rewrite S_INR; do 2 rewrite plus_INR;
+      | simpl; apply INR_eq; do 3 rewrite S_INR; do 2 rewrite plus_INR;
         rewrite S_INR; ring ].
 Qed.
 
@@ -701,27 +699,27 @@ Lemma RList_P25 :
     ordered_Rlist (cons_Rlist l1 l2).
 Proof.
   simple induction l1.
-  intros; simpl in |- *; assumption.
+  intros; simpl; assumption.
   simple induction r0.
-  intros; simpl in |- *; simpl in H2; unfold ordered_Rlist in |- *; intros;
+  intros; simpl; simpl in H2; unfold ordered_Rlist; intros;
     simpl in H3.
   induction  i as [| i Hreci].
-  simpl in |- *; assumption.
-  change (pos_Rl l2 i <= pos_Rl l2 (S i)) in |- *; apply (H1 i); apply lt_S_n;
+  simpl; assumption.
+  change (pos_Rl l2 i <= pos_Rl l2 (S i)); apply (H1 i); apply lt_S_n;
     replace (S (pred (Rlength l2))) with (Rlength l2);
     [ assumption
-      | apply S_pred with 0%nat; apply neq_O_lt; red in |- *; intro;
+      | apply S_pred with 0%nat; apply neq_O_lt; red; intro;
         rewrite <- H4 in H3; elim (lt_n_O _ H3) ].
   intros; clear H; assert (H : ordered_Rlist (cons_Rlist (cons r1 r2) l2)).
   apply H0; try assumption.
   apply RList_P4 with r; assumption.
-  unfold ordered_Rlist in |- *; intros; simpl in H4;
+  unfold ordered_Rlist; intros; simpl in H4;
     induction  i as [| i Hreci].
-  simpl in |- *; apply (H1 0%nat); simpl in |- *; apply lt_O_Sn.
+  simpl; apply (H1 0%nat); simpl; apply lt_O_Sn.
   change
     (pos_Rl (cons_Rlist (cons r1 r2) l2) i <=
-      pos_Rl (cons_Rlist (cons r1 r2) l2) (S i)) in |- *;
-    apply (H i); simpl in |- *; apply lt_S_n; assumption.
+      pos_Rl (cons_Rlist (cons r1 r2) l2) (S i));
+    apply (H i); simpl; apply lt_S_n; assumption.
 Qed.
 
 Lemma RList_P26 :
@@ -740,13 +738,13 @@ Lemma RList_P27 :
     cons_Rlist l1 (cons_Rlist l2 l3) = cons_Rlist (cons_Rlist l1 l2) l3.
 Proof.
   simple induction l1; intros;
-    [ reflexivity | simpl in |- *; rewrite (H l2 l3); reflexivity ].
+    [ reflexivity | simpl; rewrite (H l2 l3); reflexivity ].
 Qed.
 
 Lemma RList_P28 : forall l:Rlist, cons_Rlist l nil = l.
 Proof.
   simple induction l;
-    [ reflexivity | intros; simpl in |- *; rewrite H; reflexivity ].
+    [ reflexivity | intros; simpl; rewrite H; reflexivity ].
 Qed.
 
 Lemma RList_P29 :
@@ -761,23 +759,23 @@ Proof.
     replace (cons_Rlist l1 (cons r r0)) with
     (cons_Rlist (cons_Rlist l1 (cons r nil)) r0).
   inversion H0.
-  rewrite <- minus_n_n; simpl in |- *; rewrite RList_P26.
+  rewrite <- minus_n_n; simpl; rewrite RList_P26.
   clear l2 r0 H i H0 H1 H2; induction  l1 as [| r0 l1 Hrecl1].
   reflexivity.
-  simpl in |- *; assumption.
-  rewrite RList_P23; rewrite plus_comm; simpl in |- *; apply lt_n_Sn.
+  simpl; assumption.
+  rewrite RList_P23; rewrite plus_comm; simpl; apply lt_n_Sn.
   replace (S m - Rlength l1)%nat with (S (S m - S (Rlength l1))).
-  rewrite H3; simpl in |- *;
+  rewrite H3; simpl;
     replace (S (Rlength l1)) with (Rlength (cons_Rlist l1 (cons r nil))).
   apply (H (cons_Rlist l1 (cons r nil)) i).
-  rewrite RList_P23; rewrite plus_comm; simpl in |- *; rewrite <- H3;
+  rewrite RList_P23; rewrite plus_comm; simpl; rewrite <- H3;
     apply le_n_S; assumption.
-  repeat rewrite RList_P23; simpl in |- *; rewrite RList_P23 in H1;
+  repeat rewrite RList_P23; simpl; rewrite RList_P23 in H1;
     rewrite plus_comm in H1; simpl in H1; rewrite (plus_comm (Rlength l1));
-      simpl in |- *; rewrite plus_comm; apply H1.
+      simpl; rewrite plus_comm; apply H1.
   rewrite RList_P23; rewrite plus_comm; reflexivity.
-  change (S (m - Rlength l1) = (S m - Rlength l1)%nat) in |- *;
+  change (S (m - Rlength l1) = (S m - Rlength l1)%nat);
     apply minus_Sn_m; assumption.
   replace (cons r r0) with (cons_Rlist (cons r nil) r0);
-  [ symmetry  in |- *; apply RList_P27 | reflexivity ].
+  [ symmetry ; apply RList_P27 | reflexivity ].
 Qed.
diff --git a/theories/Reals/ROrderedType.v b/theories/Reals/ROrderedType.v
index 87dc07b8..726f1204 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-2012     *)
 (*   \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..8364e986 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-2012     *)
 (*   \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 *)
 (*                                                        *)
@@ -15,7 +13,7 @@
 
 Require Import Rbase.
 Require Import Omega.
-Open Local Scope R_scope.
+Local Open Scope R_scope.
 
 (*********************************************************)
 (** *    Fractional part                                 *)
@@ -47,7 +45,7 @@ Proof.
   intros; generalize (Rplus_le_compat_l 1 (IZR z) r H); intro; clear H;
     rewrite (Rplus_comm 1 (IZR z)) in H1; rewrite (Rplus_comm 1 r) in H1;
       cut (1 = IZR 1); auto with zarith real.
-  intro; generalize H1; pattern 1 at 1 in |- *; rewrite H; intro; clear H H1;
+  intro; generalize H1; pattern 1 at 1; rewrite H; intro; clear H H1;
     rewrite <- (plus_IZR z 1) in H2; apply (tech_up r (z + 1));
       auto with zarith real.
 Qed.
@@ -55,12 +53,12 @@ Qed.
 (**********)
 Lemma fp_R0 : frac_part 0 = 0.
 Proof.
-  unfold frac_part in |- *; unfold Int_part in |- *; elim (archimed 0); intros;
-    unfold Rminus in |- *; elim (Rplus_ne (- IZR (up 0 - 1)));
+  unfold frac_part; unfold Int_part; elim (archimed 0); intros;
+    unfold Rminus; elim (Rplus_ne (- IZR (up 0 - 1)));
       intros a b; rewrite b; clear a b; rewrite <- Z_R_minus;
         cut (up 0 = 1%Z).
   intro; rewrite H1;
-    rewrite (Rminus_diag_eq (IZR 1) (IZR 1) (refl_equal (IZR 1)));
+    rewrite (Rminus_diag_eq (IZR 1) (IZR 1) (eq_refl (IZR 1)));
       apply Ropp_0.
   elim (archimed 0); intros; clear H2; unfold Rgt in H1;
     rewrite (Rminus_0_r (IZR (up 0))) in H0; generalize (lt_O_IZR (up 0) H1);
@@ -83,21 +81,21 @@ Qed.
 (**********)
 Lemma base_fp : forall r:R, frac_part r >= 0 /\ frac_part r < 1.
 Proof.
-  intro; unfold frac_part in |- *; unfold Int_part in |- *; split.
+  intro; unfold frac_part; unfold Int_part; split.
      (*sup a O*)
   cut (r - IZR (up r) >= -1).
-  rewrite <- Z_R_minus; simpl in |- *; intro; unfold Rminus in |- *;
+  rewrite <- Z_R_minus; simpl; intro; unfold Rminus;
     rewrite Ropp_plus_distr; rewrite <- Rplus_assoc;
-      fold (r - IZR (up r)) in |- *; fold (r - IZR (up r) - -1) in |- *;
+      fold (r - IZR (up r)); fold (r - IZR (up r) - -1);
         apply Rge_minus; auto with zarith real.
   rewrite <- Ropp_minus_distr; apply Ropp_le_ge_contravar; elim (for_base_fp r);
     auto with zarith real.
     (*inf a 1*)
   cut (r - IZR (up r) < 0).
-  rewrite <- Z_R_minus; simpl in |- *; intro; unfold Rminus in |- *;
+  rewrite <- Z_R_minus; simpl; intro; unfold Rminus;
     rewrite Ropp_plus_distr; rewrite <- Rplus_assoc;
-      fold (r - IZR (up r)) in |- *; rewrite Ropp_involutive;
-        elim (Rplus_ne 1); intros a b; pattern 1 at 2 in |- *;
+      fold (r - IZR (up r)); rewrite Ropp_involutive;
+        elim (Rplus_ne 1); intros a b; pattern 1 at 2;
           rewrite <- a; clear a b; rewrite (Rplus_comm (r - IZR (up r)) 1);
             apply Rplus_lt_compat_l; auto with zarith real.
   elim (for_base_fp r); intros; rewrite <- Ropp_0; rewrite <- Ropp_minus_distr;
@@ -112,8 +110,8 @@ Qed.
 Lemma base_Int_part :
   forall r:R, IZR (Int_part r) <= r /\ IZR (Int_part r) - r > -1.
 Proof.
-  intro; unfold Int_part in |- *; elim (archimed r); intros.
-  split; rewrite <- (Z_R_minus (up r) 1); simpl in |- *.
+  intro; unfold Int_part; elim (archimed r); intros.
+  split; rewrite <- (Z_R_minus (up r) 1); simpl.
   generalize (Rle_minus (IZR (up r) - r) 1 H0); intro; unfold Rminus in H1;
     rewrite (Rplus_assoc (IZR (up r)) (- r) (-1)) in H1;
       rewrite (Rplus_comm (- r) (-1)) in H1;
@@ -132,31 +130,31 @@ Proof.
 Qed.
 
 (**********)
-Lemma Int_part_INR : forall n:nat, Int_part (INR n) = Z_of_nat n.
+Lemma Int_part_INR : forall n:nat, Int_part (INR n) = Z.of_nat n.
 Proof.
-  intros n; unfold Int_part in |- *.
-  cut (up (INR n) = (Z_of_nat n + Z_of_nat 1)%Z).
-  intros H'; rewrite H'; simpl in |- *; ring.
-  apply sym_equal; apply tech_up; auto.
-  replace (Z_of_nat n + Z_of_nat 1)%Z with (Z_of_nat (S n)).
+  intros n; unfold Int_part.
+  cut (up (INR n) = (Z.of_nat n + Z.of_nat 1)%Z).
+  intros H'; rewrite H'; simpl; ring.
+  symmetry; apply tech_up; auto.
+  replace (Z.of_nat n + Z.of_nat 1)%Z with (Z.of_nat (S n)).
   repeat rewrite <- INR_IZR_INZ.
   apply lt_INR; auto.
-  rewrite Zplus_comm; rewrite <- Znat.inj_plus; simpl in |- *; auto.
-  rewrite plus_IZR; simpl in |- *; auto with real.
+  rewrite Z.add_comm; rewrite <- Znat.Nat2Z.inj_add; simpl; auto.
+  rewrite plus_IZR; simpl; auto with real.
   repeat rewrite <- INR_IZR_INZ; auto with real.
 Qed.
 
 (**********)
 Lemma fp_nat : forall r:R, frac_part r = 0 ->  exists c : Z, r = IZR c.
 Proof.
-  unfold frac_part in |- *; intros; split with (Int_part r);
+  unfold frac_part; intros; split with (Int_part r);
     apply Rminus_diag_uniq; auto with zarith real.
 Qed.
 
 (**********)
 Lemma R0_fp_O : forall r:R, 0 <> frac_part r -> 0 <> r.
 Proof.
-  red in |- *; intros; rewrite <- H0 in H; generalize fp_R0; intro;
+  red; intros; rewrite <- H0 in H; generalize fp_R0; intro;
     auto with zarith real.
 Qed.
 
@@ -245,7 +243,7 @@ Proof.
   intro; rewrite H1 in H; clear H1;
     rewrite <- (plus_IZR (Int_part r1 - Int_part r2) 1) in H;
       generalize (up_tech (r1 - r2) (Int_part r1 - Int_part r2) H0 H);
-        intros; clear H H0; unfold Int_part at 1 in |- *;
+        intros; clear H H0; unfold Int_part at 1;
           omega.
 Qed.
 
@@ -338,7 +336,7 @@ Proof.
           generalize (Rlt_le (IZR (Int_part r1 - Int_part r2 - 1)) (r1 - r2) H);
             intro; clear H;
               generalize (up_tech (r1 - r2) (Int_part r1 - Int_part r2 - 1) H1 H0);
-                intros; clear H0 H1; unfold Int_part at 1 in |- *;
+                intros; clear H0 H1; unfold Int_part at 1;
                   omega.
 Qed.
 
@@ -348,9 +346,9 @@ Lemma Rminus_fp1 :
     frac_part r1 >= frac_part r2 ->
     frac_part (r1 - r2) = frac_part r1 - frac_part r2.
 Proof.
-  intros; unfold frac_part in |- *; generalize (Rminus_Int_part1 r1 r2 H);
+  intros; unfold frac_part; generalize (Rminus_Int_part1 r1 r2 H);
     intro; rewrite H0; rewrite <- (Z_R_minus (Int_part r1) (Int_part r2));
-      unfold Rminus in |- *;
+      unfold Rminus;
         rewrite (Ropp_plus_distr (IZR (Int_part r1)) (- IZR (Int_part r2)));
           rewrite (Ropp_plus_distr r2 (- IZR (Int_part r2)));
             rewrite (Ropp_involutive (IZR (Int_part r2)));
@@ -368,17 +366,17 @@ Lemma Rminus_fp2 :
     frac_part r1 < frac_part r2 ->
     frac_part (r1 - r2) = frac_part r1 - frac_part r2 + 1.
 Proof.
-  intros; unfold frac_part in |- *; generalize (Rminus_Int_part2 r1 r2 H);
+  intros; unfold frac_part; generalize (Rminus_Int_part2 r1 r2 H);
     intro; rewrite H0; rewrite <- (Z_R_minus (Int_part r1 - Int_part r2) 1);
       rewrite <- (Z_R_minus (Int_part r1) (Int_part r2));
-        unfold Rminus in |- *;
+        unfold Rminus;
           rewrite
             (Ropp_plus_distr (IZR (Int_part r1) + - IZR (Int_part r2)) (- IZR 1))
             ; rewrite (Ropp_plus_distr r2 (- IZR (Int_part r2)));
               rewrite (Ropp_involutive (IZR 1));
                 rewrite (Ropp_involutive (IZR (Int_part r2)));
                   rewrite (Ropp_plus_distr (IZR (Int_part r1)));
-                    rewrite (Ropp_involutive (IZR (Int_part r2))); simpl in |- *;
+                    rewrite (Ropp_involutive (IZR (Int_part r2))); simpl;
                       rewrite <-
                         (Rplus_assoc (r1 + - r2) (- IZR (Int_part r1) + IZR (Int_part r2)) 1)
                         ; rewrite (Rplus_assoc r1 (- r2) (- IZR (Int_part r1) + IZR (Int_part r2)));
@@ -453,7 +451,7 @@ Proof.
           rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H0;
             rewrite <- (plus_IZR (Int_part r1 + Int_part r2 + 1) 1) in H0;
               generalize (up_tech (r1 + r2) (Int_part r1 + Int_part r2 + 1) H H0);
-                intro; clear H H0; unfold Int_part at 1 in |- *; omega.
+                intro; clear H H0; unfold Int_part at 1; omega.
 Qed.
 
 (**********)
@@ -516,7 +514,7 @@ Proof.
       rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H1;
         rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H1;
           generalize (up_tech (r1 + r2) (Int_part r1 + Int_part r2) H0 H1);
-            intro; clear H0 H1; unfold Int_part at 1 in |- *;
+            intro; clear H0 H1; unfold Int_part at 1;
               omega.
 Qed.
 
@@ -526,17 +524,17 @@ Lemma plus_frac_part1 :
     frac_part r1 + frac_part r2 >= 1 ->
     frac_part (r1 + r2) = frac_part r1 + frac_part r2 - 1.
 Proof.
-  intros; unfold frac_part in |- *; generalize (plus_Int_part1 r1 r2 H); intro;
+  intros; unfold frac_part; generalize (plus_Int_part1 r1 r2 H); intro;
     rewrite H0; rewrite (plus_IZR (Int_part r1 + Int_part r2) 1);
-      rewrite (plus_IZR (Int_part r1) (Int_part r2)); simpl in |- *;
-        unfold Rminus at 3 4 in |- *;
+      rewrite (plus_IZR (Int_part r1) (Int_part r2)); simpl;
+        unfold Rminus at 3 4;
           rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (r2 + - IZR (Int_part r2)));
             rewrite (Rplus_comm r2 (- IZR (Int_part r2)));
               rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- IZR (Int_part r2)) r2);
                 rewrite (Rplus_comm (- IZR (Int_part r1) + - IZR (Int_part r2)) r2);
                   rewrite <- (Rplus_assoc r1 r2 (- IZR (Int_part r1) + - IZR (Int_part r2)));
                     rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2)));
-                      unfold Rminus in |- *;
+                      unfold Rminus;
                         rewrite
                           (Rplus_assoc (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2))) (-1))
                           ; rewrite <- (Ropp_plus_distr (IZR (Int_part r1) + IZR (Int_part r2)) 1);
@@ -549,14 +547,14 @@ Lemma plus_frac_part2 :
     frac_part r1 + frac_part r2 < 1 ->
     frac_part (r1 + r2) = frac_part r1 + frac_part r2.
 Proof.
-  intros; unfold frac_part in |- *; generalize (plus_Int_part2 r1 r2 H); intro;
+  intros; unfold frac_part; generalize (plus_Int_part2 r1 r2 H); intro;
     rewrite H0; rewrite (plus_IZR (Int_part r1) (Int_part r2));
-      unfold Rminus at 2 3 in |- *;
+      unfold Rminus at 2 3;
         rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (r2 + - IZR (Int_part r2)));
           rewrite (Rplus_comm r2 (- IZR (Int_part r2)));
             rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- IZR (Int_part r2)) r2);
               rewrite (Rplus_comm (- IZR (Int_part r1) + - IZR (Int_part r2)) r2);
                 rewrite <- (Rplus_assoc r1 r2 (- IZR (Int_part r1) + - IZR (Int_part r2)));
                   rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2)));
-                    unfold Rminus in |- *; trivial with zarith real.
+                    unfold Rminus; trivial with zarith real.
 Qed.
diff --git a/theories/Reals/R_sqr.v b/theories/Reals/R_sqr.v
index df2267d1..d6e18d9d 100644
--- a/theories/Reals/R_sqr.v
+++ b/theories/Reals/R_sqr.v
@@ -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-2012     *)
 (*   \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.
+Local Open Scope R_scope.
 
 (****************************************************)
 (** Rsqr : some results                             *)
 (****************************************************)
 
-Ltac ring_Rsqr := unfold Rsqr in |- *; ring.
+Ltac ring_Rsqr := unfold Rsqr; ring.
 
 Lemma Rsqr_neg : forall x:R, Rsqr x = Rsqr (- x).
 Proof.
@@ -50,29 +48,29 @@ Qed.
 
 Lemma Rsqr_gt_0_0 : forall x:R, 0 < Rsqr x -> x <> 0.
 Proof.
-  intros; red in |- *; intro; rewrite H0 in H; rewrite Rsqr_0 in H;
+  intros; red; intro; rewrite H0 in H; rewrite Rsqr_0 in H;
     elim (Rlt_irrefl 0 H).
 Qed.
 
 Lemma Rsqr_pos_lt : forall x:R, x <> 0 -> 0 < Rsqr x.
 Proof.
   intros; case (Rtotal_order 0 x); intro;
-    [ unfold Rsqr in |- *; apply Rmult_lt_0_compat; assumption
+    [ unfold Rsqr; apply Rmult_lt_0_compat; assumption
       | elim H0; intro;
-        [ elim H; symmetry  in |- *; exact H1
+        [ elim H; symmetry ; exact H1
           | rewrite Rsqr_neg; generalize (Ropp_lt_gt_contravar x 0 H1);
-            rewrite Ropp_0; intro; unfold Rsqr in |- *;
+            rewrite Ropp_0; intro; unfold Rsqr;
               apply Rmult_lt_0_compat; assumption ] ].
 Qed.
 
 Lemma Rsqr_div : forall x y:R, y <> 0 -> Rsqr (x / y) = Rsqr x / Rsqr y.
 Proof.
-  intros; unfold Rsqr in |- *.
-  unfold Rdiv in |- *.
+  intros; unfold Rsqr.
+  unfold Rdiv.
   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.
@@ -82,7 +80,7 @@ Qed.
 
 Lemma Rsqr_eq_0 : forall x:R, Rsqr x = 0 -> x = 0.
 Proof.
-  unfold Rsqr in |- *; intros; generalize (Rmult_integral x x H); intro;
+  unfold Rsqr; intros; generalize (Rmult_integral x x H); intro;
     elim H0; intro; assumption.
 Qed.
 
@@ -124,7 +122,7 @@ Qed.
 Lemma Rsqr_incr_1 :
   forall x y:R, x <= y -> 0 <= x -> 0 <= y -> Rsqr x <= Rsqr y.
 Proof.
-  intros; unfold Rsqr in |- *; apply Rmult_le_compat; assumption.
+  intros; unfold Rsqr; apply Rmult_le_compat; assumption.
 Qed.
 
 Lemma Rsqr_incrst_0 :
@@ -142,7 +140,7 @@ Qed.
 Lemma Rsqr_incrst_1 :
   forall x y:R, x < y -> 0 <= x -> 0 <= y -> Rsqr x < Rsqr y.
 Proof.
-  intros; unfold Rsqr in |- *; apply Rmult_le_0_lt_compat; assumption.
+  intros; unfold Rsqr; apply Rmult_le_0_lt_compat; assumption.
 Qed.
 
 Lemma Rsqr_neg_pos_le_0 :
@@ -185,7 +183,7 @@ Qed.
 
 Lemma Rsqr_abs : forall x:R, Rsqr x = Rsqr (Rabs x).
 Proof.
-  intro; unfold Rabs in |- *; case (Rcase_abs x); intro;
+  intro; unfold Rabs; case (Rcase_abs x); intro;
     [ apply Rsqr_neg | reflexivity ].
 Qed.
 
@@ -222,7 +220,7 @@ Qed.
 
 Lemma Rsqr_eq_abs_0 : forall x y:R, Rsqr x = Rsqr y -> Rabs x = Rabs y.
 Proof.
-  intros; unfold Rabs in |- *; case (Rcase_abs x); case (Rcase_abs y); intros.
+  intros; unfold Rabs; case (Rcase_abs x); case (Rcase_abs y); intros.
   rewrite (Rsqr_neg x) in H; rewrite (Rsqr_neg y) in H;
     generalize (Ropp_lt_gt_contravar y 0 r);
       generalize (Ropp_lt_gt_contravar x 0 r0); rewrite Ropp_0;
@@ -290,7 +288,7 @@ Qed.
 
 Lemma Rsqr_inv : forall x:R, x <> 0 -> Rsqr (/ x) = / Rsqr x.
 Proof.
-  intros; unfold Rsqr in |- *.
+  intros; unfold Rsqr.
   rewrite Rinv_mult_distr; try reflexivity || assumption.
 Qed.
 
@@ -304,7 +302,7 @@ Proof.
   repeat rewrite Rmult_plus_distr_l.
   repeat rewrite Rplus_assoc.
   apply Rplus_eq_compat_l.
-  unfold Rdiv, Rminus in |- *.
+  unfold Rdiv, Rminus.
   replace (2 * 1 + 2 * 1) with 4; [ idtac | ring ].
   rewrite (Rmult_plus_distr_r (4 * a * c) (- Rsqr b) (/ (4 * a))).
   rewrite Rsqr_mult.
@@ -334,7 +332,7 @@ Proof.
   rewrite (Rmult_comm x).
   apply Rplus_eq_compat_l.
   rewrite (Rmult_comm (/ a)).
-  unfold Rsqr in |- *; repeat rewrite Rmult_assoc.
+  unfold Rsqr; repeat rewrite Rmult_assoc.
   rewrite <- Rinv_l_sym.
   rewrite Rmult_1_r.
   ring.
@@ -359,7 +357,7 @@ Proof.
       rewrite Rplus_opp_l; replace (- (y * y) + x * x) with ((x - y) * (x + y)).
   intro; generalize (Rmult_integral (x - y) (x + y) H0); intro; elim H1; intros.
   left; apply Rminus_diag_uniq; assumption.
-  right; apply Rminus_diag_uniq; unfold Rminus in |- *; rewrite Ropp_involutive;
+  right; apply Rminus_diag_uniq; unfold Rminus; rewrite Ropp_involutive;
     assumption.
   ring.
 Qed.
diff --git a/theories/Reals/R_sqrt.v b/theories/Reals/R_sqrt.v
index 26980c95..2d9419bd 100644
--- a/theories/Reals/R_sqrt.v
+++ b/theories/Reals/R_sqrt.v
@@ -1,17 +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-2012     *)
 (*   \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.
-Open Local Scope R_scope.
+Local Open Scope R_scope.
 
 (** * Continuous extension of Rsqrt on R *)
 Definition sqrt (x:R) : R :=
@@ -38,7 +36,7 @@ Qed.
 Lemma sqrt_sqrt : forall x:R, 0 <= x -> sqrt x * sqrt x = x.
 Proof.
   intros.
-  unfold sqrt in |- *.
+  unfold sqrt.
   case (Rcase_abs x); intro.
   elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ r H)).
   rewrite Rsqrt_Rsqrt; reflexivity.
@@ -46,7 +44,7 @@ Qed.
 
 Lemma sqrt_0 : sqrt 0 = 0.
 Proof.
-  apply Rsqr_eq_0; unfold Rsqr in |- *; apply sqrt_sqrt; right; reflexivity.
+  apply Rsqr_eq_0; unfold Rsqr; apply sqrt_sqrt; right; reflexivity.
 Qed.
 
 Lemma sqrt_1 : sqrt 1 = 1.
@@ -54,7 +52,7 @@ Proof.
   apply (Rsqr_inj (sqrt 1) 1);
     [ apply sqrt_positivity; left
       | left
-      | unfold Rsqr in |- *; rewrite sqrt_sqrt; [ ring | left ] ];
+      | unfold Rsqr; rewrite sqrt_sqrt; [ ring | left ] ];
     apply Rlt_0_1.
 Qed.
 
@@ -75,7 +73,7 @@ Proof.
   intros; apply Rsqr_inj;
     [ apply (sqrt_positivity x H)
       | assumption
-      | unfold Rsqr in |- *; rewrite H1; apply (sqrt_sqrt x H) ].
+      | unfold Rsqr; rewrite H1; apply (sqrt_sqrt x H) ].
 Qed.
 
 Lemma sqrt_def : forall x:R, 0 <= x -> sqrt x * sqrt x = x.
@@ -88,12 +86,12 @@ Proof.
   intros;
     apply
       (Rsqr_inj (sqrt (Rsqr x)) x (sqrt_positivity (Rsqr x) (Rle_0_sqr x)) H);
-      unfold Rsqr in |- *; apply (sqrt_sqrt (Rsqr x) (Rle_0_sqr x)).
+      unfold Rsqr; apply (sqrt_sqrt (Rsqr x) (Rle_0_sqr x)).
 Qed.
 
 Lemma sqrt_Rsqr : forall x:R, 0 <= x -> sqrt (Rsqr x) = x.
 Proof.
-  intros; unfold Rsqr in |- *; apply sqrt_square; assumption.
+  intros; unfold Rsqr; apply sqrt_square; assumption.
 Qed.
 
 Lemma sqrt_Rsqr_abs : forall x:R, sqrt (Rsqr x) = Rabs x.
@@ -103,7 +101,7 @@ Qed.
 
 Lemma Rsqr_sqrt : forall x:R, 0 <= x -> Rsqr (sqrt x) = x.
 Proof.
-  intros x H1; unfold Rsqr in |- *; apply (sqrt_sqrt x H1).
+  intros x H1; unfold Rsqr; apply (sqrt_sqrt x H1).
 Qed.
 
 Lemma sqrt_mult_alt :
@@ -302,7 +300,7 @@ Proof.
   intros x H1 H2;
     generalize (sqrt_lt_1 x 1 (Rlt_le 0 x H1) (Rlt_le 0 1 Rlt_0_1) H2);
       intro H3; rewrite sqrt_1 in H3; generalize (Rmult_ne (sqrt x));
-        intro H4; elim H4; intros H5 H6; rewrite <- H5; pattern x at 1 in |- *;
+        intro H4; elim H4; intros H5 H6; rewrite <- H5; pattern x at 1;
           rewrite <- (sqrt_def x (Rlt_le 0 x H1));
             apply (Rmult_lt_compat_l (sqrt x) (sqrt x) 1 (sqrt_lt_R0 x H1) H3).
 Qed.
@@ -312,7 +310,7 @@ Lemma sqrt_cauchy :
     a * c + b * d <= sqrt (Rsqr a + Rsqr b) * sqrt (Rsqr c + Rsqr d).
 Proof.
   intros a b c d; apply Rsqr_incr_0_var;
-    [ rewrite Rsqr_mult; repeat rewrite Rsqr_sqrt; unfold Rsqr in |- *;
+    [ rewrite Rsqr_mult; repeat rewrite Rsqr_sqrt; unfold Rsqr;
       [ replace ((a * c + b * d) * (a * c + b * d)) with
         (a * a * c * c + b * b * d * d + 2 * a * b * c * d);
         [ replace ((a * a + b * b) * (c * c + d * d)) with
@@ -321,11 +319,11 @@ Proof.
             replace (a * a * d * d + b * b * c * c) with
             (2 * a * b * c * d +
               (a * a * d * d + b * b * c * c - 2 * a * b * c * d));
-            [ pattern (2 * a * b * c * d) at 1 in |- *; rewrite <- Rplus_0_r;
+            [ pattern (2 * a * b * c * d) at 1; rewrite <- Rplus_0_r;
               apply Rplus_le_compat_l;
                 replace (a * a * d * d + b * b * c * c - 2 * a * b * c * d)
               with (Rsqr (a * d - b * c));
-                [ apply Rle_0_sqr | unfold Rsqr in |- *; ring ]
+                [ apply Rle_0_sqr | unfold Rsqr; ring ]
               | ring ]
             | ring ]
           | ring ]
@@ -357,16 +355,16 @@ Lemma Rsqr_sol_eq_0_1 :
     x = sol_x1 a b c \/ x = sol_x2 a b c -> a * Rsqr x + b * x + c = 0.
 Proof.
   intros; elim H0; intro.
-  unfold sol_x1 in H1; unfold Delta in H1; rewrite H1; unfold Rdiv in |- *;
+  unfold sol_x1 in H1; unfold Delta in H1; rewrite H1; unfold Rdiv;
     repeat rewrite Rsqr_mult; rewrite Rsqr_plus; rewrite <- Rsqr_neg;
       rewrite Rsqr_sqrt.
   rewrite Rsqr_inv.
-  unfold Rsqr in |- *; repeat rewrite Rinv_mult_distr.
+  unfold Rsqr; repeat rewrite Rinv_mult_distr.
   repeat rewrite Rmult_assoc; rewrite (Rmult_comm a).
   repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
   rewrite Rmult_1_r; rewrite Rmult_plus_distr_r.
   repeat rewrite Rmult_assoc.
-  pattern 2 at 2 in |- *; rewrite (Rmult_comm 2).
+  pattern 2 at 2; rewrite (Rmult_comm 2).
   repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
   rewrite Rmult_1_r.
   rewrite
@@ -378,7 +376,7 @@ Proof.
     (b * (- b * (/ 2 * / a)) +
       (b * (sqrt (b * b - 2 * (2 * (a * c))) * (/ 2 * / a)) + c))) with
   (b * (- b * (/ 2 * / a)) + c).
-  unfold Rminus in |- *; repeat rewrite <- Rplus_assoc.
+  unfold Rminus; repeat rewrite <- Rplus_assoc.
   replace (b * b + b * b) with (2 * (b * b)).
   rewrite Rmult_plus_distr_r; repeat rewrite Rmult_assoc.
   rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc.
@@ -409,17 +407,17 @@ Proof.
   apply prod_neq_R0; [ discrR | apply (cond_nonzero a) ].
   apply prod_neq_R0; [ discrR | apply (cond_nonzero a) ].
   assumption.
-  unfold sol_x2 in H1; unfold Delta in H1; rewrite H1; unfold Rdiv in |- *;
+  unfold sol_x2 in H1; unfold Delta in H1; rewrite H1; unfold Rdiv;
     repeat rewrite Rsqr_mult; rewrite Rsqr_minus; rewrite <- Rsqr_neg;
       rewrite Rsqr_sqrt.
   rewrite Rsqr_inv.
-  unfold Rsqr in |- *; repeat rewrite Rinv_mult_distr;
+  unfold Rsqr; repeat rewrite Rinv_mult_distr;
     repeat rewrite Rmult_assoc.
   rewrite (Rmult_comm a); repeat rewrite Rmult_assoc.
   rewrite <- Rinv_l_sym.
-  rewrite Rmult_1_r; unfold Rminus in |- *; rewrite Rmult_plus_distr_r.
+  rewrite Rmult_1_r; unfold Rminus; rewrite Rmult_plus_distr_r.
   rewrite Ropp_mult_distr_l_reverse; repeat rewrite Rmult_assoc;
-    pattern 2 at 2 in |- *; rewrite (Rmult_comm 2).
+    pattern 2 at 2; rewrite (Rmult_comm 2).
   repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
   rewrite Rmult_1_r;
     rewrite
@@ -482,23 +480,23 @@ Proof.
   intro;
     generalize (Rsqr_eq (x + b / (2 * a)) (sqrt (Delta a b c) / (2 * a)) H3);
       intro; elim H4; intro.
-  left; unfold sol_x1 in |- *;
+  left; unfold sol_x1;
     generalize
       (Rplus_eq_compat_l (- (b / (2 * a))) (x + b / (2 * a))
         (sqrt (Delta a b c) / (2 * a)) H5);
       replace (- (b / (2 * a)) + (x + b / (2 * a))) with x.
-  intro; rewrite H6; unfold Rdiv in |- *; ring.
+  intro; rewrite H6; unfold Rdiv; ring.
   ring.
-  right; unfold sol_x2 in |- *;
+  right; unfold sol_x2;
     generalize
       (Rplus_eq_compat_l (- (b / (2 * a))) (x + b / (2 * a))
         (- (sqrt (Delta a b c) / (2 * a))) H5);
       replace (- (b / (2 * a)) + (x + b / (2 * a))) with x.
-  intro; rewrite H6; unfold Rdiv in |- *; ring.
+  intro; rewrite H6; unfold Rdiv; ring.
   ring.
   rewrite Rsqr_div.
   rewrite Rsqr_sqrt.
-  unfold Rdiv in |- *.
+  unfold Rdiv.
   repeat rewrite Rmult_assoc.
   rewrite (Rmult_comm (/ a)).
   rewrite Rmult_assoc.
@@ -512,9 +510,9 @@ Proof.
   assumption.
   apply prod_neq_R0; [ discrR | apply (cond_nonzero a) ].
   rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
-  symmetry  in |- *; apply Rmult_1_l.
+  symmetry ; apply Rmult_1_l.
   apply (cond_nonzero a).
-  unfold Rdiv in |- *; rewrite <- Ropp_mult_distr_l_reverse.
+  unfold Rdiv; rewrite <- Ropp_mult_distr_l_reverse.
   rewrite Ropp_minus_distr.
   reflexivity.
   reflexivity.
diff --git a/theories/Reals/Ranalysis.v b/theories/Reals/Ranalysis.v
index 39c2271b..ad86a197 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-2012     *)
 (*   \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.
@@ -28,775 +26,4 @@ Require Export RList.
 Require Export Sqrt_reg.
 Require Export Ranalysis4.
 Require Export Rpower.
-Open Local Scope R_scope.
-
-Axiom AppVar : R.
-
-(**********)
-Ltac intro_hyp_glob trm :=
-  match constr:trm with
-    | (?X1 + ?X2)%F =>
-      match goal with
-        |  |- (derivable _) => intro_hyp_glob X1; intro_hyp_glob X2
-        |  |- (continuity _) => intro_hyp_glob X1; intro_hyp_glob X2
-        | _ => idtac
-      end
-    | (?X1 - ?X2)%F =>
-      match goal with
-        |  |- (derivable _) => intro_hyp_glob X1; intro_hyp_glob X2
-        |  |- (continuity _) => intro_hyp_glob X1; intro_hyp_glob X2
-        | _ => idtac
-      end
-    | (?X1 * ?X2)%F =>
-      match goal with
-        |  |- (derivable _) => intro_hyp_glob X1; intro_hyp_glob X2
-        |  |- (continuity _) => intro_hyp_glob X1; intro_hyp_glob X2
-        | _ => idtac
-      end
-    | (?X1 / ?X2)%F =>
-      let aux := constr:X2 in
-        match goal with
-          | _:(forall x0:R, aux x0 <> 0) |- (derivable _) =>
-            intro_hyp_glob X1; intro_hyp_glob X2
-          | _:(forall x0:R, aux x0 <> 0) |- (continuity _) =>
-            intro_hyp_glob X1; intro_hyp_glob X2
-          |  |- (derivable _) =>
-            cut (forall x0:R, aux x0 <> 0);
-              [ intro; intro_hyp_glob X1; intro_hyp_glob X2 | try assumption ]
-          |  |- (continuity _) =>
-            cut (forall x0:R, aux x0 <> 0);
-              [ intro; intro_hyp_glob X1; intro_hyp_glob X2 | try assumption ]
-          | _ => idtac
-        end
-    | (comp ?X1 ?X2) =>
-      match goal with
-        |  |- (derivable _) => intro_hyp_glob X1; intro_hyp_glob X2
-        |  |- (continuity _) => intro_hyp_glob X1; intro_hyp_glob X2
-        | _ => idtac
-      end
-    | (- ?X1)%F =>
-      match goal with
-        |  |- (derivable _) => intro_hyp_glob X1
-        |  |- (continuity _) => intro_hyp_glob X1
-        | _ => idtac
-      end
-    | (/ ?X1)%F =>
-      let aux := constr:X1 in
-        match goal with
-          | _:(forall x0:R, aux x0 <> 0) |- (derivable _) =>
-            intro_hyp_glob X1
-          | _:(forall x0:R, aux x0 <> 0) |- (continuity _) =>
-            intro_hyp_glob X1
-          |  |- (derivable _) =>
-            cut (forall x0:R, aux x0 <> 0);
-              [ intro; intro_hyp_glob X1 | try assumption ]
-          |  |- (continuity _) =>
-            cut (forall x0:R, aux x0 <> 0);
-              [ intro; intro_hyp_glob X1 | try assumption ]
-          | _ => idtac
-        end
-    | cos => idtac
-    | sin => idtac
-    | cosh => idtac
-    | sinh => idtac
-    | exp => idtac
-    | Rsqr => idtac
-    | sqrt => idtac
-    | id => idtac
-    | (fct_cte _) => idtac
-    | (pow_fct _) => idtac
-    | Rabs => idtac
-    | ?X1 =>
-      let p := constr:X1 in
-        match goal with
-          | _:(derivable p) |- _ => idtac
-          |  |- (derivable p) => idtac
-          |  |- (derivable _) =>
-            cut (True -> derivable p);
-              [ intro HYPPD; cut (derivable p);
-                [ intro; clear HYPPD | apply HYPPD; clear HYPPD; trivial ]
-                | idtac ]
-          | _:(continuity p) |- _ => idtac
-          |  |- (continuity p) => idtac
-          |  |- (continuity _) =>
-            cut (True -> continuity p);
-              [ intro HYPPD; cut (continuity p);
-                [ intro; clear HYPPD | apply HYPPD; clear HYPPD; trivial ]
-                | idtac ]
-          | _ => idtac
-        end
-  end.
-
-(**********)
-Ltac intro_hyp_pt trm pt :=
-  match constr:trm with
-    | (?X1 + ?X2)%F =>
-      match goal with
-        |  |- (derivable_pt _ _) => intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
-        |  |- (continuity_pt _ _) => intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
-        |  |- (derive_pt _ _ _ = _) =>
-          intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
-        | _ => idtac
-      end
-    | (?X1 - ?X2)%F =>
-      match goal with
-        |  |- (derivable_pt _ _) => intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
-        |  |- (continuity_pt _ _) => intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
-        |  |- (derive_pt _ _ _ = _) =>
-          intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
-        | _ => idtac
-      end
-    | (?X1 * ?X2)%F =>
-      match goal with
-        |  |- (derivable_pt _ _) => intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
-        |  |- (continuity_pt _ _) => intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
-        |  |- (derive_pt _ _ _ = _) =>
-          intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
-        | _ => idtac
-      end
-    | (?X1 / ?X2)%F =>
-      let aux := constr:X2 in
-        match goal with
-          | _:(aux pt <> 0) |- (derivable_pt _ _) =>
-            intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
-          | _:(aux pt <> 0) |- (continuity_pt _ _) =>
-            intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
-          | _:(aux pt <> 0) |- (derive_pt _ _ _ = _) =>
-            intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
-          | id:(forall x0:R, aux x0 <> 0) |- (derivable_pt _ _) =>
-            generalize (id pt); intro; intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
-          | id:(forall x0:R, aux x0 <> 0) |- (continuity_pt _ _) =>
-            generalize (id pt); intro; intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
-          | id:(forall x0:R, aux x0 <> 0) |- (derive_pt _ _ _ = _) =>
-            generalize (id pt); intro; intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
-          |  |- (derivable_pt _ _) =>
-            cut (aux pt <> 0);
-              [ intro; intro_hyp_pt X1 pt; intro_hyp_pt X2 pt | try assumption ]
-          |  |- (continuity_pt _ _) =>
-            cut (aux pt <> 0);
-              [ intro; intro_hyp_pt X1 pt; intro_hyp_pt X2 pt | try assumption ]
-          |  |- (derive_pt _ _ _ = _) =>
-            cut (aux pt <> 0);
-              [ intro; intro_hyp_pt X1 pt; intro_hyp_pt X2 pt | try assumption ]
-          | _ => idtac
-        end
-    | (comp ?X1 ?X2) =>
-      match goal with
-        |  |- (derivable_pt _ _) =>
-          let pt_f1 := eval cbv beta in (X2 pt) in
-            (intro_hyp_pt X1 pt_f1; intro_hyp_pt X2 pt)
-        |  |- (continuity_pt _ _) =>
-          let pt_f1 := eval cbv beta in (X2 pt) in
-            (intro_hyp_pt X1 pt_f1; intro_hyp_pt X2 pt)
-        |  |- (derive_pt _ _ _ = _) =>
-          let pt_f1 := eval cbv beta in (X2 pt) in
-            (intro_hyp_pt X1 pt_f1; intro_hyp_pt X2 pt)
-        | _ => idtac
-      end
-    | (- ?X1)%F =>
-      match goal with
-        |  |- (derivable_pt _ _) => intro_hyp_pt X1 pt
-        |  |- (continuity_pt _ _) => intro_hyp_pt X1 pt
-        |  |- (derive_pt _ _ _ = _) => intro_hyp_pt X1 pt
-        | _ => idtac
-      end
-    | (/ ?X1)%F =>
-      let aux := constr:X1 in
-        match goal with
-          | _:(aux pt <> 0) |- (derivable_pt _ _) =>
-            intro_hyp_pt X1 pt
-          | _:(aux pt <> 0) |- (continuity_pt _ _) =>
-            intro_hyp_pt X1 pt
-          | _:(aux pt <> 0) |- (derive_pt _ _ _ = _) =>
-            intro_hyp_pt X1 pt
-          | id:(forall x0:R, aux x0 <> 0) |- (derivable_pt _ _) =>
-            generalize (id pt); intro; intro_hyp_pt X1 pt
-          | id:(forall x0:R, aux x0 <> 0) |- (continuity_pt _ _) =>
-            generalize (id pt); intro; intro_hyp_pt X1 pt
-          | id:(forall x0:R, aux x0 <> 0) |- (derive_pt _ _ _ = _) =>
-            generalize (id pt); intro; intro_hyp_pt X1 pt
-          |  |- (derivable_pt _ _) =>
-            cut (aux pt <> 0); [ intro; intro_hyp_pt X1 pt | try assumption ]
-          |  |- (continuity_pt _ _) =>
-            cut (aux pt <> 0); [ intro; intro_hyp_pt X1 pt | try assumption ]
-          |  |- (derive_pt _ _ _ = _) =>
-            cut (aux pt <> 0); [ intro; intro_hyp_pt X1 pt | try assumption ]
-          | _ => idtac
-        end
-    | cos => idtac
-    | sin => idtac
-    | cosh => idtac
-    | sinh => idtac
-    | exp => idtac
-    | Rsqr => idtac
-    | id => idtac
-    | (fct_cte _) => idtac
-    | (pow_fct _) => idtac
-    | sqrt =>
-      match goal with
-        |  |- (derivable_pt _ _) => cut (0 < pt); [ intro | try assumption ]
-        |  |- (continuity_pt _ _) =>
-          cut (0 <= pt); [ intro | try assumption ]
-        |  |- (derive_pt _ _ _ = _) =>
-          cut (0 < pt); [ intro | try assumption ]
-        | _ => idtac
-      end
-    | Rabs =>
-      match goal with
-        |  |- (derivable_pt _ _) =>
-          cut (pt <> 0); [ intro | try assumption ]
-        | _ => idtac
-      end
-    | ?X1 =>
-      let p := constr:X1 in
-        match goal with
-          | _:(derivable_pt p pt) |- _ => idtac
-          |  |- (derivable_pt p pt) => idtac
-          |  |- (derivable_pt _ _) =>
-            cut (True -> derivable_pt p pt);
-              [ intro HYPPD; cut (derivable_pt p pt);
-                [ intro; clear HYPPD | apply HYPPD; clear HYPPD; trivial ]
-                | idtac ]
-          | _:(continuity_pt p pt) |- _ => idtac
-          |  |- (continuity_pt p pt) => idtac
-          |  |- (continuity_pt _ _) =>
-            cut (True -> continuity_pt p pt);
-              [ intro HYPPD; cut (continuity_pt p pt);
-                [ intro; clear HYPPD | apply HYPPD; clear HYPPD; trivial ]
-                | idtac ]
-          |  |- (derive_pt _ _ _ = _) =>
-            cut (True -> derivable_pt p pt);
-              [ intro HYPPD; cut (derivable_pt p pt);
-                [ intro; clear HYPPD | apply HYPPD; clear HYPPD; trivial ]
-                | idtac ]
-          | _ => idtac
-        end
-  end.
-
-(**********)
-Ltac is_diff_pt :=
-  match goal with
-    |  |- (derivable_pt Rsqr _) =>
-
-  (* fonctions de base *)
-      apply derivable_pt_Rsqr
-    |  |- (derivable_pt id ?X1) => apply (derivable_pt_id X1)
-    |  |- (derivable_pt (fct_cte _) _) => apply derivable_pt_const
-    |  |- (derivable_pt sin _) => apply derivable_pt_sin
-    |  |- (derivable_pt cos _) => apply derivable_pt_cos
-    |  |- (derivable_pt sinh _) => apply derivable_pt_sinh
-    |  |- (derivable_pt cosh _) => apply derivable_pt_cosh
-    |  |- (derivable_pt exp _) => apply derivable_pt_exp
-    |  |- (derivable_pt (pow_fct _) _) =>
-      unfold pow_fct in |- *; apply derivable_pt_pow
-    |  |- (derivable_pt sqrt ?X1) =>
-      apply (derivable_pt_sqrt X1);
-        assumption ||
-          unfold plus_fct, minus_fct, opp_fct, mult_fct, div_fct, inv_fct,
-            comp, id, fct_cte, pow_fct in |- *
-    |  |- (derivable_pt Rabs ?X1) =>
-      apply (Rderivable_pt_abs X1);
-        assumption ||
-          unfold plus_fct, minus_fct, opp_fct, mult_fct, div_fct, inv_fct,
-            comp, id, fct_cte, pow_fct in |- *
-        (* regles de differentiabilite *)
-        (* PLUS *)
-    |  |- (derivable_pt (?X1 + ?X2) ?X3) =>
-      apply (derivable_pt_plus X1 X2 X3); is_diff_pt
-       (* MOINS *)
-    |  |- (derivable_pt (?X1 - ?X2) ?X3) =>
-      apply (derivable_pt_minus X1 X2 X3); is_diff_pt
-       (* OPPOSE *)
-    |  |- (derivable_pt (- ?X1) ?X2) =>
-      apply (derivable_pt_opp X1 X2);
-        is_diff_pt
-       (* MULTIPLICATION PAR UN SCALAIRE *)
-    |  |- (derivable_pt (mult_real_fct ?X1 ?X2) ?X3) =>
-      apply (derivable_pt_scal X2 X1 X3); is_diff_pt
-       (* MULTIPLICATION *)
-    |  |- (derivable_pt (?X1 * ?X2) ?X3) =>
-      apply (derivable_pt_mult X1 X2 X3); is_diff_pt
-       (* DIVISION *)
-    |  |- (derivable_pt (?X1 / ?X2) ?X3) =>
-      apply (derivable_pt_div X1 X2 X3);
-        [ is_diff_pt
-          | is_diff_pt
-          | try
-            assumption ||
-              unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct,
-                comp, pow_fct, id, fct_cte in |- * ]
-    |  |- (derivable_pt (/ ?X1) ?X2) =>
-
-       (* INVERSION *)
-      apply (derivable_pt_inv X1 X2);
-        [ assumption ||
-          unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct,
-            comp, pow_fct, id, fct_cte in |- *
-          | is_diff_pt ]
-    |  |- (derivable_pt (comp ?X1 ?X2) ?X3) =>
-
-       (* COMPOSITION *)
-      apply (derivable_pt_comp X2 X1 X3); is_diff_pt
-    | _:(derivable_pt ?X1 ?X2) |- (derivable_pt ?X1 ?X2) =>
-      assumption
-    | _:(derivable ?X1) |- (derivable_pt ?X1 ?X2) =>
-      cut (derivable X1); [ intro HypDDPT; apply HypDDPT | assumption ]
-    |  |- (True -> derivable_pt _ _) =>
-      intro HypTruE; clear HypTruE; is_diff_pt
-    | _ =>
-      try
-        unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct, id,
-          fct_cte, comp, pow_fct in |- *
-  end.
-
-(**********)
-Ltac is_diff_glob :=
-  match goal with
-    |  |- (derivable Rsqr) =>
-  (* fonctions de base *)
-      apply derivable_Rsqr
-    |  |- (derivable id) => apply derivable_id
-    |  |- (derivable (fct_cte _)) => apply derivable_const
-    |  |- (derivable sin) => apply derivable_sin
-    |  |- (derivable cos) => apply derivable_cos
-    |  |- (derivable cosh) => apply derivable_cosh
-    |  |- (derivable sinh) => apply derivable_sinh
-    |  |- (derivable exp) => apply derivable_exp
-    |  |- (derivable (pow_fct _)) =>
-      unfold pow_fct in |- *;
-        apply derivable_pow
-        (* regles de differentiabilite *)
-        (* PLUS *)
-    |  |- (derivable (?X1 + ?X2)) =>
-      apply (derivable_plus X1 X2); is_diff_glob
-       (* MOINS *)
-    |  |- (derivable (?X1 - ?X2)) =>
-      apply (derivable_minus X1 X2); is_diff_glob
-       (* OPPOSE *)
-    |  |- (derivable (- ?X1)) =>
-      apply (derivable_opp X1);
-        is_diff_glob
-       (* MULTIPLICATION PAR UN SCALAIRE *)
-    |  |- (derivable (mult_real_fct ?X1 ?X2)) =>
-      apply (derivable_scal X2 X1); is_diff_glob
-       (* MULTIPLICATION *)
-    |  |- (derivable (?X1 * ?X2)) =>
-      apply (derivable_mult X1 X2); is_diff_glob
-       (* DIVISION *)
-    |  |- (derivable (?X1 / ?X2)) =>
-      apply (derivable_div X1 X2);
-        [ is_diff_glob
-          | is_diff_glob
-          | try
-            assumption ||
-              unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct,
-                id, fct_cte, comp, pow_fct in |- * ]
-    |  |- (derivable (/ ?X1)) =>
-
-       (* INVERSION *)
-      apply (derivable_inv X1);
-        [ try
-          assumption ||
-            unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct,
-              id, fct_cte, comp, pow_fct in |- *
-          | is_diff_glob ]
-    |  |- (derivable (comp sqrt _)) =>
-
-       (* COMPOSITION *)
-      unfold derivable in |- *; intro; try is_diff_pt
-    |  |- (derivable (comp Rabs _)) =>
-      unfold derivable in |- *; intro; try is_diff_pt
-    |  |- (derivable (comp ?X1 ?X2)) =>
-      apply (derivable_comp X2 X1); is_diff_glob
-    | _:(derivable ?X1) |- (derivable ?X1) => assumption
-    |  |- (True -> derivable _) =>
-      intro HypTruE; clear HypTruE; is_diff_glob
-    | _ =>
-      try
-        unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct, id,
-          fct_cte, comp, pow_fct in |- *
-  end.
-
-(**********)
-Ltac is_cont_pt :=
-  match goal with
-    |  |- (continuity_pt Rsqr _) =>
-
-       (* fonctions de base *)
-      apply derivable_continuous_pt; apply derivable_pt_Rsqr
-    |  |- (continuity_pt id ?X1) =>
-      apply derivable_continuous_pt; apply (derivable_pt_id X1)
-    |  |- (continuity_pt (fct_cte _) _) =>
-      apply derivable_continuous_pt; apply derivable_pt_const
-    |  |- (continuity_pt sin _) =>
-      apply derivable_continuous_pt; apply derivable_pt_sin
-    |  |- (continuity_pt cos _) =>
-      apply derivable_continuous_pt; apply derivable_pt_cos
-    |  |- (continuity_pt sinh _) =>
-      apply derivable_continuous_pt; apply derivable_pt_sinh
-    |  |- (continuity_pt cosh _) =>
-      apply derivable_continuous_pt; apply derivable_pt_cosh
-    |  |- (continuity_pt exp _) =>
-      apply derivable_continuous_pt; apply derivable_pt_exp
-    |  |- (continuity_pt (pow_fct _) _) =>
-      unfold pow_fct in |- *; apply derivable_continuous_pt;
-        apply derivable_pt_pow
-    |  |- (continuity_pt sqrt ?X1) =>
-      apply continuity_pt_sqrt;
-        assumption ||
-          unfold plus_fct, minus_fct, opp_fct, mult_fct, div_fct, inv_fct,
-            comp, id, fct_cte, pow_fct in |- *
-    |  |- (continuity_pt Rabs ?X1) =>
-      apply (Rcontinuity_abs X1)
-       (* regles de differentiabilite *)
-       (* PLUS *)
-    |  |- (continuity_pt (?X1 + ?X2) ?X3) =>
-      apply (continuity_pt_plus X1 X2 X3); is_cont_pt
-       (* MOINS *)
-    |  |- (continuity_pt (?X1 - ?X2) ?X3) =>
-      apply (continuity_pt_minus X1 X2 X3); is_cont_pt
-       (* OPPOSE *)
-    |  |- (continuity_pt (- ?X1) ?X2) =>
-      apply (continuity_pt_opp X1 X2);
-        is_cont_pt
-       (* MULTIPLICATION PAR UN SCALAIRE *)
-    |  |- (continuity_pt (mult_real_fct ?X1 ?X2) ?X3) =>
-      apply (continuity_pt_scal X2 X1 X3); is_cont_pt
-       (* MULTIPLICATION *)
-    |  |- (continuity_pt (?X1 * ?X2) ?X3) =>
-      apply (continuity_pt_mult X1 X2 X3); is_cont_pt
-       (* DIVISION *)
-    |  |- (continuity_pt (?X1 / ?X2) ?X3) =>
-      apply (continuity_pt_div X1 X2 X3);
-        [ is_cont_pt
-          | is_cont_pt
-          | try
-            assumption ||
-              unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct,
-                comp, id, fct_cte, pow_fct in |- * ]
-    |  |- (continuity_pt (/ ?X1) ?X2) =>
-
-       (* INVERSION *)
-      apply (continuity_pt_inv X1 X2);
-        [ is_cont_pt
-          | assumption ||
-            unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct,
-              comp, id, fct_cte, pow_fct in |- * ]
-    |  |- (continuity_pt (comp ?X1 ?X2) ?X3) =>
-
-       (* COMPOSITION *)
-      apply (continuity_pt_comp X2 X1 X3); is_cont_pt
-    | _:(continuity_pt ?X1 ?X2) |- (continuity_pt ?X1 ?X2) =>
-      assumption
-    | _:(continuity ?X1) |- (continuity_pt ?X1 ?X2) =>
-      cut (continuity X1); [ intro HypDDPT; apply HypDDPT | assumption ]
-    | _:(derivable_pt ?X1 ?X2) |- (continuity_pt ?X1 ?X2) =>
-      apply derivable_continuous_pt; assumption
-    | _:(derivable ?X1) |- (continuity_pt ?X1 ?X2) =>
-      cut (continuity X1);
-        [ intro HypDDPT; apply HypDDPT
-          | apply derivable_continuous; assumption ]
-    |  |- (True -> continuity_pt _ _) =>
-      intro HypTruE; clear HypTruE; is_cont_pt
-    | _ =>
-      try
-        unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct, id,
-          fct_cte, comp, pow_fct in |- *
-  end.
-
-(**********)
-Ltac is_cont_glob :=
-  match goal with
-    |  |- (continuity Rsqr) =>
-
-       (* fonctions de base *)
-      apply derivable_continuous; apply derivable_Rsqr
-    |  |- (continuity id) => apply derivable_continuous; apply derivable_id
-    |  |- (continuity (fct_cte _)) =>
-      apply derivable_continuous; apply derivable_const
-    |  |- (continuity sin) => apply derivable_continuous; apply derivable_sin
-    |  |- (continuity cos) => apply derivable_continuous; apply derivable_cos
-    |  |- (continuity exp) => apply derivable_continuous; apply derivable_exp
-    |  |- (continuity (pow_fct _)) =>
-      unfold pow_fct in |- *; apply derivable_continuous; apply derivable_pow
-    |  |- (continuity sinh) =>
-      apply derivable_continuous; apply derivable_sinh
-    |  |- (continuity cosh) =>
-      apply derivable_continuous; apply derivable_cosh
-    |  |- (continuity Rabs) =>
-      apply Rcontinuity_abs
-       (* regles de continuite *)
-       (* PLUS *)
-    |  |- (continuity (?X1 + ?X2)) =>
-      apply (continuity_plus X1 X2);
-        try is_cont_glob || assumption
-            (* MOINS *)
-    |  |- (continuity (?X1 - ?X2)) =>
-      apply (continuity_minus X1 X2);
-        try is_cont_glob || assumption
-            (* OPPOSE *)
-    |  |- (continuity (- ?X1)) =>
-      apply (continuity_opp X1); try is_cont_glob || assumption
-                                      (* INVERSE *)
-    |  |- (continuity (/ ?X1)) =>
-      apply (continuity_inv X1);
-        try is_cont_glob || assumption
-            (* MULTIPLICATION PAR UN SCALAIRE *)
-    |  |- (continuity (mult_real_fct ?X1 ?X2)) =>
-      apply (continuity_scal X2 X1);
-        try is_cont_glob || assumption
-            (* MULTIPLICATION *)
-    |  |- (continuity (?X1 * ?X2)) =>
-      apply (continuity_mult X1 X2);
-        try is_cont_glob || assumption
-            (* DIVISION *)
-    |  |- (continuity (?X1 / ?X2)) =>
-      apply (continuity_div X1 X2);
-        [ try is_cont_glob || assumption
-          | try is_cont_glob || assumption
-          | try
-            assumption ||
-              unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct,
-                id, fct_cte, pow_fct in |- * ]
-    |  |- (continuity (comp sqrt _)) =>
-
-       (* COMPOSITION *)
-      unfold continuity_pt in |- *; intro; try is_cont_pt
-    |  |- (continuity (comp ?X1 ?X2)) =>
-      apply (continuity_comp X2 X1); try is_cont_glob || assumption
-    | _:(continuity ?X1) |- (continuity ?X1) => assumption
-    |  |- (True -> continuity _) =>
-      intro HypTruE; clear HypTruE; is_cont_glob
-    | _:(derivable ?X1) |- (continuity ?X1) =>
-      apply derivable_continuous; assumption
-    | _ =>
-      try
-        unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct, id,
-          fct_cte, comp, pow_fct in |- *
-  end.
-
-(**********)
-Ltac rew_term trm :=
-  match constr:trm with
-    | (?X1 + ?X2) =>
-      let p1 := rew_term X1 with p2 := rew_term X2 in
-        match constr:p1 with
-          | (fct_cte ?X3) =>
-            match constr:p2 with
-              | (fct_cte ?X4) => constr:(fct_cte (X3 + X4))
-              | _ => constr:(p1 + p2)%F
-            end
-          | _ => constr:(p1 + p2)%F
-        end
-    | (?X1 - ?X2) =>
-      let p1 := rew_term X1 with p2 := rew_term X2 in
-        match constr:p1 with
-          | (fct_cte ?X3) =>
-            match constr:p2 with
-              | (fct_cte ?X4) => constr:(fct_cte (X3 - X4))
-              | _ => constr:(p1 - p2)%F
-            end
-          | _ => constr:(p1 - p2)%F
-        end
-    | (?X1 / ?X2) =>
-      let p1 := rew_term X1 with p2 := rew_term X2 in
-        match constr:p1 with
-          | (fct_cte ?X3) =>
-            match constr:p2 with
-              | (fct_cte ?X4) => constr:(fct_cte (X3 / X4))
-              | _ => constr:(p1 / p2)%F
-            end
-          | _ =>
-            match constr:p2 with
-              | (fct_cte ?X4) => constr:(p1 * fct_cte (/ X4))%F
-              | _ => constr:(p1 / p2)%F
-            end
-        end
-    | (?X1 * / ?X2) =>
-      let p1 := rew_term X1 with p2 := rew_term X2 in
-        match constr:p1 with
-          | (fct_cte ?X3) =>
-            match constr:p2 with
-              | (fct_cte ?X4) => constr:(fct_cte (X3 / X4))
-              | _ => constr:(p1 / p2)%F
-            end
-          | _ =>
-            match constr:p2 with
-              | (fct_cte ?X4) => constr:(p1 * fct_cte (/ X4))%F
-              | _ => constr:(p1 / p2)%F
-            end
-        end
-    | (?X1 * ?X2) =>
-      let p1 := rew_term X1 with p2 := rew_term X2 in
-        match constr:p1 with
-          | (fct_cte ?X3) =>
-            match constr:p2 with
-              | (fct_cte ?X4) => constr:(fct_cte (X3 * X4))
-              | _ => constr:(p1 * p2)%F
-            end
-          | _ => constr:(p1 * p2)%F
-        end
-    | (- ?X1) =>
-      let p := rew_term X1 in
-        match constr:p with
-          | (fct_cte ?X2) => constr:(fct_cte (- X2))
-          | _ => constr:(- p)%F
-        end
-    | (/ ?X1) =>
-      let p := rew_term X1 in
-        match constr:p with
-          | (fct_cte ?X2) => constr:(fct_cte (/ X2))
-          | _ => constr:(/ p)%F
-        end
-    | (?X1 AppVar) => constr:X1
-    | (?X1 ?X2) =>
-      let p := rew_term X2 in
-        match constr:p with
-          | (fct_cte ?X3) => constr:(fct_cte (X1 X3))
-          | _ => constr:(comp X1 p)
-        end
-    | AppVar => constr:id
-    | (AppVar ^ ?X1) => constr:(pow_fct X1)
-    | (?X1 ^ ?X2) =>
-      let p := rew_term X1 in
-        match constr:p with
-          | (fct_cte ?X3) => constr:(fct_cte (pow_fct X2 X3))
-          | _ => constr:(comp (pow_fct X2) p)
-        end
-    | ?X1 => constr:(fct_cte X1)
-  end.
-
-(**********)
-Ltac deriv_proof trm pt :=
-  match constr:trm with
-    | (?X1 + ?X2)%F =>
-      let p1 := deriv_proof X1 pt with p2 := deriv_proof X2 pt in
-        constr:(derivable_pt_plus X1 X2 pt p1 p2)
-    | (?X1 - ?X2)%F =>
-      let p1 := deriv_proof X1 pt with p2 := deriv_proof X2 pt in
-        constr:(derivable_pt_minus X1 X2 pt p1 p2)
-    | (?X1 * ?X2)%F =>
-      let p1 := deriv_proof X1 pt with p2 := deriv_proof X2 pt in
-        constr:(derivable_pt_mult X1 X2 pt p1 p2)
-    | (?X1 / ?X2)%F =>
-      match goal with
-        | id:(?X2 pt <> 0) |- _ =>
-          let p1 := deriv_proof X1 pt with p2 := deriv_proof X2 pt in
-            constr:(derivable_pt_div X1 X2 pt p1 p2 id)
-        | _ => constr:False
-      end
-    | (/ ?X1)%F =>
-      match goal with
-        | id:(?X1 pt <> 0) |- _ =>
-          let p1 := deriv_proof X1 pt in
-            constr:(derivable_pt_inv X1 pt p1 id)
-        | _ => constr:False
-      end
-    | (comp ?X1 ?X2) =>
-      let pt_f1 := eval cbv beta in (X2 pt) in
-        let p1 := deriv_proof X1 pt_f1 with p2 := deriv_proof X2 pt in
-          constr:(derivable_pt_comp X2 X1 pt p2 p1)
-    | (- ?X1)%F =>
-      let p1 := deriv_proof X1 pt in
-        constr:(derivable_pt_opp X1 pt p1)
-    | sin => constr:(derivable_pt_sin pt)
-    | cos => constr:(derivable_pt_cos pt)
-    | sinh => constr:(derivable_pt_sinh pt)
-    | cosh => constr:(derivable_pt_cosh pt)
-    | exp => constr:(derivable_pt_exp pt)
-    | id => constr:(derivable_pt_id pt)
-    | Rsqr => constr:(derivable_pt_Rsqr pt)
-    | sqrt =>
-      match goal with
-        | id:(0 < pt) |- _ => constr:(derivable_pt_sqrt pt id)
-        | _ => constr:False
-      end
-    | (fct_cte ?X1) => constr:(derivable_pt_const X1 pt)
-    | ?X1 =>
-      let aux := constr:X1 in
-        match goal with
-          | id:(derivable_pt aux pt) |- _ => constr:id
-          | id:(derivable aux) |- _ => constr:(id pt)
-          | _ => constr:False
-        end
-  end.
-
-(**********)
-Ltac simplify_derive trm pt :=
-  match constr:trm with
-    | (?X1 + ?X2)%F =>
-      try rewrite derive_pt_plus; simplify_derive X1 pt;
-        simplify_derive X2 pt
-    | (?X1 - ?X2)%F =>
-      try rewrite derive_pt_minus; simplify_derive X1 pt;
-        simplify_derive X2 pt
-    | (?X1 * ?X2)%F =>
-      try rewrite derive_pt_mult; simplify_derive X1 pt;
-        simplify_derive X2 pt
-    | (?X1 / ?X2)%F =>
-      try rewrite derive_pt_div; simplify_derive X1 pt; simplify_derive X2 pt
-    | (comp ?X1 ?X2) =>
-      let pt_f1 := eval cbv beta in (X2 pt) in
-        (try rewrite derive_pt_comp; simplify_derive X1 pt_f1;
-          simplify_derive X2 pt)
-    | (- ?X1)%F => try rewrite derive_pt_opp; simplify_derive X1 pt
-    | (/ ?X1)%F =>
-      try rewrite derive_pt_inv; simplify_derive X1 pt
-    | (fct_cte ?X1) => try rewrite derive_pt_const
-    | id => try rewrite derive_pt_id
-    | sin => try rewrite derive_pt_sin
-    | cos => try rewrite derive_pt_cos
-    | sinh => try rewrite derive_pt_sinh
-    | cosh => try rewrite derive_pt_cosh
-    | exp => try rewrite derive_pt_exp
-    | Rsqr => try rewrite derive_pt_Rsqr
-    | sqrt => try rewrite derive_pt_sqrt
-    | ?X1 =>
-      let aux := constr:X1 in
-        match goal with
-          | id:(derive_pt aux pt ?X2 = _),H:(derivable aux) |- _ =>
-            try replace (derive_pt aux pt (H pt)) with (derive_pt aux pt X2);
-              [ rewrite id | apply pr_nu ]
-          | id:(derive_pt aux pt ?X2 = _),H:(derivable_pt aux pt) |- _ =>
-            try replace (derive_pt aux pt H) with (derive_pt aux pt X2);
-              [ rewrite id | apply pr_nu ]
-          | _ => idtac
-        end
-    | _ => idtac
-  end.
-
-(**********)
-Ltac reg :=
-  match goal with
-    |  |- (derivable_pt ?X1 ?X2) =>
-      let trm := eval cbv beta in (X1 AppVar) in
-        let aux := rew_term trm in
-          (intro_hyp_pt aux X2;
-            try (change (derivable_pt aux X2) in |- *; is_diff_pt) || is_diff_pt)
-    |  |- (derivable ?X1) =>
-      let trm := eval cbv beta in (X1 AppVar) in
-        let aux := rew_term trm in
-          (intro_hyp_glob aux;
-            try (change (derivable aux) in |- *; is_diff_glob) || is_diff_glob)
-    |  |- (continuity ?X1) =>
-      let trm := eval cbv beta in (X1 AppVar) in
-        let aux := rew_term trm in
-          (intro_hyp_glob aux;
-            try (change (continuity aux) in |- *; is_cont_glob) || is_cont_glob)
-    |  |- (continuity_pt ?X1 ?X2) =>
-      let trm := eval cbv beta in (X1 AppVar) in
-        let aux := rew_term trm in
-          (intro_hyp_pt aux X2;
-            try (change (continuity_pt aux X2) in |- *; is_cont_pt) || is_cont_pt)
-    |  |- (derive_pt ?X1 ?X2 ?X3 = ?X4) =>
-      let trm := eval cbv beta in (X1 AppVar) in
-      let aux := rew_term trm in
-      intro_hyp_pt aux X2;
-      (let aux2 := deriv_proof aux X2 in
-       try
-         (replace (derive_pt X1 X2 X3) with (derive_pt aux X2 aux2);
-           [ simplify_derive aux X2;
-             try unfold plus_fct, minus_fct, mult_fct, div_fct, id, fct_cte,
-                        inv_fct, opp_fct in |- *; ring || ring_simplify
-           | try apply pr_nu ]) || is_diff_pt)
-  end.
+Require Export Ranalysis_reg.
\ No newline at end of file
diff --git a/theories/Reals/Ranalysis1.v b/theories/Reals/Ranalysis1.v
index 673dc3c1..2f54ee94 100644
--- a/theories/Reals/Ranalysis1.v
+++ b/theories/Reals/Ranalysis1.v
@@ -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-2012     *)
 (*   \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.
 Require Export Rderiv.
-Open Local Scope R_scope.
+Local Open Scope R_scope.
 Implicit Type f : R -> R.
 
 (****************************************************)
@@ -30,22 +28,22 @@ 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.
 Infix "*" := mult_fct : Rfun_scope.
 Infix "-" := minus_fct : Rfun_scope.
 Infix "/" := div_fct : Rfun_scope.
-Notation Local "f1 'o' f2" := (comp f1 f2)
+Local Notation "f1 'o' f2" := (comp f1 f2)
   (at level 20, right associativity) : Rfun_scope.
 Notation "/ x" := (inv_fct x) : Rfun_scope.
 
@@ -76,22 +74,22 @@ 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 :
   forall f1 f2 (x0:R),
     continuity_pt f1 x0 -> continuity_pt f2 x0 -> continuity_pt (f1 + f2) x0.
 Proof.
-  unfold continuity_pt, plus_fct in |- *; unfold continue_in in |- *; intros;
+  unfold continuity_pt, plus_fct; unfold continue_in; intros;
     apply limit_plus; assumption.
 Qed.
 
 Lemma continuity_pt_opp :
   forall f (x0:R), continuity_pt f x0 -> continuity_pt (- f) x0.
 Proof.
-  unfold continuity_pt, opp_fct in |- *; unfold continue_in in |- *; intros;
+  unfold continuity_pt, opp_fct; unfold continue_in; intros;
     apply limit_Ropp; assumption.
 Qed.
 
@@ -99,7 +97,7 @@ Lemma continuity_pt_minus :
   forall f1 f2 (x0:R),
     continuity_pt f1 x0 -> continuity_pt f2 x0 -> continuity_pt (f1 - f2) x0.
 Proof.
-  unfold continuity_pt, minus_fct in |- *; unfold continue_in in |- *; intros;
+  unfold continuity_pt, minus_fct; unfold continue_in; intros;
     apply limit_minus; assumption.
 Qed.
 
@@ -107,17 +105,17 @@ Lemma continuity_pt_mult :
   forall f1 f2 (x0:R),
     continuity_pt f1 x0 -> continuity_pt f2 x0 -> continuity_pt (f1 * f2) x0.
 Proof.
-  unfold continuity_pt, mult_fct in |- *; unfold continue_in in |- *; intros;
+  unfold continuity_pt, mult_fct; unfold continue_in; intros;
     apply limit_mul; assumption.
 Qed.
 
 Lemma continuity_pt_const : forall f (x0:R), constant f -> continuity_pt f x0.
 Proof.
-  unfold constant, continuity_pt in |- *; unfold continue_in in |- *;
-    unfold limit1_in in |- *; unfold limit_in in |- *;
+  unfold constant, continuity_pt; unfold continue_in;
+    unfold limit1_in; unfold limit_in;
       intros; exists 1; split;
         [ apply Rlt_0_1
-          | intros; generalize (H x x0); intro; rewrite H2; simpl in |- *;
+          | intros; generalize (H x x0); intro; rewrite H2; simpl;
             rewrite R_dist_eq; assumption ].
 Qed.
 
@@ -125,9 +123,9 @@ Lemma continuity_pt_scal :
   forall f (a x0:R),
     continuity_pt f x0 -> continuity_pt (mult_real_fct a f) x0.
 Proof.
-  unfold continuity_pt, mult_real_fct in |- *; unfold continue_in in |- *;
+  unfold continuity_pt, mult_real_fct; unfold continue_in;
     intros; apply (limit_mul (fun x:R => a) f (D_x no_cond x0) a (f x0) x0).
-  unfold limit1_in in |- *; unfold limit_in in |- *; intros; exists 1; split.
+  unfold limit1_in; unfold limit_in; intros; exists 1; split.
   apply Rlt_0_1.
   intros; rewrite R_dist_eq; assumption.
   assumption.
@@ -138,9 +136,9 @@ Lemma continuity_pt_inv :
 Proof.
   intros.
   replace (/ f)%F with (fun x:R => / f x).
-  unfold continuity_pt in |- *; unfold continue_in in |- *; intros;
+  unfold continuity_pt; unfold continue_in; intros;
     apply limit_inv; assumption.
-  unfold inv_fct in |- *; reflexivity.
+  unfold inv_fct; reflexivity.
 Qed.
 
 Lemma div_eq_inv : forall f1 f2, (f1 / f2)%F = (f1 * / f2)%F.
@@ -161,8 +159,8 @@ Lemma continuity_pt_comp :
   forall f1 f2 (x:R),
     continuity_pt f1 x -> continuity_pt f2 (f1 x) -> continuity_pt (f2 o f1) x.
 Proof.
-  unfold continuity_pt in |- *; unfold continue_in in |- *; intros;
-    unfold comp in |- *.
+  unfold continuity_pt; unfold continue_in; intros;
+    unfold comp.
   cut
     (limit1_in (fun x0:R => f2 (f1 x0))
       (Dgf (D_x no_cond x) (D_x no_cond (f1 x)) f1) (
@@ -172,23 +170,23 @@ Proof.
   eapply limit_comp.
   apply H.
   apply H0.
-  unfold limit1_in in |- *; unfold limit_in in |- *; unfold dist in |- *;
-    simpl in |- *; unfold R_dist in |- *; intros.
+  unfold limit1_in; unfold limit_in; unfold dist;
+    simpl; unfold R_dist; intros.
   assert (H3 := H1 eps H2).
   elim H3; intros.
   exists x0.
   split.
   elim H4; intros; assumption.
   intros; case (Req_dec (f1 x) (f1 x1)); intro.
-  rewrite H6; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+  rewrite H6; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0;
     assumption.
   elim H4; intros; apply H8.
   split.
-  unfold Dgf, D_x, no_cond in |- *.
+  unfold Dgf, D_x, no_cond.
   split.
   split.
   trivial.
-  elim H5; unfold D_x, no_cond in |- *; intros.
+  elim H5; unfold D_x, no_cond; intros.
   elim H9; intros; assumption.
   split.
   trivial.
@@ -200,44 +198,44 @@ Qed.
 Lemma continuity_plus :
   forall f1 f2, continuity f1 -> continuity f2 -> continuity (f1 + f2).
 Proof.
-  unfold continuity in |- *; intros;
+  unfold continuity; intros;
     apply (continuity_pt_plus f1 f2 x (H x) (H0 x)).
 Qed.
 
 Lemma continuity_opp : forall f, continuity f -> continuity (- f).
 Proof.
-  unfold continuity in |- *; intros; apply (continuity_pt_opp f x (H x)).
+  unfold continuity; intros; apply (continuity_pt_opp f x (H x)).
 Qed.
 
 Lemma continuity_minus :
   forall f1 f2, continuity f1 -> continuity f2 -> continuity (f1 - f2).
 Proof.
-  unfold continuity in |- *; intros;
+  unfold continuity; intros;
     apply (continuity_pt_minus f1 f2 x (H x) (H0 x)).
 Qed.
 
 Lemma continuity_mult :
   forall f1 f2, continuity f1 -> continuity f2 -> continuity (f1 * f2).
 Proof.
-  unfold continuity in |- *; intros;
+  unfold continuity; intros;
     apply (continuity_pt_mult f1 f2 x (H x) (H0 x)).
 Qed.
 
 Lemma continuity_const : forall f, constant f -> continuity f.
 Proof.
-  unfold continuity in |- *; intros; apply (continuity_pt_const f x H).
+  unfold continuity; intros; apply (continuity_pt_const f x H).
 Qed.
 
 Lemma continuity_scal :
   forall f (a:R), continuity f -> continuity (mult_real_fct a f).
 Proof.
-  unfold continuity in |- *; intros; apply (continuity_pt_scal f a x (H x)).
+  unfold continuity; intros; apply (continuity_pt_scal f a x (H x)).
 Qed.
 
 Lemma continuity_inv :
   forall f, continuity f -> (forall x:R, f x <> 0) -> continuity (/ f).
 Proof.
-  unfold continuity in |- *; intros; apply (continuity_pt_inv f x (H x) (H0 x)).
+  unfold continuity; intros; apply (continuity_pt_inv f x (H x) (H0 x)).
 Qed.
 
 Lemma continuity_div :
@@ -245,14 +243,14 @@ Lemma continuity_div :
     continuity f1 ->
     continuity f2 -> (forall x:R, f2 x <> 0) -> continuity (f1 / f2).
 Proof.
-  unfold continuity in |- *; intros;
+  unfold continuity; intros;
     apply (continuity_pt_div f1 f2 x (H x) (H0 x) (H1 x)).
 Qed.
 
 Lemma continuity_comp :
   forall f1 f2, continuity f1 -> continuity f2 -> continuity (f2 o f1).
 Proof.
-  unfold continuity in |- *; intros.
+  unfold continuity; intros.
   apply (continuity_pt_comp f1 f2 x (H x) (H0 (f1 x))).
 Qed.
 
@@ -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,
@@ -309,23 +307,23 @@ Proof.
     apply
       (single_limit (fun h:R => (f (x + h) - f x) / h) (
         fun h:R => h <> 0) l1 l2 0); try assumption.
-  unfold adhDa in |- *; intros; exists (alp / 2).
+  unfold adhDa; intros; exists (alp / 2).
   split.
-  unfold Rdiv in |- *; apply prod_neq_R0.
-  red in |- *; intro; rewrite H2 in H1; elim (Rlt_irrefl _ H1).
+  unfold Rdiv; apply prod_neq_R0.
+  red; intro; rewrite H2 in H1; elim (Rlt_irrefl _ H1).
   apply Rinv_neq_0_compat; discrR.
-  unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
-    rewrite Rplus_0_r; unfold Rdiv in |- *; rewrite Rabs_mult.
+  unfold R_dist; unfold Rminus; rewrite Ropp_0;
+    rewrite Rplus_0_r; unfold Rdiv; rewrite Rabs_mult.
   replace (Rabs (/ 2)) with (/ 2).
   replace (Rabs alp) with alp.
   apply Rmult_lt_reg_l with 2.
   prove_sup0.
   rewrite (Rmult_comm 2); rewrite Rmult_assoc; rewrite <- Rinv_l_sym;
     [ idtac | discrR ]; rewrite Rmult_1_r; rewrite double;
-      pattern alp at 1 in |- *; replace alp with (alp + 0);
+      pattern alp at 1; replace alp with (alp + 0);
         [ idtac | ring ]; apply Rplus_lt_compat_l; assumption.
-  symmetry  in |- *; apply Rabs_right; left; assumption.
-  symmetry  in |- *; apply Rabs_right; left; change (0 < / 2) in |- *;
+  symmetry ; apply Rabs_right; left; assumption.
+  symmetry ; apply Rabs_right; left; change (0 < / 2);
     apply Rinv_0_lt_compat; prove_sup0.
 Qed.
 
@@ -334,14 +332,14 @@ Lemma uniqueness_step2 :
     derivable_pt_lim f x l ->
     limit1_in (fun h:R => (f (x + h) - f x) / h) (fun h:R => h <> 0) l 0.
 Proof.
-  unfold derivable_pt_lim in |- *; intros; unfold limit1_in in |- *;
-    unfold limit_in in |- *; intros.
+  unfold derivable_pt_lim; intros; unfold limit1_in;
+    unfold limit_in; intros.
   assert (H1 := H eps H0).
   elim H1; intros.
   exists (pos x0).
   split.
   apply (cond_pos x0).
-  simpl in |- *; unfold R_dist in |- *; intros.
+  simpl; unfold R_dist; intros.
   elim H3; intros.
   apply H2;
     [ assumption
@@ -354,15 +352,15 @@ Lemma uniqueness_step3 :
     limit1_in (fun h:R => (f (x + h) - f x) / h) (fun h:R => h <> 0) l 0 ->
     derivable_pt_lim f x l.
 Proof.
-  unfold limit1_in, derivable_pt_lim in |- *; unfold limit_in in |- *;
-    unfold dist in |- *; simpl in |- *; intros.
+  unfold limit1_in, derivable_pt_lim; unfold limit_in;
+    unfold dist; simpl; intros.
   elim (H eps H0).
   intros; elim H1; intros.
   exists (mkposreal x0 H2).
-  simpl in |- *; intros; unfold R_dist in H3; apply (H3 h).
+  simpl; intros; unfold R_dist in H3; apply (H3 h).
   split;
     [ assumption
-      | unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; assumption ].
+      | unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r; assumption ].
 Qed.
 
 Lemma uniqueness_limite :
@@ -385,8 +383,8 @@ Proof.
     assumption.
   intro; assert (H1 := proj2_sig pr); unfold derivable_pt_abs in H1.
   assert (H2 := uniqueness_limite _ _ _ _ H H1).
-  unfold derive_pt in |- *; unfold derivable_pt_abs in |- *.
-  symmetry  in |- *; assumption.
+  unfold derive_pt; unfold derivable_pt_abs.
+  symmetry ; assumption.
 Qed.
 
 (**********)
@@ -416,25 +414,25 @@ Lemma derive_pt_D_in :
     D_in f df no_cond x <-> derive_pt f x pr = df x.
 Proof.
   intros; split.
-  unfold D_in in |- *; unfold limit1_in in |- *; unfold limit_in in |- *;
-    simpl in |- *; unfold R_dist in |- *; intros.
+  unfold D_in; unfold limit1_in; unfold limit_in;
+    simpl; unfold R_dist; intros.
   apply derive_pt_eq_0.
-  unfold derivable_pt_lim in |- *.
+  unfold derivable_pt_lim.
   intros; elim (H eps H0); intros alpha H1; elim H1; intros;
     exists (mkposreal alpha H2); intros; generalize (H3 (x + h));
       intro; cut (x + h - x = h);
         [ intro; cut (D_x no_cond x (x + h) /\ Rabs (x + h - x) < alpha);
           [ intro; generalize (H6 H8); rewrite H7; intro; assumption
             | split;
-              [ unfold D_x in |- *; split;
-                [ unfold no_cond in |- *; trivial
+              [ unfold D_x; split;
+                [ unfold no_cond; trivial
                   | apply Rminus_not_eq_right; rewrite H7; assumption ]
                 | rewrite H7; assumption ] ]
           | ring ].
   intro.
   assert (H0 := derive_pt_eq_1 f x (df x) pr H).
-  unfold D_in in |- *; unfold limit1_in in |- *; unfold limit_in in |- *;
-    unfold dist in |- *; simpl in |- *; unfold R_dist in |- *;
+  unfold D_in; unfold limit1_in; unfold limit_in;
+    unfold dist; simpl; unfold R_dist;
       intros.
   elim (H0 eps H1); intros alpha H2; exists (pos alpha); split.
   apply (cond_pos alpha).
@@ -450,24 +448,24 @@ Lemma derivable_pt_lim_D_in :
     D_in f df no_cond x <-> derivable_pt_lim f x (df x).
 Proof.
   intros; split.
-  unfold D_in in |- *; unfold limit1_in in |- *; unfold limit_in in |- *;
-    simpl in |- *; unfold R_dist in |- *; intros.
-  unfold derivable_pt_lim in |- *.
+  unfold D_in; unfold limit1_in; unfold limit_in;
+    simpl; unfold R_dist; intros.
+  unfold derivable_pt_lim.
   intros; elim (H eps H0); intros alpha H1; elim H1; intros;
     exists (mkposreal alpha H2); intros; generalize (H3 (x + h));
       intro; cut (x + h - x = h);
         [ intro; cut (D_x no_cond x (x + h) /\ Rabs (x + h - x) < alpha);
           [ intro; generalize (H6 H8); rewrite H7; intro; assumption
             | split;
-              [ unfold D_x in |- *; split;
-                [ unfold no_cond in |- *; trivial
+              [ unfold D_x; split;
+                [ unfold no_cond; trivial
                   | apply Rminus_not_eq_right; rewrite H7; assumption ]
                 | rewrite H7; assumption ] ]
           | ring ].
   intro.
   unfold derivable_pt_lim in H.
-  unfold D_in in |- *; unfold limit1_in in |- *; unfold limit_in in |- *;
-    unfold dist in |- *; simpl in |- *; unfold R_dist in |- *;
+  unfold D_in; unfold limit1_in; unfold limit_in;
+    unfold dist; simpl; unfold R_dist;
       intros.
   elim (H eps H0); intros alpha H2; exists (pos alpha); split.
   apply (cond_pos alpha).
@@ -488,7 +486,7 @@ Lemma derivable_derive :
   forall f (x:R) (pr:derivable_pt f x),  exists l : R, derive_pt f x pr = l.
 Proof.
   intros; exists (proj1_sig pr).
-  unfold derive_pt in |- *; reflexivity.
+  unfold derive_pt; reflexivity.
 Qed.
 
 Theorem derivable_continuous_pt :
@@ -503,14 +501,14 @@ Proof.
   generalize (derive_pt_D_in f (fct_cte l) x); intro.
   elim (H2 X); intros.
   generalize (H4 H1); intro.
-  unfold continuity_pt in |- *.
+  unfold continuity_pt.
   apply (cont_deriv f (fct_cte l) no_cond x H5).
-  unfold fct_cte in |- *; reflexivity.
+  unfold fct_cte; reflexivity.
 Qed.
 
 Theorem derivable_continuous : forall f, derivable f -> continuity f.
 Proof.
-  unfold derivable, continuity in |- *; intros f X x.
+  unfold derivable, continuity; intros f X x.
   apply (derivable_continuous_pt f x (X x)).
 Qed.
 
@@ -526,7 +524,7 @@ Lemma derivable_pt_lim_plus :
   apply uniqueness_step3.
   assert (H1 := uniqueness_step2 _ _ _ H).
   assert (H2 := uniqueness_step2 _ _ _ H0).
-  unfold plus_fct in |- *.
+  unfold plus_fct.
   cut
     (forall h:R,
       (f1 (x + h) + f2 (x + h) - (f1 x + f2 x)) / h =
@@ -535,15 +533,15 @@ Lemma derivable_pt_lim_plus :
   generalize
     (limit_plus (fun h':R => (f1 (x + h') - f1 x) / h')
       (fun h':R => (f2 (x + h') - f2 x) / h') (fun h:R => h <> 0) l1 l2 0 H1 H2).
-  unfold limit1_in in |- *; unfold limit_in in |- *; unfold dist in |- *;
-    simpl in |- *; unfold R_dist in |- *; intros.
+  unfold limit1_in; unfold limit_in; unfold dist;
+    simpl; unfold R_dist; intros.
   elim (H4 eps H5); intros.
   exists x0.
   elim H6; intros.
   split.
   assumption.
   intros; rewrite H3; apply H8; assumption.
-  intro; unfold Rdiv in |- *; ring.
+  intro; unfold Rdiv; ring.
 Qed.
 
 Lemma derivable_pt_lim_opp :
@@ -552,20 +550,20 @@ Proof.
   intros.
   apply uniqueness_step3.
   assert (H1 := uniqueness_step2 _ _ _ H).
-  unfold opp_fct in |- *.
+  unfold opp_fct.
   cut (forall h:R, (- f (x + h) - - f x) / h = - ((f (x + h) - f x) / h)).
   intro.
   generalize
     (limit_Ropp (fun h:R => (f (x + h) - f x) / h) (fun h:R => h <> 0) l 0 H1).
-  unfold limit1_in in |- *; unfold limit_in in |- *; unfold dist in |- *;
-    simpl in |- *; unfold R_dist in |- *; intros.
+  unfold limit1_in; unfold limit_in; unfold dist;
+    simpl; unfold R_dist; intros.
   elim (H2 eps H3); intros.
   exists x0.
   elim H4; intros.
   split.
   assumption.
   intros; rewrite H0; apply H6; assumption.
-  intro; unfold Rdiv in |- *; ring.
+  intro; unfold Rdiv; ring.
 Qed.
 
 Lemma derivable_pt_lim_minus :
@@ -577,7 +575,7 @@ Proof.
   apply uniqueness_step3.
   assert (H1 := uniqueness_step2 _ _ _ H).
   assert (H2 := uniqueness_step2 _ _ _ H0).
-  unfold minus_fct in |- *.
+  unfold minus_fct.
   cut
     (forall h:R,
       (f1 (x + h) - f1 x) / h - (f2 (x + h) - f2 x) / h =
@@ -586,15 +584,15 @@ Proof.
   generalize
     (limit_minus (fun h':R => (f1 (x + h') - f1 x) / h')
       (fun h':R => (f2 (x + h') - f2 x) / h') (fun h:R => h <> 0) l1 l2 0 H1 H2).
-  unfold limit1_in in |- *; unfold limit_in in |- *; unfold dist in |- *;
-    simpl in |- *; unfold R_dist in |- *; intros.
+  unfold limit1_in; unfold limit_in; unfold dist;
+    simpl; unfold R_dist; intros.
   elim (H4 eps H5); intros.
   exists x0.
   elim H6; intros.
   split.
   assumption.
   intros; rewrite <- H3; apply H8; assumption.
-  intro; unfold Rdiv in |- *; ring.
+  intro; unfold Rdiv; ring.
 Qed.
 
 Lemma derivable_pt_lim_mult :
@@ -617,15 +615,15 @@ Proof.
   elim H1; intros.
   clear H1 H3.
   apply H2.
-  unfold mult_fct in |- *.
+  unfold mult_fct.
   apply (Dmult no_cond (fun y:R => l1) (fun y:R => l2) f1 f2 x); assumption.
 Qed.
 
 Lemma derivable_pt_lim_const : forall a x:R, derivable_pt_lim (fct_cte a) x 0.
 Proof.
-  intros; unfold fct_cte, derivable_pt_lim in |- *.
-  intros; exists (mkposreal 1 Rlt_0_1); intros; unfold Rminus in |- *;
-    rewrite Rplus_opp_r; unfold Rdiv in |- *; rewrite Rmult_0_l;
+  intros; unfold fct_cte, derivable_pt_lim.
+  intros; exists (mkposreal 1 Rlt_0_1); intros; unfold Rminus;
+    rewrite Rplus_opp_r; unfold Rdiv; rewrite Rmult_0_l;
       rewrite Rplus_opp_r; rewrite Rabs_R0; assumption.
 Qed.
 
@@ -638,34 +636,34 @@ Proof.
   replace (mult_real_fct a f) with (fct_cte a * f)%F.
   replace (a * l) with (0 * f x + a * l); [ idtac | ring ].
   apply (derivable_pt_lim_mult (fct_cte a) f x 0 l); assumption.
-  unfold mult_real_fct, mult_fct, fct_cte in |- *; reflexivity.
+  unfold mult_real_fct, mult_fct, fct_cte; reflexivity.
 Qed.
 
 Lemma derivable_pt_lim_id : forall x:R, derivable_pt_lim id x 1.
 Proof.
-  intro; unfold derivable_pt_lim in |- *.
+  intro; unfold derivable_pt_lim.
   intros eps Heps; exists (mkposreal eps Heps); intros h H1 H2;
-    unfold id in |- *; replace ((x + h - x) / h - 1) with 0.
+    unfold id; replace ((x + h - x) / h - 1) with 0.
   rewrite Rabs_R0; apply Rle_lt_trans with (Rabs h).
   apply Rabs_pos.
   assumption.
-  unfold Rminus in |- *; rewrite Rplus_assoc; rewrite (Rplus_comm x);
+  unfold Rminus; rewrite Rplus_assoc; rewrite (Rplus_comm x);
     rewrite Rplus_assoc.
-  rewrite Rplus_opp_l; rewrite Rplus_0_r; unfold Rdiv in |- *;
+  rewrite Rplus_opp_l; rewrite Rplus_0_r; unfold Rdiv;
     rewrite <- Rinv_r_sym.
-  symmetry  in |- *; apply Rplus_opp_r.
+  symmetry ; apply Rplus_opp_r.
   assumption.
 Qed.
 
 Lemma derivable_pt_lim_Rsqr : forall x:R, derivable_pt_lim Rsqr x (2 * x).
 Proof.
-  intro; unfold derivable_pt_lim in |- *.
-  unfold Rsqr in |- *; intros eps Heps; exists (mkposreal eps Heps);
+  intro; unfold derivable_pt_lim.
+  unfold Rsqr; intros eps Heps; exists (mkposreal eps Heps);
     intros h H1 H2; replace (((x + h) * (x + h) - x * x) / h - 2 * x) with h.
   assumption.
   replace ((x + h) * (x + h) - x * x) with (2 * x * h + h * h);
   [ idtac | ring ].
-  unfold Rdiv in |- *; rewrite Rmult_plus_distr_r.
+  unfold Rdiv; rewrite Rmult_plus_distr_r.
   repeat rewrite Rmult_assoc.
   repeat rewrite <- Rinv_r_sym; [ idtac | assumption ].
   ring.
@@ -686,7 +684,7 @@ Proof.
   assert (H1 := derivable_pt_lim_D_in (f2 o f1)%F (fun y:R => l2 * l1) x).
   elim H1; intros.
   clear H1 H3; apply H2.
-  unfold comp in |- *;
+  unfold comp;
     cut
       (D_in (fun x0:R => f2 (f1 x0)) (fun y:R => l2 * l1)
         (Dgf no_cond no_cond f1) x ->
@@ -695,14 +693,14 @@ Proof.
   rewrite Rmult_comm;
     apply (Dcomp no_cond no_cond (fun y:R => l1) (fun y:R => l2) f1 f2 x);
       assumption.
-  unfold Dgf, D_in, no_cond in |- *; unfold limit1_in in |- *;
-    unfold limit_in in |- *; unfold dist in |- *; simpl in |- *;
-      unfold R_dist in |- *; intros.
+  unfold Dgf, D_in, no_cond; unfold limit1_in;
+    unfold limit_in; unfold dist; simpl;
+      unfold R_dist; intros.
   elim (H1 eps H3); intros.
   exists x0; intros; split.
   elim H5; intros; assumption.
   intros; elim H5; intros; apply H9; split.
-  unfold D_x in |- *; split.
+  unfold D_x; split.
   split; trivial.
   elim H6; intros; unfold D_x in H10; elim H10; intros; assumption.
   elim H6; intros; assumption.
@@ -712,7 +710,7 @@ Lemma derivable_pt_plus :
   forall f1 f2 (x:R),
     derivable_pt f1 x -> derivable_pt f2 x -> derivable_pt (f1 + f2) x.
 Proof.
-  unfold derivable_pt in |- *; intros f1 f2 x X X0.
+  unfold derivable_pt; intros f1 f2 x X X0.
   elim X; intros.
   elim X0; intros.
   exists (x0 + x1).
@@ -722,7 +720,7 @@ Qed.
 Lemma derivable_pt_opp :
   forall f (x:R), derivable_pt f x -> derivable_pt (- f) x.
 Proof.
-  unfold derivable_pt in |- *; intros f x X.
+  unfold derivable_pt; intros f x X.
   elim X; intros.
   exists (- x0).
   apply derivable_pt_lim_opp; assumption.
@@ -732,7 +730,7 @@ Lemma derivable_pt_minus :
   forall f1 f2 (x:R),
     derivable_pt f1 x -> derivable_pt f2 x -> derivable_pt (f1 - f2) x.
 Proof.
-  unfold derivable_pt in |- *; intros f1 f2 x X X0.
+  unfold derivable_pt; intros f1 f2 x X X0.
   elim X; intros.
   elim X0; intros.
   exists (x0 - x1).
@@ -743,7 +741,7 @@ Lemma derivable_pt_mult :
   forall f1 f2 (x:R),
     derivable_pt f1 x -> derivable_pt f2 x -> derivable_pt (f1 * f2) x.
 Proof.
-  unfold derivable_pt in |- *; intros f1 f2 x X X0.
+  unfold derivable_pt; intros f1 f2 x X X0.
   elim X; intros.
   elim X0; intros.
   exists (x0 * f2 x + f1 x * x1).
@@ -752,7 +750,7 @@ Qed.
 
 Lemma derivable_pt_const : forall a x:R, derivable_pt (fct_cte a) x.
 Proof.
-  intros; unfold derivable_pt in |- *.
+  intros; unfold derivable_pt.
   exists 0.
   apply derivable_pt_lim_const.
 Qed.
@@ -760,7 +758,7 @@ Qed.
 Lemma derivable_pt_scal :
   forall f (a x:R), derivable_pt f x -> derivable_pt (mult_real_fct a f) x.
 Proof.
-  unfold derivable_pt in |- *; intros f1 a x X.
+  unfold derivable_pt; intros f1 a x X.
   elim X; intros.
   exists (a * x0).
   apply derivable_pt_lim_scal; assumption.
@@ -768,14 +766,14 @@ Qed.
 
 Lemma derivable_pt_id : forall x:R, derivable_pt id x.
 Proof.
-  unfold derivable_pt in |- *; intro.
+  unfold derivable_pt; intro.
   exists 1.
   apply derivable_pt_lim_id.
 Qed.
 
 Lemma derivable_pt_Rsqr : forall x:R, derivable_pt Rsqr x.
 Proof.
-  unfold derivable_pt in |- *; intro; exists (2 * x).
+  unfold derivable_pt; intro; exists (2 * x).
   apply derivable_pt_lim_Rsqr.
 Qed.
 
@@ -783,7 +781,7 @@ Lemma derivable_pt_comp :
   forall f1 f2 (x:R),
     derivable_pt f1 x -> derivable_pt f2 (f1 x) -> derivable_pt (f2 o f1) x.
 Proof.
-  unfold derivable_pt in |- *; intros f1 f2 x X X0.
+  unfold derivable_pt; intros f1 f2 x X X0.
   elim X; intros.
   elim X0; intros.
   exists (x1 * x0).
@@ -793,57 +791,57 @@ Qed.
 Lemma derivable_plus :
   forall f1 f2, derivable f1 -> derivable f2 -> derivable (f1 + f2).
 Proof.
-  unfold derivable in |- *; intros f1 f2 X X0 x.
+  unfold derivable; intros f1 f2 X X0 x.
   apply (derivable_pt_plus _ _ x (X _) (X0 _)).
 Qed.
 
 Lemma derivable_opp : forall f, derivable f -> derivable (- f).
 Proof.
-  unfold derivable in |- *; intros f X x.
+  unfold derivable; intros f X x.
   apply (derivable_pt_opp _ x (X _)).
 Qed.
 
 Lemma derivable_minus :
   forall f1 f2, derivable f1 -> derivable f2 -> derivable (f1 - f2).
 Proof.
-  unfold derivable in |- *; intros f1 f2 X X0 x.
+  unfold derivable; intros f1 f2 X X0 x.
   apply (derivable_pt_minus _ _ x (X _) (X0 _)).
 Qed.
 
 Lemma derivable_mult :
   forall f1 f2, derivable f1 -> derivable f2 -> derivable (f1 * f2).
 Proof.
-  unfold derivable in |- *; intros f1 f2 X X0 x.
+  unfold derivable; intros f1 f2 X X0 x.
   apply (derivable_pt_mult _ _ x (X _) (X0 _)).
 Qed.
 
 Lemma derivable_const : forall a:R, derivable (fct_cte a).
 Proof.
-  unfold derivable in |- *; intros.
+  unfold derivable; intros.
   apply derivable_pt_const.
 Qed.
 
 Lemma derivable_scal :
   forall f (a:R), derivable f -> derivable (mult_real_fct a f).
 Proof.
-  unfold derivable in |- *; intros f a X x.
+  unfold derivable; intros f a X x.
   apply (derivable_pt_scal _ a x (X _)).
 Qed.
 
 Lemma derivable_id : derivable id.
 Proof.
-  unfold derivable in |- *; intro; apply derivable_pt_id.
+  unfold derivable; intro; apply derivable_pt_id.
 Qed.
 
 Lemma derivable_Rsqr : derivable Rsqr.
 Proof.
-  unfold derivable in |- *; intro; apply derivable_pt_Rsqr.
+  unfold derivable; intro; apply derivable_pt_Rsqr.
 Qed.
 
 Lemma derivable_comp :
   forall f1 f2, derivable f1 -> derivable f2 -> derivable (f2 o f1).
 Proof.
-  unfold derivable in |- *; intros f1 f2 X X0 x.
+  unfold derivable; intros f1 f2 X X0 x.
   apply (derivable_pt_comp _ _ x (X _) (X0 _)).
 Qed.
 
@@ -998,13 +996,13 @@ Proof.
   elim (lt_irrefl _ H).
   cut (n = 0%nat \/ (0 < n)%nat).
   intro; elim H0; intro.
-  rewrite H1; simpl in |- *.
+  rewrite H1; simpl.
   replace (fun y:R => y * 1) with (id * fct_cte 1)%F.
   replace (1 * 1) with (1 * fct_cte 1 x + id x * 0).
   apply derivable_pt_lim_mult.
   apply derivable_pt_lim_id.
   apply derivable_pt_lim_const.
-  unfold fct_cte, id in |- *; ring.
+  unfold fct_cte, id; ring.
   reflexivity.
   replace (fun y:R => y ^ S n) with (fun y:R => y * y ^ n).
   replace (pred (S n)) with n; [ idtac | reflexivity ].
@@ -1013,13 +1011,13 @@ Proof.
   replace (INR (S n) * x ^ n) with (1 * f x + id x * (INR n * x ^ pred n)).
   apply derivable_pt_lim_mult.
   apply derivable_pt_lim_id.
-  unfold f in |- *; apply Hrecn; assumption.
-  unfold f in |- *.
-  pattern n at 1 5 in |- *; replace n with (S (pred n)).
-  unfold id in |- *; rewrite S_INR; simpl in |- *.
+  unfold f; apply Hrecn; assumption.
+  unfold f.
+  pattern n at 1 5; replace n with (S (pred n)).
+  unfold id; rewrite S_INR; simpl.
   ring.
-  symmetry  in |- *; apply S_pred with 0%nat; assumption.
-  unfold mult_fct, id in |- *; reflexivity.
+  symmetry ; apply S_pred with 0%nat; assumption.
+  unfold mult_fct, id; reflexivity.
   reflexivity.
   inversion H.
   left; reflexivity.
@@ -1035,7 +1033,7 @@ Lemma derivable_pt_lim_pow :
 Proof.
   intros.
   induction  n as [| n Hrecn].
-  simpl in |- *.
+  simpl.
   rewrite Rmult_0_l.
   replace (fun _:R => 1) with (fct_cte 1);
   [ apply derivable_pt_lim_const | reflexivity ].
@@ -1046,14 +1044,14 @@ Qed.
 Lemma derivable_pt_pow :
   forall (n:nat) (x:R), derivable_pt (fun y:R => y ^ n) x.
 Proof.
-  intros; unfold derivable_pt in |- *.
+  intros; unfold derivable_pt.
   exists (INR n * x ^ pred n).
   apply derivable_pt_lim_pow.
 Qed.
 
 Lemma derivable_pow : forall n:nat, derivable (fun y:R => y ^ n).
 Proof.
-  intro; unfold derivable in |- *; intro; apply derivable_pt_pow.
+  intro; unfold derivable; intro; apply derivable_pt_pow.
 Qed.
 
 Lemma derive_pt_pow :
@@ -1075,7 +1073,7 @@ Proof.
   elim pr2; intros.
   unfold derivable_pt_abs in p.
   unfold derivable_pt_abs in p0.
-  simpl in |- *.
+  simpl.
   apply (uniqueness_limite f x x0 x1 p p0).
 Qed.
 
@@ -1096,7 +1094,7 @@ Proof.
   assert (H5 := derive_pt_eq_1 f c l pr H4).
   cut (0 < l / 2);
     [ intro
-      | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+      | unfold Rdiv; apply Rmult_lt_0_compat;
         [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ].
   elim (H5 (l / 2) H6); intros delta H7.
   cut (0 < (b - c) / 2).
@@ -1121,7 +1119,7 @@ Proof.
       (Rabs
         ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
           Rmin (delta / 2) ((b + - c) / 2) + - l) < l / 2).
-  unfold Rabs in |- *;
+  unfold Rabs;
     case
     (Rcase_abs
       ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
@@ -1159,7 +1157,7 @@ Proof.
               (Rlt_le_trans 0
                 ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
                   Rmin (delta / 2) ((b + - c) / 2)) 0 H22 H16)).
-  pattern l at 2 in |- *; rewrite double_var.
+  pattern l at 2; rewrite double_var.
   ring.
   ring.
   intro.
@@ -1185,7 +1183,7 @@ Proof.
         l +
         -
         ((f (c + Rmin (delta / 2) ((b + - c) / 2)) - f c) /
-          Rmin (delta / 2) ((b + - c) / 2))) in |- *; apply Rplus_lt_le_0_compat;
+          Rmin (delta / 2) ((b + - c) / 2))); apply Rplus_lt_le_0_compat;
       [ assumption
         | rewrite <- Ropp_0; apply Ropp_ge_le_contravar; apply Rle_ge; assumption ].
   unfold Rminus; ring.
@@ -1197,13 +1195,13 @@ Proof.
     ((f c - f (c + Rmin (delta / 2) ((b - c) / 2))) /
       Rmin (delta / 2) ((b - c) / 2))).
   rewrite <- Ropp_0; apply Ropp_ge_le_contravar; apply Rle_ge;
-    unfold Rdiv in |- *; apply Rmult_le_pos;
+    unfold Rdiv; apply Rmult_le_pos;
       [ generalize
         (Rplus_le_compat_r (- f (c + Rmin (delta * / 2) ((b - c) * / 2)))
           (f (c + Rmin (delta * / 2) ((b - c) * / 2))) (
             f c) H15); rewrite Rplus_opp_r; intro; assumption
         | left; apply Rinv_0_lt_compat; assumption ].
-  unfold Rdiv in |- *.
+  unfold Rdiv.
   rewrite <- Ropp_mult_distr_l_reverse.
   repeat rewrite <- (Rmult_comm (/ Rmin (delta * / 2) ((b - c) * / 2))).
   apply Rmult_eq_reg_l with (Rmin (delta * / 2) ((b - c) * / 2)).
@@ -1211,9 +1209,9 @@ Proof.
   rewrite <- Rinv_r_sym.
   repeat rewrite Rmult_1_l.
   ring.
-  red in |- *; intro.
+  red; intro.
   unfold Rdiv in H12; rewrite H16 in H12; elim (Rlt_irrefl 0 H12).
-  red in |- *; intro.
+  red; intro.
   unfold Rdiv in H12; rewrite H16 in H12; elim (Rlt_irrefl 0 H12).
   assert (H14 := Rmin_r (delta / 2) ((b - c) / 2)).
   assert
@@ -1227,7 +1225,7 @@ Proof.
   replace (2 * b) with (b + b).
   apply Rplus_lt_compat_r; assumption.
   ring.
-  unfold Rdiv in |- *; rewrite Rmult_plus_distr_l.
+  unfold Rdiv; rewrite Rmult_plus_distr_l.
   repeat rewrite (Rmult_comm 2).
   rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
   rewrite Rmult_1_r.
@@ -1235,51 +1233,51 @@ Proof.
   discrR.
   apply Rlt_trans with c.
   assumption.
-  pattern c at 1 in |- *; rewrite <- (Rplus_0_r c); apply Rplus_lt_compat_l;
+  pattern c at 1; rewrite <- (Rplus_0_r c); apply Rplus_lt_compat_l;
     assumption.
   cut (0 < delta / 2).
   intro;
     apply
       (Rmin_stable_in_posreal (mkposreal (delta / 2) H12)
         (mkposreal ((b - c) / 2) H8)).
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+  unfold Rdiv; apply Rmult_lt_0_compat;
     [ apply (cond_pos delta) | apply Rinv_0_lt_compat; prove_sup0 ].
-  unfold Rabs in |- *; case (Rcase_abs (Rmin (delta / 2) ((b - c) / 2))).
+  unfold Rabs; case (Rcase_abs (Rmin (delta / 2) ((b - c) / 2))).
   intro.
   cut (0 < delta / 2).
   intro.
   generalize
     (Rmin_stable_in_posreal (mkposreal (delta / 2) H10)
-      (mkposreal ((b - c) / 2) H8)); simpl in |- *; intro;
+      (mkposreal ((b - c) / 2) H8)); simpl; intro;
     elim (Rlt_irrefl 0 (Rlt_trans 0 (Rmin (delta / 2) ((b - c) / 2)) 0 H11 r)).
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+  unfold Rdiv; apply Rmult_lt_0_compat;
     [ apply (cond_pos delta) | apply Rinv_0_lt_compat; prove_sup0 ].
   intro; apply Rle_lt_trans with (delta / 2).
   apply Rmin_l.
-  unfold Rdiv in |- *; apply Rmult_lt_reg_l with 2.
+  unfold Rdiv; apply Rmult_lt_reg_l with 2.
   prove_sup0.
   rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym.
   rewrite Rmult_1_l.
   replace (2 * delta) with (delta + delta).
-  pattern delta at 2 in |- *; rewrite <- (Rplus_0_r delta);
+  pattern delta at 2; rewrite <- (Rplus_0_r delta);
     apply Rplus_lt_compat_l.
   rewrite Rplus_0_r; apply (cond_pos delta).
-  symmetry  in |- *; apply double.
+  symmetry ; apply double.
   discrR.
   cut (0 < delta / 2).
   intro;
     generalize
       (Rmin_stable_in_posreal (mkposreal (delta / 2) H9)
-        (mkposreal ((b - c) / 2) H8)); simpl in |- *;
-      intro; red in |- *; intro; rewrite H11 in H10; elim (Rlt_irrefl 0 H10).
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+        (mkposreal ((b - c) / 2) H8)); simpl;
+      intro; red; intro; rewrite H11 in H10; elim (Rlt_irrefl 0 H10).
+  unfold Rdiv; apply Rmult_lt_0_compat;
     [ apply (cond_pos delta) | apply Rinv_0_lt_compat; prove_sup0 ].
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+  unfold Rdiv; apply Rmult_lt_0_compat.
   generalize (Rplus_lt_compat_r (- c) c b H0); rewrite Rplus_opp_r; intro;
     assumption.
   apply Rinv_0_lt_compat; prove_sup0.
   elim H2; intro.
-  symmetry  in |- *; assumption.
+  symmetry ; assumption.
   generalize (derivable_derive f c pr); intro; elim H4; intros l H5.
   rewrite H5 in H3; generalize (derive_pt_eq_1 f c l pr H5); intro;
     cut (0 < - (l / 2)).
@@ -1309,7 +1307,7 @@ Proof.
         ((f (c + Rmax (- (delta / 2)) ((a + - c) / 2)) + - f c) /
           Rmax (- (delta / 2)) ((a + - c) / 2) + - l) <
         - (l / 2)).
-  unfold Rabs in |- *;
+  unfold Rabs;
     case
     (Rcase_abs
       ((f (c + Rmax (- (delta / 2)) ((a + - c) / 2)) + - f c) /
@@ -1341,12 +1339,12 @@ Proof.
                 Rmax (- (delta / 2)) ((a - c) / 2)) 0 H17 H23)).
   rewrite <- (Ropp_involutive (l / 2)); rewrite <- Ropp_0;
     apply Ropp_lt_gt_contravar; assumption.
-  pattern l at 3 in |- *; rewrite double_var.
+  pattern l at 3; rewrite double_var.
   ring.
   assumption.
   apply Rplus_le_lt_0_compat; assumption.
   rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; assumption.
-  unfold Rdiv in |- *;
+  unfold Rdiv;
     replace
     ((f (c + Rmax (- (delta * / 2)) ((a - c) * / 2)) - f c) *
       / Rmax (- (delta * / 2)) ((a - c) * / 2)) with
@@ -1363,7 +1361,7 @@ Proof.
   ring.
   left; apply Rinv_0_lt_compat; rewrite <- Ropp_0; apply Ropp_lt_gt_contravar;
     assumption.
-  unfold Rdiv in |- *.
+  unfold Rdiv.
   rewrite <- Ropp_inv_permute.
   rewrite Rmult_opp_opp.
   reflexivity.
@@ -1382,7 +1380,7 @@ Proof.
   apply Rplus_lt_compat_l; assumption.
   field; discrR.
   assumption.
-  unfold Rabs in |- *; case (Rcase_abs (Rmax (- (delta / 2)) ((a - c) / 2))).
+  unfold Rabs; case (Rcase_abs (Rmax (- (delta / 2)) ((a - c) / 2))).
   intro; generalize (RmaxLess1 (- (delta / 2)) ((a - c) / 2)); intro;
     generalize
       (Ropp_le_ge_contravar (- (delta / 2)) (Rmax (- (delta / 2)) ((a - c) / 2))
@@ -1392,10 +1390,10 @@ Proof.
   assumption.
   apply Rmult_lt_reg_l with 2.
   prove_sup0.
-  unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+  unfold Rdiv; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
     rewrite <- Rinv_r_sym.
   rewrite Rmult_1_l; rewrite double.
-  pattern delta at 2 in |- *; rewrite <- (Rplus_0_r delta);
+  pattern delta at 2; rewrite <- (Rplus_0_r delta);
     apply Rplus_lt_compat_l; rewrite Rplus_0_r; apply (cond_pos delta).
   discrR.
   cut (- (delta / 2) < 0).
@@ -1403,7 +1401,7 @@ Proof.
   intros;
     generalize
       (Rmax_stable_in_negreal (mknegreal (- (delta / 2)) H13)
-        (mknegreal ((a - c) / 2) H12)); simpl in |- *;
+        (mknegreal ((a - c) / 2) H12)); simpl;
       intro; generalize (Rge_le (Rmax (- (delta / 2)) ((a - c) / 2)) 0 r);
         intro;
           elim
@@ -1412,41 +1410,41 @@ Proof.
   rewrite <- Ropp_0; rewrite <- (Ropp_involutive ((a - c) / 2));
     apply Ropp_lt_gt_contravar; replace (- ((a - c) / 2)) with ((c - a) / 2).
   assumption.
-  unfold Rdiv in |- *.
+  unfold Rdiv.
   rewrite <- Ropp_mult_distr_l_reverse.
   rewrite (Ropp_minus_distr a c).
   reflexivity.
-  rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; unfold Rdiv in |- *;
+  rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; unfold Rdiv;
     apply Rmult_lt_0_compat;
       [ apply (cond_pos delta)
         | assert (Hyp : 0 < 2); [ prove_sup0 | apply (Rinv_0_lt_compat 2 Hyp) ] ].
-  red in |- *; intro; rewrite H11 in H10; elim (Rlt_irrefl 0 H10).
+  red; intro; rewrite H11 in H10; elim (Rlt_irrefl 0 H10).
   cut ((a - c) / 2 < 0).
   intro; cut (- (delta / 2) < 0).
   intro;
     apply
       (Rmax_stable_in_negreal (mknegreal (- (delta / 2)) H11)
         (mknegreal ((a - c) / 2) H10)).
-  rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; unfold Rdiv in |- *;
+  rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; unfold Rdiv;
     apply Rmult_lt_0_compat;
       [ apply (cond_pos delta)
         | assert (Hyp : 0 < 2); [ prove_sup0 | apply (Rinv_0_lt_compat 2 Hyp) ] ].
   rewrite <- Ropp_0; rewrite <- (Ropp_involutive ((a - c) / 2));
     apply Ropp_lt_gt_contravar; replace (- ((a - c) / 2)) with ((c - a) / 2).
   assumption.
-  unfold Rdiv in |- *.
+  unfold Rdiv.
   rewrite <- Ropp_mult_distr_l_reverse.
   rewrite (Ropp_minus_distr a c).
   reflexivity.
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+  unfold Rdiv; apply Rmult_lt_0_compat;
     [ generalize (Rplus_lt_compat_r (- a) a c H); rewrite Rplus_opp_r; intro;
       assumption
       | assert (Hyp : 0 < 2); [ prove_sup0 | apply (Rinv_0_lt_compat 2 Hyp) ] ].
   replace (- (l / 2)) with (- l / 2).
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+  unfold Rdiv; apply Rmult_lt_0_compat.
   rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; assumption.
   assert (Hyp : 0 < 2); [ prove_sup0 | apply (Rinv_0_lt_compat 2 Hyp) ].
-  unfold Rdiv in |- *; apply Ropp_mult_distr_l_reverse.
+  unfold Rdiv; apply Ropp_mult_distr_l_reverse.
 Qed.
 
 Theorem deriv_minimum :
@@ -1462,7 +1460,7 @@ Proof.
   cut (forall x:R, a < x -> x < b -> (- f)%F x <= (- f)%F c).
   intro.
   apply (deriv_maximum (- f)%F a b c (derivable_pt_opp _ _ pr) H H0 H2).
-  intros; unfold opp_fct in |- *; apply Ropp_ge_le_contravar; apply Rle_ge.
+  intros; unfold opp_fct; apply Ropp_ge_le_contravar; apply Rle_ge.
   apply (H1 x H2 H3).
 Qed.
 
@@ -1495,7 +1493,7 @@ Proof.
   intro; decompose [and] H7; intros; generalize (H6 (delta / 2) H8 H11);
     cut (0 <= (f (x + delta / 2) - f x) / (delta / 2)).
   intro; cut (0 <= (f (x + delta / 2) - f x) / (delta / 2) - l).
-  intro; unfold Rabs in |- *;
+  intro; unfold Rabs;
     case (Rcase_abs ((f (x + delta / 2) - f x) / (delta / 2) - l)).
   intro;
     elim
@@ -1504,7 +1502,7 @@ Proof.
   intros;
     generalize
       (Rplus_lt_compat_r l ((f (x + delta / 2) - f x) / (delta / 2) - l)
-        (- (l / 2)) H13); unfold Rminus in |- *;
+        (- (l / 2)) H13); unfold Rminus;
       replace (- (l / 2) + l) with (l / 2).
   rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; intro;
     generalize
@@ -1514,50 +1512,50 @@ Proof.
   rewrite <- Ropp_0 in H5;
     generalize (Ropp_lt_gt_contravar (-0) (- (l / 2)) H5);
       repeat rewrite Ropp_involutive; intro; assumption.
-  pattern l at 3 in |- *; rewrite double_var.
+  pattern l at 3; rewrite double_var.
   ring.
-  unfold Rminus in |- *; apply Rplus_le_le_0_compat.
-  unfold Rdiv in |- *; apply Rmult_le_pos.
+  unfold Rminus; apply Rplus_le_le_0_compat.
+  unfold Rdiv; apply Rmult_le_pos.
   cut (x <= x + delta * / 2).
   intro; generalize (H x (x + delta * / 2) H12); intro;
     generalize (Rplus_le_compat_l (- f x) (f x) (f (x + delta * / 2)) H13);
       rewrite Rplus_opp_l; rewrite Rplus_comm; intro; assumption.
-  pattern x at 1 in |- *; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l;
+  pattern x at 1; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l;
     left; assumption.
   left; apply Rinv_0_lt_compat; assumption.
   left; rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; assumption.
-  unfold Rdiv in |- *; apply Rmult_le_pos.
+  unfold Rdiv; apply Rmult_le_pos.
   cut (x <= x + delta * / 2).
   intro; generalize (H x (x + delta * / 2) H9); intro;
     generalize (Rplus_le_compat_l (- f x) (f x) (f (x + delta * / 2)) H12);
       rewrite Rplus_opp_l; rewrite Rplus_comm; intro; assumption.
-  pattern x at 1 in |- *; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l;
+  pattern x at 1; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l;
     left; assumption.
   left; apply Rinv_0_lt_compat; assumption.
   split.
-  unfold Rdiv in |- *; apply prod_neq_R0.
-  generalize (cond_pos delta); intro; red in |- *; intro H9; rewrite H9 in H7;
+  unfold Rdiv; apply prod_neq_R0.
+  generalize (cond_pos delta); intro; red; intro H9; rewrite H9 in H7;
     elim (Rlt_irrefl 0 H7).
   apply Rinv_neq_0_compat; discrR.
   split.
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+  unfold Rdiv; apply Rmult_lt_0_compat;
     [ apply (cond_pos delta) | apply Rinv_0_lt_compat; prove_sup0 ].
   replace (Rabs (delta / 2)) with (delta / 2).
-  unfold Rdiv in |- *; apply Rmult_lt_reg_l with 2.
+  unfold Rdiv; apply Rmult_lt_reg_l with 2.
   prove_sup0.
   rewrite (Rmult_comm 2).
   rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ idtac | discrR ].
   rewrite Rmult_1_r.
   rewrite double.
-  pattern (pos delta) at 1 in |- *; rewrite <- Rplus_0_r.
+  pattern (pos delta) at 1; rewrite <- Rplus_0_r.
   apply Rplus_lt_compat_l; apply (cond_pos delta).
-  symmetry  in |- *; apply Rabs_right.
-  left; change (0 < delta / 2) in |- *; unfold Rdiv in |- *;
+  symmetry ; apply Rabs_right.
+  left; change (0 < delta / 2); unfold Rdiv;
     apply Rmult_lt_0_compat;
       [ apply (cond_pos delta) | apply Rinv_0_lt_compat; prove_sup0 ].
-  unfold Rdiv in |- *; rewrite <- Ropp_mult_distr_l_reverse;
+  unfold Rdiv; rewrite <- Ropp_mult_distr_l_reverse;
     apply Rmult_lt_0_compat.
   apply Rplus_lt_reg_r with l.
-  unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rplus_0_r; assumption.
+  unfold Rminus; rewrite Rplus_opp_r; rewrite Rplus_0_r; assumption.
   apply Rinv_0_lt_compat; prove_sup0.
 Qed.
diff --git a/theories/Reals/Ranalysis2.v b/theories/Reals/Ranalysis2.v
index fcff9a01..3c15a305 100644
--- a/theories/Reals/Ranalysis2.v
+++ b/theories/Reals/Ranalysis2.v
@@ -1,17 +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-2012     *)
 (*   \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.
-Open Local Scope R_scope.
+Local Open Scope R_scope.
 
 (**********)
 Lemma formule :
@@ -26,7 +24,7 @@ Lemma formule :
     f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2) +
     l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x).
 Proof.
-  intros; unfold Rdiv, Rminus, Rsqr in |- *.
+  intros; unfold Rdiv, Rminus, Rsqr.
   repeat rewrite Rmult_plus_distr_r; repeat rewrite Rmult_plus_distr_l;
     repeat rewrite Rinv_mult_distr; try assumption.
   replace (l1 * f2 x * (/ f2 x * / f2 x)) with (l1 * / f2 x * (f2 x * / f2 x));
@@ -83,10 +81,10 @@ Proof.
   rewrite Rabs_Rinv; [ left; exact H7 | assumption ].
   apply Rlt_le_trans with (2 / Rabs (f2 x) * Rabs (eps * f2 x / 8)).
   apply Rmult_lt_compat_l.
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+  unfold Rdiv; apply Rmult_lt_0_compat;
     [ prove_sup0 | apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption ].
   exact H8.
-  right; unfold Rdiv in |- *.
+  right; unfold Rdiv.
   repeat rewrite Rabs_mult.
   rewrite Rabs_Rinv; discrR.
   replace (Rabs 8) with 8.
@@ -98,8 +96,8 @@ Proof.
   replace (Rabs eps) with eps.
   repeat rewrite <- Rinv_r_sym; try discrR || (apply Rabs_no_R0; assumption).
   ring.
-  symmetry  in |- *; apply Rabs_right; left; assumption.
-  symmetry  in |- *; apply Rabs_right; left; prove_sup.
+  symmetry ; apply Rabs_right; left; assumption.
+  symmetry ; apply Rabs_right; left; prove_sup.
 Qed.
 
 Lemma maj_term2 :
@@ -131,11 +129,11 @@ Proof.
     (Rabs (2 * (l1 / (f2 x * f2 x))) * Rabs (eps * Rsqr (f2 x) / (8 * l1))).
   apply Rmult_lt_compat_r.
   apply Rabs_pos_lt.
-  unfold Rdiv in |- *; unfold Rsqr in |- *; repeat apply prod_neq_R0;
+  unfold Rdiv; unfold Rsqr; repeat apply prod_neq_R0;
     try assumption || discrR.
-  red in |- *; intro H10; rewrite H10 in H; elim (Rlt_irrefl _ H).
+  red; intro H10; rewrite H10 in H; elim (Rlt_irrefl _ H).
   apply Rinv_neq_0_compat; apply prod_neq_R0; try assumption || discrR.
-  unfold Rdiv in |- *.
+  unfold Rdiv.
   repeat rewrite Rinv_mult_distr; try assumption.
   repeat rewrite Rabs_mult.
   replace (Rabs 2) with 2.
@@ -149,9 +147,9 @@ Proof.
   repeat rewrite Rabs_Rinv; try assumption.
   rewrite <- (Rmult_comm 2).
   unfold Rdiv in H8; exact H8.
-  symmetry  in |- *; apply Rabs_right; left; prove_sup0.
+  symmetry ; apply Rabs_right; left; prove_sup0.
   right.
-  unfold Rsqr, Rdiv in |- *.
+  unfold Rsqr, Rdiv.
   do 1 rewrite Rinv_mult_distr; try assumption || discrR.
   do 1 rewrite Rinv_mult_distr; try assumption || discrR.
   repeat rewrite Rabs_mult.
@@ -168,9 +166,9 @@ Proof.
     (Rabs (f2 x) * / Rabs (f2 x)) * (2 * / 2)); [ idtac | ring ].
   repeat rewrite <- Rinv_r_sym; try (apply Rabs_no_R0; assumption) || discrR.
   ring.
-  symmetry  in |- *; apply Rabs_right; left; prove_sup0.
-  symmetry  in |- *; apply Rabs_right; left; prove_sup.
-  symmetry  in |- *; apply Rabs_right; left; assumption.
+  symmetry ; apply Rabs_right; left; prove_sup0.
+  symmetry ; apply Rabs_right; left; prove_sup.
+  symmetry ; apply Rabs_right; left; assumption.
 Qed.
 
 Lemma maj_term3 :
@@ -206,11 +204,11 @@ Proof.
     (Rabs (2 * (f1 x / (f2 x * f2 x))) * Rabs (Rsqr (f2 x) * eps / (8 * f1 x))).
   apply Rmult_lt_compat_r.
   apply Rabs_pos_lt.
-  unfold Rdiv in |- *; unfold Rsqr in |- *; repeat apply prod_neq_R0;
+  unfold Rdiv; unfold Rsqr; repeat apply prod_neq_R0;
     try assumption.
-  red in |- *; intro H10; rewrite H10 in H; elim (Rlt_irrefl _ H).
+  red; intro H10; rewrite H10 in H; elim (Rlt_irrefl _ H).
   apply Rinv_neq_0_compat; apply prod_neq_R0; discrR || assumption.
-  unfold Rdiv in |- *.
+  unfold Rdiv.
   repeat rewrite Rinv_mult_distr; try assumption.
   repeat rewrite Rabs_mult.
   replace (Rabs 2) with 2.
@@ -224,9 +222,9 @@ Proof.
   repeat rewrite Rabs_Rinv; assumption || idtac.
   rewrite <- (Rmult_comm 2).
   unfold Rdiv in H9; exact H9.
-  symmetry  in |- *; apply Rabs_right; left; prove_sup0.
+  symmetry ; apply Rabs_right; left; prove_sup0.
   right.
-  unfold Rsqr, Rdiv in |- *.
+  unfold Rsqr, Rdiv.
   rewrite Rinv_mult_distr; try assumption || discrR.
   rewrite Rinv_mult_distr; try assumption || discrR.
   repeat rewrite Rabs_mult.
@@ -243,9 +241,9 @@ Proof.
     (Rabs (f1 x) * / Rabs (f1 x)) * (2 * / 2)); [ idtac | ring ].
   repeat rewrite <- Rinv_r_sym; try discrR || (apply Rabs_no_R0; assumption).
   ring.
-  symmetry  in |- *; apply Rabs_right; left; prove_sup0.
-  symmetry  in |- *; apply Rabs_right; left; prove_sup.
-  symmetry  in |- *; apply Rabs_right; left; assumption.
+  symmetry ; apply Rabs_right; left; prove_sup0.
+  symmetry ; apply Rabs_right; left; prove_sup.
+  symmetry ; apply Rabs_right; left; assumption.
 Qed.
 
 Lemma maj_term4 :
@@ -283,17 +281,17 @@ Proof.
       Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))).
   apply Rmult_lt_compat_r.
   apply Rabs_pos_lt.
-  unfold Rdiv in |- *; unfold Rsqr in |- *; repeat apply prod_neq_R0;
+  unfold Rdiv; unfold Rsqr; repeat apply prod_neq_R0;
     assumption || idtac.
-  red in |- *; intro H11; rewrite H11 in H; elim (Rlt_irrefl _ H).
+  red; intro H11; rewrite H11 in H; elim (Rlt_irrefl _ H).
   apply Rinv_neq_0_compat; apply prod_neq_R0.
   apply prod_neq_R0.
   discrR.
   assumption.
   assumption.
-  unfold Rdiv in |- *.
+  unfold Rdiv.
   repeat rewrite Rinv_mult_distr;
-    try assumption || (unfold Rsqr in |- *; apply prod_neq_R0; assumption).
+    try assumption || (unfold Rsqr; apply prod_neq_R0; assumption).
   repeat rewrite Rabs_mult.
   replace (Rabs 2) with 2.
   replace
@@ -307,13 +305,13 @@ Proof.
   repeat apply Rmult_lt_compat_l.
   apply Rabs_pos_lt; assumption.
   apply Rabs_pos_lt; assumption.
-  apply Rabs_pos_lt; apply Rinv_neq_0_compat; unfold Rsqr in |- *;
+  apply Rabs_pos_lt; apply Rinv_neq_0_compat; unfold Rsqr;
     apply prod_neq_R0; assumption.
   repeat rewrite Rabs_Rinv; [ idtac | assumption | assumption ].
   rewrite <- (Rmult_comm 2).
   unfold Rdiv in H10; exact H10.
-  symmetry  in |- *; apply Rabs_right; left; prove_sup0.
-  right; unfold Rsqr, Rdiv in |- *.
+  symmetry ; apply Rabs_right; left; prove_sup0.
+  right; unfold Rsqr, Rdiv.
   rewrite Rinv_mult_distr; try assumption || discrR.
   rewrite Rinv_mult_distr; try assumption || discrR.
   rewrite Rinv_mult_distr; try assumption || discrR.
@@ -335,9 +333,9 @@ Proof.
     (Rabs (f2 x) * / Rabs (f2 x)) * (2 * / 2)); [ idtac | ring ].
   repeat rewrite <- Rinv_r_sym; try discrR || (apply Rabs_no_R0; assumption).
   ring.
-  symmetry  in |- *; apply Rabs_right; left; prove_sup0.
-  symmetry  in |- *; apply Rabs_right; left; prove_sup.
-  symmetry  in |- *; apply Rabs_right; left; assumption.
+  symmetry ; apply Rabs_right; left; prove_sup0.
+  symmetry ; apply Rabs_right; left; prove_sup.
+  symmetry ; apply Rabs_right; left; assumption.
   apply prod_neq_R0; assumption || discrR.
   apply prod_neq_R0; assumption.
 Qed.
@@ -345,11 +343,11 @@ Qed.
 Lemma D_x_no_cond : forall x a:R, a <> 0 -> D_x no_cond x (x + a).
 Proof.
   intros.
-  unfold D_x, no_cond in |- *.
+  unfold D_x, no_cond.
   split.
   trivial.
   apply Rminus_not_eq.
-  unfold Rminus in |- *.
+  unfold Rminus.
   rewrite Ropp_plus_distr.
   rewrite <- Rplus_assoc.
   rewrite Rplus_opp_r.
@@ -396,7 +394,7 @@ Qed.
 Lemma quadruple_var : forall x:R, x = x / 4 + x / 4 + x / 4 + x / 4.
 Proof.
   intro; rewrite <- quadruple.
-  unfold Rdiv in |- *; rewrite <- Rmult_assoc; rewrite Rinv_r_simpl_m; discrR.
+  unfold Rdiv; rewrite <- Rmult_assoc; rewrite Rinv_r_simpl_m; discrR.
   reflexivity.
 Qed.
 
@@ -415,10 +413,10 @@ Proof.
   cut
     (dist R_met (x0 + h) x0 < x ->
       dist R_met (f (x0 + h)) (f x0) < Rabs (f x0 / 2)).
-  unfold dist in |- *; simpl in |- *; unfold R_dist in |- *;
+  unfold dist; simpl; unfold R_dist;
     replace (x0 + h - x0) with h.
   intros; assert (H7 := H6 H4).
-  red in |- *; intro.
+  red; intro.
   rewrite H8 in H7; unfold Rminus in H7; rewrite Rplus_0_l in H7;
     rewrite Rabs_Ropp in H7; unfold Rdiv in H7; rewrite Rabs_mult in H7;
       pattern (Rabs (f x0)) at 1 in H7; rewrite <- Rmult_1_r in H7.
@@ -431,10 +429,10 @@ Proof.
     rewrite Rmult_1_r in H12; rewrite <- Rinv_r_sym in H12;
       [ idtac | discrR ].
   cut (IZR 1 < IZR 2).
-  unfold IZR in |- *; unfold INR, nat_of_P in |- *; simpl in |- *; intro;
+  unfold IZR; unfold INR, Pos.to_nat; simpl; intro;
     elim (Rlt_irrefl 1 (Rlt_trans _ _ _ H13 H12)).
   apply IZR_lt; omega.
-  unfold Rabs in |- *; case (Rcase_abs (/ 2)); intro.
+  unfold Rabs; case (Rcase_abs (/ 2)); intro.
   assert (Hyp : 0 < 2).
   prove_sup0.
   assert (H11 := Rmult_lt_compat_l 2 _ _ Hyp r); rewrite Rmult_0_r in H11;
@@ -444,18 +442,18 @@ Proof.
   apply (Rabs_pos_lt _ H0).
   ring.
   assert (H6 := Req_dec x0 (x0 + h)); elim H6; intro.
-  intro; rewrite <- H7; unfold dist, R_met in |- *; unfold R_dist in |- *;
-    unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+  intro; rewrite <- H7; unfold dist, R_met; unfold R_dist;
+    unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0;
       apply Rabs_pos_lt.
-  unfold Rdiv in |- *; apply prod_neq_R0;
+  unfold Rdiv; apply prod_neq_R0;
     [ assumption | apply Rinv_neq_0_compat; discrR ].
   intro; apply H5.
   split.
-  unfold D_x, no_cond in |- *.
+  unfold D_x, no_cond.
   split; trivial || assumption.
   assumption.
-  change (0 < Rabs (f x0 / 2)) in |- *.
-  apply Rabs_pos_lt; unfold Rdiv in |- *; apply prod_neq_R0.
+  change (0 < Rabs (f x0 / 2)).
+  apply Rabs_pos_lt; unfold Rdiv; apply prod_neq_R0.
   assumption.
   apply Rinv_neq_0_compat; discrR.
 Qed.
diff --git a/theories/Reals/Ranalysis3.v b/theories/Reals/Ranalysis3.v
index c7d95660..5eaf5a57 100644
--- a/theories/Reals/Ranalysis3.v
+++ b/theories/Reals/Ranalysis3.v
@@ -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-2012     *)
 (*   \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.
 Require Import Ranalysis2.
-Open Local Scope R_scope.
+Local Open Scope R_scope.
 
 (** Division *)
 Theorem derivable_pt_lim_div :
@@ -24,17 +22,17 @@ Theorem derivable_pt_lim_div :
 Proof.
   intros f1 f2 x l1 l2 H H0 H1.
   cut (derivable_pt f2 x);
-    [ intro X | unfold derivable_pt in |- *; exists l2; exact H0 ].
+    [ intro X | unfold derivable_pt; exists l2; exact H0 ].
   assert (H2 := continuous_neq_0 _ _ (derivable_continuous_pt _ _ X) H1).
   elim H2; clear H2; intros eps_f2 H2.
-  unfold div_fct in |- *.
+  unfold div_fct.
   assert (H3 := derivable_continuous_pt _ _ X).
   unfold continuity_pt in H3; unfold continue_in in H3; unfold limit1_in in H3;
     unfold limit_in in H3; unfold dist in H3.
   simpl in H3; unfold R_dist in H3.
   elim (H3 (Rabs (f2 x) / 2));
     [ idtac
-      | unfold Rdiv in |- *; change (0 < Rabs (f2 x) * / 2) in |- *;
+      | unfold Rdiv; change (0 < Rabs (f2 x) * / 2);
         apply Rmult_lt_0_compat;
           [ apply Rabs_pos_lt; assumption | apply Rinv_0_lt_compat; prove_sup0 ] ].
   clear H3; intros alp_f2 H3.
@@ -48,12 +46,12 @@ Proof.
     (forall a:R,
       Rabs a < Rmin eps_f2 alp_f2 -> / Rabs (f2 (x + a)) < 2 / Rabs (f2 x)).
   intro Maj.
-  unfold derivable_pt_lim in |- *; intros.
+  unfold derivable_pt_lim; intros.
   elim (H (Rabs (eps * f2 x / 8)));
     [ idtac
-      | unfold Rdiv in |- *; change (0 < Rabs (eps * f2 x * / 8)) in |- *;
+      | unfold Rdiv; change (0 < Rabs (eps * f2 x * / 8));
         apply Rabs_pos_lt; repeat apply prod_neq_R0;
-          [ red in |- *; intro H7; rewrite H7 in H6; elim (Rlt_irrefl _ H6)
+          [ red; intro H7; rewrite H7 in H6; elim (Rlt_irrefl _ H6)
             | assumption
             | apply Rinv_neq_0_compat; discrR ] ].
   intros alp_f1d H7.
@@ -70,7 +68,7 @@ Proof.
           | elim H3; intros; assumption
           | apply (cond_pos alp_f1d) ] ].
   exists (mkposreal (Rmin eps_f2 (Rmin alp_f2 alp_f1d)) H10).
-  simpl in |- *; intros.
+  simpl; intros.
   assert (H13 := Rlt_le_trans _ _ _ H12 (Rmin_r _ _)).
   assert (H14 := Rlt_le_trans _ _ _ H12 (Rmin_l _ _)).
   assert (H15 := Rlt_le_trans _ _ _ H13 (Rmin_r _ _)).
@@ -82,7 +80,7 @@ Proof.
       Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) +
       Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) +
       Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))).
-  unfold Rminus in |- *.
+  unfold Rminus.
   rewrite <-
     (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2)))
     .
@@ -100,15 +98,15 @@ Proof.
   intros.
   apply Rlt_4; assumption.
   rewrite H8.
-  unfold Rdiv in |- *; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
+  unfold Rdiv; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
   rewrite Rabs_R0; rewrite Rmult_0_l.
   apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
   rewrite H8.
-  unfold Rdiv in |- *; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
+  unfold Rdiv; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
   rewrite Rabs_R0; rewrite Rmult_0_l.
   apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
   rewrite H9.
-  unfold Rdiv in |- *; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
+  unfold Rdiv; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
   rewrite Rabs_R0; rewrite Rmult_0_l.
   apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
   rewrite <- Rabs_mult.
@@ -116,7 +114,7 @@ Proof.
     try assumption || apply H2.
   apply H14.
   apply Rmin_2; assumption.
-  right; symmetry  in |- *; apply quadruple_var.
+  right; symmetry ; apply quadruple_var.
 (***********************************)
 (*           Second case           *)
 (*           (f1 x)=0  l1<>0       *)
@@ -139,7 +137,7 @@ Proof.
   cut (0 < Rmin (Rmin eps_f2 alp_f1d) (Rmin alp_f2 alp_f2t2)).
   intro.
   exists (mkposreal (Rmin (Rmin eps_f2 alp_f1d) (Rmin alp_f2 alp_f2t2)) H12).
-  simpl in |- *.
+  simpl.
   intros.
   assert (H15 := Rlt_le_trans _ _ _ H14 (Rmin_r _ _)).
   assert (H16 := Rlt_le_trans _ _ _ H14 (Rmin_l _ _)).
@@ -154,7 +152,7 @@ Proof.
       Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) +
       Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) +
       Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))).
-  unfold Rminus in |- *.
+  unfold Rminus.
   rewrite <-
     (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2)))
     .
@@ -172,11 +170,11 @@ Proof.
   intros.
   apply Rlt_4; assumption.
   rewrite H8.
-  unfold Rdiv in |- *; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
+  unfold Rdiv; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
   rewrite Rabs_R0; rewrite Rmult_0_l.
   apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
   rewrite H8.
-  unfold Rdiv in |- *; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
+  unfold Rdiv; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
   rewrite Rabs_R0; rewrite Rmult_0_l.
   apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
   rewrite <- Rabs_mult.
@@ -187,7 +185,7 @@ Proof.
   apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); try assumption.
   apply H2; assumption.
   apply Rmin_2; assumption.
-  right; symmetry  in |- *; apply quadruple_var.
+  right; symmetry ; apply quadruple_var.
   apply H2; assumption.
   repeat apply Rmin_pos.
   apply (cond_pos eps_f2).
@@ -198,21 +196,21 @@ Proof.
   elim H10; intros.
   case (Req_dec a 0); intro.
   rewrite H14; rewrite Rplus_0_r.
-  unfold Rminus in |- *; rewrite Rplus_opp_r.
+  unfold Rminus; rewrite Rplus_opp_r.
   rewrite Rabs_R0.
   apply Rabs_pos_lt.
-  unfold Rdiv, Rsqr in |- *; repeat rewrite Rmult_assoc.
+  unfold Rdiv, Rsqr; repeat rewrite Rmult_assoc.
   repeat apply prod_neq_R0; try assumption.
-  red in |- *; intro; rewrite H15 in H6; elim (Rlt_irrefl _ H6).
+  red; intro; rewrite H15 in H6; elim (Rlt_irrefl _ H6).
   apply Rinv_neq_0_compat; repeat apply prod_neq_R0; discrR || assumption.
   apply H13.
   split.
   apply D_x_no_cond; assumption.
   replace (x + a - x) with a; [ assumption | ring ].
-  change (0 < Rabs (eps * Rsqr (f2 x) / (8 * l1))) in |- *.
-  apply Rabs_pos_lt; unfold Rdiv, Rsqr in |- *; repeat rewrite Rmult_assoc;
+  change (0 < Rabs (eps * Rsqr (f2 x) / (8 * l1))).
+  apply Rabs_pos_lt; unfold Rdiv, Rsqr; repeat rewrite Rmult_assoc;
     repeat apply prod_neq_R0.
-  red in |- *; intro; rewrite H11 in H6; elim (Rlt_irrefl _ H6).
+  red; intro; rewrite H11 in H6; elim (Rlt_irrefl _ H6).
   assumption.
   assumption.
   apply Rinv_neq_0_compat; repeat apply prod_neq_R0;
@@ -225,17 +223,17 @@ Proof.
   case (Req_dec l2 0); intro.
   elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x))));
     [ idtac
-      | apply Rabs_pos_lt; unfold Rdiv, Rsqr in |- *; repeat rewrite Rmult_assoc;
+      | apply Rabs_pos_lt; unfold Rdiv, Rsqr; repeat rewrite Rmult_assoc;
         repeat apply prod_neq_R0;
           [ assumption
             | assumption
-            | red in |- *; intro; rewrite H11 in H6; elim (Rlt_irrefl _ H6)
+            | red; intro; rewrite H11 in H6; elim (Rlt_irrefl _ H6)
             | apply Rinv_neq_0_compat; repeat apply prod_neq_R0; discrR || assumption ] ].
   intros alp_f2d H12.
   cut (0 < Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d alp_f2d)).
   intro.
   exists (mkposreal (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d alp_f2d)) H11).
-  simpl in |- *.
+  simpl.
   intros.
   assert (H15 := Rlt_le_trans _ _ _ H14 (Rmin_l _ _)).
   assert (H16 := Rlt_le_trans _ _ _ H14 (Rmin_r _ _)).
@@ -250,7 +248,7 @@ Proof.
       Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) +
       Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) +
       Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))).
-  unfold Rminus in |- *.
+  unfold Rminus.
   rewrite <-
     (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2)))
     .
@@ -268,7 +266,7 @@ Proof.
   intros.
   apply Rlt_4; assumption.
   rewrite H10.
-  unfold Rdiv in |- *; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
+  unfold Rdiv; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
   rewrite Rabs_R0; rewrite Rmult_0_l.
   apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
   rewrite <- Rabs_mult.
@@ -276,14 +274,14 @@ Proof.
   apply H2; assumption.
   apply Rmin_2; assumption.
   rewrite H9.
-  unfold Rdiv in |- *; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
+  unfold Rdiv; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
   rewrite Rabs_R0; rewrite Rmult_0_l.
   apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
   rewrite <- Rabs_mult.
   apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); assumption || idtac.
   apply H2; assumption.
   apply Rmin_2; assumption.
-  right; symmetry  in |- *; apply quadruple_var.
+  right; symmetry ; apply quadruple_var.
   apply H2; assumption.
   repeat apply Rmin_pos.
   apply (cond_pos eps_f2).
@@ -296,7 +294,7 @@ Proof.
 (***********************************)
   elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x))));
     [ idtac
-      | apply Rabs_pos_lt; unfold Rsqr, Rdiv in |- *;
+      | apply Rabs_pos_lt; unfold Rsqr, Rdiv;
         repeat rewrite Rinv_mult_distr; repeat apply prod_neq_R0;
           try assumption || discrR ].
   intros alp_f2d H11.
@@ -315,7 +313,7 @@ Proof.
   exists
     (mkposreal (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d (Rmin alp_f2d alp_f2c)))
       H14).
-  simpl in |- *; intros.
+  simpl; intros.
   assert (H17 := Rlt_le_trans _ _ _ H16 (Rmin_l _ _)).
   assert (H18 := Rlt_le_trans _ _ _ H16 (Rmin_r _ _)).
   assert (H19 := Rlt_le_trans _ _ _ H18 (Rmin_r _ _)).
@@ -337,7 +335,7 @@ Proof.
       Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) +
       Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) +
       Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))).
-  unfold Rminus in |- *.
+  unfold Rminus.
   rewrite <-
     (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2)))
     .
@@ -363,24 +361,24 @@ Proof.
   apply H2; assumption.
   apply Rmin_2; assumption.
   rewrite H9.
-  unfold Rdiv in |- *; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
+  unfold Rdiv; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
   rewrite Rabs_R0; rewrite Rmult_0_l.
   apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
   rewrite <- Rabs_mult.
   apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); try assumption.
   apply H2; assumption.
   apply Rmin_2; assumption.
-  right; symmetry  in |- *; apply quadruple_var.
+  right; symmetry ; apply quadruple_var.
   apply H2; assumption.
   intros.
   case (Req_dec a 0); intro.
   rewrite H17; rewrite Rplus_0_r.
-  unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0.
+  unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0.
   apply Rabs_pos_lt.
-  unfold Rdiv, Rsqr in |- *.
+  unfold Rdiv, Rsqr.
   repeat rewrite Rinv_mult_distr; try assumption.
   repeat apply prod_neq_R0; try assumption.
-  red in |- *; intro H18; rewrite H18 in H6; elim (Rlt_irrefl _ H6).
+  red; intro H18; rewrite H18 in H6; elim (Rlt_irrefl _ H6).
   apply Rinv_neq_0_compat; discrR.
   apply Rinv_neq_0_compat; discrR.
   apply Rinv_neq_0_compat; discrR.
@@ -403,19 +401,19 @@ Proof.
   apply (cond_pos alp_f1d).
   apply (cond_pos alp_f2d).
   elim H13; intros; assumption.
-  change (0 < Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))) in |- *.
+  change (0 < Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))).
   apply Rabs_pos_lt.
-  unfold Rsqr, Rdiv in |- *.
+  unfold Rsqr, Rdiv.
   repeat rewrite Rinv_mult_distr; try assumption || discrR.
   repeat apply prod_neq_R0; try assumption.
-  red in |- *; intro H13; rewrite H13 in H6; elim (Rlt_irrefl _ H6).
+  red; intro H13; rewrite H13 in H6; elim (Rlt_irrefl _ H6).
   apply Rinv_neq_0_compat; discrR.
   apply Rinv_neq_0_compat; discrR.
   apply Rinv_neq_0_compat; discrR.
   apply Rinv_neq_0_compat; assumption.
   apply Rinv_neq_0_compat; assumption.
   apply prod_neq_R0; [ discrR | assumption ].
-  red in |- *; intro H11; rewrite H11 in H6; elim (Rlt_irrefl _ H6).
+  red; intro H11; rewrite H11 in H6; elim (Rlt_irrefl _ H6).
   apply Rinv_neq_0_compat; discrR.
   apply Rinv_neq_0_compat; discrR.
   apply Rinv_neq_0_compat; discrR.
@@ -442,7 +440,7 @@ Proof.
   exists
     (mkposreal
       (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d (Rmin alp_f2d alp_f2t2))) H13).
-  simpl in |- *.
+  simpl.
   intros.
   cut
     (forall a:R,
@@ -464,7 +462,7 @@ Proof.
       Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) +
       Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) +
       Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))).
-  unfold Rminus in |- *.
+  unfold Rminus.
   rewrite <-
     (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2)))
     .
@@ -482,7 +480,7 @@ Proof.
   intros.
   apply Rlt_4; assumption.
   rewrite H10.
-  unfold Rdiv in |- *; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
+  unfold Rdiv; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
   rewrite Rabs_R0; rewrite Rmult_0_l.
   apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
   rewrite <- Rabs_mult.
@@ -497,20 +495,20 @@ Proof.
   apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); try assumption.
   apply H2; assumption.
   apply Rmin_2; assumption.
-  right; symmetry  in |- *; apply quadruple_var.
+  right; symmetry ; apply quadruple_var.
   apply H2; assumption.
   intros.
   case (Req_dec a 0); intro.
-  rewrite H17; rewrite Rplus_0_r; unfold Rminus in |- *; rewrite Rplus_opp_r;
+  rewrite H17; rewrite Rplus_0_r; unfold Rminus; rewrite Rplus_opp_r;
     rewrite Rabs_R0.
   apply Rabs_pos_lt.
-  unfold Rdiv in |- *; rewrite Rinv_mult_distr; try discrR || assumption.
-  unfold Rsqr in |- *.
+  unfold Rdiv; rewrite Rinv_mult_distr; try discrR || assumption.
+  unfold Rsqr.
   repeat apply prod_neq_R0;
     assumption ||
       (apply Rinv_neq_0_compat; assumption) ||
         (apply Rinv_neq_0_compat; discrR) ||
-          (red in |- *; intro H18; rewrite H18 in H6; elim (Rlt_irrefl _ H6)).
+          (red; intro H18; rewrite H18 in H6; elim (Rlt_irrefl _ H6)).
   elim H11; intros.
   apply H19.
   split.
@@ -523,20 +521,20 @@ Proof.
   apply (cond_pos alp_f2d).
   elim H11; intros; assumption.
   apply Rabs_pos_lt.
-  unfold Rdiv, Rsqr in |- *; rewrite Rinv_mult_distr; try discrR || assumption.
+  unfold Rdiv, Rsqr; rewrite Rinv_mult_distr; try discrR || assumption.
   repeat apply prod_neq_R0;
     assumption ||
       (apply Rinv_neq_0_compat; assumption) ||
         (apply Rinv_neq_0_compat; discrR) ||
-          (red in |- *; intro H12; rewrite H12 in H6; elim (Rlt_irrefl _ H6)).
-  change (0 < Rabs (eps * Rsqr (f2 x) / (8 * l1))) in |- *.
+          (red; intro H12; rewrite H12 in H6; elim (Rlt_irrefl _ H6)).
+  change (0 < Rabs (eps * Rsqr (f2 x) / (8 * l1))).
   apply Rabs_pos_lt.
-  unfold Rdiv, Rsqr in |- *; rewrite Rinv_mult_distr; try discrR || assumption.
+  unfold Rdiv, Rsqr; rewrite Rinv_mult_distr; try discrR || assumption.
   repeat apply prod_neq_R0;
     assumption ||
       (apply Rinv_neq_0_compat; assumption) ||
         (apply Rinv_neq_0_compat; discrR) ||
-          (red in |- *; intro H12; rewrite H12 in H6; elim (Rlt_irrefl _ H6)).
+          (red; intro H12; rewrite H12 in H6; elim (Rlt_irrefl _ H6)).
 (***********************************)
 (*       Sixth case                *)
 (*    (f1 x)<>0  l1<>0  l2<>0      *)
@@ -564,7 +562,7 @@ Proof.
     (mkposreal
       (Rmin (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d alp_f2d))
         (Rmin alp_f2c alp_f2t2)) H15).
-  simpl in |- *.
+  simpl.
   intros.
   assert (H18 := Rlt_le_trans _ _ _ H17 (Rmin_l _ _)).
   assert (H19 := Rlt_le_trans _ _ _ H17 (Rmin_r _ _)).
@@ -593,7 +591,7 @@ Proof.
       Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) +
       Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) +
       Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))).
-  unfold Rminus in |- *.
+  unfold Rminus.
   rewrite <-
     (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2)))
     .
@@ -626,18 +624,18 @@ Proof.
   apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); try assumption.
   apply H2; assumption.
   apply Rmin_2; assumption.
-  right; symmetry  in |- *; apply quadruple_var.
+  right; symmetry ; apply quadruple_var.
   apply H2; assumption.
   intros.
   case (Req_dec a 0); intro.
-  rewrite H18; rewrite Rplus_0_r; unfold Rminus in |- *; rewrite Rplus_opp_r;
+  rewrite H18; rewrite Rplus_0_r; unfold Rminus; rewrite Rplus_opp_r;
     rewrite Rabs_R0; apply Rabs_pos_lt.
-  unfold Rdiv, Rsqr in |- *; rewrite Rinv_mult_distr.
+  unfold Rdiv, Rsqr; rewrite Rinv_mult_distr.
   repeat apply prod_neq_R0;
     assumption ||
       (apply Rinv_neq_0_compat; assumption) ||
         (apply Rinv_neq_0_compat; discrR) ||
-          (red in |- *; intro H28; rewrite H28 in H6; elim (Rlt_irrefl _ H6)).
+          (red; intro H28; rewrite H28 in H6; elim (Rlt_irrefl _ H6)).
   apply prod_neq_R0; [ discrR | assumption ].
   apply prod_neq_R0; [ discrR | assumption ].
   assumption.
@@ -648,20 +646,20 @@ Proof.
   replace (x + a - x) with a; [ assumption | ring ].
   intros.
   case (Req_dec a 0); intro.
-  rewrite H18; rewrite Rplus_0_r; unfold Rminus in |- *; rewrite Rplus_opp_r;
+  rewrite H18; rewrite Rplus_0_r; unfold Rminus; rewrite Rplus_opp_r;
     rewrite Rabs_R0; apply Rabs_pos_lt.
-  unfold Rdiv, Rsqr in |- *; rewrite Rinv_mult_distr.
+  unfold Rdiv, Rsqr; rewrite Rinv_mult_distr.
   repeat apply prod_neq_R0;
     assumption ||
       (apply Rinv_neq_0_compat; assumption) ||
         (apply Rinv_neq_0_compat; discrR) ||
-          (red in |- *; intro H28; rewrite H28 in H6; elim (Rlt_irrefl _ H6)).
+          (red; intro H28; rewrite H28 in H6; elim (Rlt_irrefl _ H6)).
   discrR.
   assumption.
   elim H14; intros.
   apply H20.
   split.
-  unfold D_x, no_cond in |- *; split.
+  unfold D_x, no_cond; split.
   trivial.
   apply Rminus_not_eq_right.
   replace (x + a - x) with a; [ assumption | ring ].
@@ -673,34 +671,34 @@ Proof.
   apply (cond_pos alp_f2d).
   elim H13; intros; assumption.
   elim H14; intros; assumption.
-  change (0 < Rabs (eps * Rsqr (f2 x) / (8 * l1))) in |- *; apply Rabs_pos_lt.
-  unfold Rdiv, Rsqr in |- *; rewrite Rinv_mult_distr; try discrR || assumption.
+  change (0 < Rabs (eps * Rsqr (f2 x) / (8 * l1))); apply Rabs_pos_lt.
+  unfold Rdiv, Rsqr; rewrite Rinv_mult_distr; try discrR || assumption.
   repeat apply prod_neq_R0;
     assumption ||
       (apply Rinv_neq_0_compat; assumption) ||
         (apply Rinv_neq_0_compat; discrR) ||
-          (red in |- *; intro H14; rewrite H14 in H6; elim (Rlt_irrefl _ H6)).
-  change (0 < Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))) in |- *;
+          (red; intro H14; rewrite H14 in H6; elim (Rlt_irrefl _ H6)).
+  change (0 < Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2)));
     apply Rabs_pos_lt.
-  unfold Rdiv, Rsqr in |- *; rewrite Rinv_mult_distr.
+  unfold Rdiv, Rsqr; rewrite Rinv_mult_distr.
   repeat apply prod_neq_R0;
     assumption ||
       (apply Rinv_neq_0_compat; assumption) ||
         (apply Rinv_neq_0_compat; discrR) ||
-          (red in |- *; intro H13; rewrite H13 in H6; elim (Rlt_irrefl _ H6)).
+          (red; intro H13; rewrite H13 in H6; elim (Rlt_irrefl _ H6)).
   apply prod_neq_R0; [ discrR | assumption ].
   apply prod_neq_R0; [ discrR | assumption ].
   assumption.
   apply Rabs_pos_lt.
-  unfold Rdiv, Rsqr in |- *; rewrite Rinv_mult_distr;
+  unfold Rdiv, Rsqr; rewrite Rinv_mult_distr;
     [ idtac | discrR | assumption ].
   repeat apply prod_neq_R0;
     assumption ||
       (apply Rinv_neq_0_compat; assumption) ||
         (apply Rinv_neq_0_compat; discrR) ||
-          (red in |- *; intro H11; rewrite H11 in H6; elim (Rlt_irrefl _ H6)).
+          (red; intro H11; rewrite H11 in H6; elim (Rlt_irrefl _ H6)).
   intros.
-  unfold Rdiv in |- *.
+  unfold Rdiv.
   apply Rmult_lt_reg_l with (Rabs (f2 (x + a))).
   apply Rabs_pos_lt; apply H2.
   apply Rlt_le_trans with (Rmin eps_f2 alp_f2).
@@ -741,13 +739,13 @@ Proof.
   unfold Rminus in H7; assumption.
   intros.
   case (Req_dec x x0); intro.
-  rewrite <- H5; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
-    unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+  rewrite <- H5; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0;
+    unfold Rdiv; apply Rmult_lt_0_compat;
       [ apply Rabs_pos_lt; assumption | apply Rinv_0_lt_compat; prove_sup0 ].
   elim H3; intros.
   apply H7.
   split.
-  unfold D_x, no_cond in |- *; split.
+  unfold D_x, no_cond; split.
   trivial.
   assumption.
   assumption.
@@ -758,7 +756,7 @@ Lemma derivable_pt_div :
     derivable_pt f1 x ->
     derivable_pt f2 x -> f2 x <> 0 -> derivable_pt (f1 / f2) x.
 Proof.
-  unfold derivable_pt in |- *.
+  unfold derivable_pt.
   intros f1 f2 x X X0 H.
   elim X; intros.
   elim X0; intros.
@@ -771,7 +769,7 @@ Lemma derivable_div :
     derivable f1 ->
     derivable f2 -> (forall x:R, f2 x <> 0) -> derivable (f1 / f2).
 Proof.
-  unfold derivable in |- *; intros f1 f2 X X0 H x.
+  unfold derivable; intros f1 f2 X X0 H x.
   apply (derivable_pt_div _ _ _ (X x) (X0 x) (H x)).
 Qed.
 
diff --git a/theories/Reals/Ranalysis4.v b/theories/Reals/Ranalysis4.v
index a7c5a387..00c07592 100644
--- a/theories/Reals/Ranalysis4.v
+++ b/theories/Reals/Ranalysis4.v
@@ -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-2012     *)
 (*   \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.
-Require Import Rtrigo.
+Require Import Rtrigo1.
 Require Import Ranalysis1.
 Require Import Ranalysis3.
 Require Import Exp_prop.
-Open Local Scope R_scope.
+Local Open Scope R_scope.
 
 (**********)
 Lemma derivable_pt_inv :
@@ -28,12 +26,12 @@ Proof.
   apply derivable_pt_const.
   assumption.
   assumption.
-  unfold div_fct, inv_fct, fct_cte in |- *; intro X0; elim X0; intros;
-    unfold derivable_pt in |- *; exists x0;
-      unfold derivable_pt_abs in |- *; unfold derivable_pt_lim in |- *;
+  unfold div_fct, inv_fct, fct_cte; intro X0; elim X0; intros;
+    unfold derivable_pt; exists x0;
+      unfold derivable_pt_abs; unfold derivable_pt_lim;
         unfold derivable_pt_abs in p; unfold derivable_pt_lim in p;
           intros; elim (p eps H0); intros; exists x1; intros;
-            unfold Rdiv in H1; unfold Rdiv in |- *; rewrite <- (Rmult_1_l (/ f x));
+            unfold Rdiv in H1; unfold Rdiv; rewrite <- (Rmult_1_l (/ f x));
               rewrite <- (Rmult_1_l (/ f (x + h))).
   apply H1; assumption.
 Qed.
@@ -43,10 +41,10 @@ Lemma pr_nu_var :
   forall (f g:R -> R) (x:R) (pr1:derivable_pt f x) (pr2:derivable_pt g x),
     f = g -> derive_pt f x pr1 = derive_pt g x pr2.
 Proof.
-  unfold derivable_pt, derive_pt in |- *; intros.
+  unfold derivable_pt, derive_pt; intros.
   elim pr1; intros.
   elim pr2; intros.
-  simpl in |- *.
+  simpl.
   rewrite H in p.
   apply uniqueness_limite with g x; assumption.
 Qed.
@@ -56,17 +54,17 @@ Lemma pr_nu_var2 :
   forall (f g:R -> R) (x:R) (pr1:derivable_pt f x) (pr2:derivable_pt g x),
     (forall h:R, f h = g h) -> derive_pt f x pr1 = derive_pt g x pr2.
 Proof.
-  unfold derivable_pt, derive_pt in |- *; intros.
+  unfold derivable_pt, derive_pt; intros.
   elim pr1; intros.
   elim pr2; intros.
-  simpl in |- *.
+  simpl.
   assert (H0 := uniqueness_step2 _ _ _ p).
   assert (H1 := uniqueness_step2 _ _ _ p0).
   cut (limit1_in (fun h:R => (f (x + h) - f x) / h) (fun h:R => h <> 0) x1 0).
   intro; assert (H3 := uniqueness_step1 _ _ _ _ H0 H2).
   assumption.
-  unfold limit1_in in |- *; unfold limit_in in |- *; unfold dist in |- *;
-    simpl in |- *; unfold R_dist in |- *; unfold limit1_in in H1;
+  unfold limit1_in; unfold limit_in; unfold dist;
+    simpl; unfold R_dist; unfold limit1_in in H1;
       unfold limit_in in H1; unfold dist in H1; simpl in H1;
         unfold R_dist in H1.
   intros; elim (H1 eps H2); intros.
@@ -82,7 +80,7 @@ Lemma derivable_inv :
   forall f:R -> R, (forall x:R, f x <> 0) -> derivable f -> derivable (/ f).
 Proof.
   intros f H X.
-  unfold derivable in |- *; intro x.
+  unfold derivable; intro x.
   apply derivable_pt_inv.
   apply (H x).
   apply (X x).
@@ -97,25 +95,25 @@ Proof.
     replace (derive_pt (/ f) x (derivable_pt_inv f x na pr)) with
     (derive_pt (fct_cte 1 / f) x
       (derivable_pt_div (fct_cte 1) f x (derivable_pt_const 1 x) pr na)).
-  rewrite derive_pt_div; rewrite derive_pt_const; unfold fct_cte in |- *;
-    rewrite Rmult_0_l; rewrite Rmult_1_r; unfold Rminus in |- *;
+  rewrite derive_pt_div; rewrite derive_pt_const; unfold fct_cte;
+    rewrite Rmult_0_l; rewrite Rmult_1_r; unfold Rminus;
       rewrite Rplus_0_l; reflexivity.
   apply pr_nu_var2.
-  intro; unfold div_fct, fct_cte, inv_fct in |- *.
-  unfold Rdiv in |- *; ring.
+  intro; unfold div_fct, fct_cte, inv_fct.
+  unfold Rdiv; ring.
 Qed.
 
 (** Rabsolu *)
 Lemma Rabs_derive_1 : forall x:R, 0 < x -> derivable_pt_lim Rabs x 1.
 Proof.
   intros.
-  unfold derivable_pt_lim in |- *; intros.
+  unfold derivable_pt_lim; intros.
   exists (mkposreal x H); intros.
   rewrite (Rabs_right x).
   rewrite (Rabs_right (x + h)).
   rewrite Rplus_comm.
-  unfold Rminus in |- *; rewrite Rplus_assoc; rewrite Rplus_opp_r.
-  rewrite Rplus_0_r; unfold Rdiv in |- *; rewrite <- Rinv_r_sym.
+  unfold Rminus; rewrite Rplus_assoc; rewrite Rplus_opp_r.
+  rewrite Rplus_0_r; unfold Rdiv; rewrite <- Rinv_r_sym.
   rewrite Rplus_opp_r; rewrite Rabs_R0; apply H0.
   apply H1.
   apply Rle_ge.
@@ -133,16 +131,16 @@ Qed.
 Lemma Rabs_derive_2 : forall x:R, x < 0 -> derivable_pt_lim Rabs x (-1).
 Proof.
   intros.
-  unfold derivable_pt_lim in |- *; intros.
+  unfold derivable_pt_lim; intros.
   cut (0 < - x).
   intro; exists (mkposreal (- x) H1); intros.
   rewrite (Rabs_left x).
   rewrite (Rabs_left (x + h)).
   rewrite Rplus_comm.
   rewrite Ropp_plus_distr.
-  unfold Rminus in |- *; rewrite Ropp_involutive; rewrite Rplus_assoc;
+  unfold Rminus; rewrite Ropp_involutive; rewrite Rplus_assoc;
     rewrite Rplus_opp_l.
-  rewrite Rplus_0_r; unfold Rdiv in |- *.
+  rewrite Rplus_0_r; unfold Rdiv.
   rewrite Ropp_mult_distr_l_reverse.
   rewrite <- Rinv_r_sym.
   rewrite Ropp_involutive; rewrite Rplus_opp_l; rewrite Rabs_R0; apply H0.
@@ -165,24 +163,24 @@ Proof.
   intros.
   case (total_order_T x 0); intro.
   elim s; intro.
-  unfold derivable_pt in |- *; exists (-1).
+  unfold derivable_pt; exists (-1).
   apply (Rabs_derive_2 x a).
   elim H; exact b.
-  unfold derivable_pt in |- *; exists 1.
+  unfold derivable_pt; exists 1.
   apply (Rabs_derive_1 x r).
 Qed.
 
 (** Rabsolu is continuous for all x *)
 Lemma Rcontinuity_abs : continuity Rabs.
 Proof.
-  unfold continuity in |- *; intro.
+  unfold continuity; intro.
   case (Req_dec x 0); intro.
-  unfold continuity_pt in |- *; unfold continue_in in |- *;
-    unfold limit1_in in |- *; unfold limit_in in |- *;
-      simpl in |- *; unfold R_dist in |- *; intros; exists eps;
+  unfold continuity_pt; unfold continue_in;
+    unfold limit1_in; unfold limit_in;
+      simpl; unfold R_dist; intros; exists eps;
         split.
   apply H0.
-  intros; rewrite H; rewrite Rabs_R0; unfold Rminus in |- *; rewrite Ropp_0;
+  intros; rewrite H; rewrite Rabs_R0; unfold Rminus; rewrite Ropp_0;
     rewrite Rplus_0_r; rewrite Rabs_Rabsolu; elim H1;
       intros; rewrite H in H3; unfold Rminus in H3; rewrite Ropp_0 in H3;
         rewrite Rplus_0_r in H3; apply H3.
@@ -194,11 +192,11 @@ Lemma continuity_finite_sum :
   forall (An:nat -> R) (N:nat),
     continuity (fun y:R => sum_f_R0 (fun k:nat => An k * y ^ k) N).
 Proof.
-  intros; unfold continuity in |- *; intro.
+  intros; unfold continuity; intro.
   induction  N as [| N HrecN].
-  simpl in |- *.
+  simpl.
   apply continuity_pt_const.
-  unfold constant in |- *; intros; reflexivity.
+  unfold constant; intros; reflexivity.
   replace (fun y:R => sum_f_R0 (fun k:nat => An k * y ^ k) (S N)) with
   ((fun y:R => sum_f_R0 (fun k:nat => (An k * y ^ k)%R) N) +
     (fun y:R => (An (S N) * y ^ S N)%R))%F.
@@ -224,7 +222,7 @@ Proof.
   cut (N = 0%nat \/ (0 < N)%nat).
   intro; elim H0; intro.
   rewrite H1.
-  simpl in |- *.
+  simpl.
   replace (fun y:R => An 0%nat * 1 + An 1%nat * (y * 1)) with
   (fct_cte (An 0%nat * 1) + mult_real_fct (An 1%nat) (id * fct_cte 1))%F.
   replace (1 * An 1%nat * 1) with (0 + An 1%nat * (1 * fct_cte 1 x + id x * 0)).
@@ -234,7 +232,7 @@ Proof.
   apply derivable_pt_lim_mult.
   apply derivable_pt_lim_id.
   apply derivable_pt_lim_const.
-  unfold fct_cte, id in |- *; ring.
+  unfold fct_cte, id; ring.
   reflexivity.
   replace (fun y:R => sum_f_R0 (fun k:nat => An k * y ^ k) (S N)) with
   ((fun y:R => sum_f_R0 (fun k:nat => (An k * y ^ k)%R) N) +
@@ -250,7 +248,7 @@ Proof.
   (mult_real_fct (An (S N)) (fun y:R => y ^ S N)).
   apply derivable_pt_lim_scal.
   replace (pred (S N)) with N; [ idtac | reflexivity ].
-  pattern N at 3 in |- *; replace N with (pred (S N)).
+  pattern N at 3; replace N with (pred (S N)).
   apply derivable_pt_lim_pow.
   reflexivity.
   reflexivity.
@@ -261,10 +259,10 @@ Proof.
   rewrite <- H2.
   replace (pred (S N)) with N; [ idtac | reflexivity ].
   ring.
-  simpl in |- *.
+  simpl.
   apply S_pred with 0%nat; assumption.
-  unfold plus_fct in |- *.
-  simpl in |- *; reflexivity.
+  unfold plus_fct.
+  simpl; reflexivity.
   inversion H.
   left; reflexivity.
   right; apply lt_le_trans with 1%nat; [ apply lt_O_Sn | assumption ].
@@ -280,7 +278,7 @@ Lemma derivable_pt_lim_finite_sum :
 Proof.
   intros.
   induction  N as [| N HrecN].
-  simpl in |- *.
+  simpl.
   rewrite Rmult_1_r.
   replace (fun _:R => An 0%nat) with (fct_cte (An 0%nat));
   [ apply derivable_pt_lim_const | reflexivity ].
@@ -292,7 +290,7 @@ Lemma derivable_pt_finite_sum :
     derivable_pt (fun y:R => sum_f_R0 (fun k:nat => An k * y ^ k) N) x.
 Proof.
   intros.
-  unfold derivable_pt in |- *.
+  unfold derivable_pt.
   assert (H := derivable_pt_lim_finite_sum An x N).
   induction  N as [| N HrecN].
   exists 0; apply H.
@@ -305,14 +303,14 @@ Lemma derivable_finite_sum :
   forall (An:nat -> R) (N:nat),
     derivable (fun y:R => sum_f_R0 (fun k:nat => An k * y ^ k) N).
 Proof.
-  intros; unfold derivable in |- *; intro; apply derivable_pt_finite_sum.
+  intros; unfold derivable; intro; apply derivable_pt_finite_sum.
 Qed.
 
 (** Regularity of hyperbolic functions *)
 Lemma derivable_pt_lim_cosh : forall x:R, derivable_pt_lim cosh x (sinh x).
 Proof.
   intro.
-  unfold cosh, sinh in |- *; unfold Rdiv in |- *.
+  unfold cosh, sinh; unfold Rdiv.
   replace (fun x0:R => (exp x0 + exp (- x0)) * / 2) with
   ((exp + comp exp (- id)) * fct_cte (/ 2))%F; [ idtac | reflexivity ].
   replace ((exp x - exp (- x)) * / 2) with
@@ -326,13 +324,13 @@ Proof.
   apply derivable_pt_lim_id.
   apply derivable_pt_lim_exp.
   apply derivable_pt_lim_const.
-  unfold plus_fct, mult_real_fct, comp, opp_fct, id, fct_cte in |- *; ring.
+  unfold plus_fct, mult_real_fct, comp, opp_fct, id, fct_cte; ring.
 Qed.
 
 Lemma derivable_pt_lim_sinh : forall x:R, derivable_pt_lim sinh x (cosh x).
 Proof.
   intro.
-  unfold cosh, sinh in |- *; unfold Rdiv in |- *.
+  unfold cosh, sinh; unfold Rdiv.
   replace (fun x0:R => (exp x0 - exp (- x0)) * / 2) with
   ((exp - comp exp (- id)) * fct_cte (/ 2))%F; [ idtac | reflexivity ].
   replace ((exp x + exp (- x)) * / 2) with
@@ -346,13 +344,13 @@ Proof.
   apply derivable_pt_lim_id.
   apply derivable_pt_lim_exp.
   apply derivable_pt_lim_const.
-  unfold plus_fct, mult_real_fct, comp, opp_fct, id, fct_cte in |- *; ring.
+  unfold plus_fct, mult_real_fct, comp, opp_fct, id, fct_cte; ring.
 Qed.
 
 Lemma derivable_pt_exp : forall x:R, derivable_pt exp x.
 Proof.
   intro.
-  unfold derivable_pt in |- *.
+  unfold derivable_pt.
   exists (exp x).
   apply derivable_pt_lim_exp.
 Qed.
@@ -360,7 +358,7 @@ Qed.
 Lemma derivable_pt_cosh : forall x:R, derivable_pt cosh x.
 Proof.
   intro.
-  unfold derivable_pt in |- *.
+  unfold derivable_pt.
   exists (sinh x).
   apply derivable_pt_lim_cosh.
 Qed.
@@ -368,24 +366,24 @@ Qed.
 Lemma derivable_pt_sinh : forall x:R, derivable_pt sinh x.
 Proof.
   intro.
-  unfold derivable_pt in |- *.
+  unfold derivable_pt.
   exists (cosh x).
   apply derivable_pt_lim_sinh.
 Qed.
 
 Lemma derivable_exp : derivable exp.
 Proof.
-  unfold derivable in |- *; apply derivable_pt_exp.
+  unfold derivable; apply derivable_pt_exp.
 Qed.
 
 Lemma derivable_cosh : derivable cosh.
 Proof.
-  unfold derivable in |- *; apply derivable_pt_cosh.
+  unfold derivable; apply derivable_pt_cosh.
 Qed.
 
 Lemma derivable_sinh : derivable sinh.
 Proof.
-  unfold derivable in |- *; apply derivable_pt_sinh.
+  unfold derivable; apply derivable_pt_sinh.
 Qed.
 
 Lemma derive_pt_exp :
diff --git a/theories/Reals/Ranalysis5.v b/theories/Reals/Ranalysis5.v
new file mode 100644
index 00000000..c8a2e1a8
--- /dev/null
+++ b/theories/Reals/Ranalysis5.v
@@ -0,0 +1,1348 @@
+Require Import Rbase.
+Require Import Ranalysis_reg.
+Require Import Rfunctions.
+Require Import Rseries.
+Require Import Fourier.
+Require Import RiemannInt.
+Require Import SeqProp.
+Require Import Max.
+Local Open Scope R_scope.
+
+(** * Preliminaries lemmas *)
+
+Lemma f_incr_implies_g_incr_interv : forall f g:R->R, forall lb ub,
+       lb < ub ->
+       (forall x y, lb <= x -> x < y -> y <= ub -> f x < f y) ->
+       (forall x, f lb <= x -> x <= f ub -> (comp f g) x = id x) ->
+       (forall x , f lb <= x -> x <= f ub -> lb <= g x <= ub) ->
+       (forall x y, f lb <= x -> x < y -> y <= f ub -> g x < g y).
+Proof.
+intros f g lb ub lb_lt_ub f_incr f_eq_g g_ok x y lb_le_x x_lt_y y_le_ub.
+ assert (x_encad : f lb <= x <= f ub).
+  split ; [assumption | apply Rle_trans with (r2:=y) ; [apply Rlt_le|] ; assumption].
+ assert (y_encad : f lb <= y <= f ub).
+  split ; [apply Rle_trans with (r2:=x) ; [|apply Rlt_le] ; assumption | assumption].
+  assert (Temp1 : lb <= lb) by intuition ; assert (Temp2 : ub <= ub) by intuition.
+ assert (gx_encad := g_ok _ (proj1 x_encad) (proj2 x_encad)).
+ assert (gy_encad := g_ok _ (proj1 y_encad) (proj2 y_encad)).
+ clear Temp1 Temp2.
+ case (Rlt_dec (g x) (g y)).
+  intuition.
+  intros Hfalse.
+   assert (Temp := Rnot_lt_le _ _ Hfalse).
+   assert (Hcontradiction : y <= x).
+   replace y with (id y) by intuition ; replace x with (id x) by intuition ;
+   rewrite <- f_eq_g. rewrite <- f_eq_g.
+   assert (f_incr2 : forall x y, lb <= x -> x <= y -> y < ub -> f x <= f y).
+    intros m n lb_le_m m_le_n n_lt_ub.
+    case (m_le_n).
+     intros ; apply Rlt_le ; apply f_incr ; [| | apply Rlt_le] ; assumption.
+     intros Hyp ; rewrite Hyp ; apply Req_le ; reflexivity.
+   apply f_incr2.
+   intuition. intuition.
+   Focus 3. intuition.
+   Focus 2. intuition.
+   Focus 2. intuition. Focus 2. intuition.
+   assert (Temp2 : g x <> ub).
+   intro Hf.
+    assert (Htemp : (comp f g) x = f ub).
+     unfold comp ; rewrite Hf ; reflexivity.
+     rewrite f_eq_g in Htemp ; unfold id in Htemp.
+    assert (Htemp2 : x < f ub).
+     apply Rlt_le_trans with (r2:=y) ; intuition.
+    clear -Htemp Htemp2. fourier.
+    intuition. intuition.
+   clear -Temp2 gx_encad.
+   case (proj2 gx_encad).
+    intuition.
+    intro Hfalse ; apply False_ind ; apply Temp2 ; assumption.
+   apply False_ind. clear - Hcontradiction x_lt_y. fourier.
+Qed.
+
+Lemma derivable_pt_id_interv : forall (lb ub x:R),
+       lb <= x <= ub ->
+       derivable_pt id x.
+Proof.
+intros.
+ reg.
+Qed.
+
+Lemma pr_nu_var2_interv : forall (f g : R -> R) (lb ub x : R) (pr1 : derivable_pt f x)
+       (pr2 : derivable_pt g x),
+       lb < ub ->
+       lb < x < ub ->
+       (forall h : R, lb < h < ub -> f h = g h) -> derive_pt f x pr1 = derive_pt g x pr2.
+Proof.
+intros f g lb ub x Prf Prg lb_lt_ub x_encad local_eq.
+assert (forall x l, lb < x < ub -> (derivable_pt_abs f x l <-> derivable_pt_abs g x l)).
+ intros a l a_encad.
+ unfold derivable_pt_abs, derivable_pt_lim.
+ split.
+ intros Hyp eps eps_pos.
+ elim (Hyp eps eps_pos) ; intros delta Hyp2.
+ assert (Pos_cond : Rmin delta (Rmin (ub - a) (a - lb)) > 0).
+  clear-a lb ub a_encad delta.
+  apply Rmin_pos ; [exact (delta.(cond_pos)) | apply Rmin_pos ] ; apply Rlt_Rminus ; intuition.
+ exists (mkposreal (Rmin delta (Rmin (ub - a) (a - lb))) Pos_cond).
+ intros h h_neq h_encad.
+ replace (g (a + h) - g a) with (f (a + h) - f a).
+ apply Hyp2 ; intuition.
+ apply Rlt_le_trans with (r2:=Rmin delta (Rmin (ub - a) (a - lb))).
+ assumption. apply Rmin_l.
+ assert (local_eq2 : forall h : R, lb < h < ub -> - f h = - g h).
+  intros ; apply Ropp_eq_compat ; intuition.
+ rewrite local_eq ; unfold Rminus. rewrite local_eq2. reflexivity.
+ assumption.
+ assert (Sublemma2 : forall x y, Rabs x < Rabs y -> y > 0 -> x < y).
+  intros m n Hyp_abs y_pos. apply Rlt_le_trans with (r2:=Rabs n).
+   apply Rle_lt_trans with (r2:=Rabs m) ; [ | assumption] ; apply RRle_abs.
+   apply Req_le ; apply Rabs_right ; apply Rgt_ge ; assumption.
+ split.
+ assert (Sublemma : forall x y z, -z < y - x -> x < y + z).
+  intros ; fourier.
+ apply Sublemma.
+ apply Sublemma2. rewrite Rabs_Ropp.
+ apply Rlt_le_trans with (r2:=a-lb) ; [| apply RRle_abs] ;
+ apply Rlt_le_trans with (r2:=Rmin (ub - a) (a - lb)) ; [| apply Rmin_r] ;
+ apply Rlt_le_trans with (r2:=Rmin delta (Rmin (ub - a) (a - lb))) ; [| apply Rmin_r] ; assumption.
+ apply Rlt_le_trans with (r2:=Rmin (ub - a) (a - lb)) ; [| apply Rmin_r] ;
+ apply Rlt_le_trans with (r2:=Rmin delta (Rmin (ub - a) (a - lb))) ; [| apply Rmin_r] ; assumption.
+ assert (Sublemma : forall x y z, y < z - x -> x + y < z).
+  intros ; fourier.
+ apply Sublemma.
+ apply Sublemma2.
+ apply Rlt_le_trans with (r2:=ub-a) ; [| apply RRle_abs] ;
+ apply Rlt_le_trans with (r2:=Rmin (ub - a) (a - lb)) ; [| apply Rmin_l] ;
+ apply Rlt_le_trans with (r2:=Rmin delta (Rmin (ub - a) (a - lb))) ; [| apply Rmin_r] ; assumption.
+ apply Rlt_le_trans with (r2:=Rmin (ub - a) (a - lb)) ; [| apply Rmin_l] ;
+ apply Rlt_le_trans with (r2:=Rmin delta (Rmin (ub - a) (a - lb))) ; [| apply Rmin_r] ; assumption.
+ intros Hyp eps eps_pos.
+ elim (Hyp eps eps_pos) ; intros delta Hyp2.
+ assert (Pos_cond : Rmin delta (Rmin (ub - a) (a - lb)) > 0).
+  clear-a lb ub a_encad delta.
+  apply Rmin_pos ; [exact (delta.(cond_pos)) | apply Rmin_pos ] ; apply Rlt_Rminus ; intuition.
+ exists (mkposreal (Rmin delta (Rmin (ub - a) (a - lb))) Pos_cond).
+ intros h h_neq h_encad.
+ replace (f (a + h) - f a) with (g (a + h) - g a).
+ apply Hyp2 ; intuition.
+ apply Rlt_le_trans with (r2:=Rmin delta (Rmin (ub - a) (a - lb))).
+ assumption. apply Rmin_l.
+ assert (local_eq2 : forall h : R, lb < h < ub -> - f h = - g h).
+  intros ; apply Ropp_eq_compat ; intuition.
+ rewrite local_eq ; unfold Rminus. rewrite local_eq2. reflexivity.
+ assumption.
+ assert (Sublemma2 : forall x y, Rabs x < Rabs y -> y > 0 -> x < y).
+  intros m n Hyp_abs y_pos. apply Rlt_le_trans with (r2:=Rabs n).
+   apply Rle_lt_trans with (r2:=Rabs m) ; [ | assumption] ; apply RRle_abs.
+   apply Req_le ; apply Rabs_right ; apply Rgt_ge ; assumption.
+ split.
+ assert (Sublemma : forall x y z, -z < y - x -> x < y + z).
+  intros ; fourier.
+ apply Sublemma.
+ apply Sublemma2. rewrite Rabs_Ropp.
+ apply Rlt_le_trans with (r2:=a-lb) ; [| apply RRle_abs] ;
+ apply Rlt_le_trans with (r2:=Rmin (ub - a) (a - lb)) ; [| apply Rmin_r] ;
+ apply Rlt_le_trans with (r2:=Rmin delta (Rmin (ub - a) (a - lb))) ; [| apply Rmin_r] ; assumption.
+ apply Rlt_le_trans with (r2:=Rmin (ub - a) (a - lb)) ; [| apply Rmin_r] ;
+ apply Rlt_le_trans with (r2:=Rmin delta (Rmin (ub - a) (a - lb))) ; [| apply Rmin_r] ; assumption.
+ assert (Sublemma : forall x y z, y < z - x -> x + y < z).
+  intros ; fourier.
+ apply Sublemma.
+ apply Sublemma2.
+ apply Rlt_le_trans with (r2:=ub-a) ; [| apply RRle_abs] ;
+ apply Rlt_le_trans with (r2:=Rmin (ub - a) (a - lb)) ; [| apply Rmin_l] ;
+ apply Rlt_le_trans with (r2:=Rmin delta (Rmin (ub - a) (a - lb))) ; [| apply Rmin_r] ; assumption.
+ apply Rlt_le_trans with (r2:=Rmin (ub - a) (a - lb)) ; [| apply Rmin_l] ;
+ apply Rlt_le_trans with (r2:=Rmin delta (Rmin (ub - a) (a - lb))) ; [| apply Rmin_r] ; assumption.
+ unfold derivable_pt in Prf.
+  unfold derivable_pt in Prg.
+  elim Prf; intros.
+  elim Prg; intros.
+  assert (Temp := p); rewrite H in Temp.
+  unfold derivable_pt_abs in p.
+  unfold derivable_pt_abs in p0.
+  simpl in |- *.
+  apply (uniqueness_limite g x x0 x1 Temp p0).
+  assumption.
+Qed.
+
+
+(* begin hide *)
+Lemma leftinv_is_rightinv : forall (f g:R->R),
+       (forall x y, x < y -> f x < f y) ->
+       (forall x, (comp f g) x = id x) ->
+       (forall x, (comp g f) x = id x).
+Proof.
+intros f g f_incr Hyp x.
+ assert (forall x, f (g (f x)) = f x).
+  intros ; apply Hyp.
+ assert(f_inj : forall x y, f x = f y -> x = y).
+  intros a b fa_eq_fb.
+  case(total_order_T a b).
+  intro s ; case s ; clear s.
+  intro Hf.
+  assert (Hfalse := f_incr a b Hf).
+  apply False_ind. apply (Rlt_not_eq (f a) (f b)) ; assumption.
+  intuition.
+  intro Hf. assert (Hfalse := f_incr b a Hf).
+  apply False_ind. apply (Rlt_not_eq (f b) (f a)) ; [|symmetry] ; assumption.
+ apply f_inj. unfold comp.
+ unfold comp in Hyp.
+ rewrite Hyp.
+ unfold id.
+ reflexivity.
+Qed.
+(* end hide *)
+
+Lemma leftinv_is_rightinv_interv : forall (f g:R->R) (lb ub:R),
+       (forall x y, lb <= x -> x < y -> y <= ub -> f x < f y) ->
+       (forall y, f lb <= y -> y <= f ub -> (comp f g) y = id y) ->
+       (forall x, f lb <= x -> x <= f ub -> lb <= g x <= ub) ->
+       forall x,
+       lb <= x <= ub ->
+       (comp g f) x = id x.
+Proof.
+intros f g lb ub f_incr_interv Hyp g_wf x x_encad.
+ assert(f_inj : forall x y, lb <= x <= ub -> lb <= y <= ub -> f x = f y -> x = y).
+  intros a b a_encad b_encad fa_eq_fb.
+  case(total_order_T a b).
+  intro s ; case s ; clear s.
+  intro Hf.
+  assert (Hfalse := f_incr_interv a b (proj1 a_encad) Hf (proj2 b_encad)).
+  apply False_ind. apply (Rlt_not_eq (f a) (f b)) ; assumption.
+  intuition.
+  intro Hf. assert (Hfalse := f_incr_interv b a (proj1 b_encad) Hf (proj2 a_encad)).
+  apply False_ind. apply (Rlt_not_eq (f b) (f a)) ; [|symmetry] ; assumption.
+ assert (f_incr_interv2 : forall x y, lb <= x -> x <= y -> y <= ub -> f x <= f y).
+  intros m n cond1 cond2 cond3.
+   case cond2.
+   intro cond. apply Rlt_le ; apply f_incr_interv ; assumption.
+   intro cond ; right ; rewrite cond ; reflexivity.
+ assert (Hyp2:forall x, lb <= x <= ub -> f (g (f x)) = f x).
+  intros ; apply Hyp.  apply f_incr_interv2 ; intuition. 
+ apply f_incr_interv2 ; intuition.
+ unfold comp ; unfold comp in Hyp.
+ apply f_inj.
+ apply g_wf ; apply f_incr_interv2 ; intuition.
+ unfold id ; assumption.
+ apply Hyp2 ; unfold id ; assumption.
+Qed.
+
+
+(** Intermediate Value Theorem on an Interval (Proof mainly taken from Reals.Rsqrt_def) and its corollary *)
+
+Lemma IVT_interv_prelim0 : forall (x y:R) (P:R->bool) (N:nat),
+       x < y ->
+       x <= Dichotomy_ub x y P N <= y /\ x <= Dichotomy_lb x y P N <= y.
+Proof.
+assert (Sublemma : forall x y lb ub, lb <= x <= ub /\ lb <= y <= ub -> lb <= (x+y) / 2 <= ub).
+ intros x y lb ub Hyp.
+  split.
+  replace lb with ((lb + lb) * /2) by field.
+  unfold Rdiv ; apply Rmult_le_compat_r ; intuition.
+  replace ub with ((ub + ub) * /2) by field.
+  unfold Rdiv ; apply Rmult_le_compat_r ; intuition.
+intros x y P N x_lt_y.
+induction N.
+ simpl ; intuition.
+ simpl.
+ case (P ((Dichotomy_lb x y P N + Dichotomy_ub x y P N) / 2)).
+ split. apply Sublemma ; intuition.
+ intuition.
+ split. intuition.
+ apply Sublemma ; intuition.
+Qed.
+
+Lemma IVT_interv_prelim1 : forall (x y x0:R) (D : R -> bool),
+       x < y ->
+       Un_cv (dicho_up x y D) x0 ->
+       x <= x0 <= y.
+Proof.
+intros x y x0 D x_lt_y bnd.
+ assert (Main : forall n, x <= dicho_up x y D n <= y).
+  intro n. unfold dicho_up.
+  apply (proj1 (IVT_interv_prelim0 x y D n x_lt_y)).
+ split.
+  apply Rle_cv_lim with (Vn:=dicho_up x y D) (Un:=fun n => x).
+  intro n ; exact (proj1 (Main n)).
+  unfold Un_cv ; intros ; exists 0%nat ; intros ; unfold R_dist ; replace (x -x) with 0 by field ; rewrite Rabs_R0 ; assumption.
+  assumption.
+  apply Rle_cv_lim with (Un:=dicho_up x y D) (Vn:=fun n => y).
+  intro n ; exact (proj2 (Main n)).
+  assumption.
+  unfold Un_cv ; intros ; exists 0%nat ; intros ; unfold R_dist ; replace (y -y) with 0 by field ; rewrite Rabs_R0 ; assumption.
+Qed.
+
+Lemma IVT_interv : forall (f : R -> R) (x y : R),
+       (forall a, x <= a <= y -> continuity_pt f a) ->
+       x < y ->
+       f x < 0 ->
+       0 < f y ->
+       {z : R | x <= z <= y /\ f z = 0}.
+Proof.
+intros. (* f x y f_cont_interv x_lt_y fx_neg fy_pos.*)
+  cut (x <= y).
+  intro.
+  generalize (dicho_lb_cv x y (fun z:R => cond_positivity (f z)) H3). 
+  generalize (dicho_up_cv x y (fun z:R => cond_positivity (f z)) H3). 
+  intros X X0.
+  elim X; intros.
+  elim X0; intros.
+  assert (H4 := cv_dicho _ _ _ _ _ H3 p0 p).
+  rewrite H4 in p0.
+  exists x0.
+  split.
+  split.
+  apply Rle_trans with (dicho_lb x y (fun z:R => cond_positivity (f z)) 0).
+  simpl in |- *.
+  right; reflexivity.
+  apply growing_ineq.
+  apply dicho_lb_growing; assumption.
+  assumption.
+  apply Rle_trans with (dicho_up x y (fun z:R => cond_positivity (f z)) 0).
+  apply decreasing_ineq.
+  apply dicho_up_decreasing; assumption.
+  assumption.
+  right; reflexivity.
+  2: left; assumption.
+  set (Vn := fun n:nat => dicho_lb x y (fun z:R => cond_positivity (f z)) n).
+  set (Wn := fun n:nat => dicho_up x y (fun z:R => cond_positivity (f z)) n).
+  cut ((forall n:nat, f (Vn n) <= 0) -> f x0 <= 0).
+  cut ((forall n:nat, 0 <= f (Wn n)) -> 0 <= f x0).
+  intros.
+  cut (forall n:nat, f (Vn n) <= 0).
+  cut (forall n:nat, 0 <= f (Wn n)).
+  intros.
+  assert (H9 := H6 H8).
+  assert (H10 := H5 H7).
+  apply Rle_antisym; assumption.
+  intro.
+  unfold Wn in |- *.
+  cut (forall z:R, cond_positivity z = true <-> 0 <= z).
+  intro.
+  assert (H8 := dicho_up_car x y (fun z:R => cond_positivity (f z)) n).
+  elim (H7 (f (dicho_up x y (fun z:R => cond_positivity (f z)) n))); intros.
+  apply H9.
+  apply H8.
+  elim (H7 (f y)); intros.
+  apply H12.
+  left; assumption.
+  intro.
+  unfold cond_positivity in |- *.
+  case (Rle_dec 0 z); intro.
+  split.
+  intro; assumption.
+  intro; reflexivity.
+  split.
+  intro feqt;discriminate feqt.
+  intro.
+  elim n0; assumption.
+  unfold Vn in |- *.
+  cut (forall z:R, cond_positivity z = false <-> z < 0).
+  intros.
+  assert (H8 := dicho_lb_car x y (fun z:R => cond_positivity (f z)) n).
+  left.
+  elim (H7 (f (dicho_lb x y (fun z:R => cond_positivity (f z)) n))); intros.
+  apply H9.
+  apply H8.
+  elim (H7 (f x)); intros.
+  apply H12.
+  assumption.
+  intro.
+  unfold cond_positivity in |- *.
+  case (Rle_dec 0 z); intro.
+  split.
+  intro feqt; discriminate feqt.
+  intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H7)).
+  split.
+  intro; auto with real.
+  intro; reflexivity.
+  cut (Un_cv Wn x0).
+  intros.
+  assert (Temp : x <= x0 <= y).
+   apply IVT_interv_prelim1 with (D:=(fun z : R => cond_positivity (f z))) ; assumption.
+  assert (H7 := continuity_seq f Wn x0 (H x0 Temp) H5).
+  case (total_order_T 0 (f x0)); intro.
+  elim s; intro.
+  left; assumption.
+  rewrite <- b; right; reflexivity.
+  unfold Un_cv in H7; unfold R_dist in H7.
+  cut (0 < - f x0).
+  intro.
+  elim (H7 (- f x0) H8); intros.
+  cut (x2 >= x2)%nat; [ intro | unfold ge in |- *; apply le_n ].
+  assert (H11 := H9 x2 H10).
+  rewrite Rabs_right in H11.
+  pattern (- f x0) at 1 in H11; rewrite <- Rplus_0_r in H11.
+  unfold Rminus in H11; rewrite (Rplus_comm (f (Wn x2))) in H11.
+  assert (H12 := Rplus_lt_reg_r _ _ _ H11).
+  assert (H13 := H6 x2).
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H13 H12)).
+  apply Rle_ge; left; unfold Rminus in |- *; apply Rplus_le_lt_0_compat.
+  apply H6.
+  exact H8.
+  apply Ropp_0_gt_lt_contravar; assumption.
+  unfold Wn in |- *; assumption.
+  cut (Un_cv Vn x0).
+  intros.
+  assert (Temp : x <= x0 <= y).
+   apply IVT_interv_prelim1 with (D:=(fun z : R => cond_positivity (f z))) ; assumption.
+  assert (H7 := continuity_seq f Vn x0 (H x0 Temp) H5).
+  case (total_order_T 0 (f x0)); intro.
+  elim s; intro.
+  unfold Un_cv in H7; unfold R_dist in H7.
+  elim (H7 (f x0) a); intros.
+  cut (x2 >= x2)%nat; [ intro | unfold ge in |- *; apply le_n ].
+  assert (H10 := H8 x2 H9).
+  rewrite Rabs_left in H10.
+  pattern (f x0) at 2 in H10; rewrite <- Rplus_0_r in H10.
+  rewrite Ropp_minus_distr' in H10.
+  unfold Rminus in H10.
+  assert (H11 := Rplus_lt_reg_r _ _ _ H10).
+  assert (H12 := H6 x2).
+  cut (0 < f (Vn x2)).
+  intro.
+  elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H13 H12)).
+  rewrite <- (Ropp_involutive (f (Vn x2))).
+  apply Ropp_0_gt_lt_contravar; assumption.
+  apply Rplus_lt_reg_r with (f x0 - f (Vn x2)).
+  rewrite Rplus_0_r; replace (f x0 - f (Vn x2) + (f (Vn x2) - f x0)) with 0;
+    [ unfold Rminus in |- *; apply Rplus_lt_le_0_compat | ring ].
+  assumption.
+  apply Ropp_0_ge_le_contravar; apply Rle_ge; apply H6.
+  right; rewrite <- b; reflexivity.
+  left; assumption.
+  unfold Vn in |- *; assumption.
+Qed.
+
+(* begin hide *)
+Ltac case_le H :=
+   let t := type of H in 
+   let h' := fresh in 
+      match t with ?x <= ?y => case (total_order_T x y);
+         [intros h'; case h'; clear h' | 
+          intros h'; clear -H h'; elimtype False; fourier ] end.
+(* end hide *)
+
+
+Lemma f_interv_is_interv : forall (f:R->R) (lb ub y:R),
+       lb < ub ->
+       f lb <= y <= f ub ->
+       (forall x, lb <=  x <= ub -> continuity_pt f x) ->
+       {x | lb <= x <= ub /\ f x = y}.
+Proof.
+intros f lb ub y lb_lt_ub y_encad f_cont_interv.
+ case y_encad ; intro y_encad1.
+   case_le y_encad1 ; intros y_encad2 y_encad3 ; case_le y_encad3.
+    intro y_encad4.
+     clear y_encad y_encad1 y_encad3.
+     assert (Cont : forall a : R, lb <= a <= ub -> continuity_pt (fun x => f x - y) a).
+      intros a a_encad. unfold continuity_pt, continue_in, limit1_in, limit_in ; simpl ; unfold R_dist.
+      intros eps eps_pos. elim (f_cont_interv a a_encad eps eps_pos).
+      intros alpha alpha_pos. destruct alpha_pos as (alpha_pos,Temp).
+      exists alpha. split.
+      assumption. intros x  x_cond.
+      replace (f x - y - (f a - y)) with (f x - f a) by field.
+      exact (Temp x x_cond).
+     assert (H1 : (fun x : R => f x - y) lb < 0).
+       apply Rlt_minus. assumption.
+      assert (H2 : 0 < (fun x : R => f x - y) ub).
+       apply Rgt_minus ; assumption.
+     destruct (IVT_interv (fun x => f x - y) lb ub Cont lb_lt_ub H1 H2) as (x,Hx).
+     exists x.
+     destruct Hx as (Hyp,Result).
+     intuition.
+     intro H ; exists ub ; intuition.
+     intro H ; exists lb ; intuition.
+     intro H ; exists ub ; intuition.
+Qed.
+
+(** ** The derivative of a reciprocal function       *)
+
+
+(** * Continuity of the reciprocal function *)
+
+Lemma continuity_pt_recip_prelim : forall (f g:R->R) (lb ub : R) (Pr1:lb < ub),
+       (forall x y, lb <= x -> x < y -> y <= ub -> f x < f y) ->
+       (forall x, lb <= x <= ub -> (comp g f) x = id x) ->
+       (forall a, lb <= a <= ub -> continuity_pt f a) ->
+       forall b,
+       f lb < b < f ub ->
+       continuity_pt g b.
+Proof.
+assert (Sublemma : forall x y z, Rmax x y < z <-> x < z /\ y < z).
+ intros x y z. split.
+  unfold Rmax. case (Rle_dec x y) ; intros Hyp Hyp2.
+  split. apply Rle_lt_trans with (r2:=y) ; assumption. assumption.
+  split. assumption. apply Rlt_trans with (r2:=x).
+  assert (Temp : forall x y, ~ x <= y -> x > y).
+   intros m n Hypmn. intuition.
+  apply Temp ; clear Temp ; assumption.
+  assumption.
+  intros Hyp.
+  unfold Rmax. case (Rle_dec x y).
+  intro ; exact (proj2 Hyp).
+  intro ; exact (proj1 Hyp).
+assert (Sublemma2 : forall x y z, Rmin x y > z <-> x > z /\ y > z).
+ intros x y z. split.
+  unfold Rmin. case (Rle_dec x y) ; intros Hyp Hyp2.
+  split. assumption.
+  apply Rlt_le_trans with (r2:=x) ; intuition.
+  split.
+  apply Rlt_trans with (r2:=y). intuition.
+  assert (Temp : forall x y, ~ x <= y -> x > y).
+   intros m n Hypmn. intuition.
+  apply Temp ; clear Temp ; assumption.
+  assumption.
+  intros Hyp.
+  unfold Rmin. case (Rle_dec x y).
+  intro ; exact (proj1 Hyp).
+  intro ; exact (proj2 Hyp).
+assert (Sublemma3 : forall x y, x <= y /\ x <> y -> x < y).
+ intros m n Hyp. unfold Rle in Hyp.
+  destruct Hyp as (Hyp1,Hyp2).
+  case Hyp1.
+  intuition.
+  intro Hfalse ; apply False_ind ; apply Hyp2 ; exact Hfalse.
+intros f g lb ub lb_lt_ub f_incr_interv f_eq_g f_cont_interv b b_encad.
+ assert (f_incr_interv2 : forall x y, lb <= x -> x <= y -> y <= ub -> f x <= f y).
+  intros m n cond1 cond2 cond3.
+   case cond2.
+   intro cond. apply Rlt_le ; apply f_incr_interv ; assumption.
+   intro cond ; right ; rewrite cond ; reflexivity.
+ unfold continuity_pt, continue_in, limit1_in, limit_in ; intros eps eps_pos.
+ unfold dist ; simpl ; unfold R_dist.
+ assert (b_encad_e : f lb <= b <= f ub) by intuition.
+ elim (f_interv_is_interv f lb ub b lb_lt_ub b_encad_e f_cont_interv) ; intros x Temp.
+ destruct Temp as (x_encad,f_x_b).
+ assert (lb_lt_x : lb < x).
+ assert (Temp : x <> lb).
+  intro Hfalse.
+  assert (Temp' : b = f lb).
+   rewrite <- f_x_b ; rewrite Hfalse ; reflexivity.
+  assert (Temp'' : b <> f lb).
+   apply Rgt_not_eq ; exact (proj1 b_encad).
+  apply Temp'' ; exact Temp'.
+ apply Sublemma3.
+ split. exact (proj1 x_encad).
+ assert (Temp2 : forall x y:R, x <> y <-> y <> x).
+  intros m n. split ; intuition.
+ rewrite Temp2 ; assumption.
+ assert (x_lt_ub : x < ub).
+ assert (Temp : x <> ub).
+  intro Hfalse.
+  assert (Temp' : b = f ub).
+   rewrite <- f_x_b ; rewrite Hfalse ; reflexivity.
+  assert (Temp'' : b <> f ub).
+   apply Rlt_not_eq ; exact (proj2 b_encad).
+  apply Temp'' ; exact Temp'.
+ apply Sublemma3.
+ split ; [exact (proj2 x_encad) | assumption].
+ pose (x1 := Rmax (x - eps) lb).
+ pose (x2 := Rmin (x + eps) ub).
+ assert (Hx1 : x1 = Rmax (x - eps) lb) by intuition.
+ assert (Hx2 : x2 = Rmin (x + eps) ub) by intuition.
+ assert (x1_encad : lb <= x1 <= ub).
+  split. apply RmaxLess2.
+  apply Rlt_le. rewrite Hx1. rewrite Sublemma.
+  split. apply Rlt_trans with (r2:=x) ; fourier.
+  assumption.
+ assert (x2_encad : lb <= x2 <= ub).
+  split. apply Rlt_le ; rewrite Hx2 ; apply Rgt_lt ; rewrite Sublemma2.
+  split. apply Rgt_trans with (r2:=x) ; fourier.
+  assumption.
+  apply Rmin_r.
+ assert (x_lt_x2 : x < x2).
+  rewrite Hx2.
+  apply Rgt_lt. rewrite Sublemma2.
+  split ; fourier.
+ assert (x1_lt_x : x1 < x).
+  rewrite Hx1.
+  rewrite Sublemma.
+  split ; fourier.
+ exists (Rmin (f x - f x1) (f x2 - f x)).
+ split. apply Rmin_pos ; apply Rgt_minus. apply f_incr_interv ; [apply RmaxLess2 | | ] ; fourier.
+ apply f_incr_interv ; intuition.
+ intros y Temp.
+ destruct Temp as (_,y_cond).
+  rewrite <- f_x_b in y_cond.
+  assert (Temp : forall x y d1 d2, d1 > 0 -> d2 > 0 -> Rabs (y - x) < Rmin d1 d2 -> x - d1 <= y <= x + d2).
+   intros.
+    split. assert (H10 : forall x y z, x - y <= z -> x - z <= y). intuition. fourier.
+    apply H10. apply Rle_trans with (r2:=Rabs (y0 - x0)).
+    replace (Rabs (y0 - x0)) with (Rabs (x0 - y0)). apply RRle_abs.
+    rewrite <- Rabs_Ropp. unfold Rminus ; rewrite Ropp_plus_distr. rewrite Ropp_involutive.
+    intuition.
+    apply Rle_trans with (r2:= Rmin d1 d2). apply Rlt_le ; assumption.
+    apply Rmin_l.
+    assert (H10 : forall x y z, x - y <= z -> x <= y + z). intuition. fourier.
+    apply H10. apply Rle_trans with (r2:=Rabs (y0 - x0)). apply RRle_abs.
+    apply Rle_trans with (r2:= Rmin d1 d2). apply Rlt_le ; assumption.
+    apply Rmin_r.
+  assert (Temp' := Temp (f x) y (f x - f x1) (f x2 - f x)).
+  replace (f x - (f x - f x1)) with (f x1) in Temp' by field.
+  replace (f x + (f x2 - f x)) with (f x2) in Temp' by field.
+  assert (T : f x - f x1 > 0).
+   apply Rgt_minus. apply f_incr_interv ; intuition.
+  assert (T' : f x2 - f x > 0).
+   apply Rgt_minus. apply f_incr_interv ; intuition.
+  assert (Main := Temp' T T' y_cond).
+  clear Temp Temp' T T'.
+  assert (x1_lt_x2 : x1 < x2).
+   apply Rlt_trans with (r2:=x) ; assumption.
+   assert (f_cont_myinterv : forall a : R, x1 <= a <= x2 -> continuity_pt f a).
+    intros ; apply f_cont_interv ; split. 
+    apply Rle_trans with (r2 := x1) ; intuition.
+    apply Rle_trans with (r2 := x2) ; intuition.
+   elim (f_interv_is_interv f x1 x2 y x1_lt_x2 Main f_cont_myinterv) ; intros x' Temp.
+   destruct Temp as (x'_encad,f_x'_y).
+   rewrite <- f_x_b ; rewrite <- f_x'_y.
+   unfold comp in f_eq_g. rewrite f_eq_g. rewrite f_eq_g.
+   unfold id.
+   assert (x'_encad2 : x - eps <= x' <= x + eps).
+    split.
+    apply Rle_trans with (r2:=x1) ; [ apply RmaxLess1|] ; intuition.
+    apply Rle_trans with (r2:=x2) ; [ | apply Rmin_l] ; intuition.
+    assert (x1_lt_x' : x1 < x').
+     apply Sublemma3.
+     assert (x1_neq_x' : x1 <> x').
+      intro Hfalse. rewrite Hfalse, f_x'_y in y_cond.
+      assert (Hf : Rabs (y - f x) < f x - y).
+       apply Rlt_le_trans with (r2:=Rmin (f x - y) (f x2 - f x)). fourier.
+       apply Rmin_l.
+      assert(Hfin : f x - y < f x - y).
+       apply Rle_lt_trans with (r2:=Rabs (y - f x)).
+       replace (Rabs (y - f x)) with (Rabs (f x - y)). apply RRle_abs.
+       rewrite <- Rabs_Ropp. replace (- (f x - y)) with (y - f x) by field ; reflexivity. fourier.
+      apply (Rlt_irrefl (f x - y)) ; assumption.
+      split ; intuition.
+     assert (x'_lb : x - eps < x').
+      apply Sublemma3.
+      split. intuition. apply Rlt_not_eq.
+      apply Rle_lt_trans with (r2:=x1) ; [ apply RmaxLess1|] ; intuition.
+     assert (x'_lt_x2 : x' < x2).
+     apply Sublemma3.
+     assert (x1_neq_x' : x' <> x2).
+      intro Hfalse. rewrite <- Hfalse, f_x'_y in y_cond.
+      assert (Hf : Rabs (y - f x) < y - f x).
+       apply Rlt_le_trans with (r2:=Rmin (f x - f x1) (y - f x)). fourier.
+       apply Rmin_r.
+      assert(Hfin : y - f x < y - f x).
+       apply Rle_lt_trans with (r2:=Rabs (y - f x)). apply RRle_abs. fourier.
+      apply (Rlt_irrefl (y - f x)) ; assumption.
+      split ; intuition.
+     assert (x'_ub : x' < x + eps).
+      apply Sublemma3.
+      split. intuition. apply Rlt_not_eq.
+      apply Rlt_le_trans with (r2:=x2) ; [ |rewrite Hx2 ; apply Rmin_l] ; intuition.
+    apply Rabs_def1 ; fourier.
+    assumption.
+    split. apply Rle_trans with (r2:=x1) ; intuition.
+    apply Rle_trans with (r2:=x2) ; intuition.
+Qed.
+
+Lemma continuity_pt_recip_interv : forall (f g:R->R) (lb ub : R) (Pr1:lb < ub),
+       (forall x y, lb <= x -> x < y -> y <= ub -> f x < f y) ->
+       (forall x, f lb <= x -> x <= f ub -> (comp f g) x = id x) ->
+       (forall x, f lb <= x -> x <= f ub -> lb <= g x <= ub) ->
+       (forall a, lb <= a <= ub -> continuity_pt f a) ->
+       forall b,
+       f lb < b < f ub ->
+       continuity_pt g b.
+Proof.
+intros f g lb ub lb_lt_ub f_incr_interv f_eq_g g_wf.
+assert (g_eq_f_prelim := leftinv_is_rightinv_interv f g lb ub f_incr_interv f_eq_g).
+assert (g_eq_f : forall x, lb <= x <= ub -> (comp g f) x = id x).
+intro x ; apply g_eq_f_prelim ; assumption.
+apply (continuity_pt_recip_prelim f g lb ub lb_lt_ub f_incr_interv g_eq_f).
+Qed.
+
+(** *   Derivability of the reciprocal function        *)
+
+Lemma derivable_pt_lim_recip_interv : forall (f g:R->R) (lb ub x:R)
+       (Prf:forall a : R, g lb <= a <= g ub -> derivable_pt f a) (Prg : continuity_pt g x),
+       lb < ub ->
+       lb < x < ub ->
+       forall (Prg_incr:g lb <= g x <= g ub),
+       (forall x, lb <= x <= ub -> (comp f g) x = id x) ->
+       derive_pt f (g x) (Prf (g x) Prg_incr) <> 0 ->
+       derivable_pt_lim g x (1 / derive_pt f (g x) (Prf (g x) Prg_incr)).
+Proof.
+intros f g lb ub x Prf g_cont_pur lb_lt_ub x_encad Prg_incr f_eq_g df_neq.
+ assert (x_encad2 : lb <= x <= ub).
+  split ; apply Rlt_le ; intuition.
+ elim (Prf (g x)); simpl; intros l Hl.
+ unfold derivable_pt_lim.
+ intros eps eps_pos.
+  pose (y := g x).
+   assert (Hlinv := limit_inv).
+    assert (Hf_deriv : forall eps:R,
+    0 < eps ->
+    exists delta : posreal,
+    (forall h:R,
+    h <> 0 -> Rabs h < delta -> Rabs ((f (g x + h) - f (g x)) / h - l) < eps)).
+     intros eps0 eps0_pos.
+      red in Hl ; red in Hl. elim (Hl eps0 eps0_pos).
+      intros deltatemp Htemp.
+       exists deltatemp ; exact Htemp.
+    elim (Hf_deriv eps eps_pos).
+    intros deltatemp Htemp.
+     red in Hlinv ; red in Hlinv ; simpl dist in Hlinv ; unfold R_dist in Hlinv.
+     assert (Hlinv' := Hlinv (fun h => (f (y+h) - f y)/h) (fun h => h <>0) l 0).
+     unfold limit1_in, limit_in, dist in Hlinv' ; simpl in Hlinv'. unfold R_dist in Hlinv'.
+     assert (Premisse : (forall eps : R,
+     eps > 0 ->
+     exists alp : R,
+     alp > 0 /\
+     (forall x : R,
+     (fun h => h <>0) x /\ Rabs (x - 0) < alp ->
+     Rabs ((f (y + x) - f y) / x - l) < eps))).
+      intros eps0 eps0_pos.
+       elim (Hf_deriv eps0 eps0_pos).
+       intros deltatemp' Htemp'.
+        exists deltatemp'.
+        split.
+         exact deltatemp'.(cond_pos).
+         intros htemp cond.
+          apply (Htemp' htemp).
+          exact (proj1 cond).
+         replace (htemp) with (htemp - 0).
+         exact (proj2 cond).
+         intuition.
+     assert (Premisse2 : l <> 0).
+      intro l_null.
+       rewrite l_null in Hl.
+       apply df_neq.
+       rewrite derive_pt_eq.
+       exact Hl.                
+     elim (Hlinv' Premisse Premisse2 eps eps_pos).
+     intros alpha cond.
+      assert (alpha_pos := proj1 cond) ; assert (inv_cont := proj2 cond) ; clear cond.
+      unfold derivable, derivable_pt, derivable_pt_abs, derivable_pt_lim in Prf.
+      elim (Hl eps eps_pos).
+      intros delta f_deriv.
+       assert (g_cont := g_cont_pur).
+       unfold continuity_pt, continue_in, limit1_in, limit_in in g_cont.
+       pose (mydelta := Rmin delta alpha).
+       assert (mydelta_pos : mydelta > 0).
+        unfold mydelta, Rmin.
+        case (Rle_dec delta alpha).
+        intro ; exact (delta.(cond_pos)).
+        intro ; exact alpha_pos.
+       elim (g_cont mydelta mydelta_pos).
+       intros delta' new_g_cont.
+        assert(delta'_pos := proj1 (new_g_cont)).
+        clear g_cont ; assert (g_cont := proj2 (new_g_cont)) ; clear new_g_cont.
+        pose (mydelta'' := Rmin delta' (Rmin (x - lb) (ub - x))).
+        assert(mydelta''_pos : mydelta'' > 0).
+         unfold mydelta''.
+         apply Rmin_pos ; [intuition | apply Rmin_pos] ; apply Rgt_minus ; intuition.
+        pose (delta'' := mkposreal mydelta'' mydelta''_pos: posreal).
+        exists delta''.
+        intros h h_neq h_le_delta'.
+  assert (lb <= x +h <= ub).
+ assert (Sublemma2 : forall x y, Rabs x < Rabs y -> y > 0 -> x < y).
+  intros m n Hyp_abs y_pos. apply Rlt_le_trans with (r2:=Rabs n).
+   apply Rle_lt_trans with (r2:=Rabs m) ; [ | assumption] ; apply RRle_abs.
+   apply Req_le ; apply Rabs_right ; apply Rgt_ge ; assumption.
+ assert (lb <= x + h <= ub).
+ split.
+ assert (Sublemma : forall x y z, -z <= y - x -> x <= y + z).
+  intros ; fourier.
+ apply Sublemma.
+ apply Rlt_le ; apply Sublemma2. rewrite Rabs_Ropp.
+ apply Rlt_le_trans with (r2:=x-lb) ; [| apply RRle_abs] ;
+ apply Rlt_le_trans with (r2:=Rmin (x - lb) (ub - x)) ; [| apply Rmin_l] ;
+ apply Rlt_le_trans with (r2:=Rmin delta' (Rmin (x - lb) (ub - x))).
+ apply Rlt_le_trans with (r2:=delta''). assumption. intuition. apply Rmin_r.
+ apply Rgt_minus. intuition.
+ assert (Sublemma : forall x y z, y <= z - x -> x + y <= z).
+  intros ; fourier.
+ apply Sublemma.
+ apply Rlt_le ; apply Sublemma2.
+ apply Rlt_le_trans with (r2:=ub-x) ; [| apply RRle_abs] ;
+ apply Rlt_le_trans with (r2:=Rmin (x - lb) (ub - x)) ; [| apply Rmin_r] ;
+ apply Rlt_le_trans with (r2:=Rmin delta' (Rmin (x - lb) (ub - x))) ; [| apply Rmin_r] ; assumption.
+ apply Rlt_le_trans with (r2:=delta''). assumption.
+  apply Rle_trans with (r2:=Rmin delta' (Rmin (x - lb) (ub - x))). intuition.
+  apply Rle_trans with (r2:=Rmin (x - lb) (ub - x)). apply Rmin_r. apply Rmin_r.
+         replace ((g (x + h) - g x) / h) with (1/ (h / (g (x + h) - g x))).
+         assert (Hrewr : h = (comp f g ) (x+h) - (comp f g) x).
+          rewrite f_eq_g. rewrite f_eq_g ; unfold id. rewrite Rplus_comm ;
+          unfold Rminus ; rewrite Rplus_assoc ; rewrite Rplus_opp_r. intuition. intuition.    
+ assumption.
+         split ; [|intuition].
+         assert (Sublemma : forall x y z, - z <= y - x -> x <= y + z).
+          intros ; fourier.
+         apply Sublemma ; apply Rlt_le ; apply Sublemma2. rewrite Rabs_Ropp.
+ apply Rlt_le_trans with (r2:=x-lb) ; [| apply RRle_abs] ;
+ apply Rlt_le_trans with (r2:=Rmin (x - lb) (ub - x)) ; [| apply Rmin_l] ;
+ apply Rlt_le_trans with (r2:=Rmin delta' (Rmin (x - lb) (ub - x))) ; [| apply Rmin_r] ; assumption.
+ apply Rgt_minus. intuition.
+ field.
+ split. assumption.
+ intro Hfalse. assert (Hf : g (x+h) = g x) by intuition.
+ assert ((comp f g) (x+h) = (comp f g) x).
+  unfold comp ; rewrite Hf ; intuition.
+ assert (Main : x+h = x).
+ replace (x +h) with (id (x+h)) by intuition.
+ assert (Temp : x = id x) by intuition ; rewrite Temp at 2 ; clear Temp.
+ rewrite <- f_eq_g. rewrite <- f_eq_g. assumption.
+ intuition. assumption.
+ assert (h = 0).
+ apply Rplus_0_r_uniq with (r:=x) ; assumption.
+ apply h_neq ; assumption.
+         replace ((g (x + h) - g x) / h) with (1/ (h / (g (x + h) - g x))).
+         assert (Hrewr : h = (comp f g ) (x+h) - (comp f g) x).
+          rewrite f_eq_g. rewrite f_eq_g. unfold id ; rewrite Rplus_comm ;
+          unfold Rminus ; rewrite Rplus_assoc ; rewrite Rplus_opp_r ; intuition.
+          assumption. assumption.
+         rewrite Hrewr at 1. 
+         unfold comp.
+         replace (g(x+h)) with (g x + (g (x+h) - g(x))) by field.
+         pose (h':=g (x+h) - g x).
+         replace (g (x+h) - g x) with h' by intuition.
+         replace (g x + h' - g x) with h' by field.
+         assert (h'_neq : h' <> 0).
+          unfold h'.
+          intro Hfalse.
+          unfold Rminus in Hfalse ; apply Rminus_diag_uniq in Hfalse.
+          assert (Hfalse' : (comp f g) (x+h) = (comp f g) x).
+           intros ; unfold comp ; rewrite Hfalse ; trivial.
+          rewrite f_eq_g in Hfalse' ; rewrite f_eq_g in Hfalse'.
+          unfold id in Hfalse'.
+          apply Rplus_0_r_uniq in Hfalse'.
+          apply h_neq ; exact Hfalse'. assumption. assumption. assumption.
+         unfold Rdiv at 1 3; rewrite Rmult_1_l ; rewrite Rmult_1_l.
+         apply inv_cont.
+         split.
+          exact h'_neq.
+          rewrite Rminus_0_r. 
+          unfold continuity_pt, continue_in, limit1_in, limit_in in g_cont_pur.
+          elim (g_cont_pur mydelta mydelta_pos).
+          intros delta3 cond3.
+          unfold dist in cond3 ; simpl in cond3 ; unfold R_dist in cond3.
+          unfold h'.
+          assert (mydelta_le_alpha : mydelta <= alpha).
+           unfold mydelta, Rmin ; case (Rle_dec delta alpha).
+           trivial.
+           intro ; intuition.
+          apply Rlt_le_trans with (r2:=mydelta).
+          unfold dist in g_cont ; simpl in g_cont ; unfold R_dist in g_cont ; apply g_cont.
+          split.
+           unfold D_x ; simpl.
+           split.
+            unfold no_cond ; trivial.
+            intro Hfalse ; apply h_neq.
+             apply (Rplus_0_r_uniq x).
+             symmetry ; assumption.
+            replace (x + h - x) with h by field. 
+            apply Rlt_le_trans with (r2:=delta'').
+            assumption ; unfold delta''. intuition.
+            apply Rle_trans with (r2:=mydelta''). apply Req_le. unfold delta''. intuition.
+            apply Rmin_l. assumption.
+            field ; split.
+             assumption.
+             intro Hfalse ; apply h_neq.
+             apply (Rplus_0_r_uniq x).
+             assert (Hfin : (comp f g) (x+h) = (comp f g) x).
+              apply Rminus_diag_uniq in Hfalse.
+              unfold comp.
+              rewrite Hfalse ; reflexivity.
+              rewrite f_eq_g in Hfin. rewrite f_eq_g in Hfin. unfold id in Hfin. exact Hfin.
+              assumption. assumption.
+Qed.
+
+Lemma derivable_pt_recip_interv_prelim0 : forall (f g : R -> R) (lb ub x : R)
+       (Prf : forall a : R, g lb <= a <= g ub -> derivable_pt f a),
+       continuity_pt g x ->
+       lb < ub ->
+       lb < x < ub ->
+       forall Prg_incr : g lb <= g x <= g ub,
+       (forall x0 : R, lb <= x0 <= ub -> comp f g x0 = id x0) ->
+       derive_pt f (g x) (Prf (g x) Prg_incr) <> 0 ->
+       derivable_pt g x.
+Proof.
+intros f g lb ub x Prf g_cont_pt lb_lt_ub x_encad Prg_incr f_eq_g Df_neq.
+unfold derivable_pt, derivable_pt_abs.
+exists (1 / derive_pt f (g x) (Prf (g x) Prg_incr)).
+apply derivable_pt_lim_recip_interv ; assumption.
+Qed.
+
+Lemma derivable_pt_recip_interv_prelim1 :forall (f g:R->R) (lb ub x : R),
+         lb < ub ->
+         f lb < x < f ub ->
+         (forall x : R, f lb <= x -> x <= f ub -> comp f g x = id x) ->
+         (forall x : R, f lb <= x -> x <= f ub -> lb <= g x <= ub) ->
+         (forall x y : R, lb <= x -> x < y -> y <= ub -> f x < f y) ->
+         (forall a : R, lb <= a <= ub -> derivable_pt f a) ->
+         derivable_pt f (g x).
+Proof.
+intros f g lb ub x lb_lt_ub x_encad f_eq_g g_ok f_incr f_derivable.
+ apply f_derivable.
+ assert (Left_inv := leftinv_is_rightinv_interv f g lb ub f_incr f_eq_g g_ok).
+ replace lb with ((comp g f) lb).
+ replace ub with ((comp g f) ub).
+ unfold comp.
+ assert (Temp:= f_incr_implies_g_incr_interv f g lb ub lb_lt_ub f_incr f_eq_g g_ok).
+ split ; apply Rlt_le ; apply Temp ; intuition.
+ apply Left_inv ; intuition.
+ apply Left_inv ; intuition.
+Qed.
+
+Lemma derivable_pt_recip_interv : forall (f g:R->R) (lb ub x : R)
+         (lb_lt_ub:lb < ub) (x_encad:f lb < x < f ub)
+         (f_eq_g:forall x : R, f lb <= x -> x <= f ub -> comp f g x = id x)
+         (g_wf:forall x : R, f lb <= x -> x <= f ub -> lb <= g x <= ub)
+         (f_incr:forall x y : R, lb <= x -> x < y -> y <= ub -> f x < f y)
+         (f_derivable:forall a : R, lb <= a <= ub -> derivable_pt f a),
+         derive_pt f (g x)
+              (derivable_pt_recip_interv_prelim1 f g lb ub x lb_lt_ub
+              x_encad f_eq_g g_wf f_incr f_derivable)
+         <> 0 ->
+         derivable_pt g x.
+Proof.
+intros f g lb ub x lb_lt_ub x_encad f_eq_g g_wf f_incr f_derivable Df_neq.
+ assert(g_incr : g (f lb) < g x < g (f ub)).
+  assert (Temp:= f_incr_implies_g_incr_interv f g lb ub lb_lt_ub f_incr f_eq_g g_wf).
+  split ; apply Temp ; intuition.
+  exact (proj1 x_encad). apply Rlt_le ; exact (proj2 x_encad).
+  apply Rlt_le ; exact (proj1 x_encad). exact (proj2 x_encad).
+ assert(g_incr2 :  g (f lb) <= g x <= g (f ub)).
+  split ; apply Rlt_le ; intuition.
+ assert (g_eq_f :=  leftinv_is_rightinv_interv f g lb ub f_incr f_eq_g g_wf).
+ unfold comp, id in g_eq_f.
+ assert (f_derivable2 : forall a : R, g (f lb) <= a <= g (f ub) -> derivable_pt f a).
+  intros a a_encad ; apply f_derivable.
+   rewrite g_eq_f in a_encad ; rewrite g_eq_f in a_encad ; intuition.
+ apply derivable_pt_recip_interv_prelim0 with (f:=f) (lb:=f lb) (ub:=f ub)
+     (Prf:=f_derivable2) (Prg_incr:=g_incr2).
+ apply continuity_pt_recip_interv with (f:=f) (lb:=lb) (ub:=ub) ; intuition.
+ apply derivable_continuous_pt ; apply f_derivable ; intuition.
+ exact (proj1 x_encad). exact (proj2 x_encad).  apply f_incr ; intuition.
+ assumption.
+ intros x0 x0_encad ; apply f_eq_g ; intuition.
+ rewrite pr_nu_var2_interv with (g:=f) (lb:=lb) (ub:=ub) (pr2:=derivable_pt_recip_interv_prelim1 f g lb ub x lb_lt_ub x_encad
+      f_eq_g g_wf f_incr f_derivable) ; [| |rewrite g_eq_f in g_incr ; rewrite g_eq_f in g_incr| ] ; intuition.
+Qed.
+
+(****************************************************)
+(** *   Value of the derivative of the reciprocal function        *)
+(****************************************************)
+
+Lemma derive_pt_recip_interv_prelim0 : forall (f g:R->R) (lb ub x:R)
+       (Prf:derivable_pt f (g x)) (Prg:derivable_pt g x),
+       lb < ub ->
+       lb < x < ub ->
+       (forall x, lb < x < ub -> (comp f g) x = id x) ->
+       derive_pt f (g x) Prf <> 0 ->
+       derive_pt g x Prg = 1 / (derive_pt f (g x) Prf).
+Proof.
+intros f g lb ub x Prf Prg lb_lt_ub x_encad local_recip Df_neq.
+ replace (derive_pt g x Prg) with
+  ((derive_pt g x Prg) * (derive_pt f (g x) Prf) * / (derive_pt f (g x) Prf)).
+ unfold Rdiv.
+ rewrite (Rmult_comm _ (/ derive_pt f (g x) Prf)).
+ rewrite (Rmult_comm _ (/ derive_pt f (g x) Prf)). 
+ apply Rmult_eq_compat_l. 
+ rewrite Rmult_comm.
+ rewrite <- derive_pt_comp.
+ assert (x_encad2 : lb <= x <= ub) by intuition.
+ rewrite pr_nu_var2_interv with (g:=id) (pr2:= derivable_pt_id_interv lb ub x x_encad2) (lb:=lb) (ub:=ub) ; [reg| | |] ; assumption.
+ rewrite Rmult_assoc, Rinv_r.
+ intuition.
+ assumption.
+Qed.
+
+Lemma derive_pt_recip_interv_prelim1_0 : forall (f g:R->R) (lb ub x:R), 
+       lb < ub ->
+       f lb < x < f ub ->
+       (forall x y : R, lb <= x -> x < y -> y <= ub -> f x < f y) ->
+       (forall x : R, f lb <= x -> x <= f ub -> lb <= g x <= ub) ->
+       (forall x, f lb <= x -> x <= f ub -> (comp f g) x = id x) ->
+       lb < g x < ub.
+Proof.
+intros f g lb ub x lb_lt_ub x_encad f_incr g_wf f_eq_g.
+ assert (Temp:= f_incr_implies_g_incr_interv f g lb ub lb_lt_ub f_incr f_eq_g g_wf).
+ assert (Left_inv := leftinv_is_rightinv_interv f g lb ub f_incr f_eq_g g_wf).
+ unfold comp, id in Left_inv.
+ split ; [rewrite <- Left_inv with (x:=lb) | rewrite <- Left_inv ].
+ apply Temp ; intuition.
+ intuition.
+ apply Temp ; intuition.
+ intuition.
+Qed.
+
+Lemma derive_pt_recip_interv_prelim1_1 : forall (f g:R->R) (lb ub x:R), 
+       lb < ub ->
+       f lb < x < f ub ->
+       (forall x y : R, lb <= x -> x < y -> y <= ub -> f x < f y) ->
+       (forall x : R, f lb <= x -> x <= f ub -> lb <= g x <= ub) ->
+       (forall x, f lb <= x -> x <= f ub -> (comp f g) x = id x) ->
+       lb <= g x <= ub.
+Proof.
+intros f g lb ub x lb_lt_ub x_encad f_incr g_wf f_eq_g.
+ assert (Temp := derive_pt_recip_interv_prelim1_0 f g lb ub x lb_lt_ub x_encad f_incr g_wf f_eq_g).
+ split ; apply Rlt_le ; intuition.
+Qed.
+
+Lemma derive_pt_recip_interv : forall (f g:R->R) (lb ub x:R)
+       (lb_lt_ub:lb < ub) (x_encad:f lb < x < f ub)
+       (f_incr:forall x y : R, lb <= x -> x < y -> y <= ub -> f x < f y)
+       (g_wf:forall x : R, f lb <= x -> x <= f ub -> lb <= g x <= ub)
+       (Prf:forall a : R, lb <= a <= ub -> derivable_pt f a)
+       (f_eq_g:forall x, f lb <= x -> x <= f ub -> (comp f g) x = id x)
+       (Df_neq:derive_pt f (g x) (derivable_pt_recip_interv_prelim1 f g lb ub x
+                 lb_lt_ub x_encad f_eq_g g_wf f_incr Prf) <> 0),
+       derive_pt g x (derivable_pt_recip_interv f g lb ub x lb_lt_ub x_encad f_eq_g
+                 g_wf f_incr Prf Df_neq)
+       =
+       1 / (derive_pt f (g x) (Prf (g x) (derive_pt_recip_interv_prelim1_1 f g lb ub x
+       lb_lt_ub x_encad f_incr g_wf f_eq_g))).
+Proof.
+intros.
+ assert(g_incr := (derive_pt_recip_interv_prelim1_1 f g lb ub x lb_lt_ub
+        x_encad f_incr g_wf f_eq_g)).
+ apply derive_pt_recip_interv_prelim0 with (lb:=f lb) (ub:=f ub) ;
+ [intuition |assumption | intuition |].
+ intro Hfalse ; apply Df_neq.  rewrite pr_nu_var2_interv with (g:=f) (lb:=lb) (ub:=ub)
+        (pr2:= (Prf (g x) (derive_pt_recip_interv_prelim1_1 f g lb ub x lb_lt_ub x_encad
+                 f_incr g_wf f_eq_g))) ;
+ [intuition | intuition | | intuition].
+ exact (derive_pt_recip_interv_prelim1_0 f g lb ub x lb_lt_ub x_encad f_incr g_wf f_eq_g).
+Qed.
+  
+(****************************************************)
+(** * Existence of the derivative of a function which is the limit of a sequence of functions *)
+(****************************************************)
+
+(* begin hide *)
+Lemma ub_lt_2_pos : forall x ub lb, lb < x -> x < ub -> 0 < (ub-lb)/2.
+Proof.
+intros x ub lb lb_lt_x x_lt_ub.
+ assert (T : 0 < ub - lb).
+  fourier.
+ unfold Rdiv ; apply Rlt_mult_inv_pos ; intuition.
+Qed.
+
+Definition mkposreal_lb_ub (x lb ub:R) (lb_lt_x:lb<x) (x_lt_ub:x<ub) : posreal.
+ apply (mkposreal ((ub-lb)/2) (ub_lt_2_pos x ub lb lb_lt_x x_lt_ub)).
+Defined.
+(* end hide *)
+
+Definition boule_of_interval x y (h : x < y) :
+  {c :R & {r : posreal | c - r = x /\ c + r = y}}.
+exists ((x + y)/2).
+assert (radius : 0 < (y - x)/2).
+ unfold Rdiv; apply Rmult_lt_0_compat; fourier.
+ exists (mkposreal _ radius).
+ simpl; split; unfold Rdiv; field.
+Qed.
+
+Definition boule_in_interval x y z (h : x < z < y) :
+  {c : R & {r | Boule c r z /\  x < c - r /\ c + r < y}}.
+Proof.
+assert (cmp : x * /2 + z * /2 < z * /2 + y * /2).
+destruct h as [h1 h2]; fourier.
+destruct (boule_of_interval _ _ cmp) as [c [r [P1 P2]]].
+exists c, r; split.
+ destruct h; unfold Boule; simpl; apply Rabs_def1; fourier.
+destruct h; split; fourier.
+Qed.
+
+Lemma Ball_in_inter : forall c1 c2 r1 r2 x,
+  Boule c1 r1 x -> Boule c2 r2 x ->
+  {r3 : posreal | forall y, Boule x r3 y -> Boule c1 r1 y /\ Boule c2 r2 y}.
+intros c1 c2 [r1 r1p] [r2 r2p] x; unfold Boule; simpl; intros in1 in2.
+assert (Rmax (c1 - r1)(c2 - r2) < x).
+ apply Rmax_lub_lt;[revert in1 | revert in2]; intros h;
+  apply Rabs_def2 in h; destruct h; fourier.
+assert (x < Rmin (c1 + r1) (c2 + r2)).
+ apply Rmin_glb_lt;[revert in1 | revert in2]; intros h;
+  apply Rabs_def2 in h; destruct h; fourier.
+assert (t: 0 < Rmin (x - Rmax (c1 - r1) (c2 - r2)) 
+              (Rmin (c1 + r1) (c2 + r2) - x)).
+ apply Rmin_glb_lt; fourier.
+exists (mkposreal _ t).
+apply Rabs_def2 in in1; destruct in1.
+apply Rabs_def2 in in2; destruct in2.
+assert (c1 - r1 <= Rmax (c1 - r1) (c2 - r2)) by apply Rmax_l.
+assert (c2 - r2 <= Rmax (c1 - r1) (c2 - r2)) by apply Rmax_r.
+assert (Rmin (c1 + r1) (c2 + r2) <= c1 + r1) by apply Rmin_l.
+assert (Rmin (c1 + r1) (c2 + r2) <= c2 + r2) by apply Rmin_r.
+assert (Rmin (x - Rmax (c1 - r1) (c2 - r2)) 
+         (Rmin (c1 + r1) (c2 + r2) - x) <= x - Rmax (c1 - r1) (c2 - r2))
+ by apply Rmin_l.
+assert (Rmin (x - Rmax (c1 - r1) (c2 - r2)) 
+         (Rmin (c1 + r1) (c2 + r2) - x) <= Rmin (c1 + r1) (c2 + r2) - x)
+ by apply Rmin_r.
+simpl.
+intros y h; apply Rabs_def2 in h; destruct h;split; apply Rabs_def1; fourier.
+Qed.
+
+Lemma Boule_center : forall x r, Boule x r x.
+Proof.
+intros x [r rpos]; unfold Boule, Rminus; simpl; rewrite Rplus_opp_r.
+rewrite Rabs_pos_eq;[assumption | apply Rle_refl].
+Qed.
+
+Lemma derivable_pt_lim_CVU : forall (fn fn':nat -> R -> R) (f g:R->R)
+      (x:R) c r, Boule c r x ->
+      (forall y n, Boule c r y -> derivable_pt_lim (fn n) y (fn' n y)) ->
+      (forall y, Boule c r y -> Un_cv (fun n => fn n y) (f y)) ->
+      (CVU fn' g c r) ->
+      (forall y, Boule c r y -> continuity_pt g y) ->
+      derivable_pt_lim f x (g x).
+Proof.
+intros fn fn' f g x c' r xinb Dfn_eq_fn' fn_CV_f fn'_CVU_g g_cont eps eps_pos.
+assert (eps_8_pos : 0 < eps / 8) by fourier.
+elim (g_cont x xinb _ eps_8_pos) ; clear g_cont ;
+intros delta1 (delta1_pos, g_cont).
+destruct (Ball_in_inter _ _ _ _ _ xinb
+   (Boule_center x (mkposreal _ delta1_pos)))
+   as [delta Pdelta].
+exists delta; intros h hpos hinbdelta.
+assert (eps'_pos : 0 < (Rabs h) * eps / 4).
+ unfold Rdiv ; rewrite Rmult_assoc ; apply Rmult_lt_0_compat.
+ apply Rabs_pos_lt ; assumption.
+fourier.
+destruct (fn_CV_f x xinb ((Rabs h) * eps / 4) eps'_pos) as [N2 fnx_CV_fx].
+assert (xhinbxdelta : Boule x delta (x + h)).
+ clear -hinbdelta; apply Rabs_def2 in hinbdelta; unfold Boule; simpl.
+ destruct hinbdelta; apply Rabs_def1; fourier.
+assert (t : Boule c' r (x + h)).
+ apply Pdelta in xhinbxdelta; tauto.
+destruct (fn_CV_f (x+h) t ((Rabs h) * eps / 4) eps'_pos) as [N1 fnxh_CV_fxh].
+clear fn_CV_f t.
+destruct (fn'_CVU_g (eps/8) eps_8_pos) as [N3 fn'c_CVU_gc].
+pose (N := ((N1 + N2) + N3)%nat).
+assert (Main : Rabs ((f (x+h) - fn N (x+h)) - (f x - fn N x) + (fn N (x+h) - fn N x - h * (g x))) < (Rabs h)*eps).
+ apply Rle_lt_trans with (Rabs (f (x + h) - fn N (x + h) - (f x - fn N x)) +  Rabs ((fn N (x + h) - fn N x - h * g x))).
+  solve[apply Rabs_triang].
+ apply Rle_lt_trans with (Rabs (f (x + h) - fn N (x + h)) + Rabs (- (f x - fn N x)) + Rabs (fn N (x + h) - fn N x - h * g x)).
+  solve[apply Rplus_le_compat_r ; apply Rabs_triang].
+ rewrite Rabs_Ropp.
+ case (Rlt_le_dec h 0) ; intro sgn_h.
+  assert (pr1 : forall c : R, x + h < c < x -> derivable_pt (fn N) c).
+   intros c c_encad ; unfold derivable_pt.
+   exists (fn' N c) ; apply Dfn_eq_fn'.
+   assert (t : Boule x delta c).
+    apply Rabs_def2 in xhinbxdelta; destruct xhinbxdelta; destruct c_encad.
+    apply Rabs_def2 in xinb; apply Rabs_def1; fourier.
+   apply Pdelta in t; tauto.
+  assert (pr2 : forall c : R, x + h < c < x -> derivable_pt id c).
+   solve[intros; apply derivable_id].
+  assert (xh_x : x+h < x) by fourier.
+  assert (pr3 : forall c : R, x + h <= c <= x -> continuity_pt (fn N) c).
+   intros c c_encad ; apply derivable_continuous_pt.
+   exists (fn' N c) ; apply Dfn_eq_fn' ; intuition.
+   assert (t : Boule x delta c).
+    apply Rabs_def2 in xhinbxdelta; destruct xhinbxdelta.
+    apply Rabs_def2 in xinb; apply Rabs_def1; fourier.
+   apply Pdelta in t; tauto.
+  assert (pr4 : forall c : R, x + h <= c <= x -> continuity_pt id c).
+   solve[intros; apply derivable_continuous ; apply derivable_id].
+  destruct (MVT (fn N) id (x+h) x pr1 pr2 xh_x pr3 pr4) as [c [P Hc]].
+  assert (Hc' : h * derive_pt (fn N) c (pr1 c P) = (fn N (x+h) - fn N x)).
+   apply Rmult_eq_reg_l with (-1).
+    replace (-1 * (h * derive_pt (fn N) c (pr1 c P))) with (-h * derive_pt (fn N) c (pr1 c P)) by field.
+    replace (-1 * (fn N (x + h) - fn N x)) with (- (fn N (x + h) - fn N x)) by field.
+    replace (-h) with (id x - id (x + h)) by (unfold id; field).
+    rewrite <- Rmult_1_r ; replace 1 with (derive_pt id c (pr2 c P)) by reg.
+    replace (- (fn N (x + h) - fn N x)) with (fn N x - fn N (x + h)) by field.
+    assumption.
+   solve[apply Rlt_not_eq ; intuition].
+  rewrite <- Hc'; clear Hc Hc'.
+  replace (derive_pt (fn N) c (pr1 c P)) with (fn' N c).
+  replace (h * fn' N c - h * g x) with (h * (fn' N c - g x)) by field.
+   rewrite Rabs_mult.
+   apply Rlt_trans with (Rabs h * eps / 4 + Rabs (f x - fn N x) + Rabs h * Rabs (fn' N c - g x)).
+    apply Rplus_lt_compat_r ; apply Rplus_lt_compat_r ; unfold R_dist in fnxh_CV_fxh ;
+ rewrite Rabs_minus_sym ; apply fnxh_CV_fxh.
+   unfold N; omega.
+   apply Rlt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 + Rabs h * Rabs (fn' N c - g x)).
+    apply Rplus_lt_compat_r ; apply Rplus_lt_compat_l.
+    unfold R_dist in fnx_CV_fx ; rewrite Rabs_minus_sym ; apply fnx_CV_fx.
+    unfold N ; omega.
+   replace (fn' N c - g x)  with ((fn' N c - g c) +  (g c - g x)) by field.
+   apply Rle_lt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 +
+          Rabs h * Rabs (fn' N c - g c) + Rabs h * Rabs (g c - g x)).
+    rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite Rplus_assoc ;
+    apply Rplus_le_compat_l ; apply Rplus_le_compat_l ;
+    rewrite <- Rmult_plus_distr_l ; apply Rmult_le_compat_l. 
+     solve[apply Rabs_pos].
+    solve[apply Rabs_triang].
+   apply Rlt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 +
+          Rabs h * (eps / 8) + Rabs h * Rabs (g c - g x)).
+    apply Rplus_lt_compat_r; apply Rplus_lt_compat_l; apply Rmult_lt_compat_l.
+     apply Rabs_pos_lt ; assumption.
+    rewrite Rabs_minus_sym ; apply fn'c_CVU_gc.
+     unfold N ; omega.
+    assert (t : Boule x delta c).
+     destruct P.
+     apply Rabs_def2 in xhinbxdelta; destruct xhinbxdelta.
+     apply Rabs_def2 in xinb; apply Rabs_def1; fourier.
+    apply Pdelta in t; tauto.
+   apply Rlt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 + Rabs h * (eps / 8) +
+         Rabs h * (eps / 8)).
+    rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite Rplus_assoc ;
+    apply Rplus_lt_compat_l ; apply Rplus_lt_compat_l ; rewrite <- Rmult_plus_distr_l ;
+    rewrite <- Rmult_plus_distr_l ; apply Rmult_lt_compat_l.
+     apply Rabs_pos_lt ; assumption.
+     apply Rplus_lt_compat_l ; simpl in g_cont ; apply g_cont ; split ; [unfold D_x ; split |].
+      solve[unfold no_cond ; intuition].
+     apply Rgt_not_eq ; exact (proj2 P).
+    apply Rlt_trans with (Rabs h).
+     apply Rabs_def1. 
+      apply Rlt_trans with 0.
+       destruct P; fourier.
+      apply Rabs_pos_lt ; assumption.
+     rewrite <- Rabs_Ropp, Rabs_pos_eq, Ropp_involutive;[ | fourier]. 
+     destruct P; fourier.
+    clear -Pdelta xhinbxdelta.
+    apply Pdelta in xhinbxdelta; destruct xhinbxdelta as [_ P'].
+    apply Rabs_def2 in P'; simpl in P'; destruct P';
+    apply Rabs_def1; fourier.
+   rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite <- Rmult_plus_distr_l.
+   replace (Rabs h * eps / 4 + (Rabs h * eps / 4 + Rabs h * (eps / 8 + eps / 8))) with
+      (Rabs h * (eps / 4 + eps / 4 + eps / 8 + eps / 8)) by field.
+   apply Rmult_lt_compat_l. 
+    apply Rabs_pos_lt ; assumption.
+   fourier.
+  assert (H := pr1 c P) ; elim H ; clear H ; intros l Hl.
+  assert (Temp : l = fn' N c).
+   assert (bc'rc : Boule c' r c).
+    assert (t : Boule x delta c).
+     clear - xhinbxdelta P.
+     destruct P; apply Rabs_def2 in xhinbxdelta; destruct xhinbxdelta.
+     apply Rabs_def1; fourier.
+    apply Pdelta in t; tauto.
+   assert (Hl' := Dfn_eq_fn' c N bc'rc).
+   unfold derivable_pt_abs in Hl; clear -Hl Hl'.
+   apply uniqueness_limite with (f:= fn N) (x:=c) ; assumption.
+  rewrite <- Temp.
+  assert (Hl' : derivable_pt (fn N) c).
+  exists l ; apply Hl.
+  rewrite pr_nu_var with (g:= fn N) (pr2:=Hl').
+   elim Hl' ; clear Hl' ; intros l' Hl'.
+   assert (Main : l = l').
+    apply uniqueness_limite with (f:= fn N) (x:=c) ; assumption.
+   rewrite Main ; reflexivity.
+  reflexivity.
+ assert (h_pos : h > 0).
+  case sgn_h ; intro Hyp.
+  assumption.
+  apply False_ind ; apply hpos ; symmetry ; assumption.
+ clear sgn_h.
+ assert (pr1 : forall c : R, x < c < x + h -> derivable_pt (fn N) c).
+  intros c c_encad ; unfold derivable_pt.
+  exists (fn' N c) ; apply Dfn_eq_fn'.
+  assert (t : Boule x delta c).
+   apply Rabs_def2 in xhinbxdelta; destruct xhinbxdelta; destruct c_encad.
+   apply Rabs_def2 in xinb; apply Rabs_def1; fourier.
+  apply Pdelta in t; tauto.
+  assert (pr2 : forall c : R, x < c < x + h -> derivable_pt id c).
+   solve[intros; apply derivable_id].
+  assert (xh_x : x < x + h) by fourier.
+  assert (pr3 : forall c : R, x <= c <= x + h -> continuity_pt (fn N) c).
+   intros c c_encad ; apply derivable_continuous_pt.
+   exists (fn' N c) ; apply Dfn_eq_fn' ; intuition.
+   assert (t : Boule x delta c).
+    apply Rabs_def2 in xhinbxdelta; destruct xhinbxdelta.
+    apply Rabs_def2 in xinb; apply Rabs_def1; fourier.
+   apply Pdelta in t; tauto.
+  assert (pr4 : forall c : R, x <= c <= x + h -> continuity_pt id c).
+   solve[intros; apply derivable_continuous ; apply derivable_id].
+  destruct (MVT (fn N) id x (x+h) pr1 pr2 xh_x pr3 pr4) as [c [P Hc]].
+  assert (Hc' : h * derive_pt (fn N) c (pr1 c P) = fn N (x+h) - fn N x).
+    pattern h at 1; replace h with (id (x + h) - id x) by (unfold id; field).
+    rewrite <- Rmult_1_r ; replace 1 with (derive_pt id c (pr2 c P)) by reg.
+    assumption.
+  rewrite <- Hc'; clear Hc Hc'.
+  replace (derive_pt (fn N) c (pr1 c P)) with (fn' N c).
+  replace (h * fn' N c - h * g x) with (h * (fn' N c - g x)) by field.
+   rewrite Rabs_mult.
+   apply Rlt_trans with (Rabs h * eps / 4 + Rabs (f x - fn N x) + Rabs h * Rabs (fn' N c - g x)).
+    apply Rplus_lt_compat_r ; apply Rplus_lt_compat_r ; unfold R_dist in fnxh_CV_fxh ;
+ rewrite Rabs_minus_sym ; apply fnxh_CV_fxh.
+   unfold N; omega.
+   apply Rlt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 + Rabs h * Rabs (fn' N c - g x)).
+    apply Rplus_lt_compat_r ; apply Rplus_lt_compat_l.
+    unfold R_dist in fnx_CV_fx ; rewrite Rabs_minus_sym ; apply fnx_CV_fx.
+    unfold N ; omega.
+   replace (fn' N c - g x)  with ((fn' N c - g c) +  (g c - g x)) by field.
+   apply Rle_lt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 +
+          Rabs h * Rabs (fn' N c - g c) + Rabs h * Rabs (g c - g x)).
+    rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite Rplus_assoc ;
+    apply Rplus_le_compat_l ; apply Rplus_le_compat_l ;
+    rewrite <- Rmult_plus_distr_l ; apply Rmult_le_compat_l. 
+     solve[apply Rabs_pos].
+    solve[apply Rabs_triang].
+   apply Rlt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 +
+          Rabs h * (eps / 8) + Rabs h * Rabs (g c - g x)).
+    apply Rplus_lt_compat_r; apply Rplus_lt_compat_l; apply Rmult_lt_compat_l.
+     apply Rabs_pos_lt ; assumption.
+    rewrite Rabs_minus_sym ; apply fn'c_CVU_gc.
+     unfold N ; omega.
+    assert (t : Boule x delta c).
+     destruct P.
+    apply Rabs_def2 in xhinbxdelta; destruct xhinbxdelta.
+    apply Rabs_def2 in xinb; apply Rabs_def1; fourier.
+   apply Pdelta in t; tauto.
+  apply Rlt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 + Rabs h * (eps / 8) +
+         Rabs h * (eps / 8)).
+   rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite Rplus_assoc ;
+    apply Rplus_lt_compat_l ; apply Rplus_lt_compat_l ; rewrite <- Rmult_plus_distr_l ;
+   rewrite <- Rmult_plus_distr_l ; apply Rmult_lt_compat_l.
+    apply Rabs_pos_lt ; assumption.
+   apply Rplus_lt_compat_l ; simpl in g_cont ; apply g_cont ; split ; [unfold D_x ; split |].
+     solve[unfold no_cond ; intuition].
+    apply Rlt_not_eq ; exact (proj1 P).
+   apply Rlt_trans with (Rabs h).
+    apply Rabs_def1.
+     destruct P; rewrite Rabs_pos_eq;fourier.
+    apply Rle_lt_trans with 0.
+     assert (t := Rabs_pos h); clear -t; fourier.
+    clear -P; destruct P; fourier.
+   clear -Pdelta xhinbxdelta.
+   apply Pdelta in xhinbxdelta; destruct xhinbxdelta as [_ P'].
+   apply Rabs_def2 in P'; simpl in P'; destruct P';
+    apply Rabs_def1; fourier.
+  rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite <- Rmult_plus_distr_l.
+  replace (Rabs h * eps / 4 + (Rabs h * eps / 4 + Rabs h * (eps / 8 + eps / 8))) with
+      (Rabs h * (eps / 4 + eps / 4 + eps / 8 + eps / 8)) by field.
+  apply Rmult_lt_compat_l. 
+   apply Rabs_pos_lt ; assumption.
+  fourier.
+ assert (H := pr1 c P) ; elim H ; clear H ; intros l Hl.
+ assert (Temp : l = fn' N c).
+  assert (bc'rc : Boule c' r c).
+   assert (t : Boule x delta c).
+    clear - xhinbxdelta P.
+    destruct P; apply Rabs_def2 in xhinbxdelta; destruct xhinbxdelta.
+    apply Rabs_def1; fourier.
+   apply Pdelta in t; tauto.
+  assert (Hl' := Dfn_eq_fn' c N bc'rc).
+  unfold derivable_pt_abs in Hl; clear -Hl Hl'.
+  apply uniqueness_limite with (f:= fn N) (x:=c) ; assumption.
+ rewrite <- Temp.
+ assert (Hl' : derivable_pt (fn N) c).
+ exists l ; apply Hl.
+ rewrite pr_nu_var with (g:= fn N) (pr2:=Hl').
+  elim Hl' ; clear Hl' ; intros l' Hl'.
+  assert (Main : l = l').
+   apply uniqueness_limite with (f:= fn N) (x:=c) ; assumption.
+  rewrite Main ; reflexivity.
+ reflexivity.
+ replace ((f (x + h) - f x) / h - g x) with ((/h) * ((f (x + h) - f x) - h * g x)). 
+ rewrite Rabs_mult ; rewrite Rabs_Rinv.
+ replace eps with (/ Rabs h * (Rabs h * eps)).
+ apply Rmult_lt_compat_l.
+ apply Rinv_0_lt_compat ; apply Rabs_pos_lt ; assumption.
+ replace (f (x + h) - f x - h * g x) with (f (x + h) - fn N (x + h) - (f x - fn N x) +
+          (fn N (x + h) - fn N x - h * g x)) by field.
+ assumption.
+ field ; apply Rgt_not_eq ; apply Rabs_pos_lt ; assumption.
+ assumption.
+ field. assumption.
+Qed.
\ No newline at end of file
diff --git a/theories/Reals/Ranalysis_reg.v b/theories/Reals/Ranalysis_reg.v
new file mode 100644
index 00000000..a4b18288
--- /dev/null
+++ b/theories/Reals/Ranalysis_reg.v
@@ -0,0 +1,800 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import Rtrigo1.
+Require Import SeqSeries.
+Require Export Ranalysis1.
+Require Export Ranalysis2.
+Require Export Ranalysis3.
+Require Export Rtopology.
+Require Export MVT.
+Require Export PSeries_reg.
+Require Export Exp_prop.
+Require Export Rtrigo_reg.
+Require Export Rsqrt_def.
+Require Export R_sqrt.
+Require Export Rtrigo_calc.
+Require Export Rgeom.
+Require Export RList.
+Require Export Sqrt_reg.
+Require Export Ranalysis4.
+Require Export Rpower.
+Local Open Scope R_scope.
+
+Axiom AppVar : R.
+
+(**********)
+Ltac intro_hyp_glob trm :=
+  match constr:trm with
+    | (?X1 + ?X2)%F =>
+      match goal with
+        |  |- (derivable _) => intro_hyp_glob X1; intro_hyp_glob X2
+        |  |- (continuity _) => intro_hyp_glob X1; intro_hyp_glob X2
+        | _ => idtac
+      end
+    | (?X1 - ?X2)%F =>
+      match goal with
+        |  |- (derivable _) => intro_hyp_glob X1; intro_hyp_glob X2
+        |  |- (continuity _) => intro_hyp_glob X1; intro_hyp_glob X2
+        | _ => idtac
+      end
+    | (?X1 * ?X2)%F =>
+      match goal with
+        |  |- (derivable _) => intro_hyp_glob X1; intro_hyp_glob X2
+        |  |- (continuity _) => intro_hyp_glob X1; intro_hyp_glob X2
+        | _ => idtac
+      end
+    | (?X1 / ?X2)%F =>
+      let aux := constr:X2 in
+        match goal with
+          | _:(forall x0:R, aux x0 <> 0) |- (derivable _) =>
+            intro_hyp_glob X1; intro_hyp_glob X2
+          | _:(forall x0:R, aux x0 <> 0) |- (continuity _) =>
+            intro_hyp_glob X1; intro_hyp_glob X2
+          |  |- (derivable _) =>
+            cut (forall x0:R, aux x0 <> 0);
+              [ intro; intro_hyp_glob X1; intro_hyp_glob X2 | try assumption ]
+          |  |- (continuity _) =>
+            cut (forall x0:R, aux x0 <> 0);
+              [ intro; intro_hyp_glob X1; intro_hyp_glob X2 | try assumption ]
+          | _ => idtac
+        end
+    | (comp ?X1 ?X2) =>
+      match goal with
+        |  |- (derivable _) => intro_hyp_glob X1; intro_hyp_glob X2
+        |  |- (continuity _) => intro_hyp_glob X1; intro_hyp_glob X2
+        | _ => idtac
+      end
+    | (- ?X1)%F =>
+      match goal with
+        |  |- (derivable _) => intro_hyp_glob X1
+        |  |- (continuity _) => intro_hyp_glob X1
+        | _ => idtac
+      end
+    | (/ ?X1)%F =>
+      let aux := constr:X1 in
+        match goal with
+          | _:(forall x0:R, aux x0 <> 0) |- (derivable _) =>
+            intro_hyp_glob X1
+          | _:(forall x0:R, aux x0 <> 0) |- (continuity _) =>
+            intro_hyp_glob X1
+          |  |- (derivable _) =>
+            cut (forall x0:R, aux x0 <> 0);
+              [ intro; intro_hyp_glob X1 | try assumption ]
+          |  |- (continuity _) =>
+            cut (forall x0:R, aux x0 <> 0);
+              [ intro; intro_hyp_glob X1 | try assumption ]
+          | _ => idtac
+        end
+    | cos => idtac
+    | sin => idtac
+    | cosh => idtac
+    | sinh => idtac
+    | exp => idtac
+    | Rsqr => idtac
+    | sqrt => idtac
+    | id => idtac
+    | (fct_cte _) => idtac
+    | (pow_fct _) => idtac
+    | Rabs => idtac
+    | ?X1 =>
+      let p := constr:X1 in
+        match goal with
+          | _:(derivable p) |- _ => idtac
+          |  |- (derivable p) => idtac
+          |  |- (derivable _) =>
+            cut (True -> derivable p);
+              [ intro HYPPD; cut (derivable p);
+                [ intro; clear HYPPD | apply HYPPD; clear HYPPD; trivial ]
+                | idtac ]
+          | _:(continuity p) |- _ => idtac
+          |  |- (continuity p) => idtac
+          |  |- (continuity _) =>
+            cut (True -> continuity p);
+              [ intro HYPPD; cut (continuity p);
+                [ intro; clear HYPPD | apply HYPPD; clear HYPPD; trivial ]
+                | idtac ]
+          | _ => idtac
+        end
+  end.
+
+(**********)
+Ltac intro_hyp_pt trm pt :=
+  match constr:trm with
+    | (?X1 + ?X2)%F =>
+      match goal with
+        |  |- (derivable_pt _ _) => intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
+        |  |- (continuity_pt _ _) => intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
+        |  |- (derive_pt _ _ _ = _) =>
+          intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
+        | _ => idtac
+      end
+    | (?X1 - ?X2)%F =>
+      match goal with
+        |  |- (derivable_pt _ _) => intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
+        |  |- (continuity_pt _ _) => intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
+        |  |- (derive_pt _ _ _ = _) =>
+          intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
+        | _ => idtac
+      end
+    | (?X1 * ?X2)%F =>
+      match goal with
+        |  |- (derivable_pt _ _) => intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
+        |  |- (continuity_pt _ _) => intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
+        |  |- (derive_pt _ _ _ = _) =>
+          intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
+        | _ => idtac
+      end
+    | (?X1 / ?X2)%F =>
+      let aux := constr:X2 in
+        match goal with
+          | _:(aux pt <> 0) |- (derivable_pt _ _) =>
+            intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
+          | _:(aux pt <> 0) |- (continuity_pt _ _) =>
+            intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
+          | _:(aux pt <> 0) |- (derive_pt _ _ _ = _) =>
+            intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
+          | id:(forall x0:R, aux x0 <> 0) |- (derivable_pt _ _) =>
+            generalize (id pt); intro; intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
+          | id:(forall x0:R, aux x0 <> 0) |- (continuity_pt _ _) =>
+            generalize (id pt); intro; intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
+          | id:(forall x0:R, aux x0 <> 0) |- (derive_pt _ _ _ = _) =>
+            generalize (id pt); intro; intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
+          |  |- (derivable_pt _ _) =>
+            cut (aux pt <> 0);
+              [ intro; intro_hyp_pt X1 pt; intro_hyp_pt X2 pt | try assumption ]
+          |  |- (continuity_pt _ _) =>
+            cut (aux pt <> 0);
+              [ intro; intro_hyp_pt X1 pt; intro_hyp_pt X2 pt | try assumption ]
+          |  |- (derive_pt _ _ _ = _) =>
+            cut (aux pt <> 0);
+              [ intro; intro_hyp_pt X1 pt; intro_hyp_pt X2 pt | try assumption ]
+          | _ => idtac
+        end
+    | (comp ?X1 ?X2) =>
+      match goal with
+        |  |- (derivable_pt _ _) =>
+          let pt_f1 := eval cbv beta in (X2 pt) in
+            (intro_hyp_pt X1 pt_f1; intro_hyp_pt X2 pt)
+        |  |- (continuity_pt _ _) =>
+          let pt_f1 := eval cbv beta in (X2 pt) in
+            (intro_hyp_pt X1 pt_f1; intro_hyp_pt X2 pt)
+        |  |- (derive_pt _ _ _ = _) =>
+          let pt_f1 := eval cbv beta in (X2 pt) in
+            (intro_hyp_pt X1 pt_f1; intro_hyp_pt X2 pt)
+        | _ => idtac
+      end
+    | (- ?X1)%F =>
+      match goal with
+        |  |- (derivable_pt _ _) => intro_hyp_pt X1 pt
+        |  |- (continuity_pt _ _) => intro_hyp_pt X1 pt
+        |  |- (derive_pt _ _ _ = _) => intro_hyp_pt X1 pt
+        | _ => idtac
+      end
+    | (/ ?X1)%F =>
+      let aux := constr:X1 in
+        match goal with
+          | _:(aux pt <> 0) |- (derivable_pt _ _) =>
+            intro_hyp_pt X1 pt
+          | _:(aux pt <> 0) |- (continuity_pt _ _) =>
+            intro_hyp_pt X1 pt
+          | _:(aux pt <> 0) |- (derive_pt _ _ _ = _) =>
+            intro_hyp_pt X1 pt
+          | id:(forall x0:R, aux x0 <> 0) |- (derivable_pt _ _) =>
+            generalize (id pt); intro; intro_hyp_pt X1 pt
+          | id:(forall x0:R, aux x0 <> 0) |- (continuity_pt _ _) =>
+            generalize (id pt); intro; intro_hyp_pt X1 pt
+          | id:(forall x0:R, aux x0 <> 0) |- (derive_pt _ _ _ = _) =>
+            generalize (id pt); intro; intro_hyp_pt X1 pt
+          |  |- (derivable_pt _ _) =>
+            cut (aux pt <> 0); [ intro; intro_hyp_pt X1 pt | try assumption ]
+          |  |- (continuity_pt _ _) =>
+            cut (aux pt <> 0); [ intro; intro_hyp_pt X1 pt | try assumption ]
+          |  |- (derive_pt _ _ _ = _) =>
+            cut (aux pt <> 0); [ intro; intro_hyp_pt X1 pt | try assumption ]
+          | _ => idtac
+        end
+    | cos => idtac
+    | sin => idtac
+    | cosh => idtac
+    | sinh => idtac
+    | exp => idtac
+    | Rsqr => idtac
+    | id => idtac
+    | (fct_cte _) => idtac
+    | (pow_fct _) => idtac
+    | sqrt =>
+      match goal with
+        |  |- (derivable_pt _ _) => cut (0 < pt); [ intro | try assumption ]
+        |  |- (continuity_pt _ _) =>
+          cut (0 <= pt); [ intro | try assumption ]
+        |  |- (derive_pt _ _ _ = _) =>
+          cut (0 < pt); [ intro | try assumption ]
+        | _ => idtac
+      end
+    | Rabs =>
+      match goal with
+        |  |- (derivable_pt _ _) =>
+          cut (pt <> 0); [ intro | try assumption ]
+        | _ => idtac
+      end
+    | ?X1 =>
+      let p := constr:X1 in
+        match goal with
+          | _:(derivable_pt p pt) |- _ => idtac
+          |  |- (derivable_pt p pt) => idtac
+          |  |- (derivable_pt _ _) =>
+            cut (True -> derivable_pt p pt);
+              [ intro HYPPD; cut (derivable_pt p pt);
+                [ intro; clear HYPPD | apply HYPPD; clear HYPPD; trivial ]
+                | idtac ]
+          | _:(continuity_pt p pt) |- _ => idtac
+          |  |- (continuity_pt p pt) => idtac
+          |  |- (continuity_pt _ _) =>
+            cut (True -> continuity_pt p pt);
+              [ intro HYPPD; cut (continuity_pt p pt);
+                [ intro; clear HYPPD | apply HYPPD; clear HYPPD; trivial ]
+                | idtac ]
+          |  |- (derive_pt _ _ _ = _) =>
+            cut (True -> derivable_pt p pt);
+              [ intro HYPPD; cut (derivable_pt p pt);
+                [ intro; clear HYPPD | apply HYPPD; clear HYPPD; trivial ]
+                | idtac ]
+          | _ => idtac
+        end
+  end.
+
+(**********)
+Ltac is_diff_pt :=
+  match goal with
+    |  |- (derivable_pt Rsqr _) =>
+
+  (* fonctions de base *)
+      apply derivable_pt_Rsqr
+    |  |- (derivable_pt id ?X1) => apply (derivable_pt_id X1)
+    |  |- (derivable_pt (fct_cte _) _) => apply derivable_pt_const
+    |  |- (derivable_pt sin _) => apply derivable_pt_sin
+    |  |- (derivable_pt cos _) => apply derivable_pt_cos
+    |  |- (derivable_pt sinh _) => apply derivable_pt_sinh
+    |  |- (derivable_pt cosh _) => apply derivable_pt_cosh
+    |  |- (derivable_pt exp _) => apply derivable_pt_exp
+    |  |- (derivable_pt (pow_fct _) _) =>
+      unfold pow_fct in |- *; apply derivable_pt_pow
+    |  |- (derivable_pt sqrt ?X1) =>
+      apply (derivable_pt_sqrt X1);
+        assumption ||
+          unfold plus_fct, minus_fct, opp_fct, mult_fct, div_fct, inv_fct,
+            comp, id, fct_cte, pow_fct in |- *
+    |  |- (derivable_pt Rabs ?X1) =>
+      apply (Rderivable_pt_abs X1);
+        assumption ||
+          unfold plus_fct, minus_fct, opp_fct, mult_fct, div_fct, inv_fct,
+            comp, id, fct_cte, pow_fct in |- *
+        (* regles de differentiabilite *)
+        (* PLUS *)
+    |  |- (derivable_pt (?X1 + ?X2) ?X3) =>
+      apply (derivable_pt_plus X1 X2 X3); is_diff_pt
+       (* MOINS *)
+    |  |- (derivable_pt (?X1 - ?X2) ?X3) =>
+      apply (derivable_pt_minus X1 X2 X3); is_diff_pt
+       (* OPPOSE *)
+    |  |- (derivable_pt (- ?X1) ?X2) =>
+      apply (derivable_pt_opp X1 X2);
+        is_diff_pt
+       (* MULTIPLICATION PAR UN SCALAIRE *)
+    |  |- (derivable_pt (mult_real_fct ?X1 ?X2) ?X3) =>
+      apply (derivable_pt_scal X2 X1 X3); is_diff_pt
+       (* MULTIPLICATION *)
+    |  |- (derivable_pt (?X1 * ?X2) ?X3) =>
+      apply (derivable_pt_mult X1 X2 X3); is_diff_pt
+       (* DIVISION *)
+    |  |- (derivable_pt (?X1 / ?X2) ?X3) =>
+      apply (derivable_pt_div X1 X2 X3);
+        [ is_diff_pt
+          | is_diff_pt
+          | try
+            assumption ||
+              unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct,
+                comp, pow_fct, id, fct_cte in |- * ]
+    |  |- (derivable_pt (/ ?X1) ?X2) =>
+
+       (* INVERSION *)
+      apply (derivable_pt_inv X1 X2);
+        [ assumption ||
+          unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct,
+            comp, pow_fct, id, fct_cte in |- *
+          | is_diff_pt ]
+    |  |- (derivable_pt (comp ?X1 ?X2) ?X3) =>
+
+       (* COMPOSITION *)
+      apply (derivable_pt_comp X2 X1 X3); is_diff_pt
+    | _:(derivable_pt ?X1 ?X2) |- (derivable_pt ?X1 ?X2) =>
+      assumption
+    | _:(derivable ?X1) |- (derivable_pt ?X1 ?X2) =>
+      cut (derivable X1); [ intro HypDDPT; apply HypDDPT | assumption ]
+    |  |- (True -> derivable_pt _ _) =>
+      intro HypTruE; clear HypTruE; is_diff_pt
+    | _ =>
+      try
+        unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct, id,
+          fct_cte, comp, pow_fct in |- *
+  end.
+
+(**********)
+Ltac is_diff_glob :=
+  match goal with
+    |  |- (derivable Rsqr) =>
+  (* fonctions de base *)
+      apply derivable_Rsqr
+    |  |- (derivable id) => apply derivable_id
+    |  |- (derivable (fct_cte _)) => apply derivable_const
+    |  |- (derivable sin) => apply derivable_sin
+    |  |- (derivable cos) => apply derivable_cos
+    |  |- (derivable cosh) => apply derivable_cosh
+    |  |- (derivable sinh) => apply derivable_sinh
+    |  |- (derivable exp) => apply derivable_exp
+    |  |- (derivable (pow_fct _)) =>
+      unfold pow_fct in |- *;
+        apply derivable_pow
+        (* regles de differentiabilite *)
+        (* PLUS *)
+    |  |- (derivable (?X1 + ?X2)) =>
+      apply (derivable_plus X1 X2); is_diff_glob
+       (* MOINS *)
+    |  |- (derivable (?X1 - ?X2)) =>
+      apply (derivable_minus X1 X2); is_diff_glob
+       (* OPPOSE *)
+    |  |- (derivable (- ?X1)) =>
+      apply (derivable_opp X1);
+        is_diff_glob
+       (* MULTIPLICATION PAR UN SCALAIRE *)
+    |  |- (derivable (mult_real_fct ?X1 ?X2)) =>
+      apply (derivable_scal X2 X1); is_diff_glob
+       (* MULTIPLICATION *)
+    |  |- (derivable (?X1 * ?X2)) =>
+      apply (derivable_mult X1 X2); is_diff_glob
+       (* DIVISION *)
+    |  |- (derivable (?X1 / ?X2)) =>
+      apply (derivable_div X1 X2);
+        [ is_diff_glob
+          | is_diff_glob
+          | try
+            assumption ||
+              unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct,
+                id, fct_cte, comp, pow_fct in |- * ]
+    |  |- (derivable (/ ?X1)) =>
+
+       (* INVERSION *)
+      apply (derivable_inv X1);
+        [ try
+          assumption ||
+            unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct,
+              id, fct_cte, comp, pow_fct in |- *
+          | is_diff_glob ]
+    |  |- (derivable (comp sqrt _)) =>
+
+       (* COMPOSITION *)
+      unfold derivable in |- *; intro; try is_diff_pt
+    |  |- (derivable (comp Rabs _)) =>
+      unfold derivable in |- *; intro; try is_diff_pt
+    |  |- (derivable (comp ?X1 ?X2)) =>
+      apply (derivable_comp X2 X1); is_diff_glob
+    | _:(derivable ?X1) |- (derivable ?X1) => assumption
+    |  |- (True -> derivable _) =>
+      intro HypTruE; clear HypTruE; is_diff_glob
+    | _ =>
+      try
+        unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct, id,
+          fct_cte, comp, pow_fct in |- *
+  end.
+
+(**********)
+Ltac is_cont_pt :=
+  match goal with
+    |  |- (continuity_pt Rsqr _) =>
+
+       (* fonctions de base *)
+      apply derivable_continuous_pt; apply derivable_pt_Rsqr
+    |  |- (continuity_pt id ?X1) =>
+      apply derivable_continuous_pt; apply (derivable_pt_id X1)
+    |  |- (continuity_pt (fct_cte _) _) =>
+      apply derivable_continuous_pt; apply derivable_pt_const
+    |  |- (continuity_pt sin _) =>
+      apply derivable_continuous_pt; apply derivable_pt_sin
+    |  |- (continuity_pt cos _) =>
+      apply derivable_continuous_pt; apply derivable_pt_cos
+    |  |- (continuity_pt sinh _) =>
+      apply derivable_continuous_pt; apply derivable_pt_sinh
+    |  |- (continuity_pt cosh _) =>
+      apply derivable_continuous_pt; apply derivable_pt_cosh
+    |  |- (continuity_pt exp _) =>
+      apply derivable_continuous_pt; apply derivable_pt_exp
+    |  |- (continuity_pt (pow_fct _) _) =>
+      unfold pow_fct in |- *; apply derivable_continuous_pt;
+        apply derivable_pt_pow
+    |  |- (continuity_pt sqrt ?X1) =>
+      apply continuity_pt_sqrt;
+        assumption ||
+          unfold plus_fct, minus_fct, opp_fct, mult_fct, div_fct, inv_fct,
+            comp, id, fct_cte, pow_fct in |- *
+    |  |- (continuity_pt Rabs ?X1) =>
+      apply (Rcontinuity_abs X1)
+       (* regles de differentiabilite *)
+       (* PLUS *)
+    |  |- (continuity_pt (?X1 + ?X2) ?X3) =>
+      apply (continuity_pt_plus X1 X2 X3); is_cont_pt
+       (* MOINS *)
+    |  |- (continuity_pt (?X1 - ?X2) ?X3) =>
+      apply (continuity_pt_minus X1 X2 X3); is_cont_pt
+       (* OPPOSE *)
+    |  |- (continuity_pt (- ?X1) ?X2) =>
+      apply (continuity_pt_opp X1 X2);
+        is_cont_pt
+       (* MULTIPLICATION PAR UN SCALAIRE *)
+    |  |- (continuity_pt (mult_real_fct ?X1 ?X2) ?X3) =>
+      apply (continuity_pt_scal X2 X1 X3); is_cont_pt
+       (* MULTIPLICATION *)
+    |  |- (continuity_pt (?X1 * ?X2) ?X3) =>
+      apply (continuity_pt_mult X1 X2 X3); is_cont_pt
+       (* DIVISION *)
+    |  |- (continuity_pt (?X1 / ?X2) ?X3) =>
+      apply (continuity_pt_div X1 X2 X3);
+        [ is_cont_pt
+          | is_cont_pt
+          | try
+            assumption ||
+              unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct,
+                comp, id, fct_cte, pow_fct in |- * ]
+    |  |- (continuity_pt (/ ?X1) ?X2) =>
+
+       (* INVERSION *)
+      apply (continuity_pt_inv X1 X2);
+        [ is_cont_pt
+          | assumption ||
+            unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct,
+              comp, id, fct_cte, pow_fct in |- * ]
+    |  |- (continuity_pt (comp ?X1 ?X2) ?X3) =>
+
+       (* COMPOSITION *)
+      apply (continuity_pt_comp X2 X1 X3); is_cont_pt
+    | _:(continuity_pt ?X1 ?X2) |- (continuity_pt ?X1 ?X2) =>
+      assumption
+    | _:(continuity ?X1) |- (continuity_pt ?X1 ?X2) =>
+      cut (continuity X1); [ intro HypDDPT; apply HypDDPT | assumption ]
+    | _:(derivable_pt ?X1 ?X2) |- (continuity_pt ?X1 ?X2) =>
+      apply derivable_continuous_pt; assumption
+    | _:(derivable ?X1) |- (continuity_pt ?X1 ?X2) =>
+      cut (continuity X1);
+        [ intro HypDDPT; apply HypDDPT
+          | apply derivable_continuous; assumption ]
+    |  |- (True -> continuity_pt _ _) =>
+      intro HypTruE; clear HypTruE; is_cont_pt
+    | _ =>
+      try
+        unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct, id,
+          fct_cte, comp, pow_fct in |- *
+  end.
+
+(**********)
+Ltac is_cont_glob :=
+  match goal with
+    |  |- (continuity Rsqr) =>
+
+       (* fonctions de base *)
+      apply derivable_continuous; apply derivable_Rsqr
+    |  |- (continuity id) => apply derivable_continuous; apply derivable_id
+    |  |- (continuity (fct_cte _)) =>
+      apply derivable_continuous; apply derivable_const
+    |  |- (continuity sin) => apply derivable_continuous; apply derivable_sin
+    |  |- (continuity cos) => apply derivable_continuous; apply derivable_cos
+    |  |- (continuity exp) => apply derivable_continuous; apply derivable_exp
+    |  |- (continuity (pow_fct _)) =>
+      unfold pow_fct in |- *; apply derivable_continuous; apply derivable_pow
+    |  |- (continuity sinh) =>
+      apply derivable_continuous; apply derivable_sinh
+    |  |- (continuity cosh) =>
+      apply derivable_continuous; apply derivable_cosh
+    |  |- (continuity Rabs) =>
+      apply Rcontinuity_abs
+       (* regles de continuite *)
+       (* PLUS *)
+    |  |- (continuity (?X1 + ?X2)) =>
+      apply (continuity_plus X1 X2);
+        try is_cont_glob || assumption
+            (* MOINS *)
+    |  |- (continuity (?X1 - ?X2)) =>
+      apply (continuity_minus X1 X2);
+        try is_cont_glob || assumption
+            (* OPPOSE *)
+    |  |- (continuity (- ?X1)) =>
+      apply (continuity_opp X1); try is_cont_glob || assumption
+                                      (* INVERSE *)
+    |  |- (continuity (/ ?X1)) =>
+      apply (continuity_inv X1);
+        try is_cont_glob || assumption
+            (* MULTIPLICATION PAR UN SCALAIRE *)
+    |  |- (continuity (mult_real_fct ?X1 ?X2)) =>
+      apply (continuity_scal X2 X1);
+        try is_cont_glob || assumption
+            (* MULTIPLICATION *)
+    |  |- (continuity (?X1 * ?X2)) =>
+      apply (continuity_mult X1 X2);
+        try is_cont_glob || assumption
+            (* DIVISION *)
+    |  |- (continuity (?X1 / ?X2)) =>
+      apply (continuity_div X1 X2);
+        [ try is_cont_glob || assumption
+          | try is_cont_glob || assumption
+          | try
+            assumption ||
+              unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct,
+                id, fct_cte, pow_fct in |- * ]
+    |  |- (continuity (comp sqrt _)) =>
+
+       (* COMPOSITION *)
+      unfold continuity_pt in |- *; intro; try is_cont_pt
+    |  |- (continuity (comp ?X1 ?X2)) =>
+      apply (continuity_comp X2 X1); try is_cont_glob || assumption
+    | _:(continuity ?X1) |- (continuity ?X1) => assumption
+    |  |- (True -> continuity _) =>
+      intro HypTruE; clear HypTruE; is_cont_glob
+    | _:(derivable ?X1) |- (continuity ?X1) =>
+      apply derivable_continuous; assumption
+    | _ =>
+      try
+        unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct, id,
+          fct_cte, comp, pow_fct in |- *
+  end.
+
+(**********)
+Ltac rew_term trm :=
+  match constr:trm with
+    | (?X1 + ?X2) =>
+      let p1 := rew_term X1 with p2 := rew_term X2 in
+        match constr:p1 with
+          | (fct_cte ?X3) =>
+            match constr:p2 with
+              | (fct_cte ?X4) => constr:(fct_cte (X3 + X4))
+              | _ => constr:(p1 + p2)%F
+            end
+          | _ => constr:(p1 + p2)%F
+        end
+    | (?X1 - ?X2) =>
+      let p1 := rew_term X1 with p2 := rew_term X2 in
+        match constr:p1 with
+          | (fct_cte ?X3) =>
+            match constr:p2 with
+              | (fct_cte ?X4) => constr:(fct_cte (X3 - X4))
+              | _ => constr:(p1 - p2)%F
+            end
+          | _ => constr:(p1 - p2)%F
+        end
+    | (?X1 / ?X2) =>
+      let p1 := rew_term X1 with p2 := rew_term X2 in
+        match constr:p1 with
+          | (fct_cte ?X3) =>
+            match constr:p2 with
+              | (fct_cte ?X4) => constr:(fct_cte (X3 / X4))
+              | _ => constr:(p1 / p2)%F
+            end
+          | _ =>
+            match constr:p2 with
+              | (fct_cte ?X4) => constr:(p1 * fct_cte (/ X4))%F
+              | _ => constr:(p1 / p2)%F
+            end
+        end
+    | (?X1 * / ?X2) =>
+      let p1 := rew_term X1 with p2 := rew_term X2 in
+        match constr:p1 with
+          | (fct_cte ?X3) =>
+            match constr:p2 with
+              | (fct_cte ?X4) => constr:(fct_cte (X3 / X4))
+              | _ => constr:(p1 / p2)%F
+            end
+          | _ =>
+            match constr:p2 with
+              | (fct_cte ?X4) => constr:(p1 * fct_cte (/ X4))%F
+              | _ => constr:(p1 / p2)%F
+            end
+        end
+    | (?X1 * ?X2) =>
+      let p1 := rew_term X1 with p2 := rew_term X2 in
+        match constr:p1 with
+          | (fct_cte ?X3) =>
+            match constr:p2 with
+              | (fct_cte ?X4) => constr:(fct_cte (X3 * X4))
+              | _ => constr:(p1 * p2)%F
+            end
+          | _ => constr:(p1 * p2)%F
+        end
+    | (- ?X1) =>
+      let p := rew_term X1 in
+        match constr:p with
+          | (fct_cte ?X2) => constr:(fct_cte (- X2))
+          | _ => constr:(- p)%F
+        end
+    | (/ ?X1) =>
+      let p := rew_term X1 in
+        match constr:p with
+          | (fct_cte ?X2) => constr:(fct_cte (/ X2))
+          | _ => constr:(/ p)%F
+        end
+    | (?X1 AppVar) => constr:X1
+    | (?X1 ?X2) =>
+      let p := rew_term X2 in
+        match constr:p with
+          | (fct_cte ?X3) => constr:(fct_cte (X1 X3))
+          | _ => constr:(comp X1 p)
+        end
+    | AppVar => constr:id
+    | (AppVar ^ ?X1) => constr:(pow_fct X1)
+    | (?X1 ^ ?X2) =>
+      let p := rew_term X1 in
+        match constr:p with
+          | (fct_cte ?X3) => constr:(fct_cte (pow_fct X2 X3))
+          | _ => constr:(comp (pow_fct X2) p)
+        end
+    | ?X1 => constr:(fct_cte X1)
+  end.
+
+(**********)
+Ltac deriv_proof trm pt :=
+  match constr:trm with
+    | (?X1 + ?X2)%F =>
+      let p1 := deriv_proof X1 pt with p2 := deriv_proof X2 pt in
+        constr:(derivable_pt_plus X1 X2 pt p1 p2)
+    | (?X1 - ?X2)%F =>
+      let p1 := deriv_proof X1 pt with p2 := deriv_proof X2 pt in
+        constr:(derivable_pt_minus X1 X2 pt p1 p2)
+    | (?X1 * ?X2)%F =>
+      let p1 := deriv_proof X1 pt with p2 := deriv_proof X2 pt in
+        constr:(derivable_pt_mult X1 X2 pt p1 p2)
+    | (?X1 / ?X2)%F =>
+      match goal with
+        | id:(?X2 pt <> 0) |- _ =>
+          let p1 := deriv_proof X1 pt with p2 := deriv_proof X2 pt in
+            constr:(derivable_pt_div X1 X2 pt p1 p2 id)
+        | _ => constr:False
+      end
+    | (/ ?X1)%F =>
+      match goal with
+        | id:(?X1 pt <> 0) |- _ =>
+          let p1 := deriv_proof X1 pt in
+            constr:(derivable_pt_inv X1 pt p1 id)
+        | _ => constr:False
+      end
+    | (comp ?X1 ?X2) =>
+      let pt_f1 := eval cbv beta in (X2 pt) in
+        let p1 := deriv_proof X1 pt_f1 with p2 := deriv_proof X2 pt in
+          constr:(derivable_pt_comp X2 X1 pt p2 p1)
+    | (- ?X1)%F =>
+      let p1 := deriv_proof X1 pt in
+        constr:(derivable_pt_opp X1 pt p1)
+    | sin => constr:(derivable_pt_sin pt)
+    | cos => constr:(derivable_pt_cos pt)
+    | sinh => constr:(derivable_pt_sinh pt)
+    | cosh => constr:(derivable_pt_cosh pt)
+    | exp => constr:(derivable_pt_exp pt)
+    | id => constr:(derivable_pt_id pt)
+    | Rsqr => constr:(derivable_pt_Rsqr pt)
+    | sqrt =>
+      match goal with
+        | id:(0 < pt) |- _ => constr:(derivable_pt_sqrt pt id)
+        | _ => constr:False
+      end
+    | (fct_cte ?X1) => constr:(derivable_pt_const X1 pt)
+    | ?X1 =>
+      let aux := constr:X1 in
+        match goal with
+          | id:(derivable_pt aux pt) |- _ => constr:id
+          | id:(derivable aux) |- _ => constr:(id pt)
+          | _ => constr:False
+        end
+  end.
+
+(**********)
+Ltac simplify_derive trm pt :=
+  match constr:trm with
+    | (?X1 + ?X2)%F =>
+      try rewrite derive_pt_plus; simplify_derive X1 pt;
+        simplify_derive X2 pt
+    | (?X1 - ?X2)%F =>
+      try rewrite derive_pt_minus; simplify_derive X1 pt;
+        simplify_derive X2 pt
+    | (?X1 * ?X2)%F =>
+      try rewrite derive_pt_mult; simplify_derive X1 pt;
+        simplify_derive X2 pt
+    | (?X1 / ?X2)%F =>
+      try rewrite derive_pt_div; simplify_derive X1 pt; simplify_derive X2 pt
+    | (comp ?X1 ?X2) =>
+      let pt_f1 := eval cbv beta in (X2 pt) in
+        (try rewrite derive_pt_comp; simplify_derive X1 pt_f1;
+          simplify_derive X2 pt)
+    | (- ?X1)%F => try rewrite derive_pt_opp; simplify_derive X1 pt
+    | (/ ?X1)%F =>
+      try rewrite derive_pt_inv; simplify_derive X1 pt
+    | (fct_cte ?X1) => try rewrite derive_pt_const
+    | id => try rewrite derive_pt_id
+    | sin => try rewrite derive_pt_sin
+    | cos => try rewrite derive_pt_cos
+    | sinh => try rewrite derive_pt_sinh
+    | cosh => try rewrite derive_pt_cosh
+    | exp => try rewrite derive_pt_exp
+    | Rsqr => try rewrite derive_pt_Rsqr
+    | sqrt => try rewrite derive_pt_sqrt
+    | ?X1 =>
+      let aux := constr:X1 in
+        match goal with
+          | id:(derive_pt aux pt ?X2 = _),H:(derivable aux) |- _ =>
+            try replace (derive_pt aux pt (H pt)) with (derive_pt aux pt X2);
+              [ rewrite id | apply pr_nu ]
+          | id:(derive_pt aux pt ?X2 = _),H:(derivable_pt aux pt) |- _ =>
+            try replace (derive_pt aux pt H) with (derive_pt aux pt X2);
+              [ rewrite id | apply pr_nu ]
+          | _ => idtac
+        end
+    | _ => idtac
+  end.
+
+(**********)
+Ltac reg :=
+  match goal with
+    |  |- (derivable_pt ?X1 ?X2) =>
+      let trm := eval cbv beta in (X1 AppVar) in
+        let aux := rew_term trm in
+          (intro_hyp_pt aux X2;
+            try (change (derivable_pt aux X2) in |- *; is_diff_pt) || is_diff_pt)
+    |  |- (derivable ?X1) =>
+      let trm := eval cbv beta in (X1 AppVar) in
+        let aux := rew_term trm in
+          (intro_hyp_glob aux;
+            try (change (derivable aux) in |- *; is_diff_glob) || is_diff_glob)
+    |  |- (continuity ?X1) =>
+      let trm := eval cbv beta in (X1 AppVar) in
+        let aux := rew_term trm in
+          (intro_hyp_glob aux;
+            try (change (continuity aux) in |- *; is_cont_glob) || is_cont_glob)
+    |  |- (continuity_pt ?X1 ?X2) =>
+      let trm := eval cbv beta in (X1 AppVar) in
+        let aux := rew_term trm in
+          (intro_hyp_pt aux X2;
+            try (change (continuity_pt aux X2) in |- *; is_cont_pt) || is_cont_pt)
+    |  |- (derive_pt ?X1 ?X2 ?X3 = ?X4) =>
+      let trm := eval cbv beta in (X1 AppVar) in
+      let aux := rew_term trm in
+      intro_hyp_pt aux X2;
+      (let aux2 := deriv_proof aux X2 in
+       try
+         (replace (derive_pt X1 X2 X3) with (derive_pt aux X2 aux2);
+           [ simplify_derive aux X2;
+             try unfold plus_fct, minus_fct, mult_fct, div_fct, id, fct_cte,
+                        inv_fct, opp_fct in |- *; ring || ring_simplify
+           | try apply pr_nu ]) || is_diff_pt)
+  end.
diff --git a/theories/Reals/Ratan.v b/theories/Reals/Ratan.v
new file mode 100644
index 00000000..1a0ea969
--- /dev/null
+++ b/theories/Reals/Ratan.v
@@ -0,0 +1,1602 @@
+Require Import Fourier.
+Require Import Rbase.
+Require Import PSeries_reg.
+Require Import Rtrigo1.
+Require Import Ranalysis_reg.
+Require Import Rfunctions.
+Require Import AltSeries.
+Require Import Rseries.
+Require Import SeqProp.
+Require Import Ranalysis5.
+Require Import SeqSeries.
+Require Import PartSum.
+
+Local Open Scope R_scope.
+
+(** Tools *)
+
+Lemma Ropp_div : forall x y, -x/y = -(x/y).
+Proof.
+intros x y; unfold Rdiv; rewrite <-Ropp_mult_distr_l_reverse; reflexivity.
+Qed.
+
+Definition pos_half_prf : 0 < /2.
+Proof. fourier. Qed.
+
+Definition pos_half := mkposreal (/2) pos_half_prf.
+
+Lemma Boule_half_to_interval :
+  forall x , Boule (/2) pos_half x -> 0 <= x <= 1.
+Proof.
+unfold Boule, pos_half; simpl.
+intros x b; apply Rabs_def2 in b; destruct b; split; fourier.
+Qed.
+
+Lemma Boule_lt : forall c r x, Boule c r x -> Rabs x < Rabs c + r.
+Proof.
+unfold Boule; intros c r x h.
+apply Rabs_def2 in h; destruct h; apply Rabs_def1;
+ (destruct (Rle_lt_dec 0 c);[rewrite Rabs_pos_eq; fourier | 
+    rewrite <- Rabs_Ropp, Rabs_pos_eq; fourier]).
+Qed.
+
+(* The following lemma does not belong here. *)
+Lemma Un_cv_ext :
+  forall un vn, (forall n, un n = vn n) ->
+  forall l, Un_cv un l -> Un_cv vn l.
+Proof.
+intros un vn quv l P eps ep; destruct (P eps ep) as [N Pn]; exists N.
+intro n; rewrite <- quv; apply Pn.
+Qed.
+
+(* The following two lemmas are general purposes about alternated series.
+  They do not belong here. *)
+Lemma Alt_first_term_bound :forall f l N n,
+   Un_decreasing f -> Un_cv f 0 ->
+   Un_cv (sum_f_R0 (tg_alt f)) l ->
+   (N <= n)%nat ->
+   R_dist (sum_f_R0 (tg_alt f) n) l <= f N.
+Proof.
+intros f l.
+assert (WLOG :
+   forall n P, (forall k, (0 < k)%nat -> P k) ->
+         ((forall k, (0 < k)%nat -> P k) -> P 0%nat) -> P n).
+clear.
+intros [ | n] P Hs Ho;[solve[apply Ho, Hs] | apply Hs; auto with arith].
+intros N; pattern N; apply WLOG; clear N.
+intros [ | N] Npos n decr to0 cv nN.
+  clear -Npos; elimtype False; omega.
+ assert (decr' : Un_decreasing (fun i => f (S N + i)%nat)).
+  intros k; replace (S N+S k)%nat with (S (S N+k)) by ring.
+  apply (decr (S N + k)%nat).
+ assert (to' : Un_cv (fun i => f (S N + i)%nat) 0).
+  intros eps ep; destruct (to0 eps ep) as [M PM].
+  exists M; intros k kM; apply PM; omega.
+ assert (cv' : Un_cv
+         (sum_f_R0 (tg_alt (fun i => ((-1) ^ S N * f(S N + i)%nat))))
+             (l - sum_f_R0 (tg_alt f) N)).
+  intros eps ep; destruct (cv eps ep) as [M PM]; exists M.
+  intros n' nM. 
+  match goal with |- ?C => set (U := C) end.
+  assert (nM' : (n' + S N >= M)%nat) by omega.
+   generalize (PM _ nM'); unfold R_dist.
+  rewrite (tech2 (tg_alt f) N (n' + S N)).
+  assert (t : forall a b c, (a + b) - c = b - (c - a)) by (intros; ring).
+  rewrite t; clear t; unfold U, R_dist; clear U.
+  replace (n' + S N - S N)%nat with n' by omega.
+  rewrite <- (sum_eq (tg_alt (fun i => (-1) ^ S N * f(S N + i)%nat))).
+   tauto.
+   intros i _; unfold tg_alt.
+   rewrite <- Rmult_assoc, <- pow_add, !(plus_comm i); reflexivity.
+  omega.
+  assert (cv'' : Un_cv (sum_f_R0 (tg_alt (fun i => f (S N + i)%nat)))
+                   ((-1) ^ S N * (l - sum_f_R0 (tg_alt f) N))).
+  apply (Un_cv_ext (fun n => (-1) ^ S N * 
+            sum_f_R0 (tg_alt (fun i : nat => (-1) ^ S N * f (S N + i)%nat)) n)).
+   intros n0; rewrite scal_sum; apply sum_eq; intros i _.
+   unfold tg_alt; ring_simplify; replace (((-1) ^ S N) ^ 2) with 1.
+    ring.
+   rewrite <- pow_mult, mult_comm, pow_mult; replace ((-1) ^2) with 1 by ring.
+   rewrite pow1; reflexivity.
+  apply CV_mult.
+   solve[intros eps ep; exists 0%nat; intros; rewrite R_dist_eq; auto].
+  assumption.
+ destruct (even_odd_cor N) as [p [Neven | Nodd]].
+  rewrite Neven; destruct (alternated_series_ineq _ _ p decr to0 cv) as [B C].
+  case (even_odd_cor n) as [p' [neven | nodd]].
+   rewrite neven.
+   destruct (alternated_series_ineq _ _ p' decr to0 cv) as [D E].
+   unfold R_dist; rewrite Rabs_pos_eq;[ | fourier].
+   assert (dist : (p <= p')%nat) by omega.
+   assert (t := decreasing_prop _ _ _ (CV_ALT_step1 f decr) dist).
+   apply Rle_trans with (sum_f_R0 (tg_alt f) (2 * p) - l).
+    unfold Rminus; apply Rplus_le_compat_r; exact t.
+   match goal with _ : ?a <= l, _ : l <= ?b |- _ => 
+    replace (f (S (2 * p))) with (b - a) by
+     (rewrite tech5; unfold tg_alt; rewrite pow_1_odd; ring); fourier
+   end.
+  rewrite nodd; destruct (alternated_series_ineq _ _ p' decr to0 cv) as [D E].
+   unfold R_dist; rewrite <- Rabs_Ropp, Rabs_pos_eq, Ropp_minus_distr;
+     [ | fourier].
+   assert (dist : (p <= p')%nat) by omega.
+   apply Rle_trans with (l - sum_f_R0 (tg_alt f) (S (2 * p))).
+    unfold Rminus; apply Rplus_le_compat_l, Ropp_le_contravar.
+    solve[apply Rge_le, (growing_prop _ _ _ (CV_ALT_step0 f decr) dist)].
+   unfold Rminus; rewrite tech5, Ropp_plus_distr, <- Rplus_assoc.
+   unfold tg_alt at 2; rewrite pow_1_odd, Ropp_mult_distr_l_reverse; fourier.
+ rewrite Nodd; destruct (alternated_series_ineq _ _ p decr to0 cv) as [B _].
+ destruct (alternated_series_ineq _ _ (S p) decr to0 cv) as [_ C].
+ assert (keep : (2 * S p = S (S ( 2 * p)))%nat) by ring.
+ case (even_odd_cor n) as [p' [neven | nodd]].
+   rewrite neven;
+   destruct (alternated_series_ineq _ _ p' decr to0 cv) as [D E].
+   unfold R_dist; rewrite Rabs_pos_eq;[ | fourier].
+   assert (dist : (S p < S p')%nat) by omega.
+   apply Rle_trans with (sum_f_R0 (tg_alt f) (2 * S p) - l).
+   unfold Rminus; apply Rplus_le_compat_r,
+     (decreasing_prop _ _ _ (CV_ALT_step1 f decr)).
+   omega.
+  rewrite keep, tech5; unfold tg_alt at 2; rewrite <- keep, pow_1_even.
+  fourier.
+ rewrite nodd; destruct (alternated_series_ineq _ _ p' decr to0 cv) as [D E].
+ unfold R_dist; rewrite <- Rabs_Ropp, Rabs_pos_eq;[ | fourier].
+ rewrite Ropp_minus_distr.
+ apply Rle_trans with (l - sum_f_R0 (tg_alt f) (S (2 * p))).
+  unfold Rminus; apply Rplus_le_compat_l, Ropp_le_contravar, Rge_le,
+   (growing_prop _ _ _ (CV_ALT_step0 f decr)); omega.
+ generalize C; rewrite keep, tech5; unfold tg_alt.
+ rewrite <- keep, pow_1_even.
+ assert (t : forall a b c, a <= b + 1 * c -> a - b <= c) by (intros; fourier).
+ solve[apply t].
+clear WLOG; intros Hyp [ | n] decr to0 cv _.
+ generalize (alternated_series_ineq f l 0 decr to0 cv).
+ unfold R_dist, tg_alt; simpl; rewrite !Rmult_1_l, !Rmult_1_r.
+ assert (f 1%nat <= f 0%nat) by apply decr.
+ rewrite Ropp_mult_distr_l_reverse.
+ intros [A B]; rewrite Rabs_pos_eq; fourier.
+apply Rle_trans with (f 1%nat).
+ apply (Hyp 1%nat (le_n 1) (S n) decr to0 cv).
+ omega.
+solve[apply decr].
+Qed.
+
+Lemma Alt_CVU : forall (f : nat -> R -> R) g h c r,
+   (forall x, Boule c r x ->Un_decreasing (fun n => f n x)) -> 
+   (forall x, Boule c r x -> Un_cv (fun n => f n x) 0) ->
+   (forall x, Boule c r x -> 
+       Un_cv (sum_f_R0 (tg_alt  (fun i => f i x))) (g x)) ->
+   (forall x n, Boule c r x -> f n x <= h n) ->
+   (Un_cv h 0) ->
+   CVU (fun N x => sum_f_R0 (tg_alt (fun i => f i x)) N) g c r.
+Proof.
+intros f g h c r decr to0 to_g bound bound0 eps ep.  
+assert (ep' : 0 <eps/2) by fourier.
+destruct (bound0 _ ep) as [N Pn]; exists N.
+intros n y nN dy.
+rewrite <- Rabs_Ropp, Ropp_minus_distr; apply Rle_lt_trans with (f n y).
+ solve[apply (Alt_first_term_bound (fun i => f i y) (g y) n n); auto].
+apply Rle_lt_trans with (h n).
+ apply bound; assumption.
+clear - nN Pn.
+generalize (Pn _ nN); unfold R_dist; rewrite Rminus_0_r; intros t.
+apply Rabs_def2 in t; tauto.
+Qed.
+
+(* The following lemmas are general purpose lemmas about squares. 
+  They do not belong here *)
+
+Lemma pow2_ge_0 : forall x, 0 <= x ^ 2.
+Proof.
+intros x; destruct (Rle_lt_dec 0 x).
+ replace (x ^ 2) with (x * x) by field.
+ apply Rmult_le_pos; assumption.
+ replace (x ^ 2) with ((-x) * (-x)) by field.
+apply Rmult_le_pos; fourier.
+Qed.
+
+Lemma pow2_abs : forall x,  Rabs x ^ 2 = x ^ 2.
+Proof.
+intros x; destruct (Rle_lt_dec 0 x).
+ rewrite Rabs_pos_eq;[field | assumption].
+rewrite <- Rabs_Ropp, Rabs_pos_eq;[field | fourier].
+Qed.
+
+(** * Properties of tangent *)
+
+Lemma derivable_pt_tan : forall x, -PI/2 < x < PI/2 -> derivable_pt tan x.
+Proof.
+intros x xint.
+ unfold derivable_pt, tan. 
+ apply derivable_pt_div ; [reg | reg | ].
+ apply Rgt_not_eq.
+ unfold Rgt ; apply cos_gt_0;
+  [unfold Rdiv; rewrite <- Ropp_mult_distr_l_reverse; fold (-PI/2) |];tauto.
+Qed.
+
+Lemma derive_pt_tan : forall (x:R),
+ forall (Pr1: -PI/2 < x < PI/2),
+ derive_pt tan x (derivable_pt_tan x Pr1) = 1 + (tan x)^2.
+Proof.
+intros x pr.
+assert (cos x <> 0).
+ apply Rgt_not_eq, cos_gt_0; rewrite <- ?Ropp_div; tauto.
+unfold tan; reg; unfold pow, Rsqr; field; assumption.
+Qed.
+
+(** Proof that tangent is a bijection *)
+(* to be removed? *)
+
+Lemma derive_increasing_interv :
+  forall (a b:R) (f:R -> R),
+    a < b ->
+    forall (pr:forall x, a < x < b -> derivable_pt f x),
+    (forall t:R, forall (t_encad : a < t < b), 0 < derive_pt f t (pr t t_encad)) ->
+    forall x y:R, a < x < b -> a < y < b -> x < y -> f x < f y.
+Proof.
+intros a b f a_lt_b pr Df_gt_0 x y x_encad y_encad x_lt_y.
+ assert (derivable_id_interv : forall c : R, x < c < y -> derivable_pt id c).
+  intros ; apply derivable_pt_id.
+ assert (derivable_f_interv :  forall c : R, x < c < y -> derivable_pt f c).
+  intros c c_encad. apply pr. split.
+  apply Rlt_trans with (r2:=x) ; [exact (proj1 x_encad) | exact (proj1 c_encad)].
+  apply Rlt_trans with (r2:=y) ; [exact (proj2 c_encad) | exact (proj2 y_encad)].
+ assert (f_cont_interv : forall c : R, x <= c <= y -> continuity_pt f c).
+  intros c c_encad; apply derivable_continuous_pt ; apply pr. split.
+  apply Rlt_le_trans with (r2:=x) ; [exact (proj1 x_encad) | exact (proj1 c_encad)].
+  apply Rle_lt_trans with (r2:=y) ; [ exact (proj2 c_encad) | exact (proj2 y_encad)].
+ assert (id_cont_interv : forall c : R, x <= c <= y -> continuity_pt id c).
+  intros ; apply derivable_continuous_pt ; apply derivable_pt_id. 
+ elim (MVT f id x y derivable_f_interv derivable_id_interv x_lt_y f_cont_interv id_cont_interv).
+  intros c Temp ; elim Temp ; clear Temp ; intros Pr eq.
+   replace (id y - id x) with (y - x) in eq by intuition.
+   replace (derive_pt id c (derivable_id_interv c Pr)) with 1 in eq.
+   assert (Hyp : f y - f x > 0).
+    rewrite Rmult_1_r in eq. rewrite <- eq.
+    apply Rmult_gt_0_compat.
+    apply Rgt_minus ; assumption.
+    assert (c_encad2 : a <= c < b).
+     split.
+     apply Rlt_le ; apply Rlt_trans with (r2:=x) ; [exact (proj1 x_encad) | exact (proj1 Pr)].
+     apply Rle_lt_trans with (r2:=y) ; [apply Rlt_le ; exact (proj2 Pr) | exact (proj2 y_encad)].
+     assert (c_encad : a < c < b).
+      split.
+      apply Rlt_trans with (r2:=x) ; [exact (proj1 x_encad) | exact (proj1 Pr)].
+      apply Rle_lt_trans with (r2:=y) ; [apply Rlt_le ; exact (proj2 Pr) | exact (proj2 y_encad)].
+     assert (Temp := Df_gt_0 c c_encad).
+     assert (Temp2 := pr_nu f c (derivable_f_interv c Pr) (pr c c_encad)).
+     rewrite Temp2 ; apply Temp.
+   apply Rminus_gt ; exact Hyp.
+   symmetry ; rewrite derive_pt_eq ; apply derivable_pt_lim_id.
+Qed.
+
+(* begin hide *)
+Lemma plus_Rsqr_gt_0 : forall x, 1 + x ^ 2 > 0.
+Proof.
+intro m. replace 0 with (0+0) by intuition.
+ apply Rplus_gt_ge_compat. intuition.
+ elim (total_order_T m 0) ; intro s'. case s'.
+ intros m_cond. replace 0 with (0*0) by intuition.
+  replace (m ^ 2) with ((-m)^2).
+  apply Rle_ge ; apply Rmult_le_compat ; intuition ; apply Rlt_le ; rewrite Rmult_1_r ; intuition.
+  field.
+  intro H' ; rewrite H' ; right ; field.
+   left. intuition.
+Qed.
+(* end hide *)
+
+(* The following lemmas about PI should probably be in Rtrigo. *)
+
+Lemma PI2_lower_bound :
+  forall x, 0 < x < 2 -> 0 < cos x  -> x < PI/2.
+Proof.
+intros x [xp xlt2] cx.
+destruct (Rtotal_order x (PI/2)) as [xltpi2 | [xeqpi2 | xgtpi2]].
+  assumption.
+ now case (Rgt_not_eq _ _ cx); rewrite xeqpi2, cos_PI2.
+destruct (MVT_cor1 cos (PI/2) x derivable_cos xgtpi2) as
+   [c [Pc [cint1 cint2]]].
+revert Pc; rewrite cos_PI2, Rminus_0_r. 
+rewrite <- (pr_nu cos c (derivable_pt_cos c)), derive_pt_cos.
+assert (0 < c < 2) by (split; assert (t := PI2_RGT_0); fourier).
+assert (0 < sin c) by now apply sin_pos_tech.
+intros Pc.
+case (Rlt_not_le _ _ cx).
+rewrite <- (Rplus_0_l (cos x)), Pc, Ropp_mult_distr_l_reverse.
+apply Rle_minus, Rmult_le_pos;[apply Rlt_le; assumption | fourier ].
+Qed.
+
+Lemma PI2_3_2 : 3/2 < PI/2.
+Proof.
+apply PI2_lower_bound;[split; fourier | ].
+destruct (pre_cos_bound (3/2) 1) as [t _]; [fourier | fourier | ].
+apply Rlt_le_trans with (2 := t); clear t.
+unfold cos_approx; simpl; unfold cos_term.
+simpl mult; replace ((-1)^ 0) with 1 by ring; replace ((-1)^2) with 1 by ring;
+ replace ((-1)^4) with 1 by ring; replace ((-1)^1) with (-1) by ring;
+ replace ((-1)^3) with (-1) by ring; replace 3 with (IZR 3) by (simpl; ring);
+ replace 2 with (IZR 2) by (simpl; ring); simpl Z.of_nat;
+ rewrite !INR_IZR_INZ, Ropp_mult_distr_l_reverse, Rmult_1_l.
+match goal with |- _ < ?a =>
+replace a with ((- IZR 3 ^ 6 * IZR (Z.of_nat (fact 0)) * IZR (Z.of_nat (fact 2)) *
+    IZR (Z.of_nat (fact 4)) +
+    IZR 3 ^ 4 * IZR 2 ^ 2 * IZR (Z.of_nat (fact 0)) * IZR (Z.of_nat (fact 2)) *
+    IZR (Z.of_nat (fact 6)) -
+    IZR 3 ^ 2 * IZR 2 ^ 4 * IZR (Z.of_nat (fact 0)) * IZR (Z.of_nat (fact 4)) *
+    IZR (Z.of_nat (fact 6)) +
+    IZR 2 ^ 6 * IZR (Z.of_nat (fact 2)) * IZR (Z.of_nat (fact 4)) *
+    IZR (Z.of_nat (fact 6))) /
+   (IZR 2 ^ 6 * IZR (Z.of_nat (fact 0)) * IZR (Z.of_nat (fact 2)) *
+    IZR (Z.of_nat (fact 4)) * IZR (Z.of_nat (fact 6))));[ | field;
+    repeat apply conj;((rewrite <- INR_IZR_INZ; apply INR_fact_neq_0) ||
+         (apply Rgt_not_eq; apply (IZR_lt 0); reflexivity)) ]
+end.
+rewrite !fact_simpl, !Nat2Z.inj_mul; simpl Z.of_nat.
+unfold Rdiv; apply Rmult_lt_0_compat.
+unfold Rminus; rewrite !pow_IZR, <- !opp_IZR, <- !mult_IZR, <- !opp_IZR, 
+  <- !plus_IZR; apply (IZR_lt 0); reflexivity.
+apply Rinv_0_lt_compat; rewrite !pow_IZR, <- !mult_IZR; apply (IZR_lt 0).
+reflexivity.
+Qed.
+
+Lemma PI2_1 : 1 < PI/2.
+Proof. assert (t := PI2_3_2); fourier. Qed.
+
+Lemma tan_increasing :
+  forall x y:R,
+    -PI/2 < x ->
+    x < y -> 
+    y < PI/2 -> tan x < tan y.
+Proof.
+intros x y Z_le_x x_lt_y y_le_1.
+ assert (x_encad : -PI/2 < x < PI/2).
+  split ; [assumption | apply Rlt_trans with (r2:=y) ; assumption].
+ assert (y_encad : -PI/2 < y < PI/2).
+  split ; [apply Rlt_trans with (r2:=x) ; intuition | intuition ].
+ assert (local_derivable_pt_tan : forall x : R, -PI/2 < x < PI/2 ->
+          derivable_pt tan x).
+  intros ; apply derivable_pt_tan ; intuition.
+ apply derive_increasing_interv with (a:=-PI/2) (b:=PI/2) (pr:=local_derivable_pt_tan) ; intuition.
+ fourier.
+ assert (Temp := pr_nu tan t (derivable_pt_tan t t_encad) (local_derivable_pt_tan t t_encad)) ;
+ rewrite <- Temp ; clear Temp.
+ assert (Temp := derive_pt_tan t t_encad) ; rewrite Temp ; clear Temp.
+ apply plus_Rsqr_gt_0.
+Qed.
+
+Lemma tan_is_inj : forall x y, -PI/2 < x < PI/2 -> -PI/2 < y < PI/2 ->
+   tan x = tan y -> x = y.
+Proof.
+  intros a b a_encad b_encad fa_eq_fb.
+  case(total_order_T a b).
+  intro s ; case s ; clear s.
+  intro Hf.
+  assert (Hfalse := tan_increasing a b (proj1 a_encad) Hf (proj2 b_encad)).
+  case (Rlt_not_eq (tan a) (tan b)) ; assumption.
+  intuition.
+  intro Hf. assert (Hfalse := tan_increasing b a (proj1 b_encad) Hf (proj2 a_encad)).
+  case (Rlt_not_eq (tan b) (tan a)) ; [|symmetry] ; assumption.
+Qed.
+
+Lemma exists_atan_in_frame :
+ forall lb ub y, lb < ub -> -PI/2 < lb -> ub < PI/2 ->
+ tan lb < y < tan ub -> {x | lb < x < ub /\ tan x = y}.
+Proof.
+intros lb ub y lb_lt_ub lb_cond ub_cond y_encad.
+ case y_encad ; intros y_encad1 y_encad2.
+     assert (f_cont : forall a : R, lb <= a <= ub -> continuity_pt tan a).
+      intros a a_encad. apply derivable_continuous_pt ; apply derivable_pt_tan.
+      split. apply Rlt_le_trans with (r2:=lb) ; intuition.
+      apply Rle_lt_trans with (r2:=ub) ; intuition.
+     assert (Cont : forall a : R, lb <= a <= ub -> continuity_pt (fun x => tan x - y) a).
+      intros a a_encad. unfold continuity_pt, continue_in, limit1_in, limit_in ; simpl ; unfold R_dist.
+      intros eps eps_pos. elim (f_cont a a_encad eps eps_pos).
+      intros alpha alpha_pos. destruct alpha_pos as (alpha_pos,Temp).
+      exists alpha. split.
+      assumption. intros x  x_cond.
+      replace (tan x - y - (tan a - y)) with (tan x - tan a) by field.
+      exact (Temp x x_cond).
+     assert (H1 : (fun x : R => tan x - y) lb < 0).
+       apply Rlt_minus. assumption.
+      assert (H2 : 0 < (fun x : R => tan x - y) ub).
+       apply Rgt_minus. assumption.
+     destruct (IVT_interv (fun x => tan x - y) lb ub Cont lb_lt_ub H1 H2) as (x,Hx).
+     exists x.
+     destruct Hx as (Hyp,Result).
+     intuition.
+     assert (Temp2 : x <> lb).
+      intro Hfalse. rewrite Hfalse in Result.
+      assert (Temp2 : y <> tan lb).
+       apply Rgt_not_eq ; assumption.
+      clear - Temp2 Result. apply Temp2.
+      intuition.
+     clear -Temp2 H3.
+      case H3 ; intuition. apply False_ind ; apply Temp2 ; symmetry ; assumption.
+      assert (Temp : x <> ub).
+      intro Hfalse. rewrite Hfalse in Result.
+      assert (Temp2 : y <> tan ub).
+       apply Rlt_not_eq ; assumption.
+      clear - Temp2 Result. apply Temp2.
+      intuition.
+      case H4 ; intuition.
+Qed.
+
+(** * Definition of arctangent as the reciprocal function of tangent and proof of this status *)
+Lemma tan_1_gt_1 : tan 1 > 1.
+Proof.
+assert (0 < cos 1) by (apply cos_gt_0; assert (t:=PI2_1); fourier).
+assert (t1 : cos 1 <= 1 - 1/2 + 1/24).
+ destruct (pre_cos_bound 1 0) as [_ t]; try fourier; revert t.
+ unfold cos_approx, cos_term; simpl; intros t; apply Rle_trans with (1:=t).
+ clear t; apply Req_le; field.
+assert (t2 : 1 - 1/6 <= sin 1).
+ destruct (pre_sin_bound 1 0) as [t _]; try fourier; revert t.
+ unfold sin_approx, sin_term; simpl; intros t; apply Rle_trans with (2:=t).
+ clear t; apply Req_le; field.
+pattern 1 at 2; replace 1 with
+  (cos 1 / cos 1) by (field; apply Rgt_not_eq; fourier).
+apply Rlt_gt; apply (Rmult_lt_compat_r (/ cos 1) (cos 1) (sin 1)).
+ apply Rinv_0_lt_compat; assumption.
+apply Rle_lt_trans with (1 := t1); apply Rlt_le_trans with (2 := t2).
+fourier.
+Qed.
+
+Definition frame_tan y : {x | 0 < x < PI/2 /\ Rabs y < tan x}.
+destruct (total_order_T (Rabs y) 1).
+ assert (yle1 : Rabs y <= 1) by (destruct s; fourier).
+ clear s; exists 1; split;[split; [exact Rlt_0_1 | exact PI2_1] | ].
+ apply Rle_lt_trans with (1 := yle1); exact tan_1_gt_1.
+assert (0 < / (Rabs y + 1)).
+ apply Rinv_0_lt_compat; fourier.
+set (u := /2 * / (Rabs y + 1)).
+assert (0 < u).
+ apply Rmult_lt_0_compat; [fourier | assumption].
+assert (vlt1 : / (Rabs y + 1) < 1).
+ apply Rmult_lt_reg_r with (Rabs y + 1).
+  assert (t := Rabs_pos y); fourier.
+ rewrite Rinv_l; [rewrite Rmult_1_l | apply Rgt_not_eq]; fourier.
+assert (vlt2 : u < 1).
+ apply Rlt_trans with (/ (Rabs y + 1)).
+  rewrite double_var.
+  assert (t : forall x, 0 < x -> x < x + x) by (clear; intros; fourier).
+  unfold u; rewrite Rmult_comm; apply t.
+  unfold Rdiv; rewrite Rmult_comm; assumption.
+ assumption.
+assert(int : 0 < PI / 2 - u < PI / 2).
+ split.
+  assert (t := PI2_1); apply Rlt_Rminus, Rlt_trans with (2 := t); assumption.
+ assert (dumb : forall x y, 0 < y -> x - y < x) by (clear; intros; fourier).
+ apply dumb; clear dumb; assumption.
+exists (PI/2 - u).
+assert (tmp : forall x y, 0 < x -> y < 1 -> x * y < x).
+ clear; intros x y x0 y1; pattern x at 2; rewrite <- (Rmult_1_r x).
+ apply Rmult_lt_compat_l; assumption.
+assert (0 < sin u).
+ apply sin_gt_0;[ assumption | ].
+ assert (t := PI2_Rlt_PI); assert (t' := PI2_1).
+ apply Rlt_trans with (2 := Rlt_trans _ _ _ t' t); assumption.
+split.
+ assumption.
+ apply Rlt_trans with (/2 * / cos(PI / 2 - u)).
+ rewrite cos_shift.
+ assert (sin u < u).
+  assert (t1 : 0 <= u) by (apply Rlt_le; assumption).
+  assert (t2 : u <= 4) by
+   (apply Rle_trans with 1;[apply Rlt_le | fourier]; assumption).
+  destruct (pre_sin_bound u 0 t1 t2) as [_ t].
+  apply Rle_lt_trans with (1 := t); clear t1 t2 t.
+  unfold sin_approx; simpl; unfold sin_term; simpl ((-1) ^ 0);
+  replace ((-1) ^ 2) with 1 by ring; simpl ((-1) ^ 1);
+  rewrite !Rmult_1_r, !Rmult_1_l; simpl plus; simpl (INR (fact 1)).
+  rewrite <- (fun x => tech_pow_Rmult x 0), <- (fun x => tech_pow_Rmult x 2),
+    <- (fun x => tech_pow_Rmult x 4).
+  rewrite (Rmult_comm (-1)); simpl ((/(Rabs y + 1)) ^ 0).
+  unfold Rdiv; rewrite Rinv_1, !Rmult_assoc, <- !Rmult_plus_distr_l.
+  apply tmp;[assumption | ].
+  rewrite Rplus_assoc, Rmult_1_l; pattern 1 at 3; rewrite <- Rplus_0_r.
+  apply Rplus_lt_compat_l.
+  rewrite <- Rmult_assoc.
+  match goal with |- (?a * (-1)) + _ < 0 =>
+   rewrite <- (Rplus_opp_l a), Ropp_mult_distr_r_reverse, Rmult_1_r
+  end.
+  apply Rplus_lt_compat_l.
+  assert (0 < u ^ 2) by (apply pow_lt; assumption).
+  replace (u ^ 4) with (u ^ 2 * u ^ 2) by ring.
+ rewrite Rmult_assoc; apply Rmult_lt_compat_l; auto.
+  apply Rlt_trans with (u ^ 2 * /INR (fact 3)).
+   apply Rmult_lt_compat_l; auto.
+   apply Rinv_lt_contravar.
+    solve[apply Rmult_lt_0_compat; apply INR_fact_lt_0].
+   rewrite !INR_IZR_INZ; apply IZR_lt; reflexivity.
+  rewrite Rmult_comm; apply tmp.
+   solve[apply Rinv_0_lt_compat, INR_fact_lt_0].
+  apply Rlt_trans with (2 := vlt2).
+  simpl; unfold u; apply tmp; auto; rewrite Rmult_1_r; assumption.
+ apply Rlt_trans with (Rabs y + 1);[fourier | ]. 
+ pattern (Rabs y + 1) at 1; rewrite <- (Rinv_involutive (Rabs y + 1));
+  [ | apply Rgt_not_eq; fourier].
+ rewrite <- Rinv_mult_distr.
+   apply Rinv_lt_contravar.
+    apply Rmult_lt_0_compat.
+     apply Rmult_lt_0_compat;[fourier | assumption].
+    assumption.
+   replace (/(Rabs y + 1)) with (2 * u).
+    fourier.
+   unfold u; field; apply Rgt_not_eq; clear -r; fourier.
+  solve[discrR].
+ apply Rgt_not_eq; assumption.
+unfold tan.
+set (u' := PI / 2); unfold Rdiv; apply Rmult_lt_compat_r; unfold u'.
+ apply Rinv_0_lt_compat. 
+ rewrite cos_shift; assumption.
+assert (vlt3 : u < /4).
+ replace (/4) with (/2 * /2) by field.
+ unfold u; apply Rmult_lt_compat_l;[fourier | ].
+ apply Rinv_lt_contravar.
+  apply Rmult_lt_0_compat; fourier.
+ fourier.
+assert (1 < PI / 2 - u) by (assert (t := PI2_3_2); fourier).
+apply Rlt_trans with (sin 1).
+ assert (t' : 1 <= 4) by fourier.
+ destruct (pre_sin_bound 1 0 (Rlt_le _ _ Rlt_0_1) t') as [t _].
+ apply Rlt_le_trans with (2 := t); clear t.
+ simpl plus; replace (sin_approx 1 1) with (5/6);[fourier | ].
+ unfold sin_approx, sin_term; simpl; field.
+apply sin_increasing_1.
+    assert (t := PI2_1); fourier.
+   apply Rlt_le, PI2_1.
+  assert (t := PI2_1); fourier.
+ fourier.
+assumption.
+Qed.
+
+Lemma ub_opp : forall x, x < PI/2 -> -PI/2 < -x.
+Proof.
+intros x h; rewrite Ropp_div; apply Ropp_lt_contravar; assumption.
+Qed.
+
+Lemma pos_opp_lt : forall x, 0 < x -> -x < x.
+Proof. intros; fourier. Qed.
+
+Lemma tech_opp_tan : forall x y, -tan x < y -> tan (-x) < y.
+intros; rewrite tan_neg; assumption.
+Qed.
+
+Definition pre_atan (y : R) : {x : R | -PI/2 < x < PI/2 /\ tan x = y}.
+destruct (frame_tan y) as [ub [[ub0 ubpi2] Ptan_ub]].
+set (pr := (conj (tech_opp_tan _ _ (proj2 (Rabs_def2 _ _ Ptan_ub)))
+     (proj1 (Rabs_def2 _ _ Ptan_ub)))).
+destruct (exists_atan_in_frame (-ub) ub y (pos_opp_lt _ ub0) (ub_opp _ ubpi2)
+             ubpi2 pr) as [v [[vl vu] vq]].
+exists v; clear pr.
+split;[rewrite Ropp_div; split; fourier | assumption].
+Qed.
+
+Definition atan x := let (v, _) := pre_atan x in v.
+
+Lemma atan_bound : forall x, -PI/2 < atan x < PI/2.
+Proof.
+intros x; unfold atan; destruct (pre_atan x) as [v [int _]]; exact int.
+Qed.
+
+Lemma atan_right_inv : forall x, tan (atan x) = x.
+Proof.
+intros x; unfold atan; destruct (pre_atan x) as [v [_ q]]; exact q.
+Qed.
+
+Lemma atan_opp : forall x, atan (- x) = - atan x.
+Proof.
+intros x; generalize (atan_bound (-x)); rewrite Ropp_div;intros [a b].
+generalize (atan_bound x); rewrite Ropp_div; intros [c d].
+apply tan_is_inj; try rewrite Ropp_div; try split; try fourier.
+rewrite tan_neg, !atan_right_inv; reflexivity.
+Qed.
+
+Lemma derivable_pt_atan : forall x, derivable_pt atan x.
+Proof.
+intros x.
+destruct (frame_tan x) as [ub [[ub0 ubpi] P]].
+assert (lb_lt_ub : -ub < ub) by apply pos_opp_lt, ub0.
+assert (xint : tan(-ub) < x < tan ub).
+ assert (xint' : x < tan ub /\ -(tan ub) < x) by apply Rabs_def2, P.
+  rewrite tan_neg; tauto.
+assert (inv_p : forall x, tan(-ub) <= x -> x <= tan ub -> 
+                     comp tan atan x = id x).
+ intros; apply atan_right_inv.
+assert (int_tan : forall y, tan (- ub) <= y -> y <= tan ub ->
+                       -ub <= atan y <= ub).
+ clear -ub0 ubpi; intros y lo up; split.
+  destruct (Rle_lt_dec (-ub) (atan y)) as [h | abs]; auto.
+  assert (y < tan (-ub)).
+   rewrite <- (atan_right_inv y); apply tan_increasing.
+     destruct (atan_bound y); assumption.
+    assumption.
+   fourier.
+  fourier.
+ destruct (Rle_lt_dec (atan y) ub) as [h | abs]; auto.
+  assert (tan ub < y).
+   rewrite <- (atan_right_inv y); apply tan_increasing.
+    rewrite Ropp_div; fourier.
+   assumption.
+  destruct (atan_bound y); assumption.
+ fourier.
+assert (incr : forall x y, -ub <= x -> x < y -> y <= ub -> tan x < tan y).
+ intros y z l yz u; apply tan_increasing.
+   rewrite Ropp_div; fourier.
+  assumption.
+ fourier.
+assert (der : forall a, -ub <= a <= ub -> derivable_pt tan a).
+ intros a [la ua]; apply derivable_pt_tan.
+ rewrite Ropp_div; split; fourier.
+assert (df_neq : derive_pt tan (atan x)
+     (derivable_pt_recip_interv_prelim1 tan atan 
+        (- ub) ub x lb_lt_ub xint inv_p int_tan incr der) <> 0).
+ rewrite <- (pr_nu tan (atan x)
+              (derivable_pt_tan (atan x) (atan_bound x))).
+ rewrite derive_pt_tan.
+ solve[apply Rgt_not_eq, plus_Rsqr_gt_0].
+apply (derivable_pt_recip_interv tan atan (-ub) ub x
+      lb_lt_ub xint inv_p int_tan incr der).
+exact df_neq.
+Qed.
+
+Lemma atan_increasing : forall x y, x < y -> atan x < atan y.
+intros x y d.
+assert (t1 := atan_bound x).
+assert (t2 := atan_bound y).
+destruct (Rlt_le_dec (atan x) (atan y)) as [lt | bad].
+ assumption.
+apply Rlt_not_le in d.
+case d.
+rewrite <- (atan_right_inv y), <- (atan_right_inv x).
+destruct bad as [ylt | yx].
+ apply Rlt_le, tan_increasing; try tauto.
+solve[rewrite yx; apply Rle_refl].
+Qed.
+
+Lemma atan_0 : atan 0 = 0.
+apply tan_is_inj; try (apply atan_bound).
+ assert (t := PI_RGT_0); rewrite Ropp_div; split; fourier.
+rewrite atan_right_inv, tan_0.
+reflexivity.
+Qed.
+
+Lemma atan_1 : atan 1 = PI/4.
+assert (ut := PI_RGT_0).
+assert (-PI/2 < PI/4 < PI/2) by (rewrite Ropp_div; split; fourier).
+assert (t := atan_bound 1).
+apply tan_is_inj; auto.
+rewrite tan_PI4, atan_right_inv; reflexivity.
+Qed.
+
+(** atan's derivative value is the function 1 / (1+x²) *)
+
+Lemma derive_pt_atan : forall x,
+      derive_pt atan x (derivable_pt_atan x) =
+         1 / (1 + x²).
+Proof.
+intros x.
+destruct (frame_tan x) as [ub [[ub0 ubpi] Pub]].
+assert (lb_lt_ub : -ub < ub) by apply pos_opp_lt, ub0.
+assert (xint : tan(-ub) < x < tan ub).
+ assert (xint' : x < tan ub /\ -(tan ub) < x) by apply Rabs_def2, Pub.
+  rewrite tan_neg; tauto.
+assert (inv_p : forall x, tan(-ub) <= x -> x <= tan ub -> 
+                     comp tan atan x = id x).
+ intros; apply atan_right_inv.
+assert (int_tan : forall y, tan (- ub) <= y -> y <= tan ub ->
+                       -ub <= atan y <= ub).
+ clear -ub0 ubpi; intros y lo up; split.
+  destruct (Rle_lt_dec (-ub) (atan y)) as [h | abs]; auto.
+  assert (y < tan (-ub)).
+   rewrite <- (atan_right_inv y); apply tan_increasing.
+     destruct (atan_bound y); assumption.
+    assumption.
+   fourier.
+  fourier.
+ destruct (Rle_lt_dec (atan y) ub) as [h | abs]; auto.
+  assert (tan ub < y).
+   rewrite <- (atan_right_inv y); apply tan_increasing.
+    rewrite Ropp_div; fourier.
+   assumption.
+  destruct (atan_bound y); assumption.
+ fourier.
+assert (incr : forall x y, -ub <= x -> x < y -> y <= ub -> tan x < tan y).
+ intros y z l yz u; apply tan_increasing.
+   rewrite Ropp_div; fourier.
+  assumption.
+ fourier.
+assert (der : forall a, -ub <= a <= ub -> derivable_pt tan a).
+ intros a [la ua]; apply derivable_pt_tan.
+ rewrite Ropp_div; split; fourier.
+assert (df_neq : derive_pt tan (atan x)
+     (derivable_pt_recip_interv_prelim1 tan atan 
+        (- ub) ub x lb_lt_ub xint inv_p int_tan incr der) <> 0).
+ rewrite <- (pr_nu tan (atan x)
+              (derivable_pt_tan (atan x) (atan_bound x))).
+ rewrite derive_pt_tan.
+ solve[apply Rgt_not_eq, plus_Rsqr_gt_0].
+assert (t := derive_pt_recip_interv tan atan (-ub) ub x lb_lt_ub
+        xint incr int_tan der inv_p df_neq).
+rewrite <- (pr_nu atan x (derivable_pt_recip_interv tan atan (- ub) ub
+      x lb_lt_ub xint inv_p int_tan incr der df_neq)).
+rewrite t.
+assert (t' := atan_bound x).
+rewrite <- (pr_nu tan (atan x) (derivable_pt_tan _ t')). 
+rewrite derive_pt_tan, atan_right_inv.
+replace (Rsqr x) with (x ^ 2) by (unfold Rsqr; ring).
+reflexivity.
+Qed.
+
+(** * Definition of the arctangent function as the sum of the arctan power series *)
+(* Proof taken from Guillaume Melquiond's interval package for Coq *)
+
+Definition Ratan_seq x :=  fun n => (x ^ (2 * n + 1) / INR (2 * n + 1))%R.
+
+Lemma Ratan_seq_decreasing : forall x, (0 <= x <= 1)%R -> Un_decreasing (Ratan_seq x).
+Proof.
+intros x Hx n.
+ unfold Ratan_seq, Rdiv.
+ apply Rmult_le_compat. apply pow_le.
+ exact (proj1 Hx).
+ apply Rlt_le.
+ apply Rinv_0_lt_compat.
+ apply lt_INR_0.
+ omega.
+ destruct (proj1 Hx) as [Hx1|Hx1].
+ destruct (proj2 Hx) as [Hx2|Hx2].
+ (* . 0 < x < 1 *)
+ rewrite <- (Rinv_involutive x).
+ assert (/ x <> 0)%R by auto with real.
+ repeat rewrite <- Rinv_pow with (1 := H).
+ apply Rlt_le.
+ apply Rinv_lt_contravar.
+ apply Rmult_lt_0_compat ; apply pow_lt ; auto with real.
+ apply Rlt_pow.
+ rewrite <- Rinv_1.
+ apply Rinv_lt_contravar.
+ rewrite Rmult_1_r.
+ exact Hx1.
+ exact Hx2.
+ omega.
+ apply Rgt_not_eq.
+ exact Hx1.
+ (* . x = 1 *)
+ rewrite Hx2.
+ do 2 rewrite pow1.
+ apply Rle_refl.
+ (* . x = 0 *)
+ rewrite <- Hx1.
+ do 2 (rewrite pow_i ; [ idtac | omega ]).
+ apply Rle_refl.
+ apply Rlt_le.
+ apply Rinv_lt_contravar.
+ apply Rmult_lt_0_compat ; apply lt_INR_0 ; omega.
+ apply lt_INR.
+ omega.
+Qed.
+
+Lemma Ratan_seq_converging : forall x, (0 <= x <= 1)%R -> Un_cv (Ratan_seq x) 0.
+Proof.
+intros x Hx eps Heps.
+ destruct (archimed (/ eps)) as (HN,_).
+ assert (0 < up (/ eps))%Z.
+  apply lt_IZR.
+  apply Rlt_trans with (2 := HN).
+  apply Rinv_0_lt_compat.
+  exact Heps.
+ case_eq (up (/ eps)) ;
+  intros ; rewrite H0 in H ; try discriminate H.
+   rewrite H0 in HN.
+   simpl in HN.
+   pose (N := Pos.to_nat p).
+   fold N in HN.
+   clear H H0.
+   exists N.
+  intros n Hn.
+   unfold R_dist.
+   rewrite Rminus_0_r.
+   unfold Ratan_seq.
+   rewrite Rabs_right.
+   apply Rle_lt_trans with (1 ^ (2 * n + 1) / INR (2 * n + 1))%R.
+   unfold Rdiv.
+   apply Rmult_le_compat_r.
+   apply Rlt_le.
+   apply Rinv_0_lt_compat.
+   apply lt_INR_0.
+   omega.
+   apply pow_incr.
+   exact Hx.
+   rewrite pow1.
+   apply Rle_lt_trans with (/ INR (2 * N + 1))%R.
+   unfold Rdiv.
+   rewrite Rmult_1_l.
+   apply Rle_Rinv.
+   apply lt_INR_0.
+   omega.
+   replace 0 with (INR 0) by intuition.
+   apply lt_INR.
+   omega.
+   intuition.
+   rewrite <- (Rinv_involutive eps).
+   apply Rinv_lt_contravar.
+   apply Rmult_lt_0_compat.
+   auto with real.
+   apply lt_INR_0.
+   omega.
+   apply Rlt_trans with (INR N).
+   destruct (archimed (/ eps)) as (H,_).
+   assert (0 < up (/ eps))%Z.
+   apply lt_IZR.
+   apply Rlt_trans with (2 := H).
+   apply Rinv_0_lt_compat.
+   exact Heps.
+   exact HN.
+   apply lt_INR.
+   omega.
+   apply Rgt_not_eq.
+   exact Heps.
+   apply Rle_ge.
+   unfold Rdiv.
+   apply Rmult_le_pos.
+   apply pow_le.
+   exact (proj1 Hx).
+   apply Rlt_le.
+   apply Rinv_0_lt_compat.
+   apply lt_INR_0.
+   omega.
+Qed.
+
+Definition ps_atan_exists_01 (x : R) (Hx:0 <= x <= 1) :
+   {l : R | Un_cv (fun N : nat => sum_f_R0 (tg_alt (Ratan_seq x)) N) l}.
+exact (alternated_series (Ratan_seq x)
+  (Ratan_seq_decreasing _ Hx) (Ratan_seq_converging _ Hx)).
+Defined.
+
+Lemma Ratan_seq_opp : forall x n, Ratan_seq (-x) n = -Ratan_seq x n.
+Proof.
+intros x n; unfold Ratan_seq.
+rewrite !pow_add, !pow_mult, !pow_1.
+unfold Rdiv; replace ((-x) ^ 2) with (x ^ 2) by ring; ring.
+Qed.
+
+Lemma sum_Ratan_seq_opp : 
+  forall x n, sum_f_R0 (tg_alt (Ratan_seq (- x))) n =
+     - sum_f_R0 (tg_alt (Ratan_seq x)) n.
+Proof.
+intros x n; replace (-sum_f_R0 (tg_alt (Ratan_seq x)) n) with 
+  (-1 * sum_f_R0 (tg_alt (Ratan_seq x)) n) by ring.
+rewrite scal_sum; apply sum_eq; intros i _; unfold tg_alt.
+rewrite Ratan_seq_opp; ring.
+Qed.
+
+Definition ps_atan_exists_1 (x : R) (Hx : -1 <= x <= 1) :
+   {l : R | Un_cv (fun N : nat => sum_f_R0 (tg_alt (Ratan_seq x)) N) l}.
+destruct (Rle_lt_dec 0 x).
+ assert (pr : 0 <= x <= 1) by tauto.
+ exact (ps_atan_exists_01 x pr).
+assert (pr : 0 <= -x <= 1) by (destruct Hx; split; fourier).
+destruct (ps_atan_exists_01 _ pr) as [v Pv].
+exists (-v).
+ apply (Un_cv_ext (fun n => (- 1) * sum_f_R0 (tg_alt (Ratan_seq (- x))) n)).
+ intros n; rewrite sum_Ratan_seq_opp; ring.
+replace (-v) with (-1 * v) by ring.
+apply CV_mult;[ | assumption].
+solve[intros; exists 0%nat; intros; rewrite R_dist_eq; auto].
+Qed.
+
+Definition in_int (x : R) : {-1 <= x <= 1}+{~ -1 <= x <= 1}.
+destruct (Rle_lt_dec x 1).
+ destruct (Rle_lt_dec (-1) x).
+  left;split; auto.
+ right;intros [a1 a2]; fourier.
+right;intros [a1 a2]; fourier.
+Qed.
+
+Definition ps_atan (x : R) : R :=
+ match in_int x with
+   left h => let (v, _) := ps_atan_exists_1 x h in v
+ | right h => atan x
+ end.
+
+(** * Proof of the equivalence of the two definitions between -1 and 1 *)
+
+Lemma ps_atan0_0 : ps_atan 0 = 0.
+Proof.
+unfold ps_atan.
+ destruct (in_int 0) as [h1 | h2].
+ destruct (ps_atan_exists_1 0 h1) as [v P].
+ apply (UL_sequence _ _ _ P).
+  apply (Un_cv_ext (fun n => 0)).
+  symmetry;apply sum_eq_R0.
+  intros i _; unfold tg_alt, Ratan_seq; rewrite plus_comm; simpl.
+  unfold Rdiv; rewrite !Rmult_0_l, Rmult_0_r; reflexivity.
+ intros eps ep; exists 0%nat; intros n _; unfold R_dist.
+ rewrite Rminus_0_r, Rabs_pos_eq; auto with real.
+case h2; split; fourier.
+Qed.
+
+Lemma ps_atan_exists_1_opp :
+  forall x h h', proj1_sig (ps_atan_exists_1 (-x) h) = 
+     -(proj1_sig (ps_atan_exists_1 x h')).
+Proof.
+intros x h h'; destruct (ps_atan_exists_1 (-x) h) as [v Pv].
+destruct (ps_atan_exists_1 x h') as [u Pu]; simpl.
+assert (Pu' : Un_cv (fun N => (-1) * sum_f_R0 (tg_alt (Ratan_seq x)) N) (-1 * u)).
+ apply CV_mult;[ | assumption].
+ intros eps ep; exists 0%nat; intros; rewrite R_dist_eq; assumption.  
+assert (Pv' : Un_cv
+           (fun N : nat => -1 * sum_f_R0 (tg_alt (Ratan_seq x)) N) v).
+ apply Un_cv_ext with (2 := Pv); intros n; rewrite sum_Ratan_seq_opp; ring.
+replace (-u) with (-1 * u) by ring.
+apply UL_sequence with (1:=Pv') (2:= Pu').
+Qed.
+
+Lemma ps_atan_opp : forall x, ps_atan (-x) = -ps_atan x.
+Proof.
+intros x; unfold ps_atan.
+destruct (in_int (- x)) as [inside | outside].
+ destruct (in_int x) as [ins' | outs'].
+ generalize (ps_atan_exists_1_opp x inside ins').
+  intros h; exact h.
+ destruct inside; case outs'; split; fourier.   
+destruct (in_int x) as [ins' | outs'].
+ destruct outside; case ins'; split; fourier.   
+apply atan_opp.
+Qed.
+
+(** atan = ps_atan *)
+
+Lemma ps_atanSeq_continuity_pt_1 : forall (N:nat) (x:R),
+      0 <= x ->
+      x <= 1 ->
+      continuity_pt (fun x => sum_f_R0 (tg_alt (Ratan_seq x)) N) x.
+Proof.
+assert (Sublemma : forall (x:R) (N:nat), sum_f_R0 (tg_alt (Ratan_seq x)) N = x * (comp (fun x => sum_f_R0 (fun n => (fun i : nat => (-1) ^ i / INR (2 * i + 1)) n * x ^ n) N) (fun x => x ^ 2) x)).
+ intros x N.
+  induction N.
+   unfold tg_alt, Ratan_seq, comp ; simpl ; field.
+   simpl sum_f_R0 at 1.
+   rewrite IHN.
+   replace (comp (fun x => sum_f_R0 (fun n : nat => (-1) ^ n / INR (2 * n + 1) * x ^ n) (S N)) (fun x => x ^ 2))
+     with (comp (fun x => sum_f_R0 (fun n : nat => (-1) ^ n / INR (2 * n + 1) * x ^ n) N + (-1) ^ (S N) / INR (2 * (S N) + 1) * x ^ (S N)) (fun x => x ^ 2)).
+   unfold comp.
+   rewrite Rmult_plus_distr_l.
+   apply Rplus_eq_compat_l.
+   unfold tg_alt, Ratan_seq.
+   rewrite <- Rmult_assoc.
+   case (Req_dec x 0) ; intro Hyp.
+   rewrite Hyp ; rewrite pow_i. rewrite Rmult_0_l ; rewrite Rmult_0_l.
+   unfold Rdiv ; rewrite Rmult_0_l ; rewrite Rmult_0_r ; reflexivity.
+   intuition.
+   replace (x * ((-1) ^ S N / INR (2 * S N + 1)) * (x ^ 2) ^ S N) with (x ^ (2 * S N + 1) * ((-1) ^ S N / INR (2 * S N + 1))).
+   rewrite Rmult_comm ; unfold Rdiv at 1.
+   rewrite Rmult_assoc ; apply Rmult_eq_compat_l.
+   field. apply Rgt_not_eq ; intuition.
+   rewrite Rmult_assoc.
+   replace (x * ((-1) ^ S N / INR (2 * S N + 1) * (x ^ 2) ^ S N)) with (((-1) ^ S N / INR (2 * S N + 1) * (x ^ 2) ^ S N) * x).
+   rewrite Rmult_assoc.
+   replace ((x ^ 2) ^ S N * x) with (x ^ (2 * S N + 1)).
+   rewrite Rmult_comm at 1 ; reflexivity.
+   rewrite <- pow_mult.
+   assert (Temp : forall x n, x ^ n * x = x ^ (n+1)).
+    intros a n ; induction n. rewrite pow_O. simpl ; intuition.
+    simpl ; rewrite Rmult_assoc ; rewrite IHn ; intuition.
+   rewrite Temp ; reflexivity.
+   rewrite Rmult_comm ; reflexivity.
+   intuition.
+intros N x x_lb x_ub.
+ intros eps eps_pos.
+ assert (continuity_id : continuity id).
+ apply derivable_continuous ; exact derivable_id.
+assert (Temp := continuity_mult id (comp
+        (fun x1 : R =>
+         sum_f_R0 (fun n : nat => (-1) ^ n / INR (2 * n + 1) * x1 ^ n) N)
+        (fun x1 : R => x1 ^ 2))
+           continuity_id).
+assert (Temp2 : continuity
+    (comp
+       (fun x1 : R =>
+        sum_f_R0 (fun n : nat => (-1) ^ n / INR (2 * n + 1) * x1 ^ n) N)
+       (fun x1 : R => x1 ^ 2))).
+ apply continuity_comp.
+ reg.
+ apply continuity_finite_sum.
+ elim (Temp Temp2 x eps eps_pos) ; clear Temp Temp2 ; intros alpha T ; destruct T as (alpha_pos, T).
+ exists alpha ; split.
+ intuition.
+intros x0 x0_cond.
+ rewrite Sublemma ; rewrite Sublemma.
+apply T.
+intuition.
+Qed.
+
+(** Definition of ps_atan's derivative *)
+
+Definition Datan_seq := fun (x:R) (n:nat) => x ^ (2*n).
+
+Lemma pow_lt_1_compat : forall x n, 0 <= x < 1 -> (0 < n)%nat ->
+   0 <= x ^ n < 1.
+Proof.
+intros x n hx; induction 1; simpl.
+ rewrite Rmult_1_r; tauto.
+split.
+ apply Rmult_le_pos; tauto.
+rewrite <- (Rmult_1_r 1); apply Rmult_le_0_lt_compat; intuition.
+Qed.
+
+Lemma Datan_seq_Rabs : forall x n, Datan_seq (Rabs x) n = Datan_seq x n.
+Proof.
+intros x n; unfold Datan_seq; rewrite !pow_mult, pow2_abs; reflexivity.
+Qed.
+
+Lemma Datan_seq_pos : forall x n, 0 < x -> 0 < Datan_seq x n.
+Proof.
+intros x n x_lb ; unfold Datan_seq ; induction n.
+ simpl ; intuition.
+ replace (x ^ (2 * S n)) with ((x ^ 2) * (x ^ (2 * n))).
+ apply Rmult_gt_0_compat.
+ replace (x^2) with (x*x) by field ; apply Rmult_gt_0_compat ; assumption.
+ assumption.
+ replace (2 * S n)%nat with (S (S (2 * n))) by intuition.
+ simpl ; field.
+Qed.
+
+Lemma Datan_sum_eq :forall x n,
+  sum_f_R0 (tg_alt (Datan_seq x)) n = (1 - (- x ^ 2) ^ S n)/(1 + x ^ 2).
+Proof.
+intros x n.
+assert (dif : - x ^ 2 <> 1).
+apply Rlt_not_eq; apply Rle_lt_trans with 0;[ | apply Rlt_0_1].
+assert (t := pow2_ge_0 x); fourier.
+replace (1 + x ^ 2) with (1 - - (x ^ 2)) by ring; rewrite <- (tech3 _ n dif).
+apply sum_eq; unfold tg_alt, Datan_seq; intros i _.
+rewrite pow_mult, <- Rpow_mult_distr, Ropp_mult_distr_l_reverse, Rmult_1_l.
+reflexivity.
+Qed.
+
+Lemma Datan_seq_increasing : forall x y n, (n > 0)%nat -> 0 <= x < y -> Datan_seq x n < Datan_seq y n.
+Proof.
+intros x y n n_lb x_encad ; assert (x_pos : x >= 0) by intuition.
+ assert (y_pos : y > 0). apply Rle_lt_trans with (r2:=x) ; intuition.
+ induction n.
+ apply False_ind ; intuition.
+ clear -x_encad x_pos y_pos ; induction n ; unfold Datan_seq.
+ case x_pos ; clear x_pos ; intro x_pos.
+ simpl ; apply Rmult_gt_0_lt_compat ; intuition. fourier.
+ rewrite x_pos ; rewrite pow_i. replace (y ^ (2*1)) with (y*y).
+ apply Rmult_gt_0_compat ; assumption.
+ simpl ; field.
+ intuition.
+ assert (Hrew : forall a, a^(2 * S (S n)) = (a ^ 2) * (a ^ (2 * S n))).
+  clear ; intro a ; replace (2 * S (S n))%nat with (S (S (2 * S n)))%nat by intuition.
+  simpl ; field.
+ case x_pos ; clear x_pos ; intro x_pos.
+ rewrite Hrew ; rewrite Hrew.
+ apply Rmult_gt_0_lt_compat ; intuition.
+ apply Rmult_gt_0_lt_compat ; intuition ; fourier.
+ rewrite x_pos.
+ rewrite pow_i ; intuition.
+Qed.
+
+Lemma Datan_seq_decreasing : forall x,  -1 < x -> x < 1 -> Un_decreasing (Datan_seq x).
+Proof.
+intros x x_lb x_ub n.
+unfold Datan_seq.
+replace (2 * S n)%nat with (2 + 2 * n)%nat by ring.
+rewrite <- (Rmult_1_l (x ^ (2 * n))).
+rewrite pow_add.
+apply Rmult_le_compat_r.
+rewrite pow_mult; apply pow_le, pow2_ge_0.
+apply Rlt_le; rewrite <- pow2_abs.
+assert (intabs : 0 <= Rabs x < 1).
+ split;[apply Rabs_pos | apply Rabs_def1]; tauto.
+apply (pow_lt_1_compat (Rabs x) 2) in intabs.
+ tauto.
+omega.
+Qed.
+
+Lemma Datan_seq_CV_0 : forall x, -1 < x -> x < 1 -> Un_cv (Datan_seq x) 0.
+Proof.
+intros x x_lb x_ub eps eps_pos.
+assert (x_ub2 : Rabs (x^2) < 1).
+ rewrite Rabs_pos_eq;[ | apply pow2_ge_0].
+ rewrite <- pow2_abs.
+ assert (H: 0 <= Rabs x < 1)
+   by (split;[apply Rabs_pos | apply Rabs_def1; auto]).
+ apply (pow_lt_1_compat _ 2) in H;[tauto | omega].
+elim (pow_lt_1_zero (x^2) x_ub2 eps eps_pos) ; intros N HN ; exists N ; intros n Hn.
+unfold R_dist, Datan_seq.
+replace (x ^ (2 * n) - 0) with ((x ^ 2) ^ n). apply HN ; assumption.
+rewrite pow_mult ; field.
+Qed.
+
+Lemma Datan_lim : forall x, -1 < x -> x < 1 ->
+    Un_cv (fun N : nat => sum_f_R0 (tg_alt (Datan_seq x)) N) (/ (1 + x ^ 2)).
+Proof.
+intros x x_lb x_ub eps eps_pos.
+assert (Tool0 : 0 <= x ^ 2) by apply pow2_ge_0.
+assert (Tool1 : 0 < (1 + x ^ 2)).
+ solve[apply Rplus_lt_le_0_compat ; intuition].
+assert (Tool2 : / (1 + x ^ 2) > 0).
+ apply Rinv_0_lt_compat ; tauto.
+assert (x_ub2' : 0<= Rabs (x^2) < 1).
+ rewrite Rabs_pos_eq, <- pow2_abs;[ | apply pow2_ge_0].
+ apply pow_lt_1_compat;[split;[apply Rabs_pos | ] | omega].
+ apply Rabs_def1; assumption.
+assert (x_ub2 : Rabs (x^2) < 1) by tauto.
+assert (eps'_pos : ((1+x^2)*eps) > 0).
+  apply Rmult_gt_0_compat ; assumption.
+elim (pow_lt_1_zero _ x_ub2 _ eps'_pos) ; intros N HN ; exists N.
+intros n Hn.
+assert (H1 : - x^2 <> 1).
+ apply Rlt_not_eq; apply Rle_lt_trans with (2 := Rlt_0_1).
+assert (t := pow2_ge_0 x); fourier.
+rewrite Datan_sum_eq. 
+unfold R_dist.
+assert (tool : forall a b, a / b - /b = (-1 + a) /b).
+ intros a b; rewrite <- (Rmult_1_l (/b)); unfold Rdiv, Rminus.
+ rewrite <- Ropp_mult_distr_l_reverse, Rmult_plus_distr_r, Rplus_comm.
+ reflexivity.
+set (u := 1 + x ^ 2); rewrite tool; unfold Rminus; rewrite <- Rplus_assoc.
+unfold Rdiv, u.
+rewrite Rplus_opp_l, Rplus_0_l, Ropp_mult_distr_l_reverse, Rabs_Ropp.
+rewrite Rabs_mult; clear tool u.
+assert (tool : forall k, Rabs ((-x ^ 2) ^ k) = Rabs ((x ^ 2) ^ k)).
+ clear -Tool0; induction k;[simpl; rewrite Rabs_R1;tauto | ].
+ rewrite <- !(tech_pow_Rmult _ k), !Rabs_mult, Rabs_Ropp, IHk, Rabs_pos_eq.
+  reflexivity.
+ exact Tool0.
+rewrite tool, (Rabs_pos_eq (/ _)); clear tool;[ | apply Rlt_le; assumption].
+assert (tool : forall a b c, 0 < b -> a < b * c -> a * / b < c).
+ intros a b c bp h; replace c with (b * c * /b).
+  apply Rmult_lt_compat_r.  
+   apply Rinv_0_lt_compat; assumption.
+  assumption.
+ field; apply Rgt_not_eq; exact bp.
+apply tool;[exact Tool1 | ].
+apply HN; omega.
+Qed.
+
+Lemma Datan_CVU_prelim : forall c (r : posreal), Rabs c + r < 1 ->
+ CVU (fun N x => sum_f_R0 (tg_alt (Datan_seq x)) N)
+     (fun y : R => / (1 + y ^ 2)) c r.
+Proof.
+intros c r ub_ub eps eps_pos.
+apply (Alt_CVU (fun x n => Datan_seq n x) 
+         (fun x => /(1 + x ^ 2))
+         (Datan_seq (Rabs c + r)) c r).
+     intros x inb; apply Datan_seq_decreasing;
+      try (apply Boule_lt in inb; apply Rabs_def2 in inb;
+         destruct inb; fourier).
+    intros x inb; apply Datan_seq_CV_0;
+      try (apply Boule_lt in inb; apply Rabs_def2 in inb;
+         destruct inb; fourier).
+   intros x inb; apply (Datan_lim x);
+      try (apply Boule_lt in inb; apply Rabs_def2 in inb;
+         destruct inb; fourier).
+  intros x [ | n] inb.
+   solve[unfold Datan_seq; apply Rle_refl].
+  rewrite <- (Datan_seq_Rabs x); apply Rlt_le, Datan_seq_increasing.
+   omega.
+  apply Boule_lt in inb; intuition.
+  solve[apply Rabs_pos].
+ apply Datan_seq_CV_0.
+  apply Rlt_trans with 0;[fourier | ].
+  apply Rplus_le_lt_0_compat.
+   solve[apply Rabs_pos].
+  destruct r; assumption.
+ assumption.
+assumption.
+Qed.
+
+Lemma Datan_is_datan : forall (N:nat) (x:R),
+      -1 <= x ->
+      x < 1 ->
+derivable_pt_lim (fun x => sum_f_R0 (tg_alt (Ratan_seq x)) N) x (sum_f_R0 (tg_alt (Datan_seq x)) N).
+Proof.
+assert (Tool : forall N, (-1) ^ (S (2 * N))  = - 1).
+ intro n ; induction n.
+  simpl ; field.
+  replace ((-1) ^ S (2 * S n)) with ((-1) ^ 2 * (-1) ^ S (2*n)).
+  rewrite IHn ; field.
+  rewrite <- pow_add.
+  replace (2 + S (2 * n))%nat with (S (2 * S n))%nat.
+  reflexivity.
+  intuition.
+intros N x x_lb x_ub.
+ induction N.
+  unfold Datan_seq, Ratan_seq, tg_alt ; simpl.
+  intros eps eps_pos.
+   elim (derivable_pt_lim_id x eps eps_pos) ; intros delta Hdelta ; exists delta.
+   intros h hneq h_b.
+    replace (1 * ((x + h) * 1 / 1) - 1 * (x * 1 / 1)) with (id (x + h) - id x). 
+    rewrite Rmult_1_r.
+    apply Hdelta ; assumption.
+    unfold id ; field ; assumption.
+  intros eps eps_pos.
+  assert (eps_3_pos : (eps/3) > 0) by fourier.
+  elim (IHN (eps/3) eps_3_pos) ; intros delta1 Hdelta1.
+  assert (Main : derivable_pt_lim (fun x : R =>tg_alt (Ratan_seq x) (S N)) x ((tg_alt (Datan_seq x)) (S N))).
+   clear -Tool ; intros eps' eps'_pos.
+   elim (derivable_pt_lim_pow x (2 * (S N) + 1) eps' eps'_pos) ; intros delta Hdelta ; exists delta.
+   intros h h_neq h_b ; unfold tg_alt, Ratan_seq, Datan_seq.
+   replace (((-1) ^ S N * ((x + h) ^ (2 * S N + 1) / INR (2 * S N + 1)) -
+    (-1) ^ S N * (x ^ (2 * S N + 1) / INR (2 * S N + 1))) / h -
+    (-1) ^ S N * x ^ (2 * S N)) 
+    with (((-1)^(S N)) * ((((x + h) ^ (2 * S N + 1) / INR (2 * S N + 1)) -
+    (x ^ (2 * S N + 1) / INR (2 * S N + 1))) / h - x ^ (2 * S N))).
+   rewrite Rabs_mult ; rewrite pow_1_abs ; rewrite Rmult_1_l.
+   replace (((x + h) ^ (2 * S N + 1) / INR (2 * S N + 1) -
+    x ^ (2 * S N + 1) / INR (2 * S N + 1)) / h - x ^ (2 * S N))
+    with ((/INR (2* S N + 1)) * (((x + h) ^ (2 * S N + 1) - x ^ (2 * S N + 1)) / h -
+    INR (2 * S N + 1) * x ^ pred (2 * S N + 1))).
+   rewrite Rabs_mult.
+   case (Req_dec (((x + h) ^ (2 * S N + 1) - x ^ (2 * S N + 1)) / h -
+     INR (2 * S N + 1) * x ^ pred (2 * S N + 1)) 0) ; intro Heq.
+   rewrite Heq ; rewrite Rabs_R0 ; rewrite Rmult_0_r ; assumption.
+   apply Rlt_trans with (r2:=Rabs
+           (((x + h) ^ (2 * S N + 1) - x ^ (2 * S N + 1)) / h -
+            INR (2 * S N + 1) * x ^ pred (2 * S N + 1))).
+   rewrite <- Rmult_1_l ; apply Rmult_lt_compat_r.
+   apply Rabs_pos_lt ; assumption.
+   rewrite Rabs_right.
+   replace 1 with (/1) by field.
+   apply Rinv_1_lt_contravar ; intuition.
+   apply Rgt_ge ; replace (INR (2 * S N + 1)) with (INR (2*S N) + 1) ;
+   [apply RiemannInt.RinvN_pos | ].
+   replace (2 * S N + 1)%nat with (S (2 * S N))%nat by intuition ;
+   rewrite S_INR ; reflexivity.
+   apply Hdelta ; assumption.
+   rewrite Rmult_minus_distr_l.
+   replace (/ INR (2 * S N + 1) * (INR (2 * S N + 1) * x ^ pred (2 * S N + 1))) with (x ^ (2 * S N)).
+   unfold Rminus ; rewrite Rplus_comm.
+   replace (((x + h) ^ (2 * S N + 1) / INR (2 * S N + 1) +
+      - (x ^ (2 * S N + 1) / INR (2 * S N + 1))) / h + - x ^ (2 * S N))
+      with (- x ^ (2 * S N) + (((x + h) ^ (2 * S N + 1) / INR (2 * S N + 1) +
+      - (x ^ (2 * S N + 1) / INR (2 * S N + 1))) / h)) by intuition.
+   apply Rplus_eq_compat_l. field.
+   split ; [apply Rgt_not_eq|] ; intuition.
+   clear ; replace (pred (2 * S N + 1)) with (2 * S N)%nat by intuition.
+   field ; apply Rgt_not_eq ; intuition.
+   field ; split ; [apply Rgt_not_eq |] ; intuition.
+   elim (Main (eps/3) eps_3_pos) ; intros delta2 Hdelta2.
+   destruct delta1 as (delta1, delta1_pos) ; destruct delta2 as (delta2, delta2_pos).
+   pose (mydelta := Rmin delta1 delta2).
+   assert (mydelta_pos : mydelta > 0).
+    unfold mydelta ; rewrite Rmin_Rgt ; split ; assumption.
+   pose (delta := mkposreal mydelta mydelta_pos) ; exists delta ; intros h h_neq h_b.
+   clear Main IHN.
+   unfold Rminus at 1.
+   apply Rle_lt_trans with (r2:=eps/3 + eps / 3).
+   assert (Temp : (sum_f_R0 (tg_alt (Ratan_seq (x + h))) (S N) -
+    sum_f_R0 (tg_alt (Ratan_seq x)) (S N)) / h +
+    - sum_f_R0 (tg_alt (Datan_seq x)) (S N) = ((sum_f_R0 (tg_alt (Ratan_seq (x + h))) N -
+              sum_f_R0 (tg_alt (Ratan_seq x)) N) / h) + (-
+             sum_f_R0 (tg_alt (Datan_seq x)) N) + ((tg_alt (Ratan_seq (x + h)) (S N) - tg_alt (Ratan_seq x) (S N)) /
+             h - tg_alt (Datan_seq x) (S N))).
+    simpl ; field ; intuition.
+   apply Rle_trans with (r2:= Rabs ((sum_f_R0 (tg_alt (Ratan_seq (x + h))) N -
+        sum_f_R0 (tg_alt (Ratan_seq x)) N) / h +
+       - sum_f_R0 (tg_alt (Datan_seq x)) N) +
+       Rabs ((tg_alt (Ratan_seq (x + h)) (S N) - tg_alt (Ratan_seq x) (S N)) / h -
+        tg_alt (Datan_seq x) (S N))).
+   rewrite Temp ; clear Temp ; apply Rabs_triang.
+   apply Rplus_le_compat ; apply Rlt_le ; [apply Hdelta1 | apply Hdelta2] ;
+   intuition ; apply Rlt_le_trans with (r2:=delta) ; intuition unfold delta, mydelta.
+   apply Rmin_l.
+   apply Rmin_r.
+   fourier.
+Qed.
+
+Lemma Ratan_CVU' :
+  CVU (fun N x => sum_f_R0 (tg_alt (Ratan_seq x)) N)
+                     ps_atan (/2) (mkposreal (/2) pos_half_prf).
+Proof.
+apply (Alt_CVU (fun i r => Ratan_seq r i) ps_atan PI_tg (/2) pos_half);
+  lazy beta.
+    now intros; apply Ratan_seq_decreasing, Boule_half_to_interval.
+   now intros; apply Ratan_seq_converging, Boule_half_to_interval.
+  intros x b; apply Boule_half_to_interval in b.
+  unfold ps_atan; destruct (in_int x) as [inside | outside];
+   [ | destruct b; case outside; split; fourier].
+  destruct (ps_atan_exists_1 x inside) as [v Pv].
+  apply Un_cv_ext with (2 := Pv);[reflexivity].
+ intros x n b; apply Boule_half_to_interval in b.
+ rewrite <- (Rmult_1_l (PI_tg n)); unfold Ratan_seq, PI_tg. 
+ apply Rmult_le_compat_r.
+  apply Rlt_le, Rinv_0_lt_compat, (lt_INR 0); omega.
+ rewrite <- (pow1 (2 * n + 1)); apply pow_incr; assumption.
+exact PI_tg_cv.
+Qed.
+
+Lemma Ratan_CVU :
+  CVU (fun N x => sum_f_R0 (tg_alt (Ratan_seq x)) N)
+                     ps_atan 0  (mkposreal 1 Rlt_0_1).
+Proof.
+intros eps ep; destruct (Ratan_CVU' eps ep) as [N Pn].
+exists N; intros n x nN b_y.
+case (Rtotal_order 0 x) as [xgt0 | [x0 | x0]].
+  assert (Boule (/2) {| pos := / 2; cond_pos := pos_half_prf|} x).
+   revert b_y; unfold Boule; simpl; intros b_y; apply Rabs_def2 in b_y.
+   destruct b_y; unfold Boule; simpl; apply Rabs_def1; fourier.
+  apply Pn; assumption.
+ rewrite <- x0, ps_atan0_0.
+ rewrite <- (sum_eq (fun _ => 0)), sum_cte, Rmult_0_l, Rminus_0_r, Rabs_pos_eq.
+   assumption.
+  apply Rle_refl.
+ intros i _; unfold tg_alt, Ratan_seq, Rdiv; rewrite plus_comm; simpl.
+ solve[rewrite !Rmult_0_l, Rmult_0_r; auto].
+replace (ps_atan x - sum_f_R0 (tg_alt (Ratan_seq x)) n) with
+  (-(ps_atan (-x) - sum_f_R0 (tg_alt (Ratan_seq (-x))) n)).
+ rewrite Rabs_Ropp.
+ assert (Boule (/2) {| pos := / 2; cond_pos := pos_half_prf|} (-x)).
+  revert b_y; unfold Boule; simpl; intros b_y; apply Rabs_def2 in b_y.
+  destruct b_y; unfold Boule; simpl; apply Rabs_def1; fourier.
+ apply Pn; assumption.
+unfold Rminus; rewrite ps_atan_opp, Ropp_plus_distr, sum_Ratan_seq_opp.
+rewrite !Ropp_involutive; reflexivity.
+Qed.
+
+Lemma Alt_PI_tg : forall n, PI_tg n = Ratan_seq 1 n.
+Proof.
+intros n; unfold PI_tg, Ratan_seq, Rdiv; rewrite pow1, Rmult_1_l.
+reflexivity.
+Qed.
+
+Lemma Ratan_is_ps_atan : forall eps, eps > 0 ->
+       exists N, forall n, (n >= N)%nat -> forall x, -1 < x -> x < 1 ->
+       Rabs (sum_f_R0 (tg_alt (Ratan_seq x)) n - ps_atan x) < eps.
+Proof.
+intros eps ep.
+destruct (Ratan_CVU _ ep) as [N1 PN1].
+exists N1; intros n nN x xm1 x1; rewrite <- Rabs_Ropp, Ropp_minus_distr.
+apply PN1; [assumption | ].
+unfold Boule; simpl; rewrite Rminus_0_r; apply Rabs_def1; assumption.
+Qed.
+
+Lemma Datan_continuity : continuity (fun x => /(1+x ^ 2)).
+Proof.
+apply continuity_inv.
+apply continuity_plus.
+apply continuity_const ; unfold constant ; intuition.
+apply derivable_continuous ; apply derivable_pow.
+intro x ; apply Rgt_not_eq ; apply Rge_gt_trans with (1+0) ; [|fourier] ;
+ apply Rplus_ge_compat_l.
+ replace (x^2) with (x²).
+ apply Rle_ge ; apply Rle_0_sqr.
+ unfold Rsqr ; field.
+Qed.
+
+Lemma derivable_pt_lim_ps_atan : forall x, -1 < x < 1 ->
+  derivable_pt_lim ps_atan x ((fun y => /(1 + y ^ 2)) x).
+Proof.
+intros x x_encad.
+destruct (boule_in_interval (-1) 1 x x_encad) as [c [r [Pcr1 [P1 P2]]]].
+change (/ (1 + x ^ 2)) with ((fun u => /(1 + u ^ 2)) x).
+assert (t := derivable_pt_lim_CVU).
+apply derivable_pt_lim_CVU with 
+          (fn := (fun N x => sum_f_R0 (tg_alt (Ratan_seq x)) N))
+          (fn' := (fun N x => sum_f_R0 (tg_alt (Datan_seq x)) N))
+          (c := c) (r := r).
+    assumption.
+   intros y N inb; apply Rabs_def2 in inb; destruct inb.
+   apply Datan_is_datan.
+    fourier.
+   fourier.
+  intros y inb; apply Rabs_def2 in inb; destruct inb.
+  assert (y_gt_0 : -1 < y) by fourier.
+  assert (y_lt_1 : y < 1) by fourier.
+  intros eps eps_pos ; elim (Ratan_is_ps_atan eps eps_pos).
+  intros N HN ; exists N; intros n n_lb ; apply HN ; tauto.
+ apply Datan_CVU_prelim.
+ replace ((c - r + (c + r)) / 2) with c by field.
+ unfold mkposreal_lb_ub; simpl.
+ replace ((c + r - (c - r)) / 2) with (r :R) by field.
+ assert (Rabs c < 1 - r).
+  unfold Boule in Pcr1; destruct r; simpl in *; apply Rabs_def1;
+  apply Rabs_def2 in Pcr1; destruct Pcr1; fourier.
+ fourier.
+intros; apply Datan_continuity.
+Qed.
+
+Lemma derivable_pt_ps_atan :
+   forall x, -1 < x < 1 -> derivable_pt ps_atan x.
+Proof.
+intros x x_encad.
+exists (/(1+x^2)) ; apply derivable_pt_lim_ps_atan; assumption.
+Qed.
+
+Lemma ps_atan_continuity_pt_1 : forall eps : R,
+       eps > 0 ->
+       exists alp : R,
+       alp > 0 /\
+       (forall x, x < 1 -> 0 < x -> R_dist x 1 < alp ->
+       dist R_met (ps_atan x) (Alt_PI/4) < eps).
+Proof.
+intros eps eps_pos.
+assert (eps_3_pos : eps / 3 > 0) by fourier.
+elim (Ratan_is_ps_atan (eps / 3) eps_3_pos) ; intros N1 HN1.
+unfold Alt_PI.
+destruct exist_PI as [v Pv]; replace ((4 * v)/4) with v by field.
+assert (Pv' : Un_cv (sum_f_R0 (tg_alt (Ratan_seq 1))) v).
+ apply Un_cv_ext with (2:= Pv).
+ intros; apply sum_eq; intros; unfold tg_alt; rewrite Alt_PI_tg; tauto.
+destruct (Pv' (eps / 3) eps_3_pos) as [N2 HN2].
+set (N := (N1 + N2)%nat).
+assert (O_lb : 0 <= 1) by intuition ; assert (O_ub : 1 <= 1) by intuition ;
+ elim (ps_atanSeq_continuity_pt_1 N 1 O_lb O_ub (eps / 3) eps_3_pos) ; intros alpha Halpha ;
+ clear -HN1 HN2 Halpha eps_3_pos; destruct Halpha as (alpha_pos, Halpha).
+exists alpha ; split;[assumption | ].
+intros x x_ub x_lb x_bounds.
+simpl ; unfold R_dist.
+replace (ps_atan x - v) with ((ps_atan x - sum_f_R0 (tg_alt (Ratan_seq x)) N)
+     + (sum_f_R0 (tg_alt (Ratan_seq x)) N - sum_f_R0 (tg_alt (Ratan_seq 1)) N)
+     + (sum_f_R0 (tg_alt (Ratan_seq 1)) N - v)).
+apply Rle_lt_trans with (r2:=Rabs (ps_atan x - sum_f_R0 (tg_alt (Ratan_seq x)) N) +
+      Rabs ((sum_f_R0 (tg_alt (Ratan_seq x)) N - sum_f_R0 (tg_alt (Ratan_seq 1)) N) +
+   (sum_f_R0 (tg_alt (Ratan_seq 1)) N - v))).
+rewrite Rplus_assoc ; apply Rabs_triang.
+   replace eps with (2 / 3 * eps + eps / 3).
+   rewrite Rplus_comm.
+   apply Rplus_lt_compat.
+   apply Rle_lt_trans with (r2 := Rabs (sum_f_R0 (tg_alt (Ratan_seq x)) N - sum_f_R0 (tg_alt (Ratan_seq 1)) N) +
+      Rabs (sum_f_R0 (tg_alt (Ratan_seq 1)) N - v)).
+   apply Rabs_triang.
+   apply Rlt_le_trans with (r2:= eps / 3 + eps / 3).
+   apply Rplus_lt_compat.
+   simpl in Halpha ; unfold R_dist in Halpha.
+   apply Halpha ; split.
+   unfold D_x, no_cond ; split ; [ | apply Rgt_not_eq ] ; intuition.
+   intuition.
+   apply HN2; unfold N; omega.
+   fourier.
+  rewrite <- Rabs_Ropp, Ropp_minus_distr; apply HN1.
+     unfold N; omega.  
+    fourier.
+  assumption.
+ field.
+ring.
+Qed.
+
+Lemma Datan_eq_DatanSeq_interv : forall x, -1 < x < 1 ->
+ forall (Pratan:derivable_pt ps_atan x) (Prmymeta:derivable_pt atan x),
+      derive_pt ps_atan x Pratan = derive_pt atan x Prmymeta.
+Proof.
+assert (freq : 0 < tan 1) by apply (Rlt_trans _ _ _ Rlt_0_1 tan_1_gt_1).
+intros x x_encad Pratan Prmymeta.
+ rewrite pr_nu_var2_interv with (g:=ps_atan) (lb:=-1) (ub:=tan 1)
+   (pr2 := derivable_pt_ps_atan x x_encad).
+ rewrite pr_nu_var2_interv with (f:=atan) (g:=atan) (lb:=-1) (ub:= 1) (pr2:=derivable_pt_atan x).
+ assert (Temp := derivable_pt_lim_ps_atan x x_encad).
+ assert (Hrew1 : derive_pt ps_atan x (derivable_pt_ps_atan x x_encad) = (/(1+x^2))).
+  apply derive_pt_eq_0 ; assumption.
+  rewrite derive_pt_atan.
+  rewrite Hrew1.
+  replace (Rsqr x) with (x ^ 2) by (unfold Rsqr; ring).
+  unfold Rdiv; rewrite Rmult_1_l; reflexivity.
+     fourier.
+    assumption.
+   intros; reflexivity.
+  fourier.
+ assert (t := tan_1_gt_1); split;destruct x_encad; fourier.
+intros; reflexivity.
+Qed.
+
+Lemma atan_eq_ps_atan :
+ forall x, 0 < x < 1 -> atan x = ps_atan x.
+Proof.
+intros x x_encad.
+assert (pr1 : forall c : R, 0 < c < x -> derivable_pt (atan - ps_atan) c).
+ intros c c_encad.
+ apply derivable_pt_minus.
+  exact (derivable_pt_atan c).
+ apply derivable_pt_ps_atan.
+  destruct x_encad; destruct c_encad; split; fourier.
+assert (pr2 : forall c : R, 0 < c < x -> derivable_pt id c).
+ intros ; apply derivable_pt_id; fourier.
+assert (delta_cont : forall c : R, 0 <= c <= x -> continuity_pt (atan - ps_atan) c).
+ intros c [[c_encad1 | c_encad1 ] [c_encad2 | c_encad2]];
+        apply continuity_pt_minus.
+        apply derivable_continuous_pt ; apply derivable_pt_atan. 
+       apply derivable_continuous_pt ; apply derivable_pt_ps_atan.
+       split; destruct x_encad; fourier.
+      apply derivable_continuous_pt, derivable_pt_atan.
+     apply derivable_continuous_pt, derivable_pt_ps_atan.
+     subst c; destruct x_encad; split; fourier.
+    apply derivable_continuous_pt, derivable_pt_atan.
+   apply derivable_continuous_pt, derivable_pt_ps_atan.
+   subst c; split; fourier.
+  apply derivable_continuous_pt, derivable_pt_atan.
+ apply derivable_continuous_pt, derivable_pt_ps_atan.
+ subst c; destruct x_encad; split; fourier.
+assert (id_cont : forall c : R, 0 <= c <= x -> continuity_pt id c).
+    intros ; apply derivable_continuous ; apply derivable_id.
+assert (x_lb : 0 < x) by (destruct x_encad; fourier).
+elim (MVT (atan - ps_atan)%F id 0 x pr1 pr2 x_lb delta_cont id_cont) ; intros d Temp ; elim Temp ; intros d_encad Main.
+clear - Main x_encad.
+assert (Temp : forall (pr: derivable_pt (atan - ps_atan) d), derive_pt (atan - ps_atan) d pr = 0).
+ intro pr.
+ assert (d_encad3 : -1 < d < 1).
+  destruct d_encad; destruct x_encad; split; fourier.
+ pose (pr3 := derivable_pt_minus atan ps_atan d (derivable_pt_atan d) (derivable_pt_ps_atan d d_encad3)).
+ rewrite <- pr_nu_var2_interv with (f:=(atan - ps_atan)%F) (g:=(atan - ps_atan)%F) (lb:=0) (ub:=x) (pr1:=pr3) (pr2:=pr).
+    unfold pr3. rewrite derive_pt_minus.
+    rewrite Datan_eq_DatanSeq_interv with (Prmymeta := derivable_pt_atan d).
+     intuition.
+    assumption. 
+   destruct d_encad; fourier.
+  assumption.
+ reflexivity.
+assert (iatan0 : atan 0 = 0).
+ apply tan_is_inj.
+   apply atan_bound.
+  rewrite Ropp_div; assert (t := PI2_RGT_0); split; fourier.
+ rewrite tan_0, atan_right_inv; reflexivity.
+generalize Main; rewrite Temp, Rmult_0_r.
+replace ((atan - ps_atan)%F x) with (atan x - ps_atan x) by intuition.
+replace ((atan - ps_atan)%F 0) with (atan 0 - ps_atan 0) by intuition.
+rewrite iatan0, ps_atan0_0, !Rminus_0_r.
+replace (derive_pt id d (pr2 d d_encad)) with 1. 
+ rewrite Rmult_1_r.
+ solve[intros M; apply Rminus_diag_uniq; auto].
+rewrite pr_nu_var with (g:=id) (pr2:=derivable_pt_id d).
+ symmetry ; apply derive_pt_id.
+tauto.
+Qed.
+
+
+Theorem Alt_PI_eq : Alt_PI = PI.
+apply Rmult_eq_reg_r with (/4); fold (Alt_PI/4); fold (PI/4);
+  [ | apply Rgt_not_eq; fourier].
+assert (0 < PI/6) by (apply PI6_RGT_0).
+assert (t1:= PI2_1).
+assert (t2 := PI_4).
+assert (m := Alt_PI_RGT_0).
+assert (-PI/2 < 1 < PI/2) by (rewrite Ropp_div; split; fourier).
+apply cond_eq; intros eps ep.
+change (R_dist (Alt_PI/4) (PI/4) < eps).
+assert (ca : continuity_pt atan 1).
+  apply derivable_continuous_pt, derivable_pt_atan.
+assert (Xe : exists eps', exists eps'',
+  eps' + eps'' <= eps /\ 0 < eps' /\ 0 < eps'').
+ exists (eps/2); exists (eps/2); repeat apply conj; fourier.
+destruct Xe as [eps' [eps'' [eps_ineq [ep' ep'']]]].
+destruct (ps_atan_continuity_pt_1 _ ep') as [alpha [a0 Palpha]].
+destruct (ca _ ep'') as [beta [b0 Pbeta]].
+assert (Xa : exists a, 0 < a < 1 /\ R_dist a 1 < alpha /\
+                R_dist a 1 < beta).
+ exists (Rmax (/2) (Rmax (1 - alpha /2) (1 - beta /2))).
+ assert (/2 <= Rmax (/2) (Rmax (1 - alpha /2) (1 - beta /2))) by apply Rmax_l.
+ assert (Rmax (1 - alpha /2) (1 - beta /2) <=
+         Rmax (/2) (Rmax (1 - alpha /2) (1 - beta /2))) by apply Rmax_r.
+ assert ((1 - alpha /2) <= Rmax (1 - alpha /2) (1 - beta /2)) by apply Rmax_l.
+ assert ((1 - beta /2) <= Rmax (1 - alpha /2) (1 - beta /2)) by apply Rmax_r.
+ assert (Rmax (1 - alpha /2) (1 - beta /2) < 1)
+   by (apply Rmax_lub_lt; fourier).
+ split;[split;[ | apply Rmax_lub_lt]; fourier | ].
+ assert (0 <= 1 - Rmax (/ 2) (Rmax (1 - alpha / 2) (1 - beta / 2))).
+  assert (Rmax (/2) (Rmax (1 - alpha / 2) 
+            (1 - beta /2)) <= 1) by (apply Rmax_lub; fourier).
+  fourier.
+ split; unfold R_dist; rewrite <-Rabs_Ropp, Ropp_minus_distr,
+   Rabs_pos_eq;fourier.
+destruct Xa as [a [[Pa0 Pa1] [P1 P2]]].
+apply Rle_lt_trans with (1 := R_dist_tri _ _ (ps_atan a)).
+apply Rlt_le_trans with (2 := eps_ineq).
+apply Rplus_lt_compat.
+rewrite R_dist_sym; apply Palpha; assumption.
+rewrite <- atan_eq_ps_atan.
+ rewrite <- atan_1; apply (Pbeta a); auto.
+ split; [ | exact P2].
+split;[exact I | apply Rgt_not_eq; assumption].
+split; assumption.
+Qed.
+
+Lemma PI_ineq :
+  forall N : nat,
+    sum_f_R0 (tg_alt PI_tg) (S (2 * N)) <= PI / 4 <=
+    sum_f_R0 (tg_alt PI_tg) (2 * N).
+Proof.
+intros; rewrite <- Alt_PI_eq; apply Alt_PI_ineq.
+Qed.
+
diff --git a/theories/Reals/Raxioms.v b/theories/Reals/Raxioms.v
index b6286c0d..200019a8 100644
--- a/theories/Reals/Raxioms.v
+++ b/theories/Reals/Raxioms.v
@@ -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-2012     *)
 (*   \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             *)
 (*********************************************************)
 
 Require Export ZArith_base.
 Require Export Rdefinitions.
-Open Local Scope R_scope.
+Local Open Scope R_scope.
 
 (*********************************************************)
 (** *            Field axioms                            *)
@@ -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.
 
 
 (**********************************************************)
@@ -124,10 +122,10 @@ Arguments Scope INR [nat_scope].
 Definition IZR (z:Z) : R :=
   match z with
   | Z0 => 0
-  | Zpos n => INR (nat_of_P n)
-  | Zneg n => - INR (nat_of_P n)
+  | Zpos n => INR (Pos.to_nat n)
+  | Zneg n => - INR (Pos.to_nat 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..29715ed9 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-2012     *)
 (*   \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..560f389b 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-2012     *)
 (*   \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            *)
 (*                                                       *)
@@ -47,10 +45,10 @@ Qed.
 (*********)
 Lemma Rmin_Rgt_l : forall r1 r2 r, Rmin r1 r2 > r -> r1 > r /\ r2 > r.
 Proof.
-  intros r1 r2 r; unfold Rmin in |- *; case (Rle_dec r1 r2); intros.
+  intros r1 r2 r; unfold Rmin; case (Rle_dec r1 r2); intros.
   split.
   assumption.
-  unfold Rgt in |- *; unfold Rgt in H; exact (Rlt_le_trans r r1 r2 H r0).
+  unfold Rgt; unfold Rgt in H; exact (Rlt_le_trans r r1 r2 H r0).
   split.
   generalize (Rnot_le_lt r1 r2 n); intro; exact (Rgt_trans r1 r2 r H0 H).
   assumption.
@@ -59,7 +57,7 @@ Qed.
 (*********)
 Lemma Rmin_Rgt_r : forall r1 r2 r, r1 > r /\ r2 > r -> Rmin r1 r2 > r.
 Proof.
-  intros; unfold Rmin in |- *; case (Rle_dec r1 r2); elim H; clear H; intros;
+  intros; unfold Rmin; case (Rle_dec r1 r2); elim H; clear H; intros;
     assumption.
 Qed.
 
@@ -74,14 +72,14 @@ Qed.
 (*********)
 Lemma Rmin_l : forall x y:R, Rmin x y <= x.
 Proof.
-  intros; unfold Rmin in |- *; case (Rle_dec x y); intro H1;
+  intros; unfold Rmin; case (Rle_dec x y); intro H1;
     [ right; reflexivity | auto with real ].
 Qed.
 
 (*********)
 Lemma Rmin_r : forall x y:R, Rmin x y <= y.
 Proof.
-  intros; unfold Rmin in |- *; case (Rle_dec x y); intro H1;
+  intros; unfold Rmin; case (Rle_dec x y); intro H1;
     [ assumption | auto with real ].
 Qed.
 
@@ -125,20 +123,20 @@ Qed.
 (*********)
 Lemma Rmin_pos : forall x y:R, 0 < x -> 0 < y -> 0 < Rmin x y.
 Proof.
-  intros; unfold Rmin in |- *.
+  intros; unfold Rmin.
   case (Rle_dec x y); intro; assumption.
 Qed.
 
 (*********)
 Lemma Rmin_glb : forall x y z:R, z <= x -> z <= y -> z <= Rmin x y.
 Proof.
-  intros; unfold Rmin in |- *; case (Rle_dec x y); intro; assumption.
+  intros; unfold Rmin; case (Rle_dec x y); intro; assumption.
 Qed.
 
 (*********)
 Lemma Rmin_glb_lt : forall x y z:R, z < x -> z < y -> z < Rmin x y.
 Proof.
-  intros; unfold Rmin in |- *; case (Rle_dec x y); intro; assumption.
+  intros; unfold Rmin; case (Rle_dec x y); intro; assumption.
 Qed.
 
 (*******************************)
@@ -169,8 +167,8 @@ Qed.
 Lemma Rmax_Rle : forall r1 r2 r, r <= Rmax r1 r2 <-> r <= r1 \/ r <= r2.
 Proof.
   intros; split.
-  unfold Rmax in |- *; case (Rle_dec r1 r2); intros; auto.
-  intro; unfold Rmax in |- *; case (Rle_dec r1 r2); elim H; clear H; intros;
+  unfold Rmax; case (Rle_dec r1 r2); intros; auto.
+  intro; unfold Rmax; case (Rle_dec r1 r2); elim H; clear H; intros;
     auto.
   apply (Rle_trans r r1 r2); auto.
   generalize (Rnot_le_lt r1 r2 n); clear n; intro; unfold Rgt in H0;
@@ -179,7 +177,7 @@ Qed.
 
 Lemma Rmax_comm : forall x y:R, Rmax x y = Rmax y x.
 Proof.
-  intros p q; unfold Rmax in |- *; case (Rle_dec p q); case (Rle_dec q p); auto;
+  intros p q; unfold Rmax; case (Rle_dec p q); case (Rle_dec q p); auto;
     intros H1 H2; apply Rle_antisym; auto with real.
 Qed.
 
@@ -190,14 +188,14 @@ Notation RmaxSym := Rmax_comm (only parsing).
 (*********)
 Lemma Rmax_l : forall x y:R, x <= Rmax x y.
 Proof.
-  intros; unfold Rmax in |- *; case (Rle_dec x y); intro H1;
+  intros; unfold Rmax; case (Rle_dec x y); intro H1;
     [ assumption | auto with real ].
 Qed.
 
 (*********)
 Lemma Rmax_r : forall x y:R, y <= Rmax x y.
 Proof.
-  intros; unfold Rmax in |- *; case (Rle_dec x y); intro H1;
+  intros; unfold Rmax; case (Rle_dec x y); intro H1;
     [ right; reflexivity | auto with real ].
 Qed.
 
@@ -234,7 +232,7 @@ Qed.
 Lemma RmaxRmult :
   forall (p q:R) r, 0 <= r -> Rmax (r * p) (r * q) = r * Rmax p q.
 Proof.
-  intros p q r H; unfold Rmax in |- *.
+  intros p q r H; unfold Rmax.
   case (Rle_dec p q); case (Rle_dec (r * p) (r * q)); auto; intros H1 H2; auto.
   case H; intros E1.
   case H1; auto with real.
@@ -248,7 +246,7 @@ Qed.
 (*********)
 Lemma Rmax_stable_in_negreal : forall x y:negreal, Rmax x y < 0.
 Proof.
-  intros; unfold Rmax in |- *; case (Rle_dec x y); intro;
+  intros; unfold Rmax; case (Rle_dec x y); intro;
     [ apply (cond_neg y) | apply (cond_neg x) ].
 Qed.
 
@@ -267,7 +265,7 @@ Qed.
 (*********)
 Lemma Rmax_neg : forall x y:R, x < 0 -> y < 0 -> Rmax x y < 0.
 Proof.
-  intros; unfold Rmax in |- *.
+  intros; unfold Rmax.
   case (Rle_dec x y); intro; assumption.
 Qed.
 
@@ -280,7 +278,7 @@ Lemma Rcase_abs : forall r, {r < 0} + {r >= 0}.
 Proof.
   intro; generalize (Rle_dec 0 r); intro X; elim X; intro; clear X.
   right; apply (Rle_ge 0 r a).
-  left; fold (0 > r) in |- *; apply (Rnot_le_lt 0 r b).
+  left; fold (0 > r); apply (Rnot_le_lt 0 r b).
 Qed.
 
 (*********)
@@ -293,27 +291,27 @@ Definition Rabs r : R :=
 (*********)
 Lemma Rabs_R0 : Rabs 0 = 0.
 Proof.
-  unfold Rabs in |- *; case (Rcase_abs 0); auto; intro.
+  unfold Rabs; case (Rcase_abs 0); auto; intro.
   generalize (Rlt_irrefl 0); intro; exfalso; auto.
 Qed.
 
 Lemma Rabs_R1 : Rabs 1 = 1.
 Proof.
-unfold Rabs in |- *; case (Rcase_abs 1); auto with real.
+unfold Rabs; case (Rcase_abs 1); auto with real.
 intros H; absurd (1 < 0); auto with real.
 Qed.
 
 (*********)
 Lemma Rabs_no_R0 : forall r, r <> 0 -> Rabs r <> 0.
 Proof.
-  intros; unfold Rabs in |- *; case (Rcase_abs r); intro; auto.
+  intros; unfold Rabs; case (Rcase_abs r); intro; auto.
   apply Ropp_neq_0_compat; auto.
 Qed.
 
 (*********)
 Lemma Rabs_left : forall r, r < 0 -> Rabs r = - r.
 Proof.
-  intros; unfold Rabs in |- *; case (Rcase_abs r); trivial; intro;
+  intros; unfold Rabs; case (Rcase_abs r); trivial; intro;
     absurd (r >= 0).
   exact (Rlt_not_ge r 0 H).
   assumption.
@@ -322,7 +320,7 @@ Qed.
 (*********)
 Lemma Rabs_right : forall r, r >= 0 -> Rabs r = r.
 Proof.
-  intros; unfold Rabs in |- *; case (Rcase_abs r); intro.
+  intros; unfold Rabs; case (Rcase_abs r); intro.
   absurd (r >= 0).
   exact (Rlt_not_ge r 0 r0).
   assumption.
@@ -333,21 +331,21 @@ Lemma Rabs_left1 : forall a:R, a <= 0 -> Rabs a = - a.
 Proof.
   intros a H; case H; intros H1.
   apply Rabs_left; auto.
-  rewrite H1; simpl in |- *; rewrite Rabs_right; auto with real.
+  rewrite H1; simpl; rewrite Rabs_right; auto with real.
 Qed.
 
 (*********)
 Lemma Rabs_pos : forall x:R, 0 <= Rabs x.
 Proof.
-  intros; unfold Rabs in |- *; case (Rcase_abs x); intro.
+  intros; unfold Rabs; case (Rcase_abs x); intro.
   generalize (Ropp_lt_gt_contravar x 0 r); intro; unfold Rgt in H;
-    rewrite Ropp_0 in H; unfold Rle in |- *; left; assumption.
+    rewrite Ropp_0 in H; unfold Rle; left; assumption.
   apply Rge_le; assumption.
 Qed.
 
 Lemma Rle_abs : forall x:R, x <= Rabs x.
 Proof.
-  intro; unfold Rabs in |- *; case (Rcase_abs x); intros; fourier.
+  intro; unfold Rabs; case (Rcase_abs x); intros; fourier.
 Qed.
 
 Definition RRle_abs := Rle_abs.
@@ -355,7 +353,7 @@ Definition RRle_abs := Rle_abs.
 (*********)
 Lemma Rabs_pos_eq : forall x:R, 0 <= x -> Rabs x = x.
 Proof.
-  intros; unfold Rabs in |- *; case (Rcase_abs x); intro;
+  intros; unfold Rabs; case (Rcase_abs x); intro;
     [ generalize (Rgt_not_le 0 x r); intro; exfalso; auto | trivial ].
 Qed.
 
@@ -370,7 +368,7 @@ Lemma Rabs_pos_lt : forall x:R, x <> 0 -> 0 < Rabs x.
 Proof.
   intros; generalize (Rabs_pos x); intro; unfold Rle in H0; elim H0; intro;
     auto.
-  exfalso; clear H0; elim H; clear H; generalize H1; unfold Rabs in |- *;
+  exfalso; clear H0; elim H; clear H; generalize H1; unfold Rabs;
     case (Rcase_abs x); intros; auto.
   clear r H1; generalize (Rplus_eq_compat_l x 0 (- x) H0);
     rewrite (let (H1, H2) := Rplus_ne x in H1); rewrite (Rplus_opp_r x);
@@ -380,7 +378,7 @@ Qed.
 (*********)
 Lemma Rabs_minus_sym : forall x y:R, Rabs (x - y) = Rabs (y - x).
 Proof.
-  intros; unfold Rabs in |- *; case (Rcase_abs (x - y));
+  intros; unfold Rabs; case (Rcase_abs (x - y));
     case (Rcase_abs (y - x)); intros.
   generalize (Rminus_lt y x r); generalize (Rminus_lt x y r0); intros;
     generalize (Rlt_asym x y H); intro; exfalso;
@@ -399,7 +397,7 @@ Qed.
 (*********)
 Lemma Rabs_mult : forall x y:R, Rabs (x * y) = Rabs x * Rabs y.
 Proof.
-  intros; unfold Rabs in |- *; case (Rcase_abs (x * y)); case (Rcase_abs x);
+  intros; unfold Rabs; case (Rcase_abs (x * y)); case (Rcase_abs x);
     case (Rcase_abs y); intros; auto.
   generalize (Rmult_lt_gt_compat_neg_l y x 0 r r0); intro;
     rewrite (Rmult_0_r y) in H; generalize (Rlt_asym (x * y) 0 r1);
@@ -450,7 +448,7 @@ Qed.
 (*********)
 Lemma Rabs_Rinv : forall r, r <> 0 -> Rabs (/ r) = / Rabs r.
 Proof.
-  intro; unfold Rabs in |- *; case (Rcase_abs r); case (Rcase_abs (/ r)); auto;
+  intro; unfold Rabs; case (Rcase_abs r); case (Rcase_abs (/ r)); auto;
     intros.
   apply Ropp_inv_permute; auto.
   generalize (Rinv_lt_0_compat r r1); intro; unfold Rge in r0; elim r0; intros.
@@ -472,7 +470,7 @@ Proof.
   cut (Rabs (-1) = 1).
   intros; rewrite H0.
   ring.
-  unfold Rabs in |- *; case (Rcase_abs (-1)).
+  unfold Rabs; case (Rcase_abs (-1)).
   intro; ring.
   intro H0; generalize (Rge_le (-1) 0 H0); intros.
   generalize (Ropp_le_ge_contravar 0 (-1) H1).
@@ -485,13 +483,13 @@ Qed.
 (*********)
 Lemma Rabs_triang : forall a b:R, Rabs (a + b) <= Rabs a + Rabs b.
 Proof.
-  intros a b; unfold Rabs in |- *; case (Rcase_abs (a + b)); case (Rcase_abs a);
+  intros a b; unfold Rabs; case (Rcase_abs (a + b)); case (Rcase_abs a);
     case (Rcase_abs b); intros.
   apply (Req_le (- (a + b)) (- a + - b)); rewrite (Ropp_plus_distr a b);
     reflexivity.
 (**)
   rewrite (Ropp_plus_distr a b); apply (Rplus_le_compat_l (- a) (- b) b);
-    unfold Rle in |- *; unfold Rge in r; elim r; intro.
+    unfold Rle; unfold Rge in r; elim r; intro.
   left; unfold Rgt in H; generalize (Rplus_lt_compat_l (- b) 0 b H); intro;
     elim (Rplus_ne (- b)); intros v w; rewrite v in H0;
       clear v w; rewrite (Rplus_opp_l b) in H0; apply (Rlt_trans (- b) 0 b H0 H).
@@ -499,7 +497,7 @@ Proof.
 (**)
   rewrite (Ropp_plus_distr a b); rewrite (Rplus_comm (- a) (- b));
     rewrite (Rplus_comm a (- b)); apply (Rplus_le_compat_l (- b) (- a) a);
-      unfold Rle in |- *; unfold Rge in r0; elim r0; intro.
+      unfold Rle; unfold Rge in r0; elim r0; intro.
   left; unfold Rgt in H; generalize (Rplus_lt_compat_l (- a) 0 a H); intro;
     elim (Rplus_ne (- a)); intros v w; rewrite v in H0;
       clear v w; rewrite (Rplus_opp_l a) in H0; apply (Rlt_trans (- a) 0 a H0 H).
@@ -523,27 +521,27 @@ Proof.
 (**)
   rewrite (Rplus_comm a b); rewrite (Rplus_comm (- a) b);
     apply (Rplus_le_compat_l b a (- a)); apply (Rminus_le a (- a));
-      unfold Rminus in |- *; rewrite (Ropp_involutive a);
+      unfold Rminus; rewrite (Ropp_involutive a);
         generalize (Rplus_lt_compat_l a a 0 r0); clear r r1;
           intro; elim (Rplus_ne a); intros v w; rewrite v in H;
             clear v w; generalize (Rlt_trans (a + a) a 0 H r0);
               intro; apply (Rlt_le (a + a) 0 H0).
 (**)
   apply (Rplus_le_compat_l a b (- b)); apply (Rminus_le b (- b));
-    unfold Rminus in |- *; rewrite (Ropp_involutive b);
+    unfold Rminus; rewrite (Ropp_involutive b);
       generalize (Rplus_lt_compat_l b b 0 r); clear r0 r1;
         intro; elim (Rplus_ne b); intros v w; rewrite v in H;
           clear v w; generalize (Rlt_trans (b + b) b 0 H r);
             intro; apply (Rlt_le (b + b) 0 H0).
 (**)
-  unfold Rle in |- *; right; reflexivity.
+  unfold Rle; right; reflexivity.
 Qed.
 
 (*********)
 Lemma Rabs_triang_inv : forall a b:R, Rabs a - Rabs b <= Rabs (a - b).
 Proof.
   intros; apply (Rplus_le_reg_l (Rabs b) (Rabs a - Rabs b) (Rabs (a - b)));
-    unfold Rminus in |- *; rewrite <- (Rplus_assoc (Rabs b) (Rabs a) (- Rabs b));
+    unfold Rminus; rewrite <- (Rplus_assoc (Rabs b) (Rabs a) (- Rabs b));
       rewrite (Rplus_comm (Rabs b) (Rabs a));
         rewrite (Rplus_assoc (Rabs a) (Rabs b) (- Rabs b));
           rewrite (Rplus_opp_r (Rabs b)); rewrite (proj1 (Rplus_ne (Rabs a)));
@@ -563,7 +561,7 @@ Proof.
   rewrite <- (Rabs_Ropp (Rabs a - Rabs b)); rewrite <- (Rabs_Ropp (a - b));
     do 2 rewrite Ropp_minus_distr.
   apply H; left; assumption.
-  rewrite Heq; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+  rewrite Heq; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0;
     apply Rabs_pos.
   apply H; left; assumption.
   intros; replace (Rabs (Rabs a - Rabs b)) with (Rabs a - Rabs b).
@@ -578,8 +576,8 @@ Qed.
 (*********)
 Lemma Rabs_def1 : forall x a:R, x < a -> - a < x -> Rabs x < a.
 Proof.
-  unfold Rabs in |- *; intros; case (Rcase_abs x); intro.
-  generalize (Ropp_lt_gt_contravar (- a) x H0); unfold Rgt in |- *;
+  unfold Rabs; intros; case (Rcase_abs x); intro.
+  generalize (Ropp_lt_gt_contravar (- a) x H0); unfold Rgt;
     rewrite Ropp_involutive; intro; assumption.
   assumption.
 Qed.
@@ -587,15 +585,15 @@ Qed.
 (*********)
 Lemma Rabs_def2 : forall x a:R, Rabs x < a -> x < a /\ - a < x.
 Proof.
-  unfold Rabs in |- *; intro x; case (Rcase_abs x); intros.
-  generalize (Ropp_gt_lt_0_contravar x r); unfold Rgt in |- *; intro;
+  unfold Rabs; intro x; case (Rcase_abs x); intros.
+  generalize (Ropp_gt_lt_0_contravar x r); unfold Rgt; intro;
     generalize (Rlt_trans 0 (- x) a H0 H); intro; split.
   apply (Rlt_trans x 0 a r H1).
   generalize (Ropp_lt_gt_contravar (- x) a H); rewrite (Ropp_involutive x);
-    unfold Rgt in |- *; trivial.
+    unfold Rgt; trivial.
   fold (a > x) in H; generalize (Rgt_ge_trans a x 0 H r); intro;
-    generalize (Ropp_lt_gt_0_contravar a H0); intro; fold (0 > - a) in |- *;
-      generalize (Rge_gt_trans x 0 (- a) r H1); unfold Rgt in |- *;
+    generalize (Ropp_lt_gt_0_contravar a H0); intro; fold (0 > - a);
+      generalize (Rge_gt_trans x 0 (- a) r H1); unfold Rgt;
         intro; split; assumption.
 Qed.
 
@@ -625,16 +623,16 @@ Proof.
   apply RmaxLess1; auto.
 Qed.
 
-Lemma Rabs_Zabs : forall z:Z, Rabs (IZR z) = IZR (Zabs z).
+Lemma Rabs_Zabs : forall z:Z, Rabs (IZR z) = IZR (Z.abs z).
 Proof.
-  intros z; case z; simpl in |- *; auto with real.
+  intros z; case z; simpl; auto with real.
   apply Rabs_right; auto with real.
   intros p0; apply Rabs_right; auto with real zarith.
   intros p0; rewrite Rabs_Ropp.
   apply Rabs_right; auto with real zarith.
 Qed.
 
-Lemma abs_IZR : forall z, IZR (Zabs z) = Rabs (IZR z).
+Lemma abs_IZR : forall z, IZR (Z.abs z) = Rabs (IZR z).
 Proof.
   intros.
   now rewrite Rabs_Zabs.
diff --git a/theories/Reals/Rcomplete.v b/theories/Reals/Rcomplete.v
index f6d40631..8e0e0692 100644
--- a/theories/Reals/Rcomplete.v
+++ b/theories/Reals/Rcomplete.v
@@ -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-2012     *)
 (*   \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.
 Require Import SeqProp.
 Require Import Max.
-Open Local Scope R_scope.
+Local Open Scope R_scope.
 
 (****************************************************)
 (*              R is complete :                     *)
@@ -39,7 +37,7 @@ Proof.
   intros.
   exists x.
   rewrite <- H2 in p0.
-  unfold Un_cv in |- *.
+  unfold Un_cv.
   intros.
   unfold Un_cv in p; unfold Un_cv in p0.
   cut (0 < eps / 3).
@@ -48,7 +46,7 @@ Proof.
   elim (p0 (eps / 3) H4); intros.
   exists (max x1 x2).
   intros.
-  unfold R_dist in |- *.
+  unfold R_dist.
   apply Rle_lt_trans with (Rabs (Un n - Vn n) + Rabs (Vn n - x)).
   replace (Un n - x) with (Un n - Vn n + (Vn n - x));
   [ apply Rabs_triang | ring ].
@@ -56,14 +54,14 @@ Proof.
   do 2 rewrite <- (Rplus_comm (Rabs (Vn n - x))).
   apply Rplus_le_compat_l.
   repeat rewrite Rabs_right.
-  unfold Rminus in |- *; do 2 rewrite <- (Rplus_comm (- Vn n));
+  unfold Rminus; do 2 rewrite <- (Rplus_comm (- Vn n));
     apply Rplus_le_compat_l.
   assert (H8 := Vn_Un_Wn_order Un (cauchy_maj Un H) (cauchy_min Un H)).
   fold Vn Wn in H8.
   elim (H8 n); intros.
   assumption.
   apply Rle_ge.
-  unfold Rminus in |- *; apply Rplus_le_reg_l with (Vn n).
+  unfold Rminus; apply Rplus_le_reg_l with (Vn n).
   rewrite Rplus_0_r.
   replace (Vn n + (Wn n + - Vn n)) with (Wn n); [ idtac | ring ].
   assert (H8 := Vn_Un_Wn_order Un (cauchy_maj Un H) (cauchy_min Un H)).
@@ -71,7 +69,7 @@ Proof.
   elim (H8 n); intros.
   apply Rle_trans with (Un n); assumption.
   apply Rle_ge.
-  unfold Rminus in |- *; apply Rplus_le_reg_l with (Vn n).
+  unfold Rminus; apply Rplus_le_reg_l with (Vn n).
   rewrite Rplus_0_r.
   replace (Vn n + (Un n + - Vn n)) with (Un n); [ idtac | ring ].
   assert (H8 := Vn_Un_Wn_order Un (cauchy_maj Un H) (cauchy_min Un H)).
@@ -87,26 +85,26 @@ Proof.
   repeat apply Rplus_lt_compat.
   unfold R_dist in H5.
   apply H5.
-  unfold ge in |- *; apply le_trans with (max x1 x2).
+  unfold ge; apply le_trans with (max x1 x2).
   apply le_max_l.
   assumption.
   rewrite <- Rabs_Ropp.
   replace (- (x - Vn n)) with (Vn n - x); [ idtac | ring ].
   unfold R_dist in H6.
   apply H6.
-  unfold ge in |- *; apply le_trans with (max x1 x2).
+  unfold ge; apply le_trans with (max x1 x2).
   apply le_max_r.
   assumption.
   unfold R_dist in H6.
   apply H6.
-  unfold ge in |- *; apply le_trans with (max x1 x2).
+  unfold ge; apply le_trans with (max x1 x2).
   apply le_max_r.
   assumption.
   right.
-  pattern eps at 4 in |- *; replace eps with (3 * (eps / 3)).
+  pattern eps at 4; replace eps with (3 * (eps / 3)).
   ring.
-  unfold Rdiv in |- *; rewrite <- Rmult_assoc; apply Rinv_r_simpl_m; discrR.
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+  unfold Rdiv; rewrite <- Rmult_assoc; apply Rinv_r_simpl_m; discrR.
+  unfold Rdiv; apply Rmult_lt_0_compat;
     [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
   apply cond_eq.
   intros.
@@ -132,10 +130,10 @@ Proof.
   repeat apply Rplus_lt_compat.
   rewrite <- Rabs_Ropp.
   replace (- (x - Wn N)) with (Wn N - x); [ apply H4 | ring ].
-  unfold ge, N in |- *.
+  unfold ge, N.
   apply le_trans with (max N1 N2); apply le_max_l.
-  unfold Wn, Vn in |- *.
-  unfold sequence_majorant, sequence_minorant in |- *.
+  unfold Wn, Vn.
+  unfold sequence_majorant, sequence_minorant.
   assert
     (H7 :=
       approx_maj (fun k:nat => Un (N + k)%nat) (maj_ss Un N (cauchy_maj Un H))).
@@ -171,13 +169,13 @@ Proof.
   [ repeat apply Rplus_lt_compat | ring ].
   assumption.
   apply H6.
-  unfold ge in |- *.
+  unfold ge.
   apply le_trans with N.
-  unfold N in |- *; apply le_max_r.
+  unfold N; apply le_max_r.
   apply le_plus_l.
-  unfold ge in |- *.
+  unfold ge.
   apply le_trans with N.
-  unfold N in |- *; apply le_max_r.
+  unfold N; apply le_max_r.
   apply le_plus_l.
   rewrite <- Rabs_Ropp.
   replace (- (Un (N + k1)%nat - Vn N)) with (Vn N - Un (N + k1)%nat);
@@ -185,14 +183,14 @@ Proof.
   reflexivity.
   reflexivity.
   apply H5.
-  unfold ge in |- *; apply le_trans with (max N1 N2).
+  unfold ge; apply le_trans with (max N1 N2).
   apply le_max_r.
-  unfold N in |- *; apply le_max_l.
-  pattern eps at 4 in |- *; replace eps with (5 * (eps / 5)).
+  unfold N; apply le_max_l.
+  pattern eps at 4; replace eps with (5 * (eps / 5)).
   ring.
-  unfold Rdiv in |- *; rewrite <- Rmult_assoc; apply Rinv_r_simpl_m.
+  unfold Rdiv; rewrite <- Rmult_assoc; apply Rinv_r_simpl_m.
   discrR.
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+  unfold Rdiv; apply Rmult_lt_0_compat.
   assumption.
   apply Rinv_0_lt_compat.
   prove_sup0; try apply lt_O_Sn.
diff --git a/theories/Reals/Rdefinitions.v b/theories/Reals/Rdefinitions.v
index d06e2d1b..f7d03ed8 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-2012     *)
 (*   \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          *)
@@ -23,7 +21,7 @@ Delimit Scope R_scope with R.
 (* Automatically open scope R_scope for arguments of type R *)
 Bind Scope R_scope with R.
 
-Open Local Scope R_scope.
+Local Open Scope R_scope.
 
 Parameter R0 : R.
 Parameter R1 : R.
diff --git a/theories/Reals/Rderiv.v b/theories/Reals/Rderiv.v
index 701914ac..e714f5f8 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-2012     *)
 (*   \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,10 +15,8 @@ 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.
+Local Open Scope R_scope.
 
 (*********)
 Definition D_x (D:R -> Prop) (y x:R) : Prop := D x /\ y <> x.
@@ -38,18 +34,18 @@ Lemma cont_deriv :
   forall (f d:R -> R) (D:R -> Prop) (x0:R),
     D_in f d D x0 -> continue_in f D x0.
 Proof.
-  unfold continue_in in |- *; unfold D_in in |- *; unfold limit1_in in |- *;
-    unfold limit_in in |- *; unfold Rdiv in |- *; simpl in |- *;
+  unfold continue_in; unfold D_in; unfold limit1_in;
+    unfold limit_in; unfold Rdiv; simpl;
       intros; elim (H eps H0); clear H; intros; elim H;
         clear H; intros; elim (Req_dec (d x0) 0); intro.
   split with (Rmin 1 x); split.
   elim (Rmin_Rgt 1 x 0); intros a b; apply (b (conj Rlt_0_1 H)).
   intros; elim H3; clear H3; intros;
     generalize (let (H1, H2) := Rmin_Rgt 1 x (R_dist x1 x0) in H1);
-      unfold Rgt in |- *; intro; elim (H5 H4); clear H5;
+      unfold Rgt; intro; elim (H5 H4); clear H5;
         intros; generalize (H1 x1 (conj H3 H6)); clear H1;
           intro; unfold D_x in H3; elim H3; intros.
-  rewrite H2 in H1; unfold R_dist in |- *; unfold R_dist in H1;
+  rewrite H2 in H1; unfold R_dist; unfold R_dist in H1;
     cut (Rabs (f x1 - f x0) < eps * Rabs (x1 - x0)).
   intro; unfold R_dist in H5;
     generalize (Rmult_lt_compat_l eps (Rabs (x1 - x0)) 1 H0 H5);
@@ -72,7 +68,7 @@ Proof.
   intros; elim (Rmin_Rgt (Rmin (/ 2) x) (eps * / Rabs (2 * d x0)) 0);
     intros a b; apply (b (conj H4 H3)).
   apply Rmult_gt_0_compat; auto.
-  unfold Rgt in |- *; apply Rinv_0_lt_compat; apply Rabs_pos_lt;
+  unfold Rgt; apply Rinv_0_lt_compat; apply Rabs_pos_lt;
     apply Rmult_integral_contrapositive; split.
   discrR.
   assumption.
@@ -84,17 +80,17 @@ Proof.
     generalize
       (let (H1, H2) :=
         Rmin_Rgt (Rmin (/ 2) x) (eps * / Rabs (2 * d x0)) (R_dist x1 x0) in
-        H1); unfold Rgt in |- *; intro; elim (H5 H4); clear H5;
+        H1); unfold Rgt; intro; elim (H5 H4); clear H5;
       intros; generalize (let (H1, H2) := Rmin_Rgt (/ 2) x (R_dist x1 x0) in H1);
-        unfold Rgt in |- *; intro; elim (H7 H5); clear H7;
+        unfold Rgt; intro; elim (H7 H5); clear H7;
           intros; clear H4 H5; generalize (H1 x1 (conj H3 H8));
             clear H1; intro; unfold D_x in H3; elim H3; intros;
-              generalize (sym_not_eq H5); clear H5; intro H5;
+              generalize (not_eq_sym H5); clear H5; intro H5;
                 generalize (Rminus_eq_contra x1 x0 H5); intro; generalize H1;
-                  pattern (d x0) at 1 in |- *;
+                  pattern (d x0) at 1;
                     rewrite <- (let (H1, H2) := Rmult_ne (d x0) in H2);
-                      rewrite <- (Rinv_l (x1 - x0) H9); unfold R_dist in |- *;
-                        unfold Rminus at 1 in |- *; rewrite (Rmult_comm (f x1 - f x0) (/ (x1 - x0)));
+                      rewrite <- (Rinv_l (x1 - x0) H9); unfold R_dist;
+                        unfold Rminus at 1; rewrite (Rmult_comm (f x1 - f x0) (/ (x1 - x0)));
                           rewrite (Rmult_comm (/ (x1 - x0) * (x1 - x0)) (d x0));
                             rewrite <- (Ropp_mult_distr_l_reverse (d x0) (/ (x1 - x0) * (x1 - x0)));
                               rewrite (Rmult_comm (- d x0) (/ (x1 - x0) * (x1 - x0)));
@@ -117,7 +113,7 @@ Proof.
                                                   ; generalize (Rabs_triang_inv (f x1 - f x0) ((x1 - x0) * d x0));
                                                     intro; rewrite (Rmult_comm (x1 - x0) (- d x0));
                                                       rewrite (Ropp_mult_distr_l_reverse (d x0) (x1 - x0));
-                                                        fold (f x1 - f x0 - d x0 * (x1 - x0)) in |- *;
+                                                        fold (f x1 - f x0 - d x0 * (x1 - x0));
                                                           rewrite (Rmult_comm (x1 - x0) (d x0)) in H10; clear H1;
                                                             intro;
                                                               generalize
@@ -127,7 +123,7 @@ Proof.
                                                                   generalize
                                                                     (Rplus_lt_compat_l (Rabs (d x0 * (x1 - x0)))
                                                                       (Rabs (f x1 - f x0) - Rabs (d x0 * (x1 - x0))) (
-                                                                        Rabs (x1 - x0) * eps) H1); unfold Rminus at 2 in |- *;
+                                                                        Rabs (x1 - x0) * eps) H1); unfold Rminus at 2;
                                                                     rewrite (Rplus_comm (Rabs (f x1 - f x0)) (- Rabs (d x0 * (x1 - x0))));
                                                                       rewrite <-
                                                                         (Rplus_assoc (Rabs (d x0 * (x1 - x0))) (- Rabs (d x0 * (x1 - x0)))
@@ -166,27 +162,26 @@ Proof.
       (Rplus_lt_compat (Rabs (d x0 * (x1 - x0))) (eps * / 2)
         (Rabs (x1 - x0) * eps) (eps * / 2) H5 H3); intro;
       rewrite eps2 in H10; assumption.
-  unfold Rabs in |- *; case (Rcase_abs 2); auto.
+  unfold Rabs; 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.
 Proof.
-  unfold D_in in |- *; intros; unfold limit1_in in |- *;
-    unfold limit_in in |- *; unfold Rdiv in |- *; intros;
-      simpl in |- *; split with eps; split; auto.
-  intros; rewrite (Rminus_diag_eq y y (refl_equal y)); rewrite Rmult_0_l;
-    unfold R_dist in |- *; rewrite (Rminus_diag_eq 0 0 (refl_equal 0));
-      unfold Rabs in |- *; case (Rcase_abs 0); intro.
+  unfold D_in; intros; unfold limit1_in;
+    unfold limit_in; unfold Rdiv; intros;
+      simpl; split with eps; split; auto.
+  intros; rewrite (Rminus_diag_eq y y (eq_refl y)); rewrite Rmult_0_l;
+    unfold R_dist; rewrite (Rminus_diag_eq 0 0 (eq_refl 0));
+      unfold Rabs; case (Rcase_abs 0); intro.
   absurd (0 < 0); auto.
-  red in |- *; intro; apply (Rlt_irrefl 0 H1).
+  red; intro; apply (Rlt_irrefl 0 H1).
   unfold Rgt in H0; assumption.
 Qed.
 
@@ -194,15 +189,15 @@ Qed.
 Lemma Dx :
   forall (D:R -> Prop) (x0:R), D_in (fun x:R => x) (fun x:R => 1) D x0.
 Proof.
-  unfold D_in in |- *; unfold Rdiv in |- *; intros; unfold limit1_in in |- *;
-    unfold limit_in in |- *; intros; simpl in |- *; split with eps;
+  unfold D_in; unfold Rdiv; intros; unfold limit1_in;
+    unfold limit_in; intros; simpl; split with eps;
       split; auto.
   intros; elim H0; clear H0; intros; unfold D_x in H0; elim H0; intros;
-    rewrite (Rinv_r (x - x0) (Rminus_eq_contra x x0 (sym_not_eq H3)));
-      unfold R_dist in |- *; rewrite (Rminus_diag_eq 1 1 (refl_equal 1));
-        unfold Rabs in |- *; case (Rcase_abs 0); intro.
+    rewrite (Rinv_r (x - x0) (Rminus_eq_contra x x0 (not_eq_sym H3)));
+      unfold R_dist; rewrite (Rminus_diag_eq 1 1 (eq_refl 1));
+        unfold Rabs; case (Rcase_abs 0); intro.
   absurd (0 < 0); auto.
-  red in |- *; intro; apply (Rlt_irrefl 0 r).
+  red; intro; apply (Rlt_irrefl 0 r).
   unfold Rgt in H; assumption.
 Qed.
 
@@ -213,12 +208,12 @@ Lemma Dadd :
     D_in g dg D x0 ->
     D_in (fun x:R => f x + g x) (fun x:R => df x + dg x) D x0.
 Proof.
-  unfold D_in in |- *; intros;
+  unfold D_in; intros;
     generalize
       (limit_plus (fun x:R => (f x - f x0) * / (x - x0))
         (fun x:R => (g x - g x0) * / (x - x0)) (D_x D x0) (
-          df x0) (dg x0) x0 H H0); clear H H0; unfold limit1_in in |- *;
-      unfold limit_in in |- *; simpl in |- *; intros; elim (H eps H0);
+          df x0) (dg x0) x0 H H0); clear H H0; unfold limit1_in;
+      unfold limit_in; simpl; intros; elim (H eps H0);
         clear H; intros; elim H; clear H; intros; split with x;
           split; auto; intros; generalize (H1 x1 H2); clear H1;
             intro; rewrite (Rmult_comm (f x1 - f x0) (/ (x1 - x0))) in H1;
@@ -238,8 +233,8 @@ Lemma Dmult :
     D_in g dg D x0 ->
     D_in (fun x:R => f x * g x) (fun x:R => df x * g x + f x * dg x) D x0.
 Proof.
-  intros; unfold D_in in |- *; generalize H H0; intros; unfold D_in in H, H0;
-    generalize (cont_deriv f df D x0 H1); unfold continue_in in |- *;
+  intros; unfold D_in; generalize H H0; intros; unfold D_in in H, H0;
+    generalize (cont_deriv f df D x0 H1); unfold continue_in;
       intro;
         generalize
           (limit_mul (fun x:R => (g x - g x0) * / (x - x0)) (
@@ -255,8 +250,8 @@ Proof.
             (fun x:R => (g x - g x0) * / (x - x0) * f x) (
               D_x D x0) (df x0 * g x0) (dg x0 * f x0) x0 H H4);
           clear H4 H; intro; unfold limit1_in in H; unfold limit_in in H;
-            simpl in H; unfold limit1_in in |- *; unfold limit_in in |- *;
-              simpl in |- *; intros; elim (H eps H0); clear H; intros;
+            simpl in H; unfold limit1_in; unfold limit_in;
+              simpl; intros; elim (H eps H0); clear H; intros;
                 elim H; clear H; intros; split with x; split; auto;
                   intros; generalize (H1 x1 H2); clear H1; intro;
                     rewrite (Rmult_comm (f x1 - f x0) (/ (x1 - x0))) in H1;
@@ -273,9 +268,9 @@ Proof.
                                     ((f x1 - f x0) * g x0 + (g x1 - g x0) * f x1 = f x1 * g x1 - f x0 * g x0).
   intro; rewrite H3 in H1; assumption.
   ring.
-  unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *; intros;
+  unfold limit1_in; unfold limit_in; simpl; intros;
     split with eps; split; auto; intros; elim (R_dist_refl (g x0) (g x0));
-      intros a b; rewrite (b (refl_equal (g x0))); unfold Rgt in H;
+      intros a b; rewrite (b (eq_refl (g x0))); unfold Rgt in H;
         assumption.
 Qed.
 
@@ -286,7 +281,7 @@ Lemma Dmult_const :
 Proof.
   intros;
     generalize (Dmult D (fun _:R => 0) df (fun _:R => a) f x0 (Dconst D a x0) H);
-      unfold D_in in |- *; intros; rewrite (Rmult_0_l (f x0)) in H0;
+      unfold D_in; intros; rewrite (Rmult_0_l (f x0)) in H0;
         rewrite (let (H1, H2) := Rplus_ne (a * df x0) in H2) in H0;
           assumption.
 Qed.
@@ -296,10 +291,10 @@ Lemma Dopp :
   forall (D:R -> Prop) (f df:R -> R) (x0:R),
     D_in f df D x0 -> D_in (fun x:R => - f x) (fun x:R => - df x) D x0.
 Proof.
-  intros; generalize (Dmult_const D f df x0 (-1) H); unfold D_in in |- *;
-    unfold limit1_in in |- *; unfold limit_in in |- *;
+  intros; generalize (Dmult_const D f df x0 (-1) H); unfold D_in;
+    unfold limit1_in; unfold limit_in;
       intros; generalize (H0 eps H1); clear H0; intro; elim H0;
-        clear H0; intros; elim H0; clear H0; simpl in |- *;
+        clear H0; intros; elim H0; clear H0; simpl;
           intros; split with x; split; auto.
   intros; generalize (H2 x1 H3); clear H2; intro;
     rewrite Ropp_mult_distr_l_reverse in H2;
@@ -318,7 +313,7 @@ Lemma Dminus :
     D_in g dg D x0 ->
     D_in (fun x:R => f x - g x) (fun x:R => df x - dg x) D x0.
 Proof.
-  unfold Rminus in |- *; intros; generalize (Dopp D g dg x0 H0); intro;
+  unfold Rminus; intros; generalize (Dopp D g dg x0 H0); intro;
     apply (Dadd D df (fun x:R => - dg x) f (fun x:R => - g x) x0);
       assumption.
 Qed.
@@ -329,14 +324,14 @@ Lemma Dx_pow_n :
     D_in (fun x:R => x ^ n) (fun x:R => INR n * x ^ (n - 1)) D x0.
 Proof.
   simple induction n; intros.
-  simpl in |- *; rewrite Rmult_0_l; apply Dconst.
+  simpl; rewrite Rmult_0_l; apply Dconst.
   intros; cut (n0 = (S n0 - 1)%nat);
-    [ intro a; rewrite <- a; clear a | simpl in |- *; apply minus_n_O ].
+    [ intro a; rewrite <- a; clear a | simpl; apply minus_n_O ].
   generalize
     (Dmult D (fun _:R => 1) (fun x:R => INR n0 * x ^ (n0 - 1)) (
       fun x:R => x) (fun x:R => x ^ n0) x0 (Dx D x0) (
-        H D x0)); unfold D_in in |- *; unfold limit1_in in |- *;
-    unfold limit_in in |- *; simpl in |- *; intros; elim (H0 eps H1);
+        H D x0)); unfold D_in; unfold limit1_in;
+    unfold limit_in; simpl; intros; elim (H0 eps H1);
       clear H0; intros; elim H0; clear H0; intros; split with x;
         split; auto.
   intros; generalize (H2 x1 H3); clear H2 H3; intro;
@@ -344,9 +339,8 @@ 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 cond in H2; rewrite cond; simpl in H2; simpl in |- *;
+            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;
     cut (1 + x0 * 1 * 0 = 1 * 1);
       [ intro A; rewrite A in H2; assumption | ring ].
   cut (n0 <> 0%nat -> S (n0 - 1) = n0); [ intro | omega ];
@@ -361,8 +355,8 @@ Lemma Dcomp :
     D_in g dg Dg (f x0) ->
     D_in (fun x:R => g (f x)) (fun x:R => df x * dg (f x)) (Dgf Df Dg f) x0.
 Proof.
-  intros Df Dg df dg f g x0 H H0; generalize H H0; unfold D_in in |- *;
-    unfold Rdiv in |- *; intros;
+  intros Df Dg df dg f g x0 H H0; generalize H H0; unfold D_in;
+    unfold Rdiv; intros;
       generalize
         (limit_comp f (fun x:R => (g x - g (f x0)) * / (x - f x0)) (
           D_x Df x0) (D_x Dg (f x0)) (f x0) (dg (f x0)) x0);
@@ -382,8 +376,8 @@ Proof.
       (limit_mul (fun x:R => (f x - f x0) * / (x - x0)) (
         fun x:R => dg (f x0)) (D_x Df x0) (df x0) (dg (f x0)) x0 H1
       (limit_free (fun x:R => dg (f x0)) (D_x Df x0) x0 x0));
-      intro; unfold limit1_in in |- *; unfold limit_in in |- *;
-        simpl in |- *; unfold limit1_in in H5, H7; unfold limit_in in H5, H7;
+      intro; unfold limit1_in; unfold limit_in;
+        simpl; unfold limit1_in in H5, H7; unfold limit_in in H5, H7;
           simpl in H5, H7; intros; elim (H5 eps H8); elim (H7 eps H8);
             clear H5 H7; intros; elim H5; elim H7; clear H5 H7;
               intros; split with (Rmin x x1); split.
@@ -391,13 +385,13 @@ 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;
         rewrite (Rmult_0_l (/ (x2 - x0))) in H16;
           rewrite (Rmult_0_l (dg (f x0))) in H16; rewrite H12;
-            rewrite (Rminus_diag_eq (g (f x0)) (g (f x0)) (refl_equal (g (f x0))));
+            rewrite (Rminus_diag_eq (g (f x0)) (g (f x0)) (eq_refl (g (f x0))));
               rewrite (Rmult_0_l (/ (x2 - x0))); assumption.
   clear H10 H5; elim H11; clear H11; intros; elim H5; clear H5; intros;
     cut
@@ -411,8 +405,8 @@ Proof.
               in H15; rewrite (Rinv_l (f x2 - f x0) H16) in H15;
                 rewrite (let (H1, H2) := Rmult_ne (/ (x2 - x0)) in H2) in H15;
                   rewrite (Rmult_comm (df x0) (dg (f x0))); assumption.
-  clear H5 H3 H4 H2; unfold limit1_in in |- *; unfold limit_in in |- *;
-    simpl in |- *; unfold limit1_in in H1; unfold limit_in in H1;
+  clear H5 H3 H4 H2; unfold limit1_in; unfold limit_in;
+    simpl; unfold limit1_in in H1; unfold limit_in in H1;
       simpl in H1; intros; elim (H1 eps H2); clear H1; intros;
         elim H1; clear H1; intros; split with x; split; auto;
           intros; unfold D_x, Dgf in H4, H3; elim H4; clear H4;
@@ -431,8 +425,8 @@ Proof.
     generalize
       (Dcomp D D dexpr (fun x:R => INR n * x ^ (n - 1)) expr (
         fun x:R => x ^ n) x0 H (Dx_pow_n n D (expr x0)));
-      intro; unfold D_in in |- *; unfold limit1_in in |- *;
-        unfold limit_in in |- *; simpl in |- *; intros; unfold D_in in H0;
+      intro; unfold D_in; unfold limit1_in;
+        unfold limit_in; simpl; intros; unfold D_in in H0;
           unfold limit1_in in H0; unfold limit_in in H0; simpl in H0;
             elim (H0 eps H1); clear H0; intros; elim H0; clear H0;
               intros; split with x; split; intros; auto.
diff --git a/theories/Reals/Reals.v b/theories/Reals/Reals.v
index 9929733f..03bf534d 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-2012     *)
 (*   \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..4724d0e5 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-2012     *)
 (*   \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*)
 
@@ -27,8 +25,8 @@ Require Export SplitRmult.
 Require Export ArithProp.
 Require Import Omega.
 Require Import Zpower.
-Open Local Scope nat_scope.
-Open Local Scope R_scope.
+Local Open Scope nat_scope.
+Local Open Scope R_scope.
 
 (*******************************)
 (** * Lemmas about factorial   *)
@@ -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,29 @@ 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 Rpow_mult_distr : forall (x y:R) (n:nat), (x * y) ^ n = x^n * y^n.
+Proof.
+intros x y n ; induction n.
+ field.
+ simpl.
+ repeat (rewrite Rmult_assoc) ; apply Rmult_eq_compat_l.
+ rewrite IHn ; field.
+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 +105,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 +136,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 +156,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 +174,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 +204,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,9 +220,9 @@ Qed.
 
 Lemma RPow_abs : forall (x:R) (n:nat), Rabs x ^ n = Rabs (x ^ n).
 Proof.
-  intro; simple induction n; simpl in |- *.
-  apply sym_eq; apply Rabs_pos_eq; apply Rlt_le; apply Rlt_0_1.
-  intros; rewrite H; apply sym_eq; apply Rabs_mult.
+  intro; simple induction n; simpl.
+  symmetry; apply Rabs_pos_eq; apply Rlt_le; apply Rlt_0_1.
+  intros; rewrite H; symmetry; apply Rabs_mult.
 Qed.
 
 
@@ -233,16 +240,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 +261,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 +314,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 +328,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 +352,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 +363,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 +382,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 +399,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 +438,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 +455,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 +470,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 +509,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,21 +526,21 @@ Qed.
 (*i Due to L.Thery i*)
 
 Ltac case_eq name :=
-  generalize (refl_equal name); pattern name at -1 in |- *; case name.
+  generalize (eq_refl name); pattern name at -1; case name.
 
 Definition powerRZ (x:R) (n:Z) :=
   match n with
     | Z0 => 1
-    | Zpos p => x ^ nat_of_P p
-    | Zneg p => / x ^ nat_of_P p
+    | Zpos p => x ^ Pos.to_nat p
+    | Zneg p => / x ^ Pos.to_nat p
   end.
 
-Infix Local "^Z" := powerRZ (at level 30, right associativity) : R_scope.
+Local Infix "^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.
@@ -541,90 +548,73 @@ Proof.
   reflexivity.
 Qed.
 
-Lemma powerRZ_1 : forall x:R, x ^Z Zsucc 0 = x.
+Lemma powerRZ_1 : forall x:R, x ^Z Z.succ 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_pos_sub (x:R) (n m:positive) : x <> 0 ->
+   x ^Z (Z.pos_sub n m) = x ^ Pos.to_nat n * / x ^ Pos.to_nat m.
+Proof.
+ intro Hx.
+ rewrite Z.pos_sub_spec.
+ case Pos.compare_spec; intro H; simpl.
+ - subst; auto with real.
+ - rewrite Pos2Nat.inj_sub by trivial.
+   rewrite Pos2Nat.inj_lt in H.
+   rewrite (pow_RN_plus x _ (Pos.to_nat n)) by auto with real.
+   rewrite plus_comm, le_plus_minus_r by auto with real.
+   rewrite Rinv_mult_distr, Rinv_involutive; auto with real.
+ - rewrite Pos2Nat.inj_sub by trivial.
+   rewrite Pos2Nat.inj_lt in H.
+   rewrite (pow_RN_plus x _ (Pos.to_nat m)) by auto with real.
+   rewrite plus_comm, le_plus_minus_r by auto with real.
+   reflexivity.
 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 |- *;
-    auto with real.
-(* POS/POS *)
-  rewrite nat_of_P_plus_morphism; 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.
-(* 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.
-(* NEG/NEG *)
-  rewrite nat_of_P_plus_morphism; auto with real.
-  intros H'; rewrite pow_add; auto with real.
-  apply Rinv_mult_distr; auto.
-  apply pow_nonzero; auto.
-  apply pow_nonzero; auto.
+  intros x [|n|n] [|m|m]; simpl; intros; auto with real.
+  - (* + + *)
+    rewrite Pos2Nat.inj_add; auto with real.
+  - (* + - *)
+    now apply powerRZ_pos_sub.
+  - (* - + *)
+    rewrite Rmult_comm. now apply powerRZ_pos_sub.
+  - (* - - *)
+    rewrite Pos2Nat.inj_add; auto with real.
+    rewrite pow_add; auto with real.
+    apply Rinv_mult_distr; apply pow_nonzero; auto.
 Qed.
 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.
+  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 |- *.
-  replace (Zpower_nat (Z_of_nat n) (S m1)) with
-  (Z_of_nat n * Zpower_nat (Z_of_nat n) m1)%Z.
+  intros n m; elim m; simpl; auto with real.
+  intros m1 H'; rewrite SuccNat2Pos.id_succ; 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 SuccNat2Pos.id_succ; auto.
+  unfold Zpower_nat; auto.
 Qed.
 
 Lemma Zpower_pos_powerRZ :
-  forall n m, IZR (Zpower_pos n m) = IZR n ^Z Zpos m.
+  forall n m, IZR (Z.pow_pos n m) = IZR n ^Z Zpos m.
 Proof.
   intros.
   rewrite Zpower_pos_nat; simpl.
-  induction (nat_of_P m).
+  induction (Pos.to_nat m).
   easy.
   unfold Zpower_nat; simpl.
   rewrite mult_IZR.
@@ -633,7 +623,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.
 
@@ -644,21 +634,21 @@ Qed.
 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.
+  forall n m:Z, (0 <= m)%Z -> IZR (Zpower_nat n (Z.abs_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 (Pos.to_nat 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 (Pos.to_nat p); simpl; auto; intros n0 H'; rewrite H';
     ring.
-  intros p; elim (nat_of_P p); simpl in |- *.
+  intros p; elim (Pos.to_nat p); simpl.
   exact Rinv_1.
   intros n1 H'; rewrite Rinv_mult_distr; try rewrite Rinv_1; try rewrite H';
     auto with real.
@@ -676,7 +666,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 +700,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 +711,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 +734,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,10 +755,10 @@ 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.
-  rewrite (Ropp_minus_distr x y) in H; apply sym_eq;
+  unfold R_dist; intros; split_Rabs; split; intros.
+  rewrite (Ropp_minus_distr x y) in H; symmetry;
     apply (Rminus_diag_uniq y x H).
-  rewrite (Ropp_minus_distr x y); generalize (sym_eq H); intro;
+  rewrite (Ropp_minus_distr x y); generalize (eq_sym H); intro;
     apply (Rminus_diag_eq y x H0).
   apply (Rminus_diag_uniq x y H).
   apply (Rminus_diag_eq x y H).
@@ -776,13 +766,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 +780,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..ffa11608 100644
--- a/theories/Reals/Rgeom.v
+++ b/theories/Reals/Rgeom.v
@@ -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-2012     *)
 (*   \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.
-Require Import Rtrigo.
+Require Import Rtrigo1.
 Require Import R_sqrt.
-Open Local Scope R_scope.
+Local Open Scope R_scope.
 
 (** * Distance *)
 
@@ -22,23 +20,23 @@ Definition dist_euc (x0 y0 x1 y1:R) : R :=
 
 Lemma distance_refl : forall x0 y0:R, dist_euc x0 y0 x0 y0 = 0.
 Proof.
-  intros x0 y0; unfold dist_euc in |- *; apply Rsqr_inj;
+  intros x0 y0; unfold dist_euc; apply Rsqr_inj;
     [ apply sqrt_positivity; apply Rplus_le_le_0_compat;
       [ apply Rle_0_sqr | apply Rle_0_sqr ]
       | right; reflexivity
       | rewrite Rsqr_0; rewrite Rsqr_sqrt;
-        [ unfold Rsqr in |- *; ring
+        [ unfold Rsqr; ring
           | apply Rplus_le_le_0_compat; [ apply Rle_0_sqr | apply Rle_0_sqr ] ] ].
 Qed.
 
 Lemma distance_symm :
   forall x0 y0 x1 y1:R, dist_euc x0 y0 x1 y1 = dist_euc x1 y1 x0 y0.
 Proof.
-  intros x0 y0 x1 y1; unfold dist_euc in |- *; apply Rsqr_inj;
+  intros x0 y0 x1 y1; unfold dist_euc; apply Rsqr_inj;
     [ apply sqrt_positivity; apply Rplus_le_le_0_compat
       | apply sqrt_positivity; apply Rplus_le_le_0_compat
       | repeat rewrite Rsqr_sqrt;
-        [ unfold Rsqr in |- *; ring
+        [ unfold Rsqr; ring
           | apply Rplus_le_le_0_compat
           | apply Rplus_le_le_0_compat ] ]; apply Rle_0_sqr.
 Qed.
@@ -51,8 +49,8 @@ Lemma law_cosines :
           a * c * cos ac = (x0 - x1) * (x2 - x1) + (y0 - y1) * (y2 - y1) ->
           Rsqr b = Rsqr c + Rsqr a - 2 * (a * c * cos ac).
 Proof.
-  unfold dist_euc in |- *; intros; repeat rewrite Rsqr_sqrt;
-    [ rewrite H; unfold Rsqr in |- *; ring
+  unfold dist_euc; intros; repeat rewrite Rsqr_sqrt;
+    [ rewrite H; unfold Rsqr; ring
       | apply Rplus_le_le_0_compat
       | apply Rplus_le_le_0_compat
       | apply Rplus_le_le_0_compat ]; apply Rle_0_sqr.
@@ -62,7 +60,7 @@ Lemma triangle :
   forall x0 y0 x1 y1 x2 y2:R,
     dist_euc x0 y0 x1 y1 <= dist_euc x0 y0 x2 y2 + dist_euc x2 y2 x1 y1.
 Proof.
-  intros; unfold dist_euc in |- *; apply Rsqr_incr_0;
+  intros; unfold dist_euc; apply Rsqr_incr_0;
     [ rewrite Rsqr_plus; repeat rewrite Rsqr_sqrt;
       [ replace (Rsqr (x0 - x1)) with
         (Rsqr (x0 - x2) + Rsqr (x2 - x1) + 2 * (x0 - x2) * (x2 - x1));
@@ -114,7 +112,7 @@ Definition yt (y ty:R) : R := y + ty.
 
 Lemma translation_0 : forall x y:R, xt x 0 = x /\ yt y 0 = y.
 Proof.
-  intros x y; split; [ unfold xt in |- * | unfold yt in |- * ]; ring.
+  intros x y; split; [ unfold xt | unfold yt ]; ring.
 Qed.
 
 Lemma isometric_translation :
@@ -122,7 +120,7 @@ Lemma isometric_translation :
     Rsqr (x1 - x2) + Rsqr (y1 - y2) =
     Rsqr (xt x1 tx - xt x2 tx) + Rsqr (yt y1 ty - yt y2 ty).
 Proof.
-  intros; unfold Rsqr, xt, yt in |- *; ring.
+  intros; unfold Rsqr, xt, yt; ring.
 Qed.
 
 (******************************************************************)
@@ -134,13 +132,13 @@ Definition yr (x y theta:R) : R := - x * sin theta + y * cos theta.
 
 Lemma rotation_0 : forall x y:R, xr x y 0 = x /\ yr x y 0 = y.
 Proof.
-  intros x y; unfold xr, yr in |- *; split; rewrite cos_0; rewrite sin_0; ring.
+  intros x y; unfold xr, yr; split; rewrite cos_0; rewrite sin_0; ring.
 Qed.
 
 Lemma rotation_PI2 :
   forall x y:R, xr x y (PI / 2) = y /\ yr x y (PI / 2) = - x.
 Proof.
-  intros x y; unfold xr, yr in |- *; split; rewrite cos_PI2; rewrite sin_PI2;
+  intros x y; unfold xr, yr; split; rewrite cos_PI2; rewrite sin_PI2;
     ring.
 Qed.
 
@@ -150,7 +148,7 @@ Lemma isometric_rotation_0 :
     Rsqr (xr x1 y1 theta - xr x2 y2 theta) +
     Rsqr (yr x1 y1 theta - yr x2 y2 theta).
 Proof.
-  intros; unfold xr, yr in |- *;
+  intros; unfold xr, yr;
     replace
     (x1 * cos theta + y1 * sin theta - (x2 * cos theta + y2 * sin theta)) with
     (cos theta * (x1 - x2) + sin theta * (y1 - y2));
@@ -170,7 +168,7 @@ Lemma isometric_rotation :
     dist_euc (xr x1 y1 theta) (yr x1 y1 theta) (xr x2 y2 theta)
     (yr x2 y2 theta).
 Proof.
-  unfold dist_euc in |- *; intros; apply Rsqr_inj;
+  unfold dist_euc; intros; apply Rsqr_inj;
     [ apply sqrt_positivity; apply Rplus_le_le_0_compat
       | apply sqrt_positivity; apply Rplus_le_le_0_compat
       | repeat rewrite Rsqr_sqrt;
diff --git a/theories/Reals/RiemannInt.v b/theories/Reals/RiemannInt.v
index 598f5f31..0a00ca22 100644
--- a/theories/Reals/RiemannInt.v
+++ b/theories/Reals/RiemannInt.v
@@ -1,23 +1,21 @@
 (* -*- 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-2012     *)
 (*   \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.
+Require Import Ranalysis_reg.
 Require Import Rbase.
 Require Import RiemannInt_SF.
 Require Import Classical_Prop.
 Require Import Classical_Pred_Type.
 Require Import Max.
-Open Local Scope R_scope.
+Local Open Scope R_scope.
 
 Set Implicit Arguments.
 
@@ -53,19 +51,19 @@ Lemma RiemannInt_P1 :
   forall (f:R -> R) (a b:R),
     Riemann_integrable f a b -> Riemann_integrable f b a.
 Proof.
-  unfold Riemann_integrable in |- *; intros; elim (X eps); clear X; intros;
+  unfold Riemann_integrable; intros; elim (X eps); clear X; intros;
     elim p; clear p; intros; exists (mkStepFun (StepFun_P6 (pre x)));
       exists (mkStepFun (StepFun_P6 (pre x0)));
         elim p; clear p; intros; split.
   intros; apply (H t); elim H1; clear H1; intros; split;
     [ apply Rle_trans with (Rmin b a); try assumption; right;
-      unfold Rmin in |- *
+      unfold Rmin
       | apply Rle_trans with (Rmax b a); try assumption; right;
-        unfold Rmax in |- * ];
+        unfold Rmax ];
     (case (Rle_dec a b); case (Rle_dec b a); intros;
       try reflexivity || apply Rle_antisym;
         [ assumption | assumption | auto with real | auto with real ]).
-  generalize H0; unfold RiemannInt_SF in |- *; case (Rle_dec a b);
+  generalize H0; unfold RiemannInt_SF; case (Rle_dec a b);
     case (Rle_dec b a); intros;
       (replace
         (Int_SF (subdivision_val (mkStepFun (StepFun_P6 (pre x0))))
@@ -91,11 +89,11 @@ Lemma RiemannInt_P2 :
       Rabs (RiemannInt_SF (wn n)) < un n) ->
     { l:R | Un_cv (fun N:nat => RiemannInt_SF (vn N)) l }.
 Proof.
-  intros; apply R_complete; unfold Un_cv in H; unfold Cauchy_crit in |- *;
+  intros; apply R_complete; unfold Un_cv in H; unfold Cauchy_crit;
     intros; assert (H3 : 0 < eps / 2).
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+  unfold Rdiv; apply Rmult_lt_0_compat;
     [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
-  elim (H _ H3); intros N0 H4; exists N0; intros; unfold R_dist in |- *;
+  elim (H _ H3); intros N0 H4; exists N0; intros; unfold R_dist;
     unfold R_dist in H4; elim (H1 n); elim (H1 m); intros;
       replace (RiemannInt_SF (vn n) - RiemannInt_SF (vn m)) with
       (RiemannInt_SF (vn n) + -1 * RiemannInt_SF (vn m));
@@ -107,15 +105,15 @@ Proof.
   apply Rle_lt_trans with
     (RiemannInt_SF (mkStepFun (StepFun_P28 1 (wn n) (wn m)))).
   apply StepFun_P37; try assumption.
-  intros; simpl in |- *;
+  intros; simpl;
     apply Rle_trans with (Rabs (vn n x - f x) + Rabs (f x - vn m x)).
   replace (vn n x + -1 * vn m x) with (vn n x - f x + (f x - vn m x));
   [ apply Rabs_triang | ring ].
   assert (H12 : Rmin a b = a).
-  unfold Rmin in |- *; case (Rle_dec a b); intro;
+  unfold Rmin; case (Rle_dec a b); intro;
     [ reflexivity | elim n0; assumption ].
   assert (H13 : Rmax a b = b).
-  unfold Rmax in |- *; case (Rle_dec a b); intro;
+  unfold Rmax; case (Rle_dec a b); intro;
     [ reflexivity | elim n0; assumption ].
   rewrite <- H12 in H11; pattern b at 2 in H11; rewrite <- H13 in H11;
     rewrite Rmult_1_l; apply Rplus_le_compat.
@@ -158,14 +156,14 @@ Proof.
   intro; elim (H0 n0); intros; split.
   intros; apply (H2 t); elim H4; clear H4; intros; split;
     [ apply Rle_trans with (Rmin b a); try assumption; right;
-      unfold Rmin in |- *
+      unfold Rmin
       | apply Rle_trans with (Rmax b a); try assumption; right;
-        unfold Rmax in |- * ];
+        unfold Rmax ];
     (case (Rle_dec a b); case (Rle_dec b a); intros;
       try reflexivity || apply Rle_antisym;
         [ assumption | assumption | auto with real | auto with real ]).
-  generalize H3; unfold RiemannInt_SF in |- *; case (Rle_dec a b);
-    case (Rle_dec b a); unfold wn' in |- *; intros;
+  generalize H3; unfold RiemannInt_SF; case (Rle_dec a b);
+    case (Rle_dec b a); unfold wn'; intros;
       (replace
         (Int_SF (subdivision_val (mkStepFun (StepFun_P6 (pre (wn n0)))))
           (subdivision (mkStepFun (StepFun_P6 (pre (wn n0)))))) with
@@ -180,19 +178,19 @@ Proof.
   rewrite Rabs_Ropp in H4; apply H4.
   apply H4.
   assert (H3 := RiemannInt_P2 _ _ _ _ H H1 H2); elim H3; intros;
-    exists (- x); unfold Un_cv in |- *; unfold Un_cv in p;
+    exists (- x); unfold Un_cv; unfold Un_cv in p;
       intros; elim (p _ H4); intros; exists x0; intros;
-        generalize (H5 _ H6); unfold R_dist, RiemannInt_SF in |- *;
+        generalize (H5 _ H6); unfold R_dist, RiemannInt_SF;
           case (Rle_dec b a); case (Rle_dec a b); intros.
   elim n; assumption.
   unfold vn' in H7;
     replace (Int_SF (subdivision_val (vn n0)) (subdivision (vn n0))) with
     (Int_SF (subdivision_val (mkStepFun (StepFun_P6 (pre (vn n0)))))
       (subdivision (mkStepFun (StepFun_P6 (pre (vn n0))))));
-    [ unfold Rminus in |- *; rewrite Ropp_involutive; rewrite <- Rabs_Ropp;
+    [ unfold Rminus; rewrite Ropp_involutive; rewrite <- Rabs_Ropp;
       rewrite Ropp_plus_distr; rewrite Ropp_involutive;
         apply H7
-      | symmetry  in |- *; apply StepFun_P17 with (fe (vn n0)) a b;
+      | symmetry ; apply StepFun_P17 with (fe (vn n0)) a b;
         [ apply StepFun_P1
           | apply StepFun_P2;
             apply (StepFun_P1 (mkStepFun (StepFun_P6 (pre (vn n0))))) ] ].
@@ -220,9 +218,9 @@ Lemma RiemannInt_P4 :
     Un_cv (fun N:nat => RiemannInt_SF (phi_sequence un pr1 N)) l ->
     Un_cv (fun N:nat => RiemannInt_SF (phi_sequence vn pr2 N)) l.
 Proof.
-  unfold Un_cv in |- *; unfold R_dist in |- *; intros f; intros;
+  unfold Un_cv; unfold R_dist; intros f; intros;
     assert (H3 : 0 < eps / 3).
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+  unfold Rdiv; apply Rmult_lt_0_compat;
     [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
   elim (H _ H3); clear H; intros N0 H; elim (H0 _ H3); clear H0; intros N1 H0;
     elim (H1 _ H3); clear H1; intros N2 H1; set (N := max (max N0 N1) N2);
@@ -257,7 +255,7 @@ Proof.
   apply StepFun_P34; assumption.
   apply Rle_lt_trans with
     (RiemannInt_SF (mkStepFun (StepFun_P28 1 psi_un psi_vn))).
-  apply StepFun_P37; try assumption; intros; simpl in |- *; rewrite Rmult_1_l;
+  apply StepFun_P37; try assumption; intros; simpl; rewrite Rmult_1_l;
     apply Rle_trans with
       (Rabs (phi_sequence vn pr2 n x - f x) +
         Rabs (f x - phi_sequence un pr1 n x)).
@@ -265,10 +263,10 @@ Proof.
   (phi_sequence vn pr2 n x - f x + (f x - phi_sequence un pr1 n x));
   [ apply Rabs_triang | ring ].
   assert (H10 : Rmin a b = a).
-  unfold Rmin in |- *; case (Rle_dec a b); intro;
+  unfold Rmin; case (Rle_dec a b); intro;
     [ reflexivity | elim n0; assumption ].
   assert (H11 : Rmax a b = b).
-  unfold Rmax in |- *; case (Rle_dec a b); intro;
+  unfold Rmax; case (Rle_dec a b); intro;
     [ reflexivity | elim n0; assumption ].
   rewrite (Rplus_comm (psi_un x)); apply Rplus_le_compat.
   rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; elim H5; intros; apply H8.
@@ -281,20 +279,20 @@ Proof.
   apply RRle_abs.
   assumption.
   replace (pos (un n)) with (Rabs (un n - 0));
-  [ apply H; unfold ge in |- *; apply le_trans with N; try assumption;
-    unfold N in |- *; apply le_trans with (max N0 N1);
+  [ apply H; unfold ge; apply le_trans with N; try assumption;
+    unfold N; apply le_trans with (max N0 N1);
       apply le_max_l
-    | unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; apply Rabs_right;
+    | unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r; apply Rabs_right;
       apply Rle_ge; left; apply (cond_pos (un n)) ].
   apply Rlt_trans with (pos (vn n)).
   elim H5; intros; apply Rle_lt_trans with (Rabs (RiemannInt_SF psi_vn)).
   apply RRle_abs; assumption.
   assumption.
   replace (pos (vn n)) with (Rabs (vn n - 0));
-  [ apply H0; unfold ge in |- *; apply le_trans with N; try assumption;
-    unfold N in |- *; apply le_trans with (max N0 N1);
+  [ apply H0; unfold ge; apply le_trans with N; try assumption;
+    unfold N; apply le_trans with (max N0 N1);
       [ apply le_max_r | apply le_max_l ]
-    | unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; apply Rabs_right;
+    | unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r; apply Rabs_right;
       apply Rle_ge; left; apply (cond_pos (vn n)) ].
   rewrite StepFun_P39; rewrite Rabs_Ropp;
     apply Rle_lt_trans with
@@ -313,7 +311,7 @@ Proof.
       (mkStepFun (StepFun_P6 (pre (mkStepFun (StepFun_P28 1 psi_vn psi_un)))))).
   apply StepFun_P37.
   auto with real.
-  intros; simpl in |- *; rewrite Rmult_1_l;
+  intros; simpl; rewrite Rmult_1_l;
     apply Rle_trans with
       (Rabs (phi_sequence vn pr2 n x - f x) +
         Rabs (f x - phi_sequence un pr1 n x)).
@@ -321,10 +319,10 @@ Proof.
   (phi_sequence vn pr2 n x - f x + (f x - phi_sequence un pr1 n x));
   [ apply Rabs_triang | ring ].
   assert (H10 : Rmin a b = b).
-  unfold Rmin in |- *; case (Rle_dec a b); intro;
+  unfold Rmin; case (Rle_dec a b); intro;
     [ elim n0; assumption | reflexivity ].
   assert (H11 : Rmax a b = a).
-  unfold Rmax in |- *; case (Rle_dec a b); intro;
+  unfold Rmax; case (Rle_dec a b); intro;
     [ elim n0; assumption | reflexivity ].
   apply Rplus_le_compat.
   rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; elim H5; intros; apply H8.
@@ -343,10 +341,10 @@ Proof.
   rewrite <- Rabs_Ropp; apply RRle_abs.
   assumption.
   replace (pos (vn n)) with (Rabs (vn n - 0));
-  [ apply H0; unfold ge in |- *; apply le_trans with N; try assumption;
-    unfold N in |- *; apply le_trans with (max N0 N1);
+  [ apply H0; unfold ge; apply le_trans with N; try assumption;
+    unfold N; apply le_trans with (max N0 N1);
       [ apply le_max_r | apply le_max_l ]
-    | unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
+    | unfold R_dist; unfold Rminus; rewrite Ropp_0;
       rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge;
         left; apply (cond_pos (vn n)) ].
   apply Rlt_trans with (pos (un n)).
@@ -354,15 +352,15 @@ Proof.
   rewrite <- Rabs_Ropp; apply RRle_abs; assumption.
   assumption.
   replace (pos (un n)) with (Rabs (un n - 0));
-  [ apply H; unfold ge in |- *; apply le_trans with N; try assumption;
-    unfold N in |- *; apply le_trans with (max N0 N1);
+  [ apply H; unfold ge; apply le_trans with N; try assumption;
+    unfold N; apply le_trans with (max N0 N1);
       apply le_max_l
-    | unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; apply Rabs_right;
+    | unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r; apply Rabs_right;
       apply Rle_ge; left; apply (cond_pos (un n)) ].
-  apply H1; unfold ge in |- *; apply le_trans with N; try assumption;
-    unfold N in |- *; apply le_max_r.
+  apply H1; unfold ge; apply le_trans with N; try assumption;
+    unfold N; apply le_max_r.
   apply Rmult_eq_reg_l with 3;
-    [ unfold Rdiv in |- *; rewrite Rmult_plus_distr_l;
+    [ unfold Rdiv; rewrite Rmult_plus_distr_l;
       do 2 rewrite (Rmult_comm 3); repeat rewrite Rmult_assoc;
         rewrite <- Rinv_l_sym; [ ring | discrR ]
       | discrR ].
@@ -378,17 +376,17 @@ Definition RinvN (N:nat) : posreal := mkposreal _ (RinvN_pos N).
 
 Lemma RinvN_cv : Un_cv RinvN 0.
 Proof.
-  unfold Un_cv in |- *; intros; assert (H0 := archimed (/ eps)); elim H0;
+  unfold Un_cv; intros; assert (H0 := archimed (/ eps)); elim H0;
     clear H0; intros; assert (H2 : (0 <= up (/ eps))%Z).
   apply le_IZR; left; apply Rlt_trans with (/ eps);
     [ apply Rinv_0_lt_compat; assumption | assumption ].
-  elim (IZN _ H2); intros; exists x; intros; unfold R_dist in |- *;
-    simpl in |- *; unfold Rminus in |- *; rewrite Ropp_0;
+  elim (IZN _ H2); intros; exists x; intros; unfold R_dist;
+    simpl; unfold Rminus; rewrite Ropp_0;
       rewrite Rplus_0_r; assert (H5 : 0 < INR n + 1).
   apply Rplus_le_lt_0_compat; [ apply pos_INR | apply Rlt_0_1 ].
   rewrite Rabs_right;
     [ idtac
-      | left; change (0 < / (INR n + 1)) in |- *; apply Rinv_0_lt_compat;
+      | left; change (0 < / (INR n + 1)); apply Rinv_0_lt_compat;
         assumption ]; apply Rle_lt_trans with (/ (INR x + 1)).
   apply Rle_Rinv.
   apply Rplus_le_lt_0_compat; [ apply pos_INR | apply Rlt_0_1 ].
@@ -402,9 +400,9 @@ Proof.
   apply Rplus_le_lt_0_compat; [ apply pos_INR | apply Rlt_0_1 ].
   apply Rlt_trans with (INR x);
     [ rewrite INR_IZR_INZ; rewrite <- H3; apply H0
-      | pattern (INR x) at 1 in |- *; rewrite <- Rplus_0_r;
+      | pattern (INR x) at 1; rewrite <- Rplus_0_r;
         apply Rplus_lt_compat_l; apply Rlt_0_1 ].
-  red in |- *; intro; rewrite H6 in H; elim (Rlt_irrefl _ H).
+  red; intro; rewrite H6 in H; elim (Rlt_irrefl _ H).
 Qed.
 
 (**********)
@@ -415,7 +413,7 @@ Lemma RiemannInt_P5 :
   forall (f:R -> R) (a b:R) (pr1 pr2:Riemann_integrable f a b),
     RiemannInt pr1 = RiemannInt pr2.
 Proof.
-  intros; unfold RiemannInt in |- *;
+  intros; unfold RiemannInt;
     case (RiemannInt_exists pr1 RinvN RinvN_cv);
     case (RiemannInt_exists pr2 RinvN RinvN_cv); intros;
       eapply UL_sequence;
@@ -433,7 +431,7 @@ Lemma maxN :
 Proof.
   intros; set (I := fun n:nat => a + INR n * del < b);
     assert (H0 :  exists n : nat, I n).
-  exists 0%nat; unfold I in |- *; rewrite Rmult_0_l; rewrite Rplus_0_r;
+  exists 0%nat; unfold I; rewrite Rmult_0_l; rewrite Rplus_0_r;
     assumption.
   cut (Nbound I).
   intro; assert (H2 := Nzorn H0 H1); elim H2; intros; exists x; elim p; intros;
@@ -442,27 +440,27 @@ Proof.
   case (total_order_T (a + INR (S x) * del) b); intro.
   elim s; intro.
   assert (H5 := H4 (S x) a0); elim (le_Sn_n _ H5).
-  right; symmetry  in |- *; assumption.
+  right; symmetry ; assumption.
   left; apply r.
   assert (H1 : 0 <= (b - a) / del).
-  unfold Rdiv in |- *; apply Rmult_le_pos;
+  unfold Rdiv; apply Rmult_le_pos;
     [ apply Rge_le; apply Rge_minus; apply Rle_ge; left; apply H
       | left; apply Rinv_0_lt_compat; apply (cond_pos del) ].
   elim (archimed ((b - a) / del)); intros;
     assert (H4 : (0 <= up ((b - a) / del))%Z).
-  apply le_IZR; simpl in |- *; left; apply Rle_lt_trans with ((b - a) / del);
+  apply le_IZR; simpl; left; apply Rle_lt_trans with ((b - a) / del);
     assumption.
   assert (H5 := IZN _ H4); elim H5; clear H5; intros N H5;
-    unfold Nbound in |- *; exists N; intros; unfold I in H6;
+    unfold Nbound; exists N; intros; unfold I in H6;
       apply INR_le; rewrite H5 in H2; rewrite <- INR_IZR_INZ in H2;
         left; apply Rle_lt_trans with ((b - a) / del); try assumption;
           apply Rmult_le_reg_l with (pos del);
             [ apply (cond_pos del)
-              | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ del));
+              | unfold Rdiv; rewrite <- (Rmult_comm (/ del));
                 rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym;
                   [ rewrite Rmult_1_l; rewrite Rmult_comm; apply Rplus_le_reg_l with a;
                     replace (a + (b - a)) with b; [ left; assumption | ring ]
-                    | assert (H7 := cond_pos del); red in |- *; intro; rewrite H8 in H7;
+                    | assert (H7 := cond_pos del); red; intro; rewrite H8 in H7;
                       elim (Rlt_irrefl _ H7) ] ].
 Qed.
 
@@ -498,15 +496,15 @@ Proof.
             a <= x <= b ->
             a <= y <= b -> Rabs (x - y) < l -> Rabs (f x - f y) < eps));
       assert (H1 : bound E).
-  unfold bound in |- *; exists (b - a); unfold is_upper_bound in |- *; intros;
+  unfold bound; exists (b - a); unfold is_upper_bound; intros;
     unfold E in H1; elim H1; clear H1; intros H1 _; elim H1;
       intros; assumption.
   assert (H2 :  exists x : R, E x).
   assert (H2 := Heine f (fun x:R => a <= x <= b) (compact_P3 a b) H0 eps);
-    elim H2; intros; exists (Rmin x (b - a)); unfold E in |- *;
+    elim H2; intros; exists (Rmin x (b - a)); unfold E;
       split;
         [ split;
-          [ unfold Rmin in |- *; case (Rle_dec x (b - a)); intro;
+          [ unfold Rmin; case (Rle_dec x (b - a)); intro;
             [ apply (cond_pos x) | apply Rlt_Rminus; assumption ]
             | apply Rmin_r ]
           | intros; apply H3; try assumption; apply Rlt_le_trans with (Rmin x (b - a));
@@ -521,7 +519,7 @@ Proof.
     intros; apply H15; assumption.
   assert (H12 := not_ex_all_not _ (fun y:R => D < y /\ E y) H11);
     assert (H13 : is_upper_bound E D).
-  unfold is_upper_bound in |- *; intros; assert (H14 := H12 x1);
+  unfold is_upper_bound; intros; assert (H14 := H12 x1);
     elim (not_and_or (D < x1) (E x1) H14); intro.
   case (Rle_dec x1 D); intro.
   assumption.
@@ -553,7 +551,7 @@ Proof.
   exists (mkposreal _ Rlt_0_1); intros; assert (H3 : x = y);
     [ elim H0; elim H1; intros; rewrite b0 in H3; rewrite b0 in H5;
       apply Rle_antisym; apply Rle_trans with b; assumption
-      | rewrite H3; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+      | rewrite H3; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0;
         apply (cond_pos eps) ].
   exists (mkposreal _ Rlt_0_1); intros; elim H0; intros;
     elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ (Rle_trans _ _ _ H3 H4) r)).
@@ -562,14 +560,14 @@ Qed.
 Lemma SubEqui_P1 :
   forall (a b:R) (del:posreal) (h:a < b), pos_Rl (SubEqui del h) 0 = a.
 Proof.
-  intros; unfold SubEqui in |- *; case (maxN del h); intros; reflexivity.
+  intros; unfold SubEqui; case (maxN del h); intros; reflexivity.
 Qed.
 
 Lemma SubEqui_P2 :
   forall (a b:R) (del:posreal) (h:a < b),
     pos_Rl (SubEqui del h) (pred (Rlength (SubEqui del h))) = b.
 Proof.
-  intros; unfold SubEqui in |- *; case (maxN del h); intros; clear a0;
+  intros; unfold SubEqui; case (maxN del h); intros; clear a0;
     cut
       (forall (x:nat) (a:R) (del:posreal),
         pos_Rl (SubEquiN (S x) a b del)
@@ -581,14 +579,14 @@ Proof.
               change
                 (pos_Rl (SubEquiN (S n) (a0 + del0) b del0)
                   (pred (Rlength (SubEquiN (S n) (a0 + del0) b del0))) = b)
-                in |- *; apply H ] ].
+               ; apply H ] ].
 Qed.
 
 Lemma SubEqui_P3 :
   forall (N:nat) (a b:R) (del:posreal), Rlength (SubEquiN N a b del) = S N.
 Proof.
   simple induction N; intros;
-    [ reflexivity | simpl in |- *; rewrite H; reflexivity ].
+    [ reflexivity | simpl; rewrite H; reflexivity ].
 Qed.
 
 Lemma SubEqui_P4 :
@@ -596,36 +594,36 @@ Lemma SubEqui_P4 :
     (i < S N)%nat -> pos_Rl (SubEquiN (S N) a b del) i = a + INR i * del.
 Proof.
   simple induction N;
-    [ intros; inversion H; [ simpl in |- *; ring | elim (le_Sn_O _ H1) ]
+    [ intros; inversion H; [ simpl; ring | elim (le_Sn_O _ H1) ]
       | intros; induction  i as [| i Hreci];
-        [ simpl in |- *; ring
+        [ simpl; ring
           | change
             (pos_Rl (SubEquiN (S n) (a + del) b del) i = a + INR (S i) * del)
-            in |- *; rewrite H; [ rewrite S_INR; ring | apply lt_S_n; apply H0 ] ] ].
+           ; rewrite H; [ rewrite S_INR; ring | apply lt_S_n; apply H0 ] ] ].
 Qed.
 
 Lemma SubEqui_P5 :
   forall (a b:R) (del:posreal) (h:a < b),
     Rlength (SubEqui del h) = S (S (max_N del h)).
 Proof.
-  intros; unfold SubEqui in |- *; apply SubEqui_P3.
+  intros; unfold SubEqui; apply SubEqui_P3.
 Qed.
 
 Lemma SubEqui_P6 :
   forall (a b:R) (del:posreal) (h:a < b) (i:nat),
     (i < S (max_N del h))%nat -> pos_Rl (SubEqui del h) i = a + INR i * del.
 Proof.
-  intros; unfold SubEqui in |- *; apply SubEqui_P4; assumption.
+  intros; unfold SubEqui; apply SubEqui_P4; assumption.
 Qed.
 
 Lemma SubEqui_P7 :
   forall (a b:R) (del:posreal) (h:a < b), ordered_Rlist (SubEqui del h).
 Proof.
-  intros; unfold ordered_Rlist in |- *; intros; rewrite SubEqui_P5 in H;
+  intros; unfold ordered_Rlist; intros; rewrite SubEqui_P5 in H;
     simpl in H; inversion H.
   rewrite (SubEqui_P6 del h (i:=(max_N del h))).
   replace (S (max_N del h)) with (pred (Rlength (SubEqui del h))).
-  rewrite SubEqui_P2; unfold max_N in |- *; case (maxN del h); intros; left;
+  rewrite SubEqui_P2; unfold max_N; case (maxN del h); intros; left;
     elim a0; intros; assumption.
   rewrite SubEqui_P5; reflexivity.
   apply lt_n_Sn.
@@ -633,7 +631,7 @@ Proof.
   3: assumption.
   2: apply le_lt_n_Sm; assumption.
   apply Rplus_le_compat_l; rewrite S_INR; rewrite Rmult_plus_distr_r;
-    pattern (INR i * del) at 1 in |- *; rewrite <- Rplus_0_r;
+    pattern (INR i * del) at 1; rewrite <- Rplus_0_r;
       apply Rplus_le_compat_l; rewrite Rmult_1_l; left;
         apply (cond_pos del).
 Qed.
@@ -643,11 +641,11 @@ Lemma SubEqui_P8 :
     (i < Rlength (SubEqui del h))%nat -> a <= pos_Rl (SubEqui del h) i <= b.
 Proof.
   intros; split.
-  pattern a at 1 in |- *; rewrite <- (SubEqui_P1 del h); apply RList_P5.
+  pattern a at 1; rewrite <- (SubEqui_P1 del h); apply RList_P5.
   apply SubEqui_P7.
   elim (RList_P3 (SubEqui del h) (pos_Rl (SubEqui del h) i)); intros; apply H1;
     exists i; split; [ reflexivity | assumption ].
-  pattern b at 2 in |- *; rewrite <- (SubEqui_P2 del h); apply RList_P7;
+  pattern b at 2; rewrite <- (SubEqui_P2 del h); apply RList_P7;
     [ apply SubEqui_P7
       | elim (RList_P3 (SubEqui del h) (pos_Rl (SubEqui del h) i)); intros;
         apply H1; exists i; split; [ reflexivity | assumption ] ].
@@ -673,42 +671,42 @@ Lemma RiemannInt_P6 :
     a < b ->
     (forall x:R, a <= x <= b -> continuity_pt f x) -> Riemann_integrable f a b.
 Proof.
-  intros; unfold Riemann_integrable in |- *; intro;
+  intros; unfold Riemann_integrable; intro;
     assert (H1 : 0 < eps / (2 * (b - a))).
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+  unfold Rdiv; apply Rmult_lt_0_compat;
     [ apply (cond_pos eps)
       | apply Rinv_0_lt_compat; apply Rmult_lt_0_compat;
         [ prove_sup0 | apply Rlt_Rminus; assumption ] ].
   assert (H2 : Rmin a b = a).
-  unfold Rmin in |- *; case (Rle_dec a b); intro;
+  unfold Rmin; case (Rle_dec a b); intro;
     [ reflexivity | elim n; left; assumption ].
   assert (H3 : Rmax a b = b).
-  unfold Rmax in |- *; case (Rle_dec a b); intro;
+  unfold Rmax; case (Rle_dec a b); intro;
     [ reflexivity | elim n; left; assumption ].
   elim (Heine_cor2 H0 (mkposreal _ H1)); intros del H4;
     elim (SubEqui_P9 del f H); intros phi [H5 H6]; split with phi;
       split with (mkStepFun (StepFun_P4 a b (eps / (2 * (b - a)))));
         split.
-  2: rewrite StepFun_P18; unfold Rdiv in |- *; rewrite Rinv_mult_distr.
+  2: rewrite StepFun_P18; unfold Rdiv; rewrite Rinv_mult_distr.
   2: do 2 rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
   2: rewrite Rmult_1_r; rewrite Rabs_right.
   2: apply Rmult_lt_reg_l with 2.
   2: prove_sup0.
   2: rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
     rewrite <- Rinv_r_sym.
-  2: rewrite Rmult_1_l; pattern (pos eps) at 1 in |- *; rewrite <- Rplus_0_r;
+  2: rewrite Rmult_1_l; pattern (pos eps) at 1; rewrite <- Rplus_0_r;
     rewrite double; apply Rplus_lt_compat_l; apply (cond_pos eps).
   2: discrR.
   2: apply Rle_ge; left; apply Rmult_lt_0_compat.
   2: apply (cond_pos eps).
   2: apply Rinv_0_lt_compat; prove_sup0.
-  2: apply Rminus_eq_contra; red in |- *; intro; clear H6; rewrite H7 in H;
+  2: apply Rminus_eq_contra; red; intro; clear H6; rewrite H7 in H;
     elim (Rlt_irrefl _ H).
   2: discrR.
-  2: apply Rminus_eq_contra; red in |- *; intro; clear H6; rewrite H7 in H;
+  2: apply Rminus_eq_contra; red; intro; clear H6; rewrite H7 in H;
     elim (Rlt_irrefl _ H).
-  intros; rewrite H2 in H7; rewrite H3 in H7; simpl in |- *;
-    unfold fct_cte in |- *;
+  intros; rewrite H2 in H7; rewrite H3 in H7; simpl;
+    unfold fct_cte;
       cut
         (forall t:R,
           a <= t <= b ->
@@ -718,14 +716,14 @@ Proof.
             co_interval (pos_Rl (SubEqui del H) i) (pos_Rl (SubEqui del H) (S i))
             t)).
   intro; elim (H8 _ H7); intro.
-  rewrite H9; rewrite H5; unfold Rminus in |- *; rewrite Rplus_opp_r;
+  rewrite H9; rewrite H5; unfold Rminus; rewrite Rplus_opp_r;
     rewrite Rabs_R0; left; assumption.
   elim H9; clear H9; intros I [H9 H10]; assert (H11 := H6 I H9 t H10);
     rewrite H11; left; apply H4.
   assumption.
   apply SubEqui_P8; apply lt_trans with (pred (Rlength (SubEqui del H))).
   assumption.
-  apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro; rewrite <- H12 in H9;
+  apply lt_pred_n_n; apply neq_O_lt; red; intro; rewrite <- H12 in H9;
     elim (lt_n_O _ H9).
   unfold co_interval in H10; elim H10; clear H10; intros; rewrite Rabs_right.
   rewrite SubEqui_P5 in H9; simpl in H9; inversion H9.
@@ -740,7 +738,7 @@ Proof.
   rewrite H13 in H12; rewrite SubEqui_P2 in H12; apply H12.
   rewrite SubEqui_P6.
   2: apply lt_n_Sn.
-  unfold max_N in |- *; case (maxN del H); intros; elim a0; clear a0;
+  unfold max_N; case (maxN del H); intros; elim a0; clear a0;
     intros _ H13; replace (a + INR x * del + del) with (a + INR (S x) * del);
       [ assumption | rewrite S_INR; ring ].
   apply Rplus_lt_reg_r with (pos_Rl (SubEqui del H) I);
@@ -757,10 +755,10 @@ Proof.
   left; assumption.
   right; set (I := fun j:nat => a + INR j * del <= t0);
     assert (H1 :  exists n : nat, I n).
-  exists 0%nat; unfold I in |- *; rewrite Rmult_0_l; rewrite Rplus_0_r; elim H8;
+  exists 0%nat; unfold I; rewrite Rmult_0_l; rewrite Rplus_0_r; elim H8;
     intros; assumption.
   assert (H4 : Nbound I).
-  unfold Nbound in |- *; exists (S (max_N del H)); intros; unfold max_N in |- *;
+  unfold Nbound; exists (S (max_N del H)); intros; unfold max_N;
     case (maxN del H); intros; elim a0; clear a0; intros _ H5;
       apply INR_le; apply Rmult_le_reg_l with (pos del).
   apply (cond_pos del).
@@ -769,7 +767,7 @@ Proof.
       apply Rle_trans with b; try assumption; elim H8; intros;
         assumption.
   elim (Nzorn H1 H4); intros N [H5 H6]; assert (H7 : (N < S (max_N del H))%nat).
-  unfold max_N in |- *; case (maxN del H); intros; apply INR_lt;
+  unfold max_N; case (maxN del H); intros; apply INR_lt;
     apply Rmult_lt_reg_l with (pos del).
   apply (cond_pos del).
   apply Rplus_lt_reg_r with a; do 2 rewrite (Rmult_comm del);
@@ -780,8 +778,8 @@ Proof.
   assumption.
   elim H0; assumption.
   exists N; split.
-  rewrite SubEqui_P5; simpl in |- *; assumption.
-  unfold co_interval in |- *; split.
+  rewrite SubEqui_P5; simpl; assumption.
+  unfold co_interval; split.
   rewrite SubEqui_P6.
   apply H5.
   assumption.
@@ -801,13 +799,13 @@ Qed.
 
 Lemma RiemannInt_P7 : forall (f:R -> R) (a:R), Riemann_integrable f a a.
 Proof.
-  unfold Riemann_integrable in |- *; intro f; intros;
+  unfold Riemann_integrable; intro f; intros;
     split with (mkStepFun (StepFun_P4 a a (f a)));
       split with (mkStepFun (StepFun_P4 a a 0)); split.
-  intros; simpl in |- *; unfold fct_cte in |- *; replace t with a.
-  unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; right;
+  intros; simpl; unfold fct_cte; replace t with a.
+  unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; right;
     reflexivity.
-  generalize H; unfold Rmin, Rmax in |- *; case (Rle_dec a a); intros; elim H0;
+  generalize H; unfold Rmin, Rmax; case (Rle_dec a a); intros; elim H0;
     intros; apply Rle_antisym; assumption.
   rewrite StepFun_P18; rewrite Rmult_0_l; rewrite Rabs_R0; apply (cond_pos eps).
 Qed.
@@ -828,9 +826,9 @@ Lemma RiemannInt_P8 :
     (pr2:Riemann_integrable f b a), RiemannInt pr1 = - RiemannInt pr2.
 Proof.
   intro f; intros; eapply UL_sequence.
-  unfold RiemannInt in |- *; case (RiemannInt_exists pr1 RinvN RinvN_cv);
+  unfold RiemannInt; case (RiemannInt_exists pr1 RinvN RinvN_cv);
     intros; apply u.
-  unfold RiemannInt in |- *; case (RiemannInt_exists pr2 RinvN RinvN_cv);
+  unfold RiemannInt; case (RiemannInt_exists pr2 RinvN RinvN_cv);
     intros;
       cut
         (exists psi1 : nat -> StepFun a b,
@@ -847,9 +845,9 @@ Proof.
           Rabs (f t - phi_sequence RinvN pr2 n t) <= psi2 n t) /\
         Rabs (RiemannInt_SF (psi2 n)) < RinvN n)).
   intros; elim H; clear H; intros psi2 H; elim H0; clear H0; intros psi1 H0;
-    assert (H1 := RinvN_cv); unfold Un_cv in |- *; intros;
+    assert (H1 := RinvN_cv); unfold Un_cv; intros;
       assert (H3 : 0 < eps / 3).
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+  unfold Rdiv; apply Rmult_lt_0_compat;
     [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
   unfold Un_cv in H1; elim (H1 _ H3); clear H1; intros N0 H1;
     unfold R_dist in H1; simpl in H1;
@@ -857,10 +855,10 @@ Proof.
   intros; assert (H5 := H1 _ H4);
     replace (pos (RinvN n)) with (Rabs (/ (INR n + 1) - 0));
     [ assumption
-      | unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; apply Rabs_right;
+      | unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r; apply Rabs_right;
         left; apply (cond_pos (RinvN n)) ].
   clear H1; unfold Un_cv in u; elim (u _ H3); clear u; intros N1 H1;
-    exists (max N0 N1); intros; unfold R_dist in |- *;
+    exists (max N0 N1); intros; unfold R_dist;
       apply Rle_lt_trans with
         (Rabs
           (RiemannInt_SF (phi_sequence RinvN pr1 n) +
@@ -897,7 +895,7 @@ Proof.
       (mkStepFun
         (StepFun_P28 1 (psi1 n) (mkStepFun (StepFun_P6 (pre (psi2 n))))))).
   apply StepFun_P37; try assumption.
-  intros; simpl in |- *; rewrite Rmult_1_l;
+  intros; simpl; rewrite Rmult_1_l;
     apply Rle_trans with
       (Rabs (phi_sequence RinvN pr1 n x0 - f x0) +
         Rabs (f x0 - phi_sequence RinvN pr2 n x0)).
@@ -905,10 +903,10 @@ Proof.
   (phi_sequence RinvN pr1 n x0 - f x0 + (f x0 - phi_sequence RinvN pr2 n x0));
   [ apply Rabs_triang | ring ].
   assert (H7 : Rmin a b = a).
-  unfold Rmin in |- *; case (Rle_dec a b); intro;
+  unfold Rmin; case (Rle_dec a b); intro;
     [ reflexivity | elim n0; assumption ].
   assert (H8 : Rmax a b = b).
-  unfold Rmax in |- *; case (Rle_dec a b); intro;
+  unfold Rmax; case (Rle_dec a b); intro;
     [ reflexivity | elim n0; assumption ].
   apply Rplus_le_compat.
   elim (H0 n); intros; rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H9;
@@ -921,7 +919,7 @@ Proof.
     [ apply RRle_abs
       | apply Rlt_trans with (pos (RinvN n));
         [ assumption
-          | apply H4; unfold ge in |- *; apply le_trans with (max N0 N1);
+          | apply H4; unfold ge; apply le_trans with (max N0 N1);
             [ apply le_max_l | assumption ] ] ].
   elim (H n); intros;
     rewrite <-
@@ -931,7 +929,7 @@ Proof.
           [ rewrite <- Rabs_Ropp; apply RRle_abs
             | apply Rlt_trans with (pos (RinvN n));
               [ assumption
-                | apply H4; unfold ge in |- *; apply le_trans with (max N0 N1);
+                | apply H4; unfold ge; apply le_trans with (max N0 N1);
                   [ apply le_max_l | assumption ] ] ].
   assert (Hyp : b <= a).
   auto with real.
@@ -950,7 +948,7 @@ Proof.
       (mkStepFun
         (StepFun_P28 1 (mkStepFun (StepFun_P6 (pre (psi1 n)))) (psi2 n)))).
   apply StepFun_P37; try assumption.
-  intros; simpl in |- *; rewrite Rmult_1_l;
+  intros; simpl; rewrite Rmult_1_l;
     apply Rle_trans with
       (Rabs (phi_sequence RinvN pr1 n x0 - f x0) +
         Rabs (f x0 - phi_sequence RinvN pr2 n x0)).
@@ -958,10 +956,10 @@ Proof.
   (phi_sequence RinvN pr1 n x0 - f x0 + (f x0 - phi_sequence RinvN pr2 n x0));
   [ apply Rabs_triang | ring ].
   assert (H7 : Rmin a b = b).
-  unfold Rmin in |- *; case (Rle_dec a b); intro;
+  unfold Rmin; case (Rle_dec a b); intro;
     [ elim n0; assumption | reflexivity ].
   assert (H8 : Rmax a b = a).
-  unfold Rmax in |- *; case (Rle_dec a b); intro;
+  unfold Rmax; case (Rle_dec a b); intro;
     [ elim n0; assumption | reflexivity ].
   apply Rplus_le_compat.
   elim (H0 n); intros; rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H9;
@@ -978,18 +976,18 @@ Proof.
           [ rewrite <- Rabs_Ropp; apply RRle_abs
             | apply Rlt_trans with (pos (RinvN n));
               [ assumption
-                | apply H4; unfold ge in |- *; apply le_trans with (max N0 N1);
+                | apply H4; unfold ge; apply le_trans with (max N0 N1);
                   [ apply le_max_l | assumption ] ] ].
   elim (H n); intros; apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi2 n)));
     [ apply RRle_abs
       | apply Rlt_trans with (pos (RinvN n));
         [ assumption
-          | apply H4; unfold ge in |- *; apply le_trans with (max N0 N1);
+          | apply H4; unfold ge; apply le_trans with (max N0 N1);
             [ apply le_max_l | assumption ] ] ].
-  unfold R_dist in H1; apply H1; unfold ge in |- *;
+  unfold R_dist in H1; apply H1; unfold ge;
     apply le_trans with (max N0 N1); [ apply le_max_r | assumption ].
   apply Rmult_eq_reg_l with 3;
-    [ unfold Rdiv in |- *; rewrite Rmult_plus_distr_l;
+    [ unfold Rdiv; rewrite Rmult_plus_distr_l;
       do 2 rewrite (Rmult_comm 3); repeat rewrite Rmult_assoc;
         rewrite <- Rinv_l_sym; [ ring | discrR ]
       | discrR ].
@@ -1004,7 +1002,7 @@ Lemma RiemannInt_P9 :
   forall (f:R -> R) (a:R) (pr:Riemann_integrable f a a), RiemannInt pr = 0.
 Proof.
   intros; assert (H := RiemannInt_P8 pr pr); apply Rmult_eq_reg_l with 2;
-    [ rewrite Rmult_0_r; rewrite double; pattern (RiemannInt pr) at 2 in |- *;
+    [ rewrite Rmult_0_r; rewrite double; pattern (RiemannInt pr) at 2;
       rewrite H; apply Rplus_opp_r
       | discrR ].
 Qed.
@@ -1013,9 +1011,9 @@ Lemma Req_EM_T : forall r1 r2:R, {r1 = r2} + {r1 <> r2}.
 Proof.
   intros; elim (total_order_T r1 r2); intros;
     [ elim a; intro;
-      [ right; red in |- *; intro; rewrite H in a0; elim (Rlt_irrefl r2 a0)
+      [ right; red; intro; rewrite H in a0; elim (Rlt_irrefl r2 a0)
         | left; assumption ]
-      | right; red in |- *; intro; rewrite H in b; elim (Rlt_irrefl r2 b) ].
+      | right; red; intro; rewrite H in b; elim (Rlt_irrefl r2 b) ].
 Qed.
 
 (* L1([a,b]) is a vectorial space *)
@@ -1025,16 +1023,16 @@ Lemma RiemannInt_P10 :
     Riemann_integrable g a b ->
     Riemann_integrable (fun x:R => f x + l * g x) a b.
 Proof.
-  unfold Riemann_integrable in |- *; intros f g; intros; case (Req_EM_T l 0);
+  unfold Riemann_integrable; intros f g; intros; case (Req_EM_T l 0);
     intro.
   elim (X eps); intros; split with x; elim p; intros; split with x0; elim p0;
     intros; split; try assumption; rewrite e; intros;
       rewrite Rmult_0_l; rewrite Rplus_0_r; apply H; assumption.
   assert (H : 0 < eps / 2).
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+  unfold Rdiv; apply Rmult_lt_0_compat;
     [ apply (cond_pos eps) | apply Rinv_0_lt_compat; prove_sup0 ].
   assert (H0 : 0 < eps / (2 * Rabs l)).
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+  unfold Rdiv; apply Rmult_lt_0_compat;
     [ apply (cond_pos eps)
       | apply Rinv_0_lt_compat; apply Rmult_lt_0_compat;
         [ prove_sup0 | apply Rabs_pos_lt; assumption ] ].
@@ -1042,7 +1040,7 @@ Proof.
     split with (mkStepFun (StepFun_P28 l x x0)); elim p0;
       elim p; intros; split with (mkStepFun (StepFun_P28 (Rabs l) x1 x2));
         elim p1; elim p2; clear p1 p2 p0 p X X0; intros; split.
-  intros; simpl in |- *;
+  intros; simpl;
     apply Rle_trans with (Rabs (f t - x t) + Rabs (l * (g t - x0 t))).
   replace (f t + l * g t - (x t + l * x0 t)) with
   (f t - x t + l * (g t - x0 t)); [ apply Rabs_triang | ring ].
@@ -1062,7 +1060,7 @@ Proof.
     [ rewrite Rmult_1_l;
       replace (/ Rabs l * (eps / 2)) with (eps / (2 * Rabs l));
       [ apply H2
-        | unfold Rdiv in |- *; rewrite Rinv_mult_distr;
+        | unfold Rdiv; rewrite Rinv_mult_distr;
           [ ring | discrR | apply Rabs_no_R0; assumption ] ]
       | apply Rabs_no_R0; assumption ].
 Qed.
@@ -1082,14 +1080,14 @@ Lemma RiemannInt_P11 :
     Un_cv (fun N:nat => RiemannInt_SF (phi1 N)) l ->
     Un_cv (fun N:nat => RiemannInt_SF (phi2 N)) l.
 Proof.
-  unfold Un_cv in |- *; intro f; intros; intros.
+  unfold Un_cv; intro f; intros; intros.
   case (Rle_dec a b); intro Hyp.
   assert (H4 : 0 < eps / 3).
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+  unfold Rdiv; apply Rmult_lt_0_compat;
     [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
   elim (H _ H4); clear H; intros N0 H.
   elim (H2 _ H4); clear H2; intros N1 H2.
-  set (N := max N0 N1); exists N; intros; unfold R_dist in |- *.
+  set (N := max N0 N1); exists N; intros; unfold R_dist.
   apply Rle_lt_trans with
     (Rabs (RiemannInt_SF (phi2 n) - RiemannInt_SF (phi1 n)) +
       Rabs (RiemannInt_SF (phi1 n) - l)).
@@ -1108,24 +1106,24 @@ Proof.
   apply StepFun_P34; assumption.
   apply Rle_lt_trans with
     (RiemannInt_SF (mkStepFun (StepFun_P28 1 (psi1 n) (psi2 n)))).
-  apply StepFun_P37; try assumption; intros; simpl in |- *; rewrite Rmult_1_l.
+  apply StepFun_P37; try assumption; intros; simpl; rewrite Rmult_1_l.
   apply Rle_trans with (Rabs (phi2 n x - f x) + Rabs (f x - phi1 n x)).
   replace (phi2 n x + -1 * phi1 n x) with (phi2 n x - f x + (f x - phi1 n x));
   [ apply Rabs_triang | ring ].
   rewrite (Rplus_comm (psi1 n x)); apply Rplus_le_compat.
   rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; elim (H1 n); intros; apply H7.
   assert (H10 : Rmin a b = a).
-  unfold Rmin in |- *; case (Rle_dec a b); intro;
+  unfold Rmin; case (Rle_dec a b); intro;
     [ reflexivity | elim n0; assumption ].
   assert (H11 : Rmax a b = b).
-  unfold Rmax in |- *; case (Rle_dec a b); intro;
+  unfold Rmax; case (Rle_dec a b); intro;
     [ reflexivity | elim n0; assumption ].
   rewrite H10; rewrite H11; elim H6; intros; split; left; assumption.
   elim (H0 n); intros; apply H7; assert (H10 : Rmin a b = a).
-  unfold Rmin in |- *; case (Rle_dec a b); intro;
+  unfold Rmin; case (Rle_dec a b); intro;
     [ reflexivity | elim n0; assumption ].
   assert (H11 : Rmax a b = b).
-  unfold Rmax in |- *; case (Rle_dec a b); intro;
+  unfold Rmax; case (Rle_dec a b); intro;
     [ reflexivity | elim n0; assumption ].
   rewrite H10; rewrite H11; elim H6; intros; split; left; assumption.
   rewrite StepFun_P30; rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat.
@@ -1134,9 +1132,9 @@ Proof.
   apply RRle_abs.
   assumption.
   replace (pos (un n)) with (R_dist (un n) 0).
-  apply H; unfold ge in |- *; apply le_trans with N; try assumption.
-  unfold N in |- *; apply le_max_l.
-  unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
+  apply H; unfold ge; apply le_trans with N; try assumption.
+  unfold N; apply le_max_l.
+  unfold R_dist; unfold Rminus; rewrite Ropp_0;
     rewrite Rplus_0_r; apply Rabs_right.
   apply Rle_ge; left; apply (cond_pos (un n)).
   apply Rlt_trans with (pos (un n)).
@@ -1144,24 +1142,24 @@ Proof.
   apply RRle_abs; assumption.
   assumption.
   replace (pos (un n)) with (R_dist (un n) 0).
-  apply H; unfold ge in |- *; apply le_trans with N; try assumption;
-    unfold N in |- *; apply le_max_l.
-  unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
+  apply H; unfold ge; apply le_trans with N; try assumption;
+    unfold N; apply le_max_l.
+  unfold R_dist; unfold Rminus; rewrite Ropp_0;
     rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge;
       left; apply (cond_pos (un n)).
-  unfold R_dist in H2; apply H2; unfold ge in |- *; apply le_trans with N;
-    try assumption; unfold N in |- *; apply le_max_r.
+  unfold R_dist in H2; apply H2; unfold ge; apply le_trans with N;
+    try assumption; unfold N; apply le_max_r.
   apply Rmult_eq_reg_l with 3;
-    [ unfold Rdiv in |- *; rewrite Rmult_plus_distr_l;
+    [ unfold Rdiv; rewrite Rmult_plus_distr_l;
       do 2 rewrite (Rmult_comm 3); repeat rewrite Rmult_assoc;
         rewrite <- Rinv_l_sym; [ ring | discrR ]
       | discrR ].
   assert (H4 : 0 < eps / 3).
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+  unfold Rdiv; apply Rmult_lt_0_compat;
     [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
   elim (H _ H4); clear H; intros N0 H.
   elim (H2 _ H4); clear H2; intros N1 H2.
-  set (N := max N0 N1); exists N; intros; unfold R_dist in |- *.
+  set (N := max N0 N1); exists N; intros; unfold R_dist.
   apply Rle_lt_trans with
     (Rabs (RiemannInt_SF (phi2 n) - RiemannInt_SF (phi1 n)) +
       Rabs (RiemannInt_SF (phi1 n) - l)).
@@ -1191,24 +1189,24 @@ Proof.
       (mkStepFun
         (StepFun_P6 (pre (mkStepFun (StepFun_P28 1 (psi1 n) (psi2 n))))))).
   apply StepFun_P37; try assumption.
-  intros; simpl in |- *; rewrite Rmult_1_l.
+  intros; simpl; rewrite Rmult_1_l.
   apply Rle_trans with (Rabs (phi2 n x - f x) + Rabs (f x - phi1 n x)).
   replace (phi2 n x + -1 * phi1 n x) with (phi2 n x - f x + (f x - phi1 n x));
   [ apply Rabs_triang | ring ].
   rewrite (Rplus_comm (psi1 n x)); apply Rplus_le_compat.
   rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; elim (H1 n); intros; apply H7.
   assert (H10 : Rmin a b = b).
-  unfold Rmin in |- *; case (Rle_dec a b); intro;
+  unfold Rmin; case (Rle_dec a b); intro;
     [ elim Hyp; assumption | reflexivity ].
   assert (H11 : Rmax a b = a).
-  unfold Rmax in |- *; case (Rle_dec a b); intro;
+  unfold Rmax; case (Rle_dec a b); intro;
     [ elim Hyp; assumption | reflexivity ].
   rewrite H10; rewrite H11; elim H6; intros; split; left; assumption.
   elim (H0 n); intros; apply H7; assert (H10 : Rmin a b = b).
-  unfold Rmin in |- *; case (Rle_dec a b); intro;
+  unfold Rmin; case (Rle_dec a b); intro;
     [ elim Hyp; assumption | reflexivity ].
   assert (H11 : Rmax a b = a).
-  unfold Rmax in |- *; case (Rle_dec a b); intro;
+  unfold Rmax; case (Rle_dec a b); intro;
     [ elim Hyp; assumption | reflexivity ].
   rewrite H10; rewrite H11; elim H6; intros; split; left; assumption.
   rewrite <-
@@ -1226,9 +1224,9 @@ Proof.
   rewrite <- Rabs_Ropp; apply RRle_abs.
   assumption.
   replace (pos (un n)) with (R_dist (un n) 0).
-  apply H; unfold ge in |- *; apply le_trans with N; try assumption.
-  unfold N in |- *; apply le_max_l.
-  unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
+  apply H; unfold ge; apply le_trans with N; try assumption.
+  unfold N; apply le_max_l.
+  unfold R_dist; unfold Rminus; rewrite Ropp_0;
     rewrite Rplus_0_r; apply Rabs_right.
   apply Rle_ge; left; apply (cond_pos (un n)).
   apply Rlt_trans with (pos (un n)).
@@ -1236,15 +1234,15 @@ Proof.
   rewrite <- Rabs_Ropp; apply RRle_abs; assumption.
   assumption.
   replace (pos (un n)) with (R_dist (un n) 0).
-  apply H; unfold ge in |- *; apply le_trans with N; try assumption;
-    unfold N in |- *; apply le_max_l.
-  unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
+  apply H; unfold ge; apply le_trans with N; try assumption;
+    unfold N; apply le_max_l.
+  unfold R_dist; unfold Rminus; rewrite Ropp_0;
     rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge;
       left; apply (cond_pos (un n)).
-  unfold R_dist in H2; apply H2; unfold ge in |- *; apply le_trans with N;
-    try assumption; unfold N in |- *; apply le_max_r.
+  unfold R_dist in H2; apply H2; unfold ge; apply le_trans with N;
+    try assumption; unfold N; apply le_max_r.
   apply Rmult_eq_reg_l with 3;
-    [ unfold Rdiv in |- *; rewrite Rmult_plus_distr_l;
+    [ unfold Rdiv; rewrite Rmult_plus_distr_l;
       do 2 rewrite (Rmult_comm 3); repeat rewrite Rmult_assoc;
         rewrite <- Rinv_l_sym; [ ring | discrR ]
       | discrR ].
@@ -1257,8 +1255,8 @@ Lemma RiemannInt_P12 :
     a <= b -> RiemannInt pr3 = RiemannInt pr1 + l * RiemannInt pr2.
 Proof.
   intro f; intros; case (Req_dec l 0); intro.
-  pattern l at 2 in |- *; rewrite H0; rewrite Rmult_0_l; rewrite Rplus_0_r;
-    unfold RiemannInt in |- *; case (RiemannInt_exists pr3 RinvN RinvN_cv);
+  pattern l at 2; rewrite H0; rewrite Rmult_0_l; rewrite Rplus_0_r;
+    unfold RiemannInt; case (RiemannInt_exists pr3 RinvN RinvN_cv);
       case (RiemannInt_exists pr1 RinvN RinvN_cv); intros;
         eapply UL_sequence;
           [ apply u0
@@ -1280,18 +1278,18 @@ Proof.
                             [ apply H2; assumption | rewrite H0; ring ] ]
                     | assumption ] ].
   eapply UL_sequence.
-  unfold RiemannInt in |- *; case (RiemannInt_exists pr3 RinvN RinvN_cv);
+  unfold RiemannInt; case (RiemannInt_exists pr3 RinvN RinvN_cv);
     intros; apply u.
-  unfold Un_cv in |- *; intros; unfold RiemannInt in |- *;
+  unfold Un_cv; intros; unfold RiemannInt;
     case (RiemannInt_exists pr1 RinvN RinvN_cv);
-    case (RiemannInt_exists pr2 RinvN RinvN_cv); unfold Un_cv in |- *;
+    case (RiemannInt_exists pr2 RinvN RinvN_cv); unfold Un_cv;
       intros; assert (H2 : 0 < eps / 5).
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+  unfold Rdiv; apply Rmult_lt_0_compat;
     [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
   elim (u0 _ H2); clear u0; intros N0 H3; assert (H4 := RinvN_cv);
     unfold Un_cv in H4; elim (H4 _ H2); clear H4 H2; intros N1 H4;
       assert (H5 : 0 < eps / (5 * Rabs l)).
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+  unfold Rdiv; apply Rmult_lt_0_compat;
     [ assumption
       | apply Rinv_0_lt_compat; apply Rmult_lt_0_compat;
         [ prove_sup0 | apply Rabs_pos_lt; assumption ] ].
@@ -1300,17 +1298,17 @@ Proof.
       unfold R_dist in H3, H4, H5, H6; set (N := max (max N0 N1) (max N2 N3)).
   assert (H7 : forall n:nat, (n >= N1)%nat -> RinvN n < eps / 5).
   intros; replace (pos (RinvN n)) with (Rabs (RinvN n - 0));
-    [ unfold RinvN in |- *; apply H4; assumption
-      | unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; apply Rabs_right;
+    [ unfold RinvN; apply H4; assumption
+      | unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r; apply Rabs_right;
         left; apply (cond_pos (RinvN n)) ].
   clear H4; assert (H4 := H7); clear H7;
     assert (H7 : forall n:nat, (n >= N3)%nat -> RinvN n < eps / (5 * Rabs l)).
   intros; replace (pos (RinvN n)) with (Rabs (RinvN n - 0));
-    [ unfold RinvN in |- *; apply H5; assumption
-      | unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; apply Rabs_right;
+    [ unfold RinvN; apply H5; assumption
+      | unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r; apply Rabs_right;
         left; apply (cond_pos (RinvN n)) ].
   clear H5; assert (H5 := H7); clear H7; exists N; intros;
-    unfold R_dist in |- *.
+    unfold R_dist.
   apply Rle_lt_trans with
     (Rabs
       (RiemannInt_SF (phi_sequence RinvN pr3 n) -
@@ -1383,10 +1381,10 @@ Proof.
         (RiemannInt_SF (phi_sequence RinvN pr1 n) +
           l * RiemannInt_SF (phi_sequence RinvN pr2 n)));
       [ idtac | ring ]; do 2 rewrite <- StepFun_P30; assert (H10 : Rmin a b = a).
-  unfold Rmin in |- *; case (Rle_dec a b); intro;
+  unfold Rmin; case (Rle_dec a b); intro;
     [ reflexivity | elim n0; assumption ].
   assert (H11 : Rmax a b = b).
-  unfold Rmax in |- *; case (Rle_dec a b); intro;
+  unfold Rmax; case (Rle_dec a b); intro;
     [ reflexivity | elim n0; assumption ].
   rewrite H10 in H7; rewrite H10 in H8; rewrite H10 in H9; rewrite H11 in H7;
     rewrite H11 in H8; rewrite H11 in H9;
@@ -1406,7 +1404,7 @@ Proof.
         (StepFun_P28 1 (psi3 n)
           (mkStepFun (StepFun_P28 (Rabs l) (psi1 n) (psi2 n)))))).
   apply StepFun_P37; try assumption.
-  intros; simpl in |- *; rewrite Rmult_1_l.
+  intros; simpl; rewrite Rmult_1_l.
   apply Rle_trans with
     (Rabs (phi_sequence RinvN pr3 n x1 - (f x1 + l * g x1)) +
       Rabs
@@ -1446,16 +1444,16 @@ Proof.
   apply Rlt_trans with (pos (RinvN n));
     [ apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi3 n)));
       [ apply RRle_abs | elim (H9 n); intros; assumption ]
-      | apply H4; unfold ge in |- *; apply le_trans with N;
+      | apply H4; unfold ge; apply le_trans with N;
         [ apply le_trans with (max N0 N1);
-          [ apply le_max_r | unfold N in |- *; apply le_max_l ]
+          [ apply le_max_r | unfold N; apply le_max_l ]
           | assumption ] ].
   apply Rlt_trans with (pos (RinvN n));
     [ apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi1 n)));
       [ apply RRle_abs | elim (H7 n); intros; assumption ]
-      | apply H4; unfold ge in |- *; apply le_trans with N;
+      | apply H4; unfold ge; apply le_trans with N;
         [ apply le_trans with (max N0 N1);
-          [ apply le_max_r | unfold N in |- *; apply le_max_l ]
+          [ apply le_max_r | unfold N; apply le_max_l ]
           | assumption ] ].
   apply Rmult_lt_reg_l with (/ Rabs l).
   apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption.
@@ -1464,28 +1462,28 @@ Proof.
   apply Rlt_trans with (pos (RinvN n));
     [ apply Rle_lt_trans with (Rabs (RiemannInt_SF (psi2 n)));
       [ apply RRle_abs | elim (H8 n); intros; assumption ]
-      | apply H5; unfold ge in |- *; apply le_trans with N;
+      | apply H5; unfold ge; apply le_trans with N;
         [ apply le_trans with (max N2 N3);
-          [ apply le_max_r | unfold N in |- *; apply le_max_r ]
+          [ apply le_max_r | unfold N; apply le_max_r ]
           | assumption ] ].
-  unfold Rdiv in |- *; rewrite Rinv_mult_distr;
+  unfold Rdiv; rewrite Rinv_mult_distr;
     [ ring | discrR | apply Rabs_no_R0; assumption ].
   apply Rabs_no_R0; assumption.
-  apply H3; unfold ge in |- *; apply le_trans with (max N0 N1);
+  apply H3; unfold ge; apply le_trans with (max N0 N1);
     [ apply le_max_l
-      | apply le_trans with N; [ unfold N in |- *; apply le_max_l | assumption ] ].
+      | apply le_trans with N; [ unfold N; apply le_max_l | assumption ] ].
   apply Rmult_lt_reg_l with (/ Rabs l).
   apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption.
   rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
   rewrite Rmult_1_l; replace (/ Rabs l * (eps / 5)) with (eps / (5 * Rabs l)).
-  apply H6; unfold ge in |- *; apply le_trans with (max N2 N3);
+  apply H6; unfold ge; apply le_trans with (max N2 N3);
     [ apply le_max_l
-      | apply le_trans with N; [ unfold N in |- *; apply le_max_r | assumption ] ].
-  unfold Rdiv in |- *; rewrite Rinv_mult_distr;
+      | apply le_trans with N; [ unfold N; apply le_max_r | assumption ] ].
+  unfold Rdiv; rewrite Rinv_mult_distr;
     [ ring | discrR | apply Rabs_no_R0; assumption ].
   apply Rabs_no_R0; assumption.
   apply Rmult_eq_reg_l with 5;
-    [ unfold Rdiv in |- *; do 2 rewrite Rmult_plus_distr_l;
+    [ unfold Rdiv; do 2 rewrite Rmult_plus_distr_l;
       do 3 rewrite (Rmult_comm 5); repeat rewrite Rmult_assoc;
         rewrite <- Rinv_l_sym; [ ring | discrR ]
       | discrR ].
@@ -1502,11 +1500,11 @@ Proof.
       | assert (H : b <= a);
         [ auto with real
           | replace (RiemannInt pr3) with (- RiemannInt (RiemannInt_P1 pr3));
-            [ idtac | symmetry  in |- *; apply RiemannInt_P8 ];
+            [ idtac | symmetry ; apply RiemannInt_P8 ];
             replace (RiemannInt pr2) with (- RiemannInt (RiemannInt_P1 pr2));
-            [ idtac | symmetry  in |- *; apply RiemannInt_P8 ];
+            [ idtac | symmetry ; apply RiemannInt_P8 ];
             replace (RiemannInt pr1) with (- RiemannInt (RiemannInt_P1 pr1));
-            [ idtac | symmetry  in |- *; apply RiemannInt_P8 ];
+            [ idtac | symmetry ; apply RiemannInt_P8 ];
             rewrite
               (RiemannInt_P12 (RiemannInt_P1 pr1) (RiemannInt_P1 pr2)
                 (RiemannInt_P1 pr3) H); ring ] ].
@@ -1514,11 +1512,11 @@ Qed.
 
 Lemma RiemannInt_P14 : forall a b c:R, Riemann_integrable (fct_cte c) a b.
 Proof.
-  unfold Riemann_integrable in |- *; intros;
+  unfold Riemann_integrable; intros;
     split with (mkStepFun (StepFun_P4 a b c));
       split with (mkStepFun (StepFun_P4 a b 0)); split;
-        [ intros; simpl in |- *; unfold Rminus in |- *; rewrite Rplus_opp_r;
-          rewrite Rabs_R0; unfold fct_cte in |- *; right;
+        [ intros; simpl; unfold Rminus; rewrite Rplus_opp_r;
+          rewrite Rabs_R0; unfold fct_cte; right;
             reflexivity
           | rewrite StepFun_P18; rewrite Rmult_0_l; rewrite Rabs_R0;
             apply (cond_pos eps) ].
@@ -1528,11 +1526,11 @@ Lemma RiemannInt_P15 :
   forall (a b c:R) (pr:Riemann_integrable (fct_cte c) a b),
     RiemannInt pr = c * (b - a).
 Proof.
-  intros; unfold RiemannInt in |- *; case (RiemannInt_exists pr RinvN RinvN_cv);
+  intros; unfold RiemannInt; case (RiemannInt_exists pr RinvN RinvN_cv);
     intros; eapply UL_sequence.
   apply u.
   set (phi1 := fun N:nat => phi_sequence RinvN pr N);
-    change (Un_cv (fun N:nat => RiemannInt_SF (phi1 N)) (c * (b - a))) in |- *;
+    change (Un_cv (fun N:nat => RiemannInt_SF (phi1 N)) (c * (b - a)));
       set (f := fct_cte c);
         assert
           (H1 :
@@ -1551,13 +1549,13 @@ Proof.
           try assumption.
   apply RinvN_cv.
   intro; split.
-  intros; unfold f in |- *; simpl in |- *; unfold Rminus in |- *;
-    rewrite Rplus_opp_r; rewrite Rabs_R0; unfold fct_cte in |- *;
+  intros; unfold f; simpl; unfold Rminus;
+    rewrite Rplus_opp_r; rewrite Rabs_R0; unfold fct_cte;
       right; reflexivity.
-  unfold psi2 in |- *; rewrite StepFun_P18; rewrite Rmult_0_l; rewrite Rabs_R0;
+  unfold psi2; rewrite StepFun_P18; rewrite Rmult_0_l; rewrite Rabs_R0;
     apply (cond_pos (RinvN n)).
-  unfold Un_cv in |- *; intros; split with 0%nat; intros; unfold R_dist in |- *;
-    unfold phi2 in |- *; rewrite StepFun_P18; unfold Rminus in |- *;
+  unfold Un_cv; intros; split with 0%nat; intros; unfold R_dist;
+    unfold phi2; rewrite StepFun_P18; unfold Rminus;
       rewrite Rplus_opp_r; rewrite Rabs_R0; apply H.
 Qed.
 
@@ -1565,9 +1563,9 @@ Lemma RiemannInt_P16 :
   forall (f:R -> R) (a b:R),
     Riemann_integrable f a b -> Riemann_integrable (fun x:R => Rabs (f x)) a b.
 Proof.
-  unfold Riemann_integrable in |- *; intro f; intros; elim (X eps); clear X;
+  unfold Riemann_integrable; intro f; intros; elim (X eps); clear X;
     intros phi [psi [H H0]]; split with (mkStepFun (StepFun_P32 phi));
-      split with psi; split; try assumption; intros; simpl in |- *;
+      split with psi; split; try assumption; intros; simpl;
         apply Rle_trans with (Rabs (f t - phi t));
           [ apply Rabs_triang_inv2 | apply H; assumption ].
 Qed.
@@ -1581,9 +1579,9 @@ Proof.
   assert (H2 : l2 < l1).
   auto with real.
   clear n; assert (H3 : 0 < (l1 - l2) / 2).
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+  unfold Rdiv; apply Rmult_lt_0_compat;
     [ apply Rlt_Rminus; assumption | apply Rinv_0_lt_compat; prove_sup0 ].
-  elim (H1 _ H3); elim (H0 _ H3); clear H0 H1; unfold R_dist in |- *; intros;
+  elim (H1 _ H3); elim (H0 _ H3); clear H0 H1; unfold R_dist; intros;
     set (N := max x x0); cut (Vn N < Un N).
   intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ (H N) H4)).
   apply Rlt_trans with ((l1 + l2) / 2).
@@ -1591,9 +1589,9 @@ Proof.
     replace (- l2 + (l1 + l2) / 2) with ((l1 - l2) / 2).
   rewrite Rplus_comm; apply Rle_lt_trans with (Rabs (Vn N - l2)).
   apply RRle_abs.
-  apply H1; unfold ge in |- *; unfold N in |- *; apply le_max_r.
+  apply H1; unfold ge; unfold N; apply le_max_r.
   apply Rmult_eq_reg_l with 2;
-    [ unfold Rdiv in |- *; do 2 rewrite (Rmult_comm 2);
+    [ unfold Rdiv; do 2 rewrite (Rmult_comm 2);
       rewrite (Rmult_plus_distr_r (- l2) ((l1 + l2) * / 2) 2);
         repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym;
           [ ring | discrR ]
@@ -1602,9 +1600,9 @@ Proof.
     replace (l1 + - ((l1 + l2) / 2)) with ((l1 - l2) / 2).
   apply Rle_lt_trans with (Rabs (Un N - l1)).
   rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply RRle_abs.
-  apply H0; unfold ge in |- *; unfold N in |- *; apply le_max_l.
+  apply H0; unfold ge; unfold N; apply le_max_l.
   apply Rmult_eq_reg_l with 2;
-    [ unfold Rdiv in |- *; do 2 rewrite (Rmult_comm 2);
+    [ unfold Rdiv; do 2 rewrite (Rmult_comm 2);
       rewrite (Rmult_plus_distr_r l1 (- ((l1 + l2) * / 2)) 2);
         rewrite <- Ropp_mult_distr_l_reverse; repeat rewrite Rmult_assoc;
           rewrite <- Rinv_l_sym; [ ring | discrR ]
@@ -1616,7 +1614,7 @@ Lemma RiemannInt_P17 :
     (pr2:Riemann_integrable (fun x:R => Rabs (f x)) a b),
     a <= b -> Rabs (RiemannInt pr1) <= RiemannInt pr2.
 Proof.
-  intro f; intros; unfold RiemannInt in |- *;
+  intro f; intros; unfold RiemannInt;
     case (RiemannInt_exists pr1 RinvN RinvN_cv);
     case (RiemannInt_exists pr2 RinvN RinvN_cv); intros;
       set (phi1 := phi_sequence RinvN pr1) in u0;
@@ -1624,7 +1622,7 @@ Proof.
           apply Rle_cv_lim with
             (fun N:nat => Rabs (RiemannInt_SF (phi1 N)))
             (fun N:nat => RiemannInt_SF (phi2 N)).
-  intro; unfold phi2 in |- *; apply StepFun_P34; assumption.
+  intro; unfold phi2; apply StepFun_P34; assumption.
   apply (continuity_seq Rabs (fun N:nat => RiemannInt_SF (phi1 N)) x0);
     try assumption.
   apply Rcontinuity_abs.
@@ -1658,7 +1656,7 @@ Proof.
     apply (proj2_sig (phi_sequence_prop RinvN pr1 n)).
   elim H1; clear H1; intros psi2 H1; split with psi2; intros; elim (H1 n);
     clear H1; intros; split; try assumption.
-  intros; unfold phi2 in |- *; simpl in |- *;
+  intros; unfold phi2; simpl;
     apply Rle_trans with (Rabs (f t - phi1 n t)).
   apply Rabs_triang_inv2.
   apply H1; assumption.
@@ -1673,13 +1671,13 @@ Lemma RiemannInt_P18 :
     a <= b ->
     (forall x:R, a < x < b -> f x = g x) -> RiemannInt pr1 = RiemannInt pr2.
 Proof.
-  intro f; intros; unfold RiemannInt in |- *;
+  intro f; intros; unfold RiemannInt;
     case (RiemannInt_exists pr1 RinvN RinvN_cv);
     case (RiemannInt_exists pr2 RinvN RinvN_cv); intros;
       eapply UL_sequence.
   apply u0.
   set (phi1 := fun N:nat => phi_sequence RinvN pr1 N);
-    change (Un_cv (fun N:nat => RiemannInt_SF (phi1 N)) x) in |- *;
+    change (Un_cv (fun N:nat => RiemannInt_SF (phi1 N)) x);
       assert
         (H1 :
           exists psi1 : nat -> StepFun a b,
@@ -1719,45 +1717,45 @@ Proof.
       try assumption.
   apply RinvN_cv.
   intro; elim (H2 n); intros; split; try assumption.
-  intros; unfold phi2_m in |- *; simpl in |- *; unfold phi2_aux in |- *;
+  intros; unfold phi2_m; simpl; unfold phi2_aux;
     case (Req_EM_T t a); case (Req_EM_T t b); intros.
-  rewrite e0; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+  rewrite e0; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0;
     apply Rle_trans with (Rabs (g t - phi2 n t)).
   apply Rabs_pos.
-  pattern a at 3 in |- *; rewrite <- e0; apply H3; assumption.
-  rewrite e; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+  pattern a at 3; rewrite <- e0; apply H3; assumption.
+  rewrite e; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0;
     apply Rle_trans with (Rabs (g t - phi2 n t)).
   apply Rabs_pos.
-  pattern a at 3 in |- *; rewrite <- e; apply H3; assumption.
-  rewrite e; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+  pattern a at 3; rewrite <- e; apply H3; assumption.
+  rewrite e; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0;
     apply Rle_trans with (Rabs (g t - phi2 n t)).
   apply Rabs_pos.
-  pattern b at 3 in |- *; rewrite <- e; apply H3; assumption.
+  pattern b at 3; rewrite <- e; apply H3; assumption.
   replace (f t) with (g t).
   apply H3; assumption.
-  symmetry  in |- *; apply H0; elim H5; clear H5; intros.
+  symmetry ; apply H0; elim H5; clear H5; intros.
   assert (H7 : Rmin a b = a).
-  unfold Rmin in |- *; case (Rle_dec a b); intro;
+  unfold Rmin; case (Rle_dec a b); intro;
     [ reflexivity | elim n2; assumption ].
   assert (H8 : Rmax a b = b).
-  unfold Rmax in |- *; case (Rle_dec a b); intro;
+  unfold Rmax; case (Rle_dec a b); intro;
     [ reflexivity | elim n2; assumption ].
   rewrite H7 in H5; rewrite H8 in H6; split.
-  elim H5; intro; [ assumption | elim n1; symmetry  in |- *; assumption ].
+  elim H5; intro; [ assumption | elim n1; symmetry ; assumption ].
   elim H6; intro; [ assumption | elim n0; assumption ].
   cut (forall N:nat, RiemannInt_SF (phi2_m N) = RiemannInt_SF (phi2 N)).
-  intro; unfold Un_cv in |- *; intros; elim (u _ H4); intros; exists x1; intros;
+  intro; unfold Un_cv; intros; elim (u _ H4); intros; exists x1; intros;
     rewrite (H3 n); apply H5; assumption.
   intro; apply Rle_antisym.
   apply StepFun_P37; try assumption.
-  intros; unfold phi2_m in |- *; simpl in |- *; unfold phi2_aux in |- *;
+  intros; unfold phi2_m; simpl; unfold phi2_aux;
     case (Req_EM_T x1 a); case (Req_EM_T x1 b); intros.
   elim H3; intros; rewrite e0 in H4; elim (Rlt_irrefl _ H4).
   elim H3; intros; rewrite e in H4; elim (Rlt_irrefl _ H4).
   elim H3; intros; rewrite e in H5; elim (Rlt_irrefl _ H5).
   right; reflexivity.
   apply StepFun_P37; try assumption.
-  intros; unfold phi2_m in |- *; simpl in |- *; unfold phi2_aux in |- *;
+  intros; unfold phi2_m; simpl; unfold phi2_aux;
     case (Req_EM_T x1 a); case (Req_EM_T x1 b); intros.
   elim H3; intros; rewrite e0 in H4; elim (Rlt_irrefl _ H4).
   elim H3; intros; rewrite e in H4; elim (Rlt_irrefl _ H4).
@@ -1766,10 +1764,10 @@ Proof.
   intro; assert (H2 := pre (phi2 N)); unfold IsStepFun in H2;
     unfold is_subdivision in H2; elim H2; clear H2; intros l [lf H2];
       split with l; split with lf; unfold adapted_couple in H2;
-        decompose [and] H2; clear H2; unfold adapted_couple in |- *;
+        decompose [and] H2; clear H2; unfold adapted_couple;
           repeat split; try assumption.
   intros; assert (H9 := H8 i H2); unfold constant_D_eq, open_interval in H9;
-    unfold constant_D_eq, open_interval in |- *; intros;
+    unfold constant_D_eq, open_interval; intros;
       rewrite <- (H9 x1 H7); assert (H10 : a <= pos_Rl l i).
   replace a with (Rmin a b).
   rewrite <- H5; elim (RList_P6 l); intros; apply H10.
@@ -1777,7 +1775,7 @@ Proof.
   apply le_O_n.
   apply lt_trans with (pred (Rlength l)); [ assumption | apply lt_pred_n_n ].
   apply neq_O_lt; intro; rewrite <- H12 in H6; discriminate.
-  unfold Rmin in |- *; case (Rle_dec a b); intro;
+  unfold Rmin; case (Rle_dec a b); intro;
     [ reflexivity | elim n; assumption ].
   assert (H11 : pos_Rl l (S i) <= b).
   replace b with (Rmax a b).
@@ -1785,9 +1783,9 @@ Proof.
   assumption.
   apply lt_le_S; assumption.
   apply lt_pred_n_n; apply neq_O_lt; intro; rewrite <- H13 in H6; discriminate.
-  unfold Rmax in |- *; case (Rle_dec a b); intro;
+  unfold Rmax; case (Rle_dec a b); intro;
     [ reflexivity | elim n; assumption ].
-  elim H7; clear H7; intros; unfold phi2_aux in |- *; case (Req_EM_T x1 a);
+  elim H7; clear H7; intros; unfold phi2_aux; case (Req_EM_T x1 a);
     case (Req_EM_T x1 b); intros.
   rewrite e in H12; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H11 H12)).
   rewrite e in H7; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H10 H7)).
@@ -1854,12 +1852,12 @@ Proof.
   intros; replace (primitive h pr a) with 0.
   replace (RiemannInt pr0) with (primitive h pr b).
   ring.
-  unfold primitive in |- *; case (Rle_dec a b); case (Rle_dec b b); intros;
+  unfold primitive; case (Rle_dec a b); case (Rle_dec b b); intros;
     [ apply RiemannInt_P5
       | elim n; right; reflexivity
       | elim n; assumption
       | elim n0; assumption ].
-  symmetry  in |- *; unfold primitive in |- *; case (Rle_dec a a);
+  symmetry ; unfold primitive; case (Rle_dec a a);
     case (Rle_dec a b); intros;
       [ apply RiemannInt_P9
         | elim n; assumption
@@ -1874,9 +1872,9 @@ Lemma RiemannInt_P21 :
     Riemann_integrable f a b ->
     Riemann_integrable f b c -> Riemann_integrable f a c.
 Proof.
-  unfold Riemann_integrable in |- *; intros f a b c Hyp1 Hyp2 X X0 eps.
+  unfold Riemann_integrable; intros f a b c Hyp1 Hyp2 X X0 eps.
   assert (H : 0 < eps / 2).
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+  unfold Rdiv; apply Rmult_lt_0_compat;
     [ apply (cond_pos eps) | apply Rinv_0_lt_compat; prove_sup0 ].
   elim (X (mkposreal _ H)); clear X; intros phi1 [psi1 H1];
     elim (X0 (mkposreal _ H)); clear X0; intros phi2 [psi2 H2].
@@ -1906,35 +1904,35 @@ Proof.
   intro; cut (IsStepFun psi3 a b).
   intro; cut (IsStepFun psi3 b c).
   intro; cut (IsStepFun psi3 a c).
-  intro; split with (mkStepFun X); split with (mkStepFun X2); simpl in |- *;
+  intro; split with (mkStepFun X); split with (mkStepFun X2); simpl;
     split.
-  intros; unfold phi3, psi3 in |- *; case (Rle_dec t b); case (Rle_dec a t);
+  intros; unfold phi3, psi3; case (Rle_dec t b); case (Rle_dec a t);
     intros.
   elim H1; intros; apply H3.
   replace (Rmin a b) with a.
   replace (Rmax a b) with b.
   split; assumption.
-  unfold Rmax in |- *; case (Rle_dec a b); intro;
+  unfold Rmax; case (Rle_dec a b); intro;
     [ reflexivity | elim n; assumption ].
-  unfold Rmin in |- *; case (Rle_dec a b); intro;
+  unfold Rmin; case (Rle_dec a b); intro;
     [ reflexivity | elim n; assumption ].
   elim n; replace a with (Rmin a c).
   elim H0; intros; assumption.
-  unfold Rmin in |- *; case (Rle_dec a c); intro;
+  unfold Rmin; case (Rle_dec a c); intro;
     [ reflexivity | elim n0; apply Rle_trans with b; assumption ].
   elim H2; intros; apply H3.
   replace (Rmax b c) with (Rmax a c).
   elim H0; intros; split; try assumption.
   replace (Rmin b c) with b.
   auto with real.
-  unfold Rmin in |- *; case (Rle_dec b c); intro;
+  unfold Rmin; case (Rle_dec b c); intro;
     [ reflexivity | elim n0; assumption ].
-  unfold Rmax in |- *; case (Rle_dec a c); case (Rle_dec b c); intros;
+  unfold Rmax; case (Rle_dec a c); case (Rle_dec b c); intros;
     try (elim n0; assumption || elim n0; apply Rle_trans with b; assumption).
   reflexivity.
   elim n; replace a with (Rmin a c).
   elim H0; intros; assumption.
-  unfold Rmin in |- *; case (Rle_dec a c); intro;
+  unfold Rmin; case (Rle_dec a c); intro;
     [ reflexivity | elim n1; apply Rle_trans with b; assumption ].
   rewrite <- (StepFun_P43 X0 X1 X2).
   apply Rle_lt_trans with
@@ -1948,14 +1946,14 @@ Proof.
   elim H2; intros; assumption.
   apply Rle_antisym.
   apply StepFun_P37; try assumption.
-  simpl in |- *; intros; unfold psi3 in |- *; elim H0; clear H0; intros;
+  simpl; intros; unfold psi3; elim H0; clear H0; intros;
     case (Rle_dec a x); case (Rle_dec x b); intros;
       [ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H0))
         | right; reflexivity
         | elim n; apply Rle_trans with b; [ assumption | left; assumption ]
         | elim n0; apply Rle_trans with b; [ assumption | left; assumption ] ].
   apply StepFun_P37; try assumption.
-  simpl in |- *; intros; unfold psi3 in |- *; elim H0; clear H0; intros;
+  simpl; intros; unfold psi3; elim H0; clear H0; intros;
     case (Rle_dec a x); case (Rle_dec x b); intros;
       [ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H0))
         | right; reflexivity
@@ -1963,14 +1961,14 @@ Proof.
         | elim n0; apply Rle_trans with b; [ assumption | left; assumption ] ].
   apply Rle_antisym.
   apply StepFun_P37; try assumption.
-  simpl in |- *; intros; unfold psi3 in |- *; elim H0; clear H0; intros;
+  simpl; intros; unfold psi3; elim H0; clear H0; intros;
     case (Rle_dec a x); case (Rle_dec x b); intros;
       [ right; reflexivity
         | elim n; left; assumption
         | elim n; left; assumption
         | elim n0; left; assumption ].
   apply StepFun_P37; try assumption.
-  simpl in |- *; intros; unfold psi3 in |- *; elim H0; clear H0; intros;
+  simpl; intros; unfold psi3; elim H0; clear H0; intros;
     case (Rle_dec a x); case (Rle_dec x b); intros;
       [ right; reflexivity
         | elim n; left; assumption
@@ -1980,19 +1978,19 @@ Proof.
   assert (H3 := pre psi2); unfold IsStepFun in H3; unfold is_subdivision in H3;
     elim H3; clear H3; intros l1 [lf1 H3]; split with l1;
       split with lf1; unfold adapted_couple in H3; decompose [and] H3;
-        clear H3; unfold adapted_couple in |- *; repeat split;
+        clear H3; unfold adapted_couple; repeat split;
           try assumption.
-  intros; assert (H9 := H8 i H3); unfold constant_D_eq, open_interval in |- *;
+  intros; assert (H9 := H8 i H3); unfold constant_D_eq, open_interval;
     unfold constant_D_eq, open_interval in H9; intros;
-      rewrite <- (H9 x H7); unfold psi3 in |- *; assert (H10 : b < x).
+      rewrite <- (H9 x H7); unfold psi3; assert (H10 : b < x).
   apply Rle_lt_trans with (pos_Rl l1 i).
   replace b with (Rmin b c).
   rewrite <- H5; elim (RList_P6 l1); intros; apply H10; try assumption.
   apply le_O_n.
   apply lt_trans with (pred (Rlength l1)); try assumption; apply lt_pred_n_n;
-    apply neq_O_lt; red in |- *; intro; rewrite <- H12 in H6;
+    apply neq_O_lt; red; intro; rewrite <- H12 in H6;
       discriminate.
-  unfold Rmin in |- *; case (Rle_dec b c); intro;
+  unfold Rmin; case (Rle_dec b c); intro;
     [ reflexivity | elim n; assumption ].
   elim H7; intros; assumption.
   case (Rle_dec a x); case (Rle_dec x b); intros;
@@ -2003,18 +2001,18 @@ Proof.
   assert (H3 := pre psi1); unfold IsStepFun in H3; unfold is_subdivision in H3;
     elim H3; clear H3; intros l1 [lf1 H3]; split with l1;
       split with lf1; unfold adapted_couple in H3; decompose [and] H3;
-        clear H3; unfold adapted_couple in |- *; repeat split;
+        clear H3; unfold adapted_couple; repeat split;
           try assumption.
-  intros; assert (H9 := H8 i H3); unfold constant_D_eq, open_interval in |- *;
+  intros; assert (H9 := H8 i H3); unfold constant_D_eq, open_interval;
     unfold constant_D_eq, open_interval in H9; intros;
-      rewrite <- (H9 x H7); unfold psi3 in |- *; assert (H10 : x <= b).
+      rewrite <- (H9 x H7); unfold psi3; assert (H10 : x <= b).
   apply Rle_trans with (pos_Rl l1 (S i)).
   elim H7; intros; left; assumption.
   replace b with (Rmax a b).
   rewrite <- H4; elim (RList_P6 l1); intros; apply H10; try assumption.
-  apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro; rewrite <- H12 in H6;
+  apply lt_pred_n_n; apply neq_O_lt; red; intro; rewrite <- H12 in H6;
     discriminate.
-  unfold Rmax in |- *; case (Rle_dec a b); intro;
+  unfold Rmax; case (Rle_dec a b); intro;
     [ reflexivity | elim n; assumption ].
   assert (H11 : a <= x).
   apply Rle_trans with (pos_Rl l1 i).
@@ -2022,9 +2020,9 @@ Proof.
   rewrite <- H5; elim (RList_P6 l1); intros; apply H11; try assumption.
   apply le_O_n.
   apply lt_trans with (pred (Rlength l1)); try assumption; apply lt_pred_n_n;
-    apply neq_O_lt; red in |- *; intro; rewrite <- H13 in H6;
+    apply neq_O_lt; red; intro; rewrite <- H13 in H6;
       discriminate.
-  unfold Rmin in |- *; case (Rle_dec a b); intro;
+  unfold Rmin; case (Rle_dec a b); intro;
     [ reflexivity | elim n; assumption ].
   left; elim H7; intros; assumption.
   case (Rle_dec a x); case (Rle_dec x b); intros; reflexivity || elim n;
@@ -2033,18 +2031,18 @@ Proof.
   assert (H3 := pre phi1); unfold IsStepFun in H3; unfold is_subdivision in H3;
     elim H3; clear H3; intros l1 [lf1 H3]; split with l1;
       split with lf1; unfold adapted_couple in H3; decompose [and] H3;
-        clear H3; unfold adapted_couple in |- *; repeat split;
+        clear H3; unfold adapted_couple; repeat split;
           try assumption.
-  intros; assert (H9 := H8 i H3); unfold constant_D_eq, open_interval in |- *;
+  intros; assert (H9 := H8 i H3); unfold constant_D_eq, open_interval;
     unfold constant_D_eq, open_interval in H9; intros;
-      rewrite <- (H9 x H7); unfold psi3 in |- *; assert (H10 : x <= b).
+      rewrite <- (H9 x H7); unfold psi3; assert (H10 : x <= b).
   apply Rle_trans with (pos_Rl l1 (S i)).
   elim H7; intros; left; assumption.
   replace b with (Rmax a b).
   rewrite <- H4; elim (RList_P6 l1); intros; apply H10; try assumption.
-  apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro; rewrite <- H12 in H6;
+  apply lt_pred_n_n; apply neq_O_lt; red; intro; rewrite <- H12 in H6;
     discriminate.
-  unfold Rmax in |- *; case (Rle_dec a b); intro;
+  unfold Rmax; case (Rle_dec a b); intro;
     [ reflexivity | elim n; assumption ].
   assert (H11 : a <= x).
   apply Rle_trans with (pos_Rl l1 i).
@@ -2052,32 +2050,32 @@ Proof.
   rewrite <- H5; elim (RList_P6 l1); intros; apply H11; try assumption.
   apply le_O_n.
   apply lt_trans with (pred (Rlength l1)); try assumption; apply lt_pred_n_n;
-    apply neq_O_lt; red in |- *; intro; rewrite <- H13 in H6;
+    apply neq_O_lt; red; intro; rewrite <- H13 in H6;
       discriminate.
-  unfold Rmin in |- *; case (Rle_dec a b); intro;
+  unfold Rmin; case (Rle_dec a b); intro;
     [ reflexivity | elim n; assumption ].
   left; elim H7; intros; assumption.
-  unfold phi3 in |- *; case (Rle_dec a x); case (Rle_dec x b); intros;
+  unfold phi3; case (Rle_dec a x); case (Rle_dec x b); intros;
     reflexivity || elim n; assumption.
   assert (H3 := pre phi2); unfold IsStepFun in H3; unfold is_subdivision in H3;
     elim H3; clear H3; intros l1 [lf1 H3]; split with l1;
       split with lf1; unfold adapted_couple in H3; decompose [and] H3;
-        clear H3; unfold adapted_couple in |- *; repeat split;
+        clear H3; unfold adapted_couple; repeat split;
           try assumption.
-  intros; assert (H9 := H8 i H3); unfold constant_D_eq, open_interval in |- *;
+  intros; assert (H9 := H8 i H3); unfold constant_D_eq, open_interval;
     unfold constant_D_eq, open_interval in H9; intros;
-      rewrite <- (H9 x H7); unfold psi3 in |- *; assert (H10 : b < x).
+      rewrite <- (H9 x H7); unfold psi3; assert (H10 : b < x).
   apply Rle_lt_trans with (pos_Rl l1 i).
   replace b with (Rmin b c).
   rewrite <- H5; elim (RList_P6 l1); intros; apply H10; try assumption.
   apply le_O_n.
   apply lt_trans with (pred (Rlength l1)); try assumption; apply lt_pred_n_n;
-    apply neq_O_lt; red in |- *; intro; rewrite <- H12 in H6;
+    apply neq_O_lt; red; intro; rewrite <- H12 in H6;
       discriminate.
-  unfold Rmin in |- *; case (Rle_dec b c); intro;
+  unfold Rmin; case (Rle_dec b c); intro;
     [ reflexivity | elim n; assumption ].
   elim H7; intros; assumption.
-  unfold phi3 in |- *; case (Rle_dec a x); case (Rle_dec x b); intros;
+  unfold phi3; case (Rle_dec a x); case (Rle_dec x b); intros;
     [ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H10))
       | reflexivity
       | elim n; apply Rle_trans with b; [ assumption | left; assumption ]
@@ -2088,7 +2086,7 @@ Lemma RiemannInt_P22 :
   forall (f:R -> R) (a b c:R),
     Riemann_integrable f a b -> a <= c <= b -> Riemann_integrable f a c.
 Proof.
-  unfold Riemann_integrable in |- *; intros; elim (X eps); clear X;
+  unfold Riemann_integrable; intros; elim (X eps); clear X;
     intros phi [psi H0]; elim H; elim H0; clear H H0;
       intros; assert (H3 : IsStepFun phi a c).
   apply StepFun_P44 with b.
@@ -2099,18 +2097,18 @@ Proof.
   apply (pre psi).
   split; assumption.
   split with (mkStepFun H3); split with (mkStepFun H4); split.
-  simpl in |- *; intros; apply H.
+  simpl; intros; apply H.
   replace (Rmin a b) with (Rmin a c).
   elim H5; intros; split; try assumption.
   apply Rle_trans with (Rmax a c); try assumption.
   replace (Rmax a b) with b.
   replace (Rmax a c) with c.
   assumption.
-  unfold Rmax in |- *; case (Rle_dec a c); intro;
+  unfold Rmax; case (Rle_dec a c); intro;
     [ reflexivity | elim n; assumption ].
-  unfold Rmax in |- *; case (Rle_dec a b); intro;
+  unfold Rmax; case (Rle_dec a b); intro;
     [ reflexivity | elim n; apply Rle_trans with c; assumption ].
-  unfold Rmin in |- *; case (Rle_dec a c); case (Rle_dec a b); intros;
+  unfold Rmin; case (Rle_dec a c); case (Rle_dec a b); intros;
     [ reflexivity
       | elim n; apply Rle_trans with c; assumption
       | elim n; assumption
@@ -2123,12 +2121,12 @@ Proof.
   replace (RiemannInt_SF (mkStepFun H4)) with
   (RiemannInt_SF psi - RiemannInt_SF (mkStepFun H5)).
   apply Rle_lt_trans with (RiemannInt_SF psi).
-  unfold Rminus in |- *; pattern (RiemannInt_SF psi) at 2 in |- *;
+  unfold Rminus; pattern (RiemannInt_SF psi) at 2;
     rewrite <- Rplus_0_r; apply Rplus_le_compat_l; rewrite <- Ropp_0;
       apply Ropp_ge_le_contravar; apply Rle_ge;
         replace 0 with (RiemannInt_SF (mkStepFun (StepFun_P4 c b 0))).
   apply StepFun_P37; try assumption.
-  intros; simpl in |- *; unfold fct_cte in |- *;
+  intros; simpl; unfold fct_cte;
     apply Rle_trans with (Rabs (f x - phi x)).
   apply Rabs_pos.
   apply H.
@@ -2137,9 +2135,9 @@ Proof.
   elim H6; intros; split; left.
   apply Rle_lt_trans with c; assumption.
   assumption.
-  unfold Rmax in |- *; case (Rle_dec a b); intro;
+  unfold Rmax; case (Rle_dec a b); intro;
     [ reflexivity | elim n; apply Rle_trans with c; assumption ].
-  unfold Rmin in |- *; case (Rle_dec a b); intro;
+  unfold Rmin; case (Rle_dec a b); intro;
     [ reflexivity | elim n; apply Rle_trans with c; assumption ].
   rewrite StepFun_P18; ring.
   apply Rle_lt_trans with (Rabs (RiemannInt_SF psi)).
@@ -2149,16 +2147,16 @@ Proof.
   apply (pre psi).
   replace (RiemannInt_SF psi) with (RiemannInt_SF (mkStepFun H6)).
   rewrite <- (StepFun_P43 H4 H5 H6); ring.
-  unfold RiemannInt_SF in |- *; case (Rle_dec a b); intro.
+  unfold RiemannInt_SF; case (Rle_dec a b); intro.
   eapply StepFun_P17.
   apply StepFun_P1.
-  simpl in |- *; apply StepFun_P1.
+  simpl; apply StepFun_P1.
   apply Ropp_eq_compat; eapply StepFun_P17.
   apply StepFun_P1.
-  simpl in |- *; apply StepFun_P1.
+  simpl; apply StepFun_P1.
   apply Rle_ge; replace 0 with (RiemannInt_SF (mkStepFun (StepFun_P4 a c 0))).
   apply StepFun_P37; try assumption.
-  intros; simpl in |- *; unfold fct_cte in |- *;
+  intros; simpl; unfold fct_cte;
     apply Rle_trans with (Rabs (f x - phi x)).
   apply Rabs_pos.
   apply H.
@@ -2167,9 +2165,9 @@ Proof.
   elim H5; intros; split; left.
   assumption.
   apply Rlt_le_trans with c; assumption.
-  unfold Rmax in |- *; case (Rle_dec a b); intro;
+  unfold Rmax; case (Rle_dec a b); intro;
     [ reflexivity | elim n; apply Rle_trans with c; assumption ].
-  unfold Rmin in |- *; case (Rle_dec a b); intro;
+  unfold Rmin; case (Rle_dec a b); intro;
     [ reflexivity | elim n; apply Rle_trans with c; assumption ].
   rewrite StepFun_P18; ring.
 Qed.
@@ -2178,7 +2176,7 @@ Lemma RiemannInt_P23 :
   forall (f:R -> R) (a b c:R),
     Riemann_integrable f a b -> a <= c <= b -> Riemann_integrable f c b.
 Proof.
-  unfold Riemann_integrable in |- *; intros; elim (X eps); clear X;
+  unfold Riemann_integrable; intros; elim (X eps); clear X;
     intros phi [psi H0]; elim H; elim H0; clear H H0;
       intros; assert (H3 : IsStepFun phi c b).
   apply StepFun_P45 with a.
@@ -2189,18 +2187,18 @@ Proof.
   apply (pre psi).
   split; assumption.
   split with (mkStepFun H3); split with (mkStepFun H4); split.
-  simpl in |- *; intros; apply H.
+  simpl; intros; apply H.
   replace (Rmax a b) with (Rmax c b).
   elim H5; intros; split; try assumption.
   apply Rle_trans with (Rmin c b); try assumption.
   replace (Rmin a b) with a.
   replace (Rmin c b) with c.
   assumption.
-  unfold Rmin in |- *; case (Rle_dec c b); intro;
+  unfold Rmin; case (Rle_dec c b); intro;
     [ reflexivity | elim n; assumption ].
-  unfold Rmin in |- *; case (Rle_dec a b); intro;
+  unfold Rmin; case (Rle_dec a b); intro;
     [ reflexivity | elim n; apply Rle_trans with c; assumption ].
-  unfold Rmax in |- *; case (Rle_dec c b); case (Rle_dec a b); intros;
+  unfold Rmax; case (Rle_dec c b); case (Rle_dec a b); intros;
     [ reflexivity
       | elim n; apply Rle_trans with c; assumption
       | elim n; assumption
@@ -2213,12 +2211,12 @@ Proof.
   replace (RiemannInt_SF (mkStepFun H4)) with
   (RiemannInt_SF psi - RiemannInt_SF (mkStepFun H5)).
   apply Rle_lt_trans with (RiemannInt_SF psi).
-  unfold Rminus in |- *; pattern (RiemannInt_SF psi) at 2 in |- *;
+  unfold Rminus; pattern (RiemannInt_SF psi) at 2;
     rewrite <- Rplus_0_r; apply Rplus_le_compat_l; rewrite <- Ropp_0;
       apply Ropp_ge_le_contravar; apply Rle_ge;
         replace 0 with (RiemannInt_SF (mkStepFun (StepFun_P4 a c 0))).
   apply StepFun_P37; try assumption.
-  intros; simpl in |- *; unfold fct_cte in |- *;
+  intros; simpl; unfold fct_cte;
     apply Rle_trans with (Rabs (f x - phi x)).
   apply Rabs_pos.
   apply H.
@@ -2227,9 +2225,9 @@ Proof.
   elim H6; intros; split; left.
   assumption.
   apply Rlt_le_trans with c; assumption.
-  unfold Rmax in |- *; case (Rle_dec a b); intro;
+  unfold Rmax; case (Rle_dec a b); intro;
     [ reflexivity | elim n; apply Rle_trans with c; assumption ].
-  unfold Rmin in |- *; case (Rle_dec a b); intro;
+  unfold Rmin; case (Rle_dec a b); intro;
     [ reflexivity | elim n; apply Rle_trans with c; assumption ].
   rewrite StepFun_P18; ring.
   apply Rle_lt_trans with (Rabs (RiemannInt_SF psi)).
@@ -2239,16 +2237,16 @@ Proof.
   apply (pre psi).
   replace (RiemannInt_SF psi) with (RiemannInt_SF (mkStepFun H6)).
   rewrite <- (StepFun_P43 H5 H4 H6); ring.
-  unfold RiemannInt_SF in |- *; case (Rle_dec a b); intro.
+  unfold RiemannInt_SF; case (Rle_dec a b); intro.
   eapply StepFun_P17.
   apply StepFun_P1.
-  simpl in |- *; apply StepFun_P1.
+  simpl; apply StepFun_P1.
   apply Ropp_eq_compat; eapply StepFun_P17.
   apply StepFun_P1.
-  simpl in |- *; apply StepFun_P1.
+  simpl; apply StepFun_P1.
   apply Rle_ge; replace 0 with (RiemannInt_SF (mkStepFun (StepFun_P4 c b 0))).
   apply StepFun_P37; try assumption.
-  intros; simpl in |- *; unfold fct_cte in |- *;
+  intros; simpl; unfold fct_cte;
     apply Rle_trans with (Rabs (f x - phi x)).
   apply Rabs_pos.
   apply H.
@@ -2257,9 +2255,9 @@ Proof.
   elim H5; intros; split; left.
   apply Rle_lt_trans with c; assumption.
   assumption.
-  unfold Rmax in |- *; case (Rle_dec a b); intro;
+  unfold Rmax; case (Rle_dec a b); intro;
     [ reflexivity | elim n; apply Rle_trans with c; assumption ].
-  unfold Rmin in |- *; case (Rle_dec a b); intro;
+  unfold Rmin; case (Rle_dec a b); intro;
     [ reflexivity | elim n; apply Rle_trans with c; assumption ].
   rewrite StepFun_P18; ring.
 Qed.
@@ -2292,14 +2290,14 @@ Lemma RiemannInt_P25 :
     (pr2:Riemann_integrable f b c) (pr3:Riemann_integrable f a c),
     a <= b -> b <= c -> RiemannInt pr1 + RiemannInt pr2 = RiemannInt pr3.
 Proof.
-  intros f a b c pr1 pr2 pr3 Hyp1 Hyp2; unfold RiemannInt in |- *;
+  intros f a b c pr1 pr2 pr3 Hyp1 Hyp2; unfold RiemannInt;
     case (RiemannInt_exists pr1 RinvN RinvN_cv);
     case (RiemannInt_exists pr2 RinvN RinvN_cv);
     case (RiemannInt_exists pr3 RinvN RinvN_cv); intros;
-      symmetry  in |- *; eapply UL_sequence.
+      symmetry ; eapply UL_sequence.
   apply u.
-  unfold Un_cv in |- *; intros; assert (H0 : 0 < eps / 3).
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+  unfold Un_cv; intros; assert (H0 : 0 < eps / 3).
+  unfold Rdiv; apply Rmult_lt_0_compat;
     [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
   elim (u1 _ H0); clear u1; intros N1 H1; elim (u0 _ H0); clear u0;
     intros N2 H2;
@@ -2311,7 +2309,7 @@ Proof.
               RiemannInt_SF (phi_sequence RinvN pr2 n))) 0).
   intro; elim (H3 _ H0); clear H3; intros N3 H3;
     set (N0 := max (max N1 N2) N3); exists N0; intros;
-      unfold R_dist in |- *;
+      unfold R_dist;
         apply Rle_lt_trans with
           (Rabs
             (RiemannInt_SF (phi_sequence RinvN pr3 n) -
@@ -2332,8 +2330,8 @@ Proof.
   unfold R_dist in H3; cut (n >= N3)%nat.
   intro; assert (H6 := H3 _ H5); unfold Rminus in H6; rewrite Ropp_0 in H6;
     rewrite Rplus_0_r in H6; apply H6.
-  unfold ge in |- *; apply le_trans with N0;
-    [ unfold N0 in |- *; apply le_max_r | assumption ].
+  unfold ge; apply le_trans with N0;
+    [ unfold N0; apply le_max_r | assumption ].
   apply Rle_lt_trans with
     (Rabs (RiemannInt_SF (phi_sequence RinvN pr1 n) - x1) +
       Rabs (RiemannInt_SF (phi_sequence RinvN pr2 n) - x0)).
@@ -2345,17 +2343,17 @@ Proof.
   [ apply Rabs_triang | ring ].
   apply Rplus_lt_compat.
   unfold R_dist in H1; apply H1.
-  unfold ge in |- *; apply le_trans with N0;
+  unfold ge; apply le_trans with N0;
     [ apply le_trans with (max N1 N2);
-      [ apply le_max_l | unfold N0 in |- *; apply le_max_l ]
+      [ apply le_max_l | unfold N0; apply le_max_l ]
       | assumption ].
   unfold R_dist in H2; apply H2.
-  unfold ge in |- *; apply le_trans with N0;
+  unfold ge; apply le_trans with N0;
     [ apply le_trans with (max N1 N2);
-      [ apply le_max_r | unfold N0 in |- *; apply le_max_l ]
+      [ apply le_max_r | unfold N0; apply le_max_l ]
       | assumption ].
   apply Rmult_eq_reg_l with 3;
-    [ unfold Rdiv in |- *; repeat rewrite Rmult_plus_distr_l;
+    [ unfold Rdiv; repeat rewrite Rmult_plus_distr_l;
       do 2 rewrite (Rmult_comm 3); repeat rewrite Rmult_assoc;
         rewrite <- Rinv_l_sym; [ ring | discrR ]
       | discrR ].
@@ -2392,8 +2390,8 @@ Proof.
     apply (proj2_sig (phi_sequence_prop RinvN pr3 n)).
   elim H1; clear H1; intros psi1 H1; elim H2; clear H2; intros psi2 H2; elim H3;
     clear H3; intros psi3 H3; assert (H := RinvN_cv);
-      unfold Un_cv in |- *; intros; assert (H4 : 0 < eps / 3).
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+      unfold Un_cv; intros; assert (H4 : 0 < eps / 3).
+  unfold Rdiv; apply Rmult_lt_0_compat;
     [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
   elim (H _ H4); clear H; intros N0 H;
     assert (H5 : forall n:nat, (n >= N0)%nat -> RinvN n < eps / 3).
@@ -2401,11 +2399,11 @@ Proof.
     replace (pos (RinvN n)) with
     (R_dist (mkposreal (/ (INR n + 1)) (RinvN_pos n)) 0).
   apply H; assumption.
-  unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
+  unfold R_dist; unfold Rminus; rewrite Ropp_0;
     rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge;
       left; apply (cond_pos (RinvN n)).
   exists N0; intros; elim (H1 n); elim (H2 n); elim (H3 n); clear H1 H2 H3;
-    intros; unfold R_dist in |- *; unfold Rminus in |- *;
+    intros; unfold R_dist; unfold Rminus;
       rewrite Ropp_0; rewrite Rplus_0_r;
         set (phi1 := phi_sequence RinvN pr1 n) in H8 |- *;
           set (phi2 := phi_sequence RinvN pr2 n) in H3 |- *;
@@ -2471,7 +2469,7 @@ Proof.
         (StepFun_P32 (mkStepFun (StepFun_P28 (-1) (mkStepFun H10) phi1)))) +
       RiemannInt_SF (mkStepFun (StepFun_P28 1 (mkStepFun H13) (psi2 n)))).
   apply Rplus_le_compat_l; apply StepFun_P37; try assumption.
-  intros; simpl in |- *; rewrite Rmult_1_l;
+  intros; simpl; rewrite Rmult_1_l;
     apply Rle_trans with (Rabs (f x - phi3 x) + Rabs (f x - phi2 x)).
   rewrite <- (Rabs_Ropp (f x - phi3 x)); rewrite Ropp_minus_distr;
     replace (phi3 x + -1 * phi2 x) with (phi3 x - f x + (f x - phi2 x));
@@ -2482,28 +2480,28 @@ Proof.
   replace (Rmin a c) with a.
   apply Rle_trans with b; try assumption.
   left; assumption.
-  unfold Rmin in |- *; case (Rle_dec a c); intro;
+  unfold Rmin; case (Rle_dec a c); intro;
     [ reflexivity | elim n0; apply Rle_trans with b; assumption ].
   replace (Rmax a c) with c.
   left; assumption.
-  unfold Rmax in |- *; case (Rle_dec a c); intro;
+  unfold Rmax; case (Rle_dec a c); intro;
     [ reflexivity | elim n0; apply Rle_trans with b; assumption ].
   apply H3.
   elim H14; intros; split.
   replace (Rmin b c) with b.
   left; assumption.
-  unfold Rmin in |- *; case (Rle_dec b c); intro;
+  unfold Rmin; case (Rle_dec b c); intro;
     [ reflexivity | elim n0; assumption ].
   replace (Rmax b c) with c.
   left; assumption.
-  unfold Rmax in |- *; case (Rle_dec b c); intro;
+  unfold Rmax; case (Rle_dec b c); intro;
     [ reflexivity | elim n0; assumption ].
   do 2
     rewrite <-
       (Rplus_comm
         (RiemannInt_SF (mkStepFun (StepFun_P28 1 (mkStepFun H13) (psi2 n)))))
       ; apply Rplus_le_compat_l; apply StepFun_P37; try assumption.
-  intros; simpl in |- *; rewrite Rmult_1_l;
+  intros; simpl; rewrite Rmult_1_l;
     apply Rle_trans with (Rabs (f x - phi3 x) + Rabs (f x - phi1 x)).
   rewrite <- (Rabs_Ropp (f x - phi3 x)); rewrite Ropp_minus_distr;
     replace (phi3 x + -1 * phi1 x) with (phi3 x - f x + (f x - phi1 x));
@@ -2513,23 +2511,23 @@ Proof.
   elim H14; intros; split.
   replace (Rmin a c) with a.
   left; assumption.
-  unfold Rmin in |- *; case (Rle_dec a c); intro;
+  unfold Rmin; case (Rle_dec a c); intro;
     [ reflexivity | elim n0; apply Rle_trans with b; assumption ].
   replace (Rmax a c) with c.
   apply Rle_trans with b.
   left; assumption.
   assumption.
-  unfold Rmax in |- *; case (Rle_dec a c); intro;
+  unfold Rmax; case (Rle_dec a c); intro;
     [ reflexivity | elim n0; apply Rle_trans with b; assumption ].
   apply H8.
   elim H14; intros; split.
   replace (Rmin a b) with a.
   left; assumption.
-  unfold Rmin in |- *; case (Rle_dec a b); intro;
+  unfold Rmin; case (Rle_dec a b); intro;
     [ reflexivity | elim n0; assumption ].
   replace (Rmax a b) with b.
   left; assumption.
-  unfold Rmax in |- *; case (Rle_dec a b); intro;
+  unfold Rmax; case (Rle_dec a b); intro;
     [ reflexivity | elim n0; assumption ].
   do 2 rewrite StepFun_P30.
   do 2 rewrite Rmult_1_l;
@@ -2555,7 +2553,7 @@ Proof.
   assumption.
   apply H5; assumption.
   apply Rmult_eq_reg_l with 3;
-    [ unfold Rdiv in |- *; repeat rewrite Rmult_plus_distr_l;
+    [ unfold Rdiv; repeat rewrite Rmult_plus_distr_l;
       do 2 rewrite (Rmult_comm 3); repeat rewrite Rmult_assoc;
         rewrite <- Rinv_l_sym; [ ring | discrR ]
       | discrR ].
@@ -2610,13 +2608,13 @@ Lemma RiemannInt_P27 :
 Proof.
   intro f; intros; elim H; clear H; intros; assert (H1 : continuity_pt f x).
   apply C0; split; left; assumption.
-  unfold derivable_pt_lim in |- *; intros; assert (Hyp : 0 < eps / 2).
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+  unfold derivable_pt_lim; intros; assert (Hyp : 0 < eps / 2).
+  unfold Rdiv; apply Rmult_lt_0_compat;
     [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
-  elim (H1 _ Hyp); unfold dist, D_x, no_cond in |- *; simpl in |- *;
-    unfold R_dist in |- *; intros; set (del := Rmin x0 (Rmin (b - x) (x - a)));
+  elim (H1 _ Hyp); unfold dist, D_x, no_cond; simpl;
+    unfold R_dist; intros; set (del := Rmin x0 (Rmin (b - x) (x - a)));
       assert (H4 : 0 < del).
-  unfold del in |- *; unfold Rmin in |- *; case (Rle_dec (b - x) (x - a));
+  unfold del; unfold Rmin; case (Rle_dec (b - x) (x - a));
     intro.
   case (Rle_dec x0 (b - x)); intro;
     [ elim H3; intros; assumption | apply Rlt_Rminus; assumption ].
@@ -2633,22 +2631,22 @@ Proof.
   left; apply Rlt_le_trans with (x + del).
   apply Rplus_lt_compat_l; apply Rle_lt_trans with (Rabs h0);
     [ apply RRle_abs | apply H6 ].
-  unfold del in |- *; apply Rle_trans with (x + Rmin (b - x) (x - a)).
+  unfold del; apply Rle_trans with (x + Rmin (b - x) (x - a)).
   apply Rplus_le_compat_l; apply Rmin_r.
-  pattern b at 2 in |- *; replace b with (x + (b - x));
+  pattern b at 2; replace b with (x + (b - x));
     [ apply Rplus_le_compat_l; apply Rmin_l | ring ].
   apply RiemannInt_P1; apply continuity_implies_RiemannInt; auto with real.
   intros; apply C0; elim H7; intros; split.
   apply Rle_trans with (x + h0).
   left; apply Rle_lt_trans with (x - del).
-  unfold del in |- *; apply Rle_trans with (x - Rmin (b - x) (x - a)).
-  pattern a at 1 in |- *; replace a with (x + (a - x)); [ idtac | ring ].
-  unfold Rminus in |- *; apply Rplus_le_compat_l; apply Ropp_le_cancel.
+  unfold del; apply Rle_trans with (x - Rmin (b - x) (x - a)).
+  pattern a at 1; replace a with (x + (a - x)); [ idtac | ring ].
+  unfold Rminus; apply Rplus_le_compat_l; apply Ropp_le_cancel.
   rewrite Ropp_involutive; rewrite Ropp_plus_distr; rewrite Ropp_involutive;
     rewrite (Rplus_comm x); apply Rmin_r.
-  unfold Rminus in |- *; apply Rplus_le_compat_l; apply Ropp_le_cancel.
+  unfold Rminus; apply Rplus_le_compat_l; apply Ropp_le_cancel.
   do 2 rewrite Ropp_involutive; apply Rmin_r.
-  unfold Rminus in |- *; apply Rplus_lt_compat_l; apply Ropp_lt_cancel.
+  unfold Rminus; apply Rplus_lt_compat_l; apply Ropp_lt_cancel.
   rewrite Ropp_involutive; apply Rle_lt_trans with (Rabs h0);
     [ rewrite <- Rabs_Ropp; apply RRle_abs | apply H6 ].
   assumption.
@@ -2661,7 +2659,7 @@ Proof.
     with ((RiemannInt H7 - RiemannInt (RiemannInt_P14 x (x + h0) (f x))) / h0).
   replace (RiemannInt H7 - RiemannInt (RiemannInt_P14 x (x + h0) (f x))) with
   (RiemannInt (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x + h0) (f x)))).
-  unfold Rdiv in |- *; rewrite Rabs_mult; case (Rle_dec x (x + h0)); intro.
+  unfold Rdiv; rewrite Rabs_mult; case (Rle_dec x (x + h0)); intro.
   apply Rle_lt_trans with
     (RiemannInt
       (RiemannInt_P16
@@ -2680,8 +2678,8 @@ Proof.
   apply Rabs_pos.
   apply RiemannInt_P19; try assumption.
   intros; replace (f x1 + -1 * fct_cte (f x) x1) with (f x1 - f x).
-  unfold fct_cte in |- *; case (Req_dec x x1); intro.
-  rewrite H9; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; left;
+  unfold fct_cte; case (Req_dec x x1); intro.
+  rewrite H9; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; left;
     assumption.
   elim H3; intros; left; apply H11.
   repeat split.
@@ -2692,16 +2690,16 @@ Proof.
   elim H8; intros; assumption.
   apply Rplus_le_compat_l; apply Rle_trans with del.
   left; apply Rle_lt_trans with (Rabs h0); [ apply RRle_abs | assumption ].
-  unfold del in |- *; apply Rmin_l.
+  unfold del; apply Rmin_l.
   apply Rge_minus; apply Rle_ge; left; elim H8; intros; assumption.
-  unfold fct_cte in |- *; ring.
+  unfold fct_cte; ring.
   rewrite RiemannInt_P15.
   rewrite Rmult_assoc; replace ((x + h0 - x) * Rabs (/ h0)) with 1.
-  rewrite Rmult_1_r; unfold Rdiv in |- *; apply Rmult_lt_reg_l with 2;
+  rewrite Rmult_1_r; unfold Rdiv; apply Rmult_lt_reg_l with 2;
     [ prove_sup0
       | rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
         rewrite <- Rinv_r_sym;
-          [ rewrite Rmult_1_l; pattern eps at 1 in |- *; rewrite <- Rplus_0_r;
+          [ rewrite Rmult_1_l; pattern eps at 1; rewrite <- Rplus_0_r;
             rewrite double; apply Rplus_lt_compat_l; assumption
             | discrR ] ].
   rewrite Rabs_right.
@@ -2711,7 +2709,7 @@ Proof.
   apply Rle_ge; left; apply Rinv_0_lt_compat.
   elim r; intro.
   apply Rplus_lt_reg_r with x; rewrite Rplus_0_r; assumption.
-  elim H5; symmetry  in |- *; apply Rplus_eq_reg_l with x; rewrite Rplus_0_r;
+  elim H5; symmetry ; apply Rplus_eq_reg_l with x; rewrite Rplus_0_r;
     assumption.
   apply Rle_lt_trans with
     (RiemannInt
@@ -2735,7 +2733,7 @@ Proof.
           (RiemannInt_P1
             (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x + h0) (f x))))));
       auto with real.
-  symmetry  in |- *; apply RiemannInt_P8.
+  symmetry ; apply RiemannInt_P8.
   apply Rle_lt_trans with
     (RiemannInt (RiemannInt_P14 (x + h0) x (eps / 2)) * Rabs (/ h0)).
   do 2 rewrite <- (Rmult_comm (Rabs (/ h0))); apply Rmult_le_compat_l.
@@ -2743,8 +2741,8 @@ Proof.
   apply RiemannInt_P19.
   auto with real.
   intros; replace (f x1 + -1 * fct_cte (f x) x1) with (f x1 - f x).
-  unfold fct_cte in |- *; case (Req_dec x x1); intro.
-  rewrite H9; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; left;
+  unfold fct_cte; case (Req_dec x x1); intro.
+  rewrite H9; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; left;
     assumption.
   elim H3; intros; left; apply H11.
   repeat split.
@@ -2754,22 +2752,22 @@ Proof.
     [ idtac | ring ].
   replace (x1 - x0 + - (x1 - x)) with (x - x0); [ idtac | ring ].
   apply Rle_lt_trans with (x + h0).
-  unfold Rminus in |- *; apply Rplus_le_compat_l; apply Ropp_le_cancel.
+  unfold Rminus; apply Rplus_le_compat_l; apply Ropp_le_cancel.
   rewrite Ropp_involutive; apply Rle_trans with (Rabs h0).
   rewrite <- Rabs_Ropp; apply RRle_abs.
   apply Rle_trans with del;
-    [ left; assumption | unfold del in |- *; apply Rmin_l ].
+    [ left; assumption | unfold del; apply Rmin_l ].
   elim H8; intros; assumption.
   apply Rplus_lt_reg_r with x; rewrite Rplus_0_r;
     replace (x + (x1 - x)) with x1; [ elim H8; intros; assumption | ring ].
-  unfold fct_cte in |- *; ring.
+  unfold fct_cte; ring.
   rewrite RiemannInt_P15.
   rewrite Rmult_assoc; replace ((x - (x + h0)) * Rabs (/ h0)) with 1.
-  rewrite Rmult_1_r; unfold Rdiv in |- *; apply Rmult_lt_reg_l with 2;
+  rewrite Rmult_1_r; unfold Rdiv; apply Rmult_lt_reg_l with 2;
     [ prove_sup0
       | rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
         rewrite <- Rinv_r_sym;
-          [ rewrite Rmult_1_l; pattern eps at 1 in |- *; rewrite <- Rplus_0_r;
+          [ rewrite Rmult_1_l; pattern eps at 1; rewrite <- Rplus_0_r;
             rewrite double; apply Rplus_lt_compat_l; assumption
             | discrR ] ].
   rewrite Rabs_left.
@@ -2786,14 +2784,14 @@ Proof.
       (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x + h0) (f x))))
     .
   ring.
-  unfold Rdiv, Rminus in |- *; rewrite Rmult_plus_distr_r; ring.
+  unfold Rdiv, Rminus; rewrite Rmult_plus_distr_r; ring.
   rewrite RiemannInt_P15; apply Rmult_eq_reg_l with h0;
-    [ unfold Rdiv in |- *; rewrite (Rmult_comm h0); repeat rewrite Rmult_assoc;
+    [ unfold Rdiv; rewrite (Rmult_comm h0); repeat rewrite Rmult_assoc;
       rewrite <- Rinv_l_sym; [ ring | assumption ]
       | assumption ].
   cut (a <= x + h0).
   cut (x + h0 <= b).
-  intros; unfold primitive in |- *.
+  intros; unfold primitive.
   case (Rle_dec a (x + h0)); case (Rle_dec (x + h0) b); case (Rle_dec a x);
   case (Rle_dec x b); intros; try (elim n; assumption || left; assumption).
   rewrite <- (RiemannInt_P26 (FTC_P1 h C0 r0 r) H7 (FTC_P1 h C0 r2 r1)); ring.
@@ -2803,7 +2801,7 @@ Proof.
   apply RRle_abs.
   apply Rle_trans with del;
     [ left; assumption
-      | unfold del in |- *; apply Rle_trans with (Rmin (b - x) (x - a));
+      | unfold del; apply Rle_trans with (Rmin (b - x) (x - a));
         [ apply Rmin_r | apply Rmin_l ] ].
   apply Ropp_le_cancel; apply Rplus_le_reg_l with x;
     replace (x + - (x + h0)) with (- h0); [ idtac | ring ].
@@ -2811,7 +2809,7 @@ Proof.
     [ rewrite <- Rabs_Ropp; apply RRle_abs
       | apply Rle_trans with del;
         [ left; assumption
-          | unfold del in |- *; apply Rle_trans with (Rmin (b - x) (x - a));
+          | unfold del; apply Rle_trans with (Rmin (b - x) (x - a));
             apply Rmin_r ] ].
 Qed.
 
@@ -2828,14 +2826,14 @@ Proof.
     (f_b := fun x:R => f b * (x - b) + RiemannInt (FTC_P1 h C0 h (Rle_refl b)));
     rewrite H3.
   assert (H4 : derivable_pt_lim f_b b (f b)).
-  unfold f_b in |- *; pattern (f b) at 2 in |- *; replace (f b) with (f b + 0).
+  unfold f_b; pattern (f b) at 2; replace (f b) with (f b + 0).
   change
     (derivable_pt_lim
       ((fct_cte (f b) * (id - fct_cte b))%F +
         fct_cte (RiemannInt (FTC_P1 h C0 h (Rle_refl b)))) b (
-          f b + 0)) in |- *.
+          f b + 0)).
   apply derivable_pt_lim_plus.
-  pattern (f b) at 2 in |- *;
+  pattern (f b) at 2;
     replace (f b) with (0 * (id - fct_cte b)%F b + fct_cte (f b) b * 1).
   apply derivable_pt_lim_mult.
   apply derivable_pt_lim_const.
@@ -2843,26 +2841,26 @@ Proof.
   apply derivable_pt_lim_minus.
   apply derivable_pt_lim_id.
   apply derivable_pt_lim_const.
-  unfold fct_cte in |- *; ring.
+  unfold fct_cte; ring.
   apply derivable_pt_lim_const.
   ring.
-  unfold derivable_pt_lim in |- *; intros; elim (H4 _ H5); intros;
+  unfold derivable_pt_lim; intros; elim (H4 _ H5); intros;
     assert (H7 : continuity_pt f b).
   apply C0; split; [ left; assumption | right; reflexivity ].
   assert (H8 : 0 < eps / 2).
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+  unfold Rdiv; apply Rmult_lt_0_compat;
     [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
-  elim (H7 _ H8); unfold D_x, no_cond, dist in |- *; simpl in |- *;
-    unfold R_dist in |- *; intros; set (del := Rmin x0 (Rmin x1 (b - a)));
+  elim (H7 _ H8); unfold D_x, no_cond, dist; simpl;
+    unfold R_dist; intros; set (del := Rmin x0 (Rmin x1 (b - a)));
       assert (H10 : 0 < del).
-  unfold del in |- *; unfold Rmin in |- *; case (Rle_dec x1 (b - a)); intros.
+  unfold del; unfold Rmin; case (Rle_dec x1 (b - a)); intros.
   case (Rle_dec x0 x1); intro;
     [ apply (cond_pos x0) | elim H9; intros; assumption ].
   case (Rle_dec x0 (b - a)); intro;
     [ apply (cond_pos x0) | apply Rlt_Rminus; assumption ].
   split with (mkposreal _ H10); intros; case (Rcase_abs h0); intro.
   assert (H14 : b + h0 < b).
-  pattern b at 2 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
+  pattern b at 2; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
     assumption.
   assert (H13 : Riemann_integrable f (b + h0) b).
   apply continuity_implies_RiemannInt.
@@ -2876,11 +2874,11 @@ Proof.
   apply Rle_trans with (Rabs h0).
   rewrite <- Rabs_Ropp; apply RRle_abs.
   left; assumption.
-  unfold del in |- *; apply Rle_trans with (Rmin x1 (b - a)); apply Rmin_r.
+  unfold del; apply Rle_trans with (Rmin x1 (b - a)); apply Rmin_r.
   replace (primitive h (FTC_P1 h C0) (b + h0) - primitive h (FTC_P1 h C0) b)
     with (- RiemannInt H13).
   replace (f b) with (- RiemannInt (RiemannInt_P14 (b + h0) b (f b)) / h0).
-  rewrite <- Rabs_Ropp; unfold Rminus in |- *; unfold Rdiv in |- *;
+  rewrite <- Rabs_Ropp; unfold Rminus; unfold Rdiv;
     rewrite Ropp_mult_distr_l_reverse; rewrite Ropp_plus_distr;
       repeat rewrite Ropp_involutive;
         replace
@@ -2889,7 +2887,7 @@ Proof.
         ((RiemannInt H13 - RiemannInt (RiemannInt_P14 (b + h0) b (f b))) / h0).
   replace (RiemannInt H13 - RiemannInt (RiemannInt_P14 (b + h0) b (f b))) with
   (RiemannInt (RiemannInt_P10 (-1) H13 (RiemannInt_P14 (b + h0) b (f b)))).
-  unfold Rdiv in |- *; rewrite Rabs_mult;
+  unfold Rdiv; rewrite Rabs_mult;
     apply Rle_lt_trans with
       (RiemannInt
         (RiemannInt_P16
@@ -2909,8 +2907,8 @@ Proof.
   apply RiemannInt_P19.
   left; assumption.
   intros; replace (f x2 + -1 * fct_cte (f b) x2) with (f x2 - f b).
-  unfold fct_cte in |- *; case (Req_dec b x2); intro.
-  rewrite H16; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+  unfold fct_cte; case (Req_dec b x2); intro.
+  rewrite H16; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0;
     left; assumption.
   elim H9; intros; left; apply H18.
   repeat split.
@@ -2921,22 +2919,22 @@ Proof.
   replace (x2 - x1 + x1) with x2; [ idtac | ring ].
   apply Rlt_le_trans with (b + h0).
   2: elim H15; intros; left; assumption.
-  unfold Rminus in |- *; apply Rplus_lt_compat_l; apply Ropp_lt_cancel;
+  unfold Rminus; apply Rplus_lt_compat_l; apply Ropp_lt_cancel;
     rewrite Ropp_involutive; apply Rle_lt_trans with (Rabs h0).
   rewrite <- Rabs_Ropp; apply RRle_abs.
   apply Rlt_le_trans with del;
     [ assumption
-      | unfold del in |- *; apply Rle_trans with (Rmin x1 (b - a));
+      | unfold del; apply Rle_trans with (Rmin x1 (b - a));
         [ apply Rmin_r | apply Rmin_l ] ].
   apply Rle_ge; left; apply Rlt_Rminus; elim H15; intros; assumption.
-  unfold fct_cte in |- *; ring.
+  unfold fct_cte; ring.
   rewrite RiemannInt_P15.
   rewrite Rmult_assoc; replace ((b - (b + h0)) * Rabs (/ h0)) with 1.
-  rewrite Rmult_1_r; unfold Rdiv in |- *; apply Rmult_lt_reg_l with 2;
+  rewrite Rmult_1_r; unfold Rdiv; apply Rmult_lt_reg_l with 2;
     [ prove_sup0
       | rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
         rewrite <- Rinv_r_sym;
-          [ rewrite Rmult_1_l; pattern eps at 1 in |- *; rewrite <- Rplus_0_r;
+          [ rewrite Rmult_1_l; pattern eps at 1; rewrite <- Rplus_0_r;
             rewrite double; apply Rplus_lt_compat_l; assumption
             | discrR ] ].
   rewrite Rabs_left.
@@ -2950,16 +2948,16 @@ Proof.
     (RiemannInt_P13 H13 (RiemannInt_P14 (b + h0) b (f b))
       (RiemannInt_P10 (-1) H13 (RiemannInt_P14 (b + h0) b (f b))))
     ; ring.
-  unfold Rdiv, Rminus in |- *; rewrite Rmult_plus_distr_r; ring.
+  unfold Rdiv, Rminus; rewrite Rmult_plus_distr_r; ring.
   rewrite RiemannInt_P15.
   rewrite <- Ropp_mult_distr_l_reverse; apply Rmult_eq_reg_l with h0;
-    [ repeat rewrite (Rmult_comm h0); unfold Rdiv in |- *;
+    [ repeat rewrite (Rmult_comm h0); unfold Rdiv;
       repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym;
         [ ring | assumption ]
       | assumption ].
   cut (a <= b + h0).
   cut (b + h0 <= b).
-  intros; unfold primitive in |- *; case (Rle_dec a (b + h0));
+  intros; unfold primitive; case (Rle_dec a (b + h0));
     case (Rle_dec (b + h0) b); case (Rle_dec a b); case (Rle_dec b b);
     intros; try (elim n; right; reflexivity) || (elim n; left; assumption).
   rewrite <- (RiemannInt_P26 (FTC_P1 h C0 r3 r2) H13 (FTC_P1 h C0 r1 r0)); ring.
@@ -2972,26 +2970,26 @@ Proof.
   apply Rle_trans with (Rabs h0).
   rewrite <- Rabs_Ropp; apply RRle_abs.
   left; assumption.
-  unfold del in |- *; apply Rle_trans with (Rmin x1 (b - a)); apply Rmin_r.
+  unfold del; apply Rle_trans with (Rmin x1 (b - a)); apply Rmin_r.
   cut (primitive h (FTC_P1 h C0) b = f_b b).
   intro; cut (primitive h (FTC_P1 h C0) (b + h0) = f_b (b + h0)).
   intro; rewrite H13; rewrite H14; apply H6.
   assumption.
   apply Rlt_le_trans with del;
-    [ assumption | unfold del in |- *; apply Rmin_l ].
+    [ assumption | unfold del; apply Rmin_l ].
   assert (H14 : b < b + h0).
-  pattern b at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l.
+  pattern b at 1; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l.
   assert (H14 := Rge_le _ _ r); elim H14; intro.
   assumption.
-  elim H11; symmetry  in |- *; assumption.
-  unfold primitive in |- *; case (Rle_dec a (b + h0));
+  elim H11; symmetry ; assumption.
+  unfold primitive; case (Rle_dec a (b + h0));
     case (Rle_dec (b + h0) b); intros;
       [ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r0 H14))
-        | unfold f_b in |- *; reflexivity
+        | unfold f_b; reflexivity
         | elim n; left; apply Rlt_trans with b; assumption
         | elim n0; left; apply Rlt_trans with b; assumption ].
-  unfold f_b in |- *; unfold Rminus in |- *; rewrite Rplus_opp_r;
-    rewrite Rmult_0_r; rewrite Rplus_0_l; unfold primitive in |- *;
+  unfold f_b; unfold Rminus; rewrite Rplus_opp_r;
+    rewrite Rmult_0_r; rewrite Rplus_0_l; unfold primitive;
       case (Rle_dec a b); case (Rle_dec b b); intros;
         [ apply RiemannInt_P5
           | elim n; right; reflexivity
@@ -3000,9 +2998,9 @@ Proof.
 (*****)
   set (f_a := fun x:R => f a * (x - a)); rewrite <- H2;
     assert (H3 : derivable_pt_lim f_a a (f a)).
-  unfold f_a in |- *;
+  unfold f_a;
     change (derivable_pt_lim (fct_cte (f a) * (id - fct_cte a)%F) a (f a))
-      in |- *; pattern (f a) at 2 in |- *;
+     ; pattern (f a) at 2;
         replace (f a) with (0 * (id - fct_cte a)%F a + fct_cte (f a) a * 1).
   apply derivable_pt_lim_mult.
   apply derivable_pt_lim_const.
@@ -3010,18 +3008,18 @@ Proof.
   apply derivable_pt_lim_minus.
   apply derivable_pt_lim_id.
   apply derivable_pt_lim_const.
-  unfold fct_cte in |- *; ring.
-  unfold derivable_pt_lim in |- *; intros; elim (H3 _ H4); intros.
+  unfold fct_cte; ring.
+  unfold derivable_pt_lim; intros; elim (H3 _ H4); intros.
   assert (H6 : continuity_pt f a).
   apply C0; split; [ right; reflexivity | left; assumption ].
   assert (H7 : 0 < eps / 2).
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+  unfold Rdiv; apply Rmult_lt_0_compat;
     [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
-  elim (H6 _ H7); unfold D_x, no_cond, dist in |- *; simpl in |- *;
-    unfold R_dist in |- *; intros.
+  elim (H6 _ H7); unfold D_x, no_cond, dist; simpl;
+    unfold R_dist; intros.
   set (del := Rmin x0 (Rmin x1 (b - a))).
   assert (H9 : 0 < del).
-  unfold del in |- *; unfold Rmin in |- *.
+  unfold del; unfold Rmin.
   case (Rle_dec x1 (b - a)); intros.
   case (Rle_dec x0 x1); intro.
   apply (cond_pos x0).
@@ -3032,9 +3030,9 @@ Proof.
   split with (mkposreal _ H9).
   intros; case (Rcase_abs h0); intro.
   assert (H12 : a + h0 < a).
-  pattern a at 2 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
+  pattern a at 2; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
     assumption.
-  unfold primitive in |- *.
+  unfold primitive.
   case (Rle_dec a (a + h0)); case (Rle_dec (a + h0) b); case (Rle_dec a a);
   case (Rle_dec a b); intros;
     try (elim n; left; assumption) || (elim n; right; reflexivity).
@@ -3044,15 +3042,15 @@ Proof.
   replace (f a * (a + h0 - a)) with (f_a (a + h0)).
   apply H5; try assumption.
   apply Rlt_le_trans with del;
-    [ assumption | unfold del in |- *; apply Rmin_l ].
-  unfold f_a in |- *; ring.
-  unfold f_a in |- *; ring.
+    [ assumption | unfold del; apply Rmin_l ].
+  unfold f_a; ring.
+  unfold f_a; ring.
   elim n; left; apply Rlt_trans with a; assumption.
   assert (H12 : a < a + h0).
-  pattern a at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l.
+  pattern a at 1; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l.
   assert (H12 := Rge_le _ _ r); elim H12; intro.
   assumption.
-  elim H10; symmetry  in |- *; assumption.
+  elim H10; symmetry ; assumption.
   assert (H13 : Riemann_integrable f a (a + h0)).
   apply continuity_implies_RiemannInt.
   left; assumption.
@@ -3064,7 +3062,7 @@ Proof.
   apply Ropp_le_cancel; rewrite Ropp_involutive; rewrite Ropp_minus_distr;
     apply Rle_trans with del.
   apply Rle_trans with (Rabs h0); [ apply RRle_abs | left; assumption ].
-  unfold del in |- *; apply Rle_trans with (Rmin x1 (b - a)); apply Rmin_r.
+  unfold del; apply Rle_trans with (Rmin x1 (b - a)); apply Rmin_r.
   replace (primitive h (FTC_P1 h C0) (a + h0) - primitive h (FTC_P1 h C0) a)
     with (RiemannInt H13).
   replace (f a) with (RiemannInt (RiemannInt_P14 a (a + h0) (f a)) / h0).
@@ -3073,7 +3071,7 @@ Proof.
     with ((RiemannInt H13 - RiemannInt (RiemannInt_P14 a (a + h0) (f a))) / h0).
   replace (RiemannInt H13 - RiemannInt (RiemannInt_P14 a (a + h0) (f a))) with
   (RiemannInt (RiemannInt_P10 (-1) H13 (RiemannInt_P14 a (a + h0) (f a)))).
-  unfold Rdiv in |- *; rewrite Rabs_mult;
+  unfold Rdiv; rewrite Rabs_mult;
     apply Rle_lt_trans with
       (RiemannInt
         (RiemannInt_P16
@@ -3093,8 +3091,8 @@ Proof.
   apply RiemannInt_P19.
   left; assumption.
   intros; replace (f x2 + -1 * fct_cte (f a) x2) with (f x2 - f a).
-  unfold fct_cte in |- *; case (Req_dec a x2); intro.
-  rewrite H15; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+  unfold fct_cte; case (Req_dec a x2); intro.
+  rewrite H15; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0;
     left; assumption.
   elim H8; intros; left; apply H17; repeat split.
   assumption.
@@ -3106,42 +3104,42 @@ Proof.
   apply RRle_abs.
   apply Rlt_le_trans with del;
     [ assumption
-      | unfold del in |- *; apply Rle_trans with (Rmin x1 (b - a));
+      | unfold del; apply Rle_trans with (Rmin x1 (b - a));
         [ apply Rmin_r | apply Rmin_l ] ].
   apply Rle_ge; left; apply Rlt_Rminus; elim H14; intros; assumption.
-  unfold fct_cte in |- *; ring.
+  unfold fct_cte; ring.
   rewrite RiemannInt_P15.
   rewrite Rmult_assoc; replace ((a + h0 - a) * Rabs (/ h0)) with 1.
-  rewrite Rmult_1_r; unfold Rdiv in |- *; apply Rmult_lt_reg_l with 2;
+  rewrite Rmult_1_r; unfold Rdiv; apply Rmult_lt_reg_l with 2;
     [ prove_sup0
       | rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
         rewrite <- Rinv_r_sym;
-          [ rewrite Rmult_1_l; pattern eps at 1 in |- *; rewrite <- Rplus_0_r;
+          [ rewrite Rmult_1_l; pattern eps at 1; rewrite <- Rplus_0_r;
             rewrite double; apply Rplus_lt_compat_l; assumption
             | discrR ] ].
   rewrite Rabs_right.
-  rewrite Rplus_comm; unfold Rminus in |- *; rewrite Rplus_assoc;
+  rewrite Rplus_comm; unfold Rminus; rewrite Rplus_assoc;
     rewrite Rplus_opp_r; rewrite Rplus_0_r; rewrite <- Rinv_r_sym;
       [ reflexivity | assumption ].
   apply Rle_ge; left; apply Rinv_0_lt_compat; assert (H14 := Rge_le _ _ r);
     elim H14; intro.
   assumption.
-  elim H10; symmetry  in |- *; assumption.
+  elim H10; symmetry ; assumption.
   rewrite
     (RiemannInt_P13 H13 (RiemannInt_P14 a (a + h0) (f a))
       (RiemannInt_P10 (-1) H13 (RiemannInt_P14 a (a + h0) (f a))))
     ; ring.
-  unfold Rdiv, Rminus in |- *; rewrite Rmult_plus_distr_r; ring.
+  unfold Rdiv, Rminus; rewrite Rmult_plus_distr_r; ring.
   rewrite RiemannInt_P15.
-  rewrite Rplus_comm; unfold Rminus in |- *; rewrite Rplus_assoc;
-    rewrite Rplus_opp_r; rewrite Rplus_0_r; unfold Rdiv in |- *;
+  rewrite Rplus_comm; unfold Rminus; rewrite Rplus_assoc;
+    rewrite Rplus_opp_r; rewrite Rplus_0_r; unfold Rdiv;
       rewrite Rmult_assoc; rewrite <- Rinv_r_sym; [ ring | assumption ].
   cut (a <= a + h0).
   cut (a + h0 <= b).
-  intros; unfold primitive in |- *; case (Rle_dec a (a + h0));
+  intros; unfold primitive; case (Rle_dec a (a + h0));
     case (Rle_dec (a + h0) b); case (Rle_dec a a); case (Rle_dec a b);
     intros; try (elim n; right; reflexivity) || (elim n; left; assumption).
-  rewrite RiemannInt_P9; unfold Rminus in |- *; rewrite Ropp_0;
+  rewrite RiemannInt_P9; unfold Rminus; rewrite Ropp_0;
     rewrite Rplus_0_r; apply RiemannInt_P5.
   elim n; assumption.
   elim n; assumption.
@@ -3150,15 +3148,15 @@ Proof.
     [ idtac | ring ].
   rewrite Rplus_comm; apply Rle_trans with del;
     [ apply Rle_trans with (Rabs h0); [ apply RRle_abs | left; assumption ]
-      | unfold del in |- *; apply Rle_trans with (Rmin x1 (b - a)); apply Rmin_r ].
+      | unfold del; apply Rle_trans with (Rmin x1 (b - a)); apply Rmin_r ].
 (*****)
   assert (H1 : x = a).
   rewrite <- H0 in H; elim H; intros; apply Rle_antisym; assumption.
   set (f_a := fun x:R => f a * (x - a)).
   assert (H2 : derivable_pt_lim f_a a (f a)).
-  unfold f_a in |- *;
+  unfold f_a;
     change (derivable_pt_lim (fct_cte (f a) * (id - fct_cte a)%F) a (f a))
-      in |- *; pattern (f a) at 2 in |- *;
+     ; pattern (f a) at 2;
         replace (f a) with (0 * (id - fct_cte a)%F a + fct_cte (f a) a * 1).
   apply derivable_pt_lim_mult.
   apply derivable_pt_lim_const.
@@ -3166,18 +3164,18 @@ Proof.
   apply derivable_pt_lim_minus.
   apply derivable_pt_lim_id.
   apply derivable_pt_lim_const.
-  unfold fct_cte in |- *; ring.
+  unfold fct_cte; ring.
   set
     (f_b := fun x:R => f b * (x - b) + RiemannInt (FTC_P1 h C0 h (Rle_refl b))).
   assert (H3 : derivable_pt_lim f_b b (f b)).
-  unfold f_b in |- *; pattern (f b) at 2 in |- *; replace (f b) with (f b + 0).
+  unfold f_b; pattern (f b) at 2; replace (f b) with (f b + 0).
   change
     (derivable_pt_lim
       ((fct_cte (f b) * (id - fct_cte b))%F +
         fct_cte (RiemannInt (FTC_P1 h C0 h (Rle_refl b)))) b (
-          f b + 0)) in |- *.
+          f b + 0)).
   apply derivable_pt_lim_plus.
-  pattern (f b) at 2 in |- *;
+  pattern (f b) at 2;
     replace (f b) with (0 * (id - fct_cte b)%F b + fct_cte (f b) b * 1).
   apply derivable_pt_lim_mult.
   apply derivable_pt_lim_const.
@@ -3185,20 +3183,20 @@ Proof.
   apply derivable_pt_lim_minus.
   apply derivable_pt_lim_id.
   apply derivable_pt_lim_const.
-  unfold fct_cte in |- *; ring.
+  unfold fct_cte; ring.
   apply derivable_pt_lim_const.
   ring.
-  unfold derivable_pt_lim in |- *; intros; elim (H2 _ H4); intros;
+  unfold derivable_pt_lim; intros; elim (H2 _ H4); intros;
     elim (H3 _ H4); intros; set (del := Rmin x0 x1).
   assert (H7 : 0 < del).
-  unfold del in |- *; unfold Rmin in |- *; case (Rle_dec x0 x1); intro.
+  unfold del; unfold Rmin; case (Rle_dec x0 x1); intro.
   apply (cond_pos x0).
   apply (cond_pos x1).
   split with (mkposreal _ H7); intros; case (Rcase_abs h0); intro.
   assert (H10 : a + h0 < a).
-  pattern a at 2 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
+  pattern a at 2; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
     assumption.
-  rewrite H1; unfold primitive in |- *; case (Rle_dec a (a + h0));
+  rewrite H1; unfold primitive; case (Rle_dec a (a + h0));
     case (Rle_dec (a + h0) b); case (Rle_dec a a); case (Rle_dec a b);
     intros; try (elim n; right; assumption || reflexivity).
   elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r3 H10)).
@@ -3207,27 +3205,27 @@ Proof.
   replace (f a * (a + h0 - a)) with (f_a (a + h0)).
   apply H5; try assumption.
   apply Rlt_le_trans with del; try assumption.
-  unfold del in |- *; apply Rmin_l.
-  unfold f_a in |- *; ring.
-  unfold f_a in |- *; ring.
+  unfold del; apply Rmin_l.
+  unfold f_a; ring.
+  unfold f_a; ring.
   elim n; rewrite <- H0; left; assumption.
   assert (H10 : a < a + h0).
-  pattern a at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l.
+  pattern a at 1; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l.
   assert (H10 := Rge_le _ _ r); elim H10; intro.
   assumption.
-  elim H8; symmetry  in |- *; assumption.
-  rewrite H0 in H1; rewrite H1; unfold primitive in |- *;
+  elim H8; symmetry ; assumption.
+  rewrite H0 in H1; rewrite H1; unfold primitive;
     case (Rle_dec a (b + h0)); case (Rle_dec (b + h0) b);
     case (Rle_dec a b); case (Rle_dec b b); intros;
       try (elim n; right; assumption || reflexivity).
   rewrite H0 in H10; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r2 H10)).
   repeat rewrite RiemannInt_P9.
   replace (RiemannInt (FTC_P1 h C0 r1 r0)) with (f_b b).
-  fold (f_b (b + h0)) in |- *.
+  fold (f_b (b + h0)).
   apply H6; try assumption.
   apply Rlt_le_trans with del; try assumption.
-  unfold del in |- *; apply Rmin_r.
-  unfold f_b in |- *; unfold Rminus in |- *; rewrite Rplus_opp_r;
+  unfold del; apply Rmin_r.
+  unfold f_b; unfold Rminus; rewrite Rplus_opp_r;
     rewrite Rmult_0_r; rewrite Rplus_0_l; apply RiemannInt_P5.
   elim n; rewrite <- H0; left; assumption.
   elim n0; rewrite <- H0; left; assumption.
@@ -3238,11 +3236,11 @@ Lemma RiemannInt_P29 :
     (C0:forall x:R, a <= x <= b -> continuity_pt f x),
     antiderivative f (primitive h (FTC_P1 h C0)) a b.
 Proof.
-  intro f; intros; unfold antiderivative in |- *; split; try assumption; intros;
+  intro f; intros; unfold antiderivative; split; try assumption; intros;
     assert (H0 := RiemannInt_P28 h C0 H);
       assert (H1 : derivable_pt (primitive h (FTC_P1 h C0)) x);
-        [ unfold derivable_pt in |- *; split with (f x); apply H0
-          | split with H1; symmetry  in |- *; apply derive_pt_eq_0; apply H0 ].
+        [ unfold derivable_pt; split with (f x); apply H0
+          | split with H1; symmetry ; apply derive_pt_eq_0; apply H0 ].
 Qed.
 
 Lemma RiemannInt_P30 :
@@ -3261,7 +3259,7 @@ Lemma RiemannInt_P31 :
   forall (f:C1_fun) (a b:R),
     a <= b -> antiderivative (derive f (diff0 f)) f a b.
 Proof.
-  intro f; intros; unfold antiderivative in |- *; split; try assumption; intros;
+  intro f; intros; unfold antiderivative; split; try assumption; intros;
     split with (diff0 f x); reflexivity.
 Qed.
 
diff --git a/theories/Reals/RiemannInt_SF.v b/theories/Reals/RiemannInt_SF.v
index d0d9519c..d523a1f4 100644
--- a/theories/Reals/RiemannInt_SF.v
+++ b/theories/Reals/RiemannInt_SF.v
@@ -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-2012     *)
 (*   \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.
+Require Import Ranalysis_reg.
 Require Import Classical_Prop.
-Open Local Scope R_scope.
+Local Open Scope R_scope.
 
 Set Implicit Arguments.
 
@@ -23,7 +21,7 @@ Set Implicit Arguments.
 Definition Nbound (I:nat -> Prop) : Prop :=
   exists n : nat, (forall i:nat, I i -> (i <= n)%nat).
 
-Lemma IZN_var : forall z:Z, (0 <= z)%Z -> {n : nat | z = Z_of_nat n}.
+Lemma IZN_var : forall z:Z, (0 <= z)%Z -> {n : nat | z = Z.of_nat n}.
 Proof.
   intros; apply Z_of_nat_complete_inf; assumption.
 Qed.
@@ -35,19 +33,19 @@ Lemma Nzorn :
 Proof.
   intros I H H0; set (E := fun x:R =>  exists i : nat, I i /\ INR i = x);
     assert (H1 : bound E).
-  unfold Nbound in H0; elim H0; intros N H1; unfold bound in |- *;
-    exists (INR N); unfold is_upper_bound in |- *; intros;
+  unfold Nbound in H0; elim H0; intros N H1; unfold bound;
+    exists (INR N); unfold is_upper_bound; intros;
       unfold E in H2; elim H2; intros; elim H3; intros;
         rewrite <- H5; apply le_INR; apply H1; assumption.
   assert (H2 :  exists x : R, E x).
-  elim H; intros; exists (INR x); unfold E in |- *; exists x; split;
+  elim H; intros; exists (INR x); unfold E; exists x; split;
     [ assumption | reflexivity ].
   assert (H3 := completeness E H1 H2); elim H3; intros; unfold is_lub in p;
     elim p; clear p; intros; unfold is_upper_bound in H4, H5;
       assert (H6 : 0 <= x).
   elim H2; intros; unfold E in H6; elim H6; intros; elim H7; intros;
     apply Rle_trans with x0;
-      [ rewrite <- H9; change (INR 0 <= INR x1) in |- *; apply le_INR;
+      [ rewrite <- H9; change (INR 0 <= INR x1); apply le_INR;
         apply le_O_n
         | apply H4; assumption ].
   assert (H7 := archimed x); elim H7; clear H7; intros;
@@ -90,7 +88,7 @@ Proof.
     [ idtac | reflexivity ]; rewrite <- minus_INR.
   replace (x0 - 1)%nat with (pred x0);
   [ reflexivity
-    | case x0; [ reflexivity | intro; simpl in |- *; apply minus_n_O ] ].
+    | case x0; [ reflexivity | intro; simpl; apply minus_n_O ] ].
   induction  x0 as [| x0 Hrecx0];
     [ rewrite p in H7; rewrite <- INR_IZR_INZ in H7; simpl in H7;
       elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H6 H7))
@@ -101,10 +99,10 @@ Proof.
       assert (H16 : INR x0 = INR x1 + 1).
   rewrite H15; ring.
   rewrite <- S_INR in H16; assert (H17 := INR_eq _ _ H16); rewrite H17;
-    simpl in |- *; split.
+    simpl; split.
   assumption.
   intros; apply INR_le; rewrite H15; rewrite <- H15; elim H12; intros;
-    rewrite H20; apply H4; unfold E in |- *; exists i;
+    rewrite H20; apply H4; unfold E; exists i;
       split; [ assumption | reflexivity ].
 Qed.
 
@@ -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' =>
@@ -175,7 +173,7 @@ Lemma StepFun_P1 :
   forall (a b:R) (f:StepFun a b),
     adapted_couple f a b (subdivision f) (subdivision_val f).
 Proof.
-  intros a b f; unfold subdivision_val in |- *; case (projT2 (pre f)); intros;
+  intros a b f; unfold subdivision_val; case (projT2 (pre f)); intros;
     apply a0.
 Qed.
 
@@ -183,13 +181,13 @@ Lemma StepFun_P2 :
   forall (a b:R) (f:R -> R) (l lf:Rlist),
     adapted_couple f a b l lf -> adapted_couple f b a l lf.
 Proof.
-  unfold adapted_couple in |- *; intros; decompose [and] H; clear H;
+  unfold adapted_couple; intros; decompose [and] H; clear H;
     repeat split; try assumption.
-  rewrite H2; unfold Rmin in |- *; case (Rle_dec a b); intro;
+  rewrite H2; unfold Rmin; case (Rle_dec a b); intro;
     case (Rle_dec b a); intro; try reflexivity.
   apply Rle_antisym; assumption.
   apply Rle_antisym; auto with real.
-  rewrite H1; unfold Rmax in |- *; case (Rle_dec a b); intro;
+  rewrite H1; unfold Rmax; case (Rle_dec a b); intro;
     case (Rle_dec b a); intro; try reflexivity.
   apply Rle_antisym; assumption.
   apply Rle_antisym; auto with real.
@@ -200,23 +198,23 @@ Lemma StepFun_P3 :
     a <= b ->
     adapted_couple (fct_cte c) a b (cons a (cons b nil)) (cons c nil).
 Proof.
-  intros; unfold adapted_couple in |- *; repeat split.
-  unfold ordered_Rlist in |- *; intros; simpl in H0; inversion H0;
-    [ simpl in |- *; assumption | elim (le_Sn_O _ H2) ].
-  simpl in |- *; unfold Rmin in |- *; case (Rle_dec a b); intro;
+  intros; unfold adapted_couple; repeat split.
+  unfold ordered_Rlist; intros; simpl in H0; inversion H0;
+    [ simpl; assumption | elim (le_Sn_O _ H2) ].
+  simpl; unfold Rmin; case (Rle_dec a b); intro;
     [ reflexivity | elim n; assumption ].
-  simpl in |- *; unfold Rmax in |- *; case (Rle_dec a b); intro;
+  simpl; unfold Rmax; case (Rle_dec a b); intro;
     [ reflexivity | elim n; assumption ].
-  unfold constant_D_eq, open_interval in |- *; intros; simpl in H0;
+  unfold constant_D_eq, open_interval; intros; simpl in H0;
     inversion H0; [ reflexivity | elim (le_Sn_O _ H3) ].
 Qed.
 
 Lemma StepFun_P4 : forall a b c:R, IsStepFun (fct_cte c) a b.
 Proof.
-  intros; unfold IsStepFun in |- *; case (Rle_dec a b); intro.
-  apply existT with (cons a (cons b nil)); unfold is_subdivision in |- *;
+  intros; unfold IsStepFun; case (Rle_dec a b); intro.
+  apply existT with (cons a (cons b nil)); unfold is_subdivision;
     apply existT with (cons c nil); apply (StepFun_P3 c r).
-  apply existT with (cons b (cons a nil)); unfold is_subdivision in |- *;
+  apply existT with (cons b (cons a nil)); unfold is_subdivision;
     apply existT with (cons c nil); apply StepFun_P2;
       apply StepFun_P3; auto with real.
 Qed.
@@ -234,7 +232,7 @@ Qed.
 Lemma StepFun_P6 :
   forall (f:R -> R) (a b:R), IsStepFun f a b -> IsStepFun f b a.
 Proof.
-  unfold IsStepFun in |- *; intros; elim X; intros; apply existT with x;
+  unfold IsStepFun; intros; elim X; intros; apply existT with x;
     apply StepFun_P5; assumption.
 Qed.
 
@@ -244,26 +242,26 @@ Lemma StepFun_P7 :
     adapted_couple f a b (cons r1 (cons r2 l)) (cons r3 lf) ->
     adapted_couple f r2 b (cons r2 l) lf.
 Proof.
-  unfold adapted_couple in |- *; intros; decompose [and] H0; clear H0;
+  unfold adapted_couple; intros; decompose [and] H0; clear H0;
     assert (H5 : Rmax a b = b).
-  unfold Rmax in |- *; case (Rle_dec a b); intro;
+  unfold Rmax; case (Rle_dec a b); intro;
     [ reflexivity | elim n; assumption ].
   assert (H7 : r2 <= b).
   rewrite H5 in H2; rewrite <- H2; apply RList_P7;
-    [ assumption | simpl in |- *; right; left; reflexivity ].
+    [ assumption | simpl; right; left; reflexivity ].
   repeat split.
   apply RList_P4 with r1; assumption.
-  rewrite H5 in H2; unfold Rmin in |- *; case (Rle_dec r2 b); intro;
+  rewrite H5 in H2; unfold Rmin; case (Rle_dec r2 b); intro;
     [ reflexivity | elim n; assumption ].
-  unfold Rmax in |- *; case (Rle_dec r2 b); intro;
+  unfold Rmax; case (Rle_dec r2 b); intro;
     [ rewrite H5 in H2; rewrite <- H2; reflexivity | elim n; assumption ].
-  simpl in H4; simpl in |- *; apply INR_eq; apply Rplus_eq_reg_l with 1;
+  simpl in H4; simpl; apply INR_eq; apply Rplus_eq_reg_l with 1;
     do 2 rewrite (Rplus_comm 1); do 2 rewrite <- S_INR;
       rewrite H4; reflexivity.
-  intros; unfold constant_D_eq, open_interval in |- *; intros;
+  intros; unfold constant_D_eq, open_interval; intros;
     unfold constant_D_eq, open_interval in H6;
       assert (H9 : (S i < pred (Rlength (cons r1 (cons r2 l))))%nat).
-  simpl in |- *; simpl in H0; apply lt_n_S; assumption.
+  simpl; simpl in H0; apply lt_n_S; assumption.
   assert (H10 := H6 _ H9); apply H10; assumption.
 Qed.
 
@@ -280,19 +278,19 @@ Proof.
     discriminate.
   intros; induction  lf1 as [| r3 lf1 Hreclf1].
   reflexivity.
-  simpl in |- *; cut (r = r1).
+  simpl; cut (r = r1).
   intro; rewrite H3; rewrite (H0 lf1 r b).
   ring.
   rewrite H3; apply StepFun_P7 with a r r3; [ right; assumption | assumption ].
   clear H H0 Hreclf1 r0; unfold adapted_couple in H1; decompose [and] H1;
-    intros; simpl in H4; rewrite H4; unfold Rmin in |- *;
+    intros; simpl in H4; rewrite H4; unfold Rmin;
       case (Rle_dec a b); intro; [ assumption | reflexivity ].
   unfold adapted_couple in H1; decompose [and] H1; intros; apply Rle_antisym.
-  apply (H3 0%nat); simpl in |- *; apply lt_O_Sn.
+  apply (H3 0%nat); simpl; apply lt_O_Sn.
   simpl in H5; rewrite H2 in H5; rewrite H5; replace (Rmin b b) with (Rmax a b);
     [ rewrite <- H4; apply RList_P7;
-      [ assumption | simpl in |- *; right; left; reflexivity ]
-      | unfold Rmin, Rmax in |- *; case (Rle_dec b b); case (Rle_dec a b); intros;
+      [ assumption | simpl; right; left; reflexivity ]
+      | unfold Rmin, Rmax; case (Rle_dec b b); case (Rle_dec a b); intros;
         try assumption || reflexivity ].
 Qed.
 
@@ -305,10 +303,10 @@ Proof.
       [ simpl in H4; discriminate
         | induction  l as [| r0 l Hrecl0];
           [ simpl in H3; simpl in H2; generalize H3; generalize H2;
-            unfold Rmin, Rmax in |- *; case (Rle_dec a b);
+            unfold Rmin, Rmax; case (Rle_dec a b);
               intros; elim H0; rewrite <- H5; rewrite <- H7;
                 reflexivity
-            | simpl in |- *; do 2 apply le_n_S; apply le_O_n ] ].
+            | simpl; do 2 apply le_n_S; apply le_O_n ] ].
 Qed.
 
 Lemma StepFun_P10 :
@@ -322,12 +320,12 @@ Proof.
   intros; unfold adapted_couple in H0; decompose [and] H0; simpl in H4;
     discriminate.
   intros; case (Req_dec a b); intro.
-  exists (cons a nil); exists nil; unfold adapted_couple_opt in |- *;
-    unfold adapted_couple in |- *; unfold ordered_Rlist in |- *;
+  exists (cons a nil); exists nil; unfold adapted_couple_opt;
+    unfold adapted_couple; unfold ordered_Rlist;
       repeat split; try (intros; simpl in H3; elim (lt_n_O _ H3)).
-  simpl in |- *; rewrite <- H2; unfold Rmin in |- *; case (Rle_dec a a); intro;
+  simpl; rewrite <- H2; unfold Rmin; case (Rle_dec a a); intro;
     reflexivity.
-  simpl in |- *; rewrite <- H2; unfold Rmax in |- *; case (Rle_dec a a); intro;
+  simpl; rewrite <- H2; unfold Rmax; case (Rle_dec a a); intro;
     reflexivity.
   elim (RList_P20 _ (StepFun_P9 H1 H2)); intros t1 [t2 [t3 H3]];
     induction  lf as [| r1 lf Hreclf].
@@ -342,32 +340,32 @@ Proof.
   apply H6.
   rewrite <- Hyp_eq; rewrite H3 in H1; unfold adapted_couple in H1;
     decompose [and] H1; clear H1; simpl in H9; rewrite H9;
-      unfold Rmin in |- *; case (Rle_dec a b); intro;
+      unfold Rmin; case (Rle_dec a b); intro;
         [ reflexivity | elim n; assumption ].
   elim H6; clear H6; intros l' [lf' H6]; case (Req_dec t2 b); intro.
   exists (cons a (cons b nil)); exists (cons r1 nil);
-    unfold adapted_couple_opt in |- *; unfold adapted_couple in |- *;
+    unfold adapted_couple_opt; unfold adapted_couple;
       repeat split.
-  unfold ordered_Rlist in |- *; intros; simpl in H8; inversion H8;
-    [ simpl in |- *; assumption | elim (le_Sn_O _ H10) ].
-  simpl in |- *; unfold Rmin in |- *; case (Rle_dec a b); intro;
+  unfold ordered_Rlist; intros; simpl in H8; inversion H8;
+    [ simpl; assumption | elim (le_Sn_O _ H10) ].
+  simpl; unfold Rmin; case (Rle_dec a b); intro;
     [ reflexivity | elim n; assumption ].
-  simpl in |- *; unfold Rmax in |- *; case (Rle_dec a b); intro;
+  simpl; unfold Rmax; case (Rle_dec a b); intro;
     [ reflexivity | elim n; assumption ].
   intros; simpl in H8; inversion H8.
-  unfold constant_D_eq, open_interval in |- *; intros; simpl in |- *;
+  unfold constant_D_eq, open_interval; intros; simpl;
     simpl in H9; rewrite H3 in H1; unfold adapted_couple in H1;
       decompose [and] H1; apply (H16 0%nat).
-  simpl in |- *; apply lt_O_Sn.
-  unfold open_interval in |- *; simpl in |- *; rewrite H7; simpl in H13;
-    rewrite H13; unfold Rmin in |- *; case (Rle_dec a b);
+  simpl; apply lt_O_Sn.
+  unfold open_interval; simpl; rewrite H7; simpl in H13;
+    rewrite H13; unfold Rmin; case (Rle_dec a b);
       intro; [ assumption | elim n; assumption ].
   elim (le_Sn_O _ H10).
   intros; simpl in H8; elim (lt_n_O _ H8).
   intros; simpl in H8; inversion H8;
-    [ simpl in |- *; assumption | elim (le_Sn_O _ H10) ].
+    [ simpl; assumption | elim (le_Sn_O _ H10) ].
   assert (Hyp_min : Rmin t2 b = t2).
-  unfold Rmin in |- *; case (Rle_dec t2 b); intro;
+  unfold Rmin; case (Rle_dec t2 b); intro;
     [ reflexivity | elim n; assumption ].
   unfold adapted_couple in H6; elim H6; clear H6; intros;
     elim (RList_P20 _ (StepFun_P9 H6 H7)); intros s1 [s2 [s3 H9]];
@@ -379,141 +377,141 @@ Proof.
   exists (cons t1 (cons s2 s3)); exists (cons r1 lf'); rewrite H3 in H1;
     rewrite H9 in H6; unfold adapted_couple in H6, H1;
       decompose [and] H1; decompose [and] H6; clear H1 H6;
-        unfold adapted_couple_opt in |- *; unfold adapted_couple in |- *;
+        unfold adapted_couple_opt; unfold adapted_couple;
           repeat split.
-  unfold ordered_Rlist in |- *; intros; simpl in H1;
+  unfold ordered_Rlist; intros; simpl in H1;
     induction  i as [| i Hreci].
-  simpl in |- *; apply Rle_trans with s1.
+  simpl; apply Rle_trans with s1.
   replace s1 with t2.
   apply (H12 0%nat).
-  simpl in |- *; apply lt_O_Sn.
-  simpl in H19; rewrite H19; symmetry  in |- *; apply Hyp_min.
-  apply (H16 0%nat); simpl in |- *; apply lt_O_Sn.
-  change (pos_Rl (cons s2 s3) i <= pos_Rl (cons s2 s3) (S i)) in |- *;
-    apply (H16 (S i)); simpl in |- *; assumption.
-  simpl in |- *; simpl in H14; rewrite H14; reflexivity.
-  simpl in |- *; simpl in H18; rewrite H18; unfold Rmax in |- *;
+  simpl; apply lt_O_Sn.
+  simpl in H19; rewrite H19; symmetry ; apply Hyp_min.
+  apply (H16 0%nat); simpl; apply lt_O_Sn.
+  change (pos_Rl (cons s2 s3) i <= pos_Rl (cons s2 s3) (S i));
+    apply (H16 (S i)); simpl; assumption.
+  simpl; simpl in H14; rewrite H14; reflexivity.
+  simpl; simpl in H18; rewrite H18; unfold Rmax;
     case (Rle_dec a b); case (Rle_dec t2 b); intros; reflexivity || elim n;
       assumption.
-  simpl in |- *; simpl in H20; apply H20.
-  intros; simpl in H1; unfold constant_D_eq, open_interval in |- *; intros;
+  simpl; simpl in H20; apply H20.
+  intros; simpl in H1; unfold constant_D_eq, open_interval; intros;
     induction  i as [| i Hreci].
-  simpl in |- *; simpl in H6; case (total_order_T x t2); intro.
+  simpl; simpl in H6; case (total_order_T x t2); intro.
   elim s; intro.
   apply (H17 0%nat);
-    [ simpl in |- *; apply lt_O_Sn
-      | unfold open_interval in |- *; simpl in |- *; elim H6; intros; split;
+    [ simpl; apply lt_O_Sn
+      | unfold open_interval; simpl; elim H6; intros; split;
         assumption ].
   rewrite b0; assumption.
   rewrite H10; apply (H22 0%nat);
-    [ simpl in |- *; apply lt_O_Sn
-      | unfold open_interval in |- *; simpl in |- *; replace s1 with t2;
+    [ simpl; apply lt_O_Sn
+      | unfold open_interval; simpl; replace s1 with t2;
         [ elim H6; intros; split; assumption
           | simpl in H19; rewrite H19; rewrite Hyp_min; reflexivity ] ].
-  simpl in |- *; simpl in H6; apply (H22 (S i));
-    [ simpl in |- *; assumption
-      | unfold open_interval in |- *; simpl in |- *; apply H6 ].
+  simpl; simpl in H6; apply (H22 (S i));
+    [ simpl; assumption
+      | unfold open_interval; simpl; apply H6 ].
   intros; simpl in H1; rewrite H10;
     change
       (pos_Rl (cons r2 lf') i <> pos_Rl (cons r2 lf') (S i) \/
         f (pos_Rl (cons s1 (cons s2 s3)) (S i)) <> pos_Rl (cons r2 lf') i)
-      in |- *; rewrite <- H9; elim H8; intros; apply H6;
-        simpl in |- *; apply H1.
+     ; rewrite <- H9; elim H8; intros; apply H6;
+        simpl; apply H1.
   intros; induction  i as [| i Hreci].
-  simpl in |- *; red in |- *; intro; elim Hyp_eq; apply Rle_antisym.
-  apply (H12 0%nat); simpl in |- *; apply lt_O_Sn.
+  simpl; red; intro; elim Hyp_eq; apply Rle_antisym.
+  apply (H12 0%nat); simpl; apply lt_O_Sn.
   rewrite <- Hyp_min; rewrite H6; simpl in H19; rewrite <- H19;
-    apply (H16 0%nat); simpl in |- *; apply lt_O_Sn.
-  elim H8; intros; rewrite H9 in H21; apply (H21 (S i)); simpl in |- *;
+    apply (H16 0%nat); simpl; apply lt_O_Sn.
+  elim H8; intros; rewrite H9 in H21; apply (H21 (S i)); simpl;
     simpl in H1; apply H1.
   exists (cons t1 l'); exists (cons r1 (cons r2 lf')); rewrite H9 in H6;
     rewrite H3 in H1; unfold adapted_couple in H1, H6;
       decompose [and] H6; decompose [and] H1; clear H6 H1;
-        unfold adapted_couple_opt in |- *; unfold adapted_couple in |- *;
+        unfold adapted_couple_opt; unfold adapted_couple;
           repeat split.
-  rewrite H9; unfold ordered_Rlist in |- *; intros; simpl in H1;
+  rewrite H9; unfold ordered_Rlist; intros; simpl in H1;
     induction  i as [| i Hreci].
-  simpl in |- *; replace s1 with t2.
-  apply (H16 0%nat); simpl in |- *; apply lt_O_Sn.
+  simpl; replace s1 with t2.
+  apply (H16 0%nat); simpl; apply lt_O_Sn.
   simpl in H14; rewrite H14; rewrite Hyp_min; reflexivity.
   change
     (pos_Rl (cons s1 (cons s2 s3)) i <= pos_Rl (cons s1 (cons s2 s3)) (S i))
-    in |- *; apply (H12 i); simpl in |- *; apply lt_S_n;
+   ; apply (H12 i); simpl; apply lt_S_n;
       assumption.
-  simpl in |- *; simpl in H19; apply H19.
-  rewrite H9; simpl in |- *; simpl in H13; rewrite H13; unfold Rmax in |- *;
+  simpl; simpl in H19; apply H19.
+  rewrite H9; simpl; simpl in H13; rewrite H13; unfold Rmax;
     case (Rle_dec t2 b); case (Rle_dec a b); intros; reflexivity || elim n;
       assumption.
-  rewrite H9; simpl in |- *; simpl in H15; rewrite H15; reflexivity.
-  intros; simpl in H1; unfold constant_D_eq, open_interval in |- *; intros;
+  rewrite H9; simpl; simpl in H15; rewrite H15; reflexivity.
+  intros; simpl in H1; unfold constant_D_eq, open_interval; intros;
     induction  i as [| i Hreci].
-  simpl in |- *; rewrite H9 in H6; simpl in H6; apply (H22 0%nat).
-  simpl in |- *; apply lt_O_Sn.
-  unfold open_interval in |- *; simpl in |- *.
+  simpl; rewrite H9 in H6; simpl in H6; apply (H22 0%nat).
+  simpl; apply lt_O_Sn.
+  unfold open_interval; simpl.
   replace t2 with s1.
   assumption.
   simpl in H14; rewrite H14; rewrite Hyp_min; reflexivity.
-  change (f x = pos_Rl (cons r2 lf') i) in |- *; clear Hreci; apply (H17 i).
-  simpl in |- *; rewrite H9 in H1; simpl in H1; apply lt_S_n; apply H1.
-  rewrite H9 in H6; unfold open_interval in |- *; apply H6.
+  change (f x = pos_Rl (cons r2 lf') i); clear Hreci; apply (H17 i).
+  simpl; rewrite H9 in H1; simpl in H1; apply lt_S_n; apply H1.
+  rewrite H9 in H6; unfold open_interval; apply H6.
   intros; simpl in H1; induction  i as [| i Hreci].
-  simpl in |- *; rewrite H9; right; simpl in |- *; replace s1 with t2.
+  simpl; rewrite H9; right; simpl; replace s1 with t2.
   assumption.
   simpl in H14; rewrite H14; rewrite Hyp_min; reflexivity.
   elim H8; intros; apply (H6 i).
-  simpl in |- *; apply lt_S_n; apply H1.
+  simpl; apply lt_S_n; apply H1.
   intros; rewrite H9; induction  i as [| i Hreci].
-  simpl in |- *; red in |- *; intro; elim Hyp_eq; apply Rle_antisym.
-  apply (H16 0%nat); simpl in |- *; apply lt_O_Sn.
+  simpl; red; intro; elim Hyp_eq; apply Rle_antisym.
+  apply (H16 0%nat); simpl; apply lt_O_Sn.
   rewrite <- Hyp_min; rewrite H6; simpl in H14; rewrite <- H14; right;
     reflexivity.
   elim H8; intros; rewrite <- H9; apply (H21 i); rewrite H9; rewrite H9 in H1;
-    simpl in |- *; simpl in H1; apply lt_S_n; apply H1.
+    simpl; simpl in H1; apply lt_S_n; apply H1.
   exists (cons t1 l'); exists (cons r1 (cons r2 lf')); rewrite H9 in H6;
     rewrite H3 in H1; unfold adapted_couple in H1, H6;
       decompose [and] H6; decompose [and] H1; clear H6 H1;
-        unfold adapted_couple_opt in |- *; unfold adapted_couple in |- *;
+        unfold adapted_couple_opt; unfold adapted_couple;
           repeat split.
-  rewrite H9; unfold ordered_Rlist in |- *; intros; simpl in H1;
+  rewrite H9; unfold ordered_Rlist; intros; simpl in H1;
     induction  i as [| i Hreci].
-  simpl in |- *; replace s1 with t2.
-  apply (H15 0%nat); simpl in |- *; apply lt_O_Sn.
+  simpl; replace s1 with t2.
+  apply (H15 0%nat); simpl; apply lt_O_Sn.
   simpl in H13; rewrite H13; rewrite Hyp_min; reflexivity.
   change
     (pos_Rl (cons s1 (cons s2 s3)) i <= pos_Rl (cons s1 (cons s2 s3)) (S i))
-    in |- *; apply (H11 i); simpl in |- *; apply lt_S_n;
+   ; apply (H11 i); simpl; apply lt_S_n;
       assumption.
-  simpl in |- *; simpl in H18; apply H18.
-  rewrite H9; simpl in |- *; simpl in H12; rewrite H12; unfold Rmax in |- *;
+  simpl; simpl in H18; apply H18.
+  rewrite H9; simpl; simpl in H12; rewrite H12; unfold Rmax;
     case (Rle_dec t2 b); case (Rle_dec a b); intros; reflexivity || elim n;
       assumption.
-  rewrite H9; simpl in |- *; simpl in H14; rewrite H14; reflexivity.
-  intros; simpl in H1; unfold constant_D_eq, open_interval in |- *; intros;
+  rewrite H9; simpl; simpl in H14; rewrite H14; reflexivity.
+  intros; simpl in H1; unfold constant_D_eq, open_interval; intros;
     induction  i as [| i Hreci].
-  simpl in |- *; rewrite H9 in H6; simpl in H6; apply (H21 0%nat).
-  simpl in |- *; apply lt_O_Sn.
-  unfold open_interval in |- *; simpl in |- *; replace t2 with s1.
+  simpl; rewrite H9 in H6; simpl in H6; apply (H21 0%nat).
+  simpl; apply lt_O_Sn.
+  unfold open_interval; simpl; replace t2 with s1.
   assumption.
   simpl in H13; rewrite H13; rewrite Hyp_min; reflexivity.
-  change (f x = pos_Rl (cons r2 lf') i) in |- *; clear Hreci; apply (H16 i).
-  simpl in |- *; rewrite H9 in H1; simpl in H1; apply lt_S_n; apply H1.
-  rewrite H9 in H6; unfold open_interval in |- *; apply H6.
+  change (f x = pos_Rl (cons r2 lf') i); clear Hreci; apply (H16 i).
+  simpl; rewrite H9 in H1; simpl in H1; apply lt_S_n; apply H1.
+  rewrite H9 in H6; unfold open_interval; apply H6.
   intros; simpl in H1; induction  i as [| i Hreci].
-  simpl in |- *; left; assumption.
+  simpl; left; assumption.
   elim H8; intros; apply (H6 i).
-  simpl in |- *; apply lt_S_n; apply H1.
+  simpl; apply lt_S_n; apply H1.
   intros; rewrite H9; induction  i as [| i Hreci].
-  simpl in |- *; red in |- *; intro; elim Hyp_eq; apply Rle_antisym.
-  apply (H15 0%nat); simpl in |- *; apply lt_O_Sn.
+  simpl; red; intro; elim Hyp_eq; apply Rle_antisym.
+  apply (H15 0%nat); simpl; apply lt_O_Sn.
   rewrite <- Hyp_min; rewrite H6; simpl in H13; rewrite <- H13; right;
     reflexivity.
   elim H8; intros; rewrite <- H9; apply (H20 i); rewrite H9; rewrite H9 in H1;
-    simpl in |- *; simpl in H1; apply lt_S_n; apply H1.
+    simpl; simpl in H1; apply lt_S_n; apply H1.
   rewrite H3 in H1; clear H4; unfold adapted_couple in H1; decompose [and] H1;
     clear H1; clear H H7 H9; cut (Rmax a b = b);
       [ intro; rewrite H in H5; rewrite <- H5; apply RList_P7;
-        [ assumption | simpl in |- *; right; left; reflexivity ]
-        | unfold Rmax in |- *; case (Rle_dec a b); intro;
+        [ assumption | simpl; right; left; reflexivity ]
+        | unfold Rmax; case (Rle_dec a b); intro;
           [ reflexivity | elim n; assumption ] ].
 Qed.
 
@@ -536,7 +534,7 @@ Proof.
   simpl in H9; rewrite H9 in H16; cut (r1 <= Rmax a b).
   intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H17 H16)).
   rewrite <- H4; apply RList_P7;
-    [ assumption | simpl in |- *; right; left; reflexivity ].
+    [ assumption | simpl; right; left; reflexivity ].
   clear Hrecs3; induction  lf2 as [| r5 lf2 Hreclf2].
   simpl in H11; discriminate.
   clear Hreclf2; assert (H17 : r3 = r4).
@@ -546,31 +544,31 @@ Proof.
         simpl in H18; rewrite <- (H17 x).
   rewrite <- (H18 x).
   reflexivity.
-  rewrite <- H12; unfold x in |- *; split.
+  rewrite <- H12; unfold x; split.
   apply Rmult_lt_reg_l with 2;
     [ prove_sup0
-      | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+      | unfold Rdiv; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
         rewrite <- Rinv_r_sym;
           [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; assumption
             | discrR ] ].
   apply Rmult_lt_reg_l with 2;
     [ prove_sup0
-      | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+      | unfold Rdiv; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
         rewrite <- Rinv_r_sym;
           [ rewrite Rmult_1_l; rewrite (Rplus_comm r); rewrite double;
             apply Rplus_lt_compat_l; assumption
             | discrR ] ].
-  unfold x in |- *; split.
+  unfold x; split.
   apply Rmult_lt_reg_l with 2;
     [ prove_sup0
-      | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+      | unfold Rdiv; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
         rewrite <- Rinv_r_sym;
           [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; assumption
             | discrR ] ].
   apply Rlt_trans with s2;
     [ apply Rmult_lt_reg_l with 2;
       [ prove_sup0
-        | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2));
+        | unfold Rdiv; rewrite <- (Rmult_comm (/ 2));
           rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym;
             [ rewrite Rmult_1_l; rewrite (Rplus_comm r); rewrite double;
               apply Rplus_lt_compat_l; assumption
@@ -578,8 +576,8 @@ Proof.
       | assumption ].
   assert (H18 : f s2 = r3).
   apply (H8 0%nat);
-    [ simpl in |- *; apply lt_O_Sn
-      | unfold open_interval in |- *; simpl in |- *; split; assumption ].
+    [ simpl; apply lt_O_Sn
+      | unfold open_interval; simpl; split; assumption ].
   assert (H19 : r3 = r5).
   assert (H19 := H7 1%nat); simpl in H19;
     assert (H20 := H19 (lt_n_S _ _ (lt_O_Sn _))); elim H20;
@@ -589,18 +587,18 @@ Proof.
       rewrite <- (H22 (lt_O_Sn _) x).
   rewrite <- (H23 (lt_n_S _ _ (lt_O_Sn _)) x).
   reflexivity.
-  unfold open_interval in |- *; simpl in |- *; unfold x in |- *; split.
+  unfold open_interval; simpl; unfold x; split.
   apply Rmult_lt_reg_l with 2;
     [ prove_sup0
-      | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+      | unfold Rdiv; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
         rewrite <- Rinv_r_sym;
           [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l;
-            unfold Rmin in |- *; case (Rle_dec r1 r0); intro;
+            unfold Rmin; case (Rle_dec r1 r0); intro;
               assumption
             | discrR ] ].
   apply Rmult_lt_reg_l with 2;
     [ prove_sup0
-      | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+      | unfold Rdiv; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
         rewrite <- Rinv_r_sym;
           [ rewrite Rmult_1_l; rewrite double;
             apply Rlt_le_trans with (r0 + Rmin r1 r0);
@@ -608,20 +606,20 @@ Proof.
                 assumption
                 | apply Rplus_le_compat_l; apply Rmin_r ]
             | discrR ] ].
-  unfold open_interval in |- *; simpl in |- *; unfold x in |- *; split.
+  unfold open_interval; simpl; unfold x; split.
   apply Rlt_trans with s2;
     [ assumption
       | apply Rmult_lt_reg_l with 2;
         [ prove_sup0
-          | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2));
+          | unfold Rdiv; rewrite <- (Rmult_comm (/ 2));
             rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym;
               [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l;
-                unfold Rmin in |- *; case (Rle_dec r1 r0);
+                unfold Rmin; case (Rle_dec r1 r0);
                   intro; assumption
                 | discrR ] ] ].
   apply Rmult_lt_reg_l with 2;
     [ prove_sup0
-      | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+      | unfold Rdiv; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
         rewrite <- Rinv_r_sym;
           [ rewrite Rmult_1_l; rewrite double;
             apply Rlt_le_trans with (r1 + Rmin r1 r0);
@@ -638,20 +636,20 @@ Proof.
         | elim H24; rewrite <- H17; assumption ].
   elim H2; clear H2; intros; assert (H17 := H16 0%nat); simpl in H17;
     elim (H17 (lt_O_Sn _)); assumption.
-  rewrite <- H0; rewrite H12; apply (H7 0%nat); simpl in |- *; apply lt_O_Sn.
+  rewrite <- H0; rewrite H12; apply (H7 0%nat); simpl; apply lt_O_Sn.
 Qed.
 
 Lemma StepFun_P12 :
   forall (a b:R) (f:R -> R) (l lf:Rlist),
     adapted_couple_opt f a b l lf -> adapted_couple_opt f b a l lf.
 Proof.
-  unfold adapted_couple_opt in |- *; unfold adapted_couple in |- *; intros;
+  unfold adapted_couple_opt; unfold adapted_couple; intros;
     decompose [and] H; clear H; repeat split; try assumption.
-  rewrite H0; unfold Rmin in |- *; case (Rle_dec a b); intro;
+  rewrite H0; unfold Rmin; case (Rle_dec a b); intro;
     case (Rle_dec b a); intro; try reflexivity.
   apply Rle_antisym; assumption.
   apply Rle_antisym; auto with real.
-  rewrite H3; unfold Rmax in |- *; case (Rle_dec a b); intro;
+  rewrite H3; unfold Rmax; case (Rle_dec a b); intro;
     case (Rle_dec b a); intro; try reflexivity.
   apply Rle_antisym; assumption.
   apply Rle_antisym; auto with real.
@@ -691,10 +689,10 @@ Proof.
     case (Req_dec a b); intro.
   rewrite (StepFun_P8 H2 H4); rewrite (StepFun_P8 H H4); reflexivity.
   assert (Hyp_min : Rmin a b = a).
-  unfold Rmin in |- *; case (Rle_dec a b); intro;
+  unfold Rmin; case (Rle_dec a b); intro;
     [ reflexivity | elim n; assumption ].
   assert (Hyp_max : Rmax a b = b).
-  unfold Rmax in |- *; case (Rle_dec a b); intro;
+  unfold Rmax; case (Rle_dec a b); intro;
     [ reflexivity | elim n; assumption ].
   elim (RList_P20 _ (StepFun_P9 H H4)); intros s1 [s2 [s3 H5]]; rewrite H5 in H;
     rewrite H5; induction  lf1 as [| r3 lf1 Hreclf1].
@@ -718,34 +716,34 @@ Proof.
   rewrite <- (H20 (lt_O_Sn _) x).
   reflexivity.
   assert (H21 := H13 0%nat (lt_O_Sn _)); simpl in H21; elim H21; intro;
-    [ idtac | elim H7; assumption ]; unfold x in |- *;
+    [ idtac | elim H7; assumption ]; unfold x;
       split.
   apply Rmult_lt_reg_l with 2;
     [ prove_sup0
-      | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+      | unfold Rdiv; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
         rewrite <- Rinv_r_sym;
           [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; apply H
             | discrR ] ].
   apply Rmult_lt_reg_l with 2;
     [ prove_sup0
-      | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+      | unfold Rdiv; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
         rewrite <- Rinv_r_sym;
           [ rewrite Rmult_1_l; rewrite <- (Rplus_comm r1); rewrite double;
             apply Rplus_lt_compat_l; apply H
             | discrR ] ].
   rewrite <- H6; assert (H21 := H13 0%nat (lt_O_Sn _)); simpl in H21; elim H21;
-    intro; [ idtac | elim H7; assumption ]; unfold x in |- *;
+    intro; [ idtac | elim H7; assumption ]; unfold x;
       split.
   apply Rmult_lt_reg_l with 2;
     [ prove_sup0
-      | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+      | unfold Rdiv; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
         rewrite <- Rinv_r_sym;
           [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; apply H
             | discrR ] ].
   apply Rlt_le_trans with r1;
     [ apply Rmult_lt_reg_l with 2;
       [ prove_sup0
-        | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2));
+        | unfold Rdiv; rewrite <- (Rmult_comm (/ 2));
           rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym;
             [ rewrite Rmult_1_l; rewrite <- (Rplus_comm r1); rewrite double;
               apply Rplus_lt_compat_l; apply H
@@ -754,64 +752,64 @@ Proof.
   eapply StepFun_P13.
   apply H4.
   apply H2.
-  unfold adapted_couple_opt in |- *; split.
+  unfold adapted_couple_opt; split.
   apply H.
   rewrite H5 in H3; apply H3.
   assert (H8 : r1 <= s2).
   eapply StepFun_P13.
   apply H4.
   apply H2.
-  unfold adapted_couple_opt in |- *; split.
+  unfold adapted_couple_opt; split.
   apply H.
   rewrite H5 in H3; apply H3.
   elim H7; intro.
-  simpl in |- *; elim H8; intro.
+  simpl; elim H8; intro.
   replace (r4 * (s2 - s1)) with (r3 * (r1 - r) + r3 * (s2 - r1));
   [ idtac | rewrite H9; rewrite H6; ring ].
   rewrite Rplus_assoc; apply Rplus_eq_compat_l;
     change
       (Int_SF lf1 (cons r1 r2) = Int_SF (cons r3 lf2) (cons r1 (cons s2 s3)))
-      in |- *; apply H0 with r1 b.
+     ; apply H0 with r1 b.
   unfold adapted_couple in H2; decompose [and] H2; clear H2;
     replace b with (Rmax a b).
   rewrite <- H12; apply RList_P7;
-    [ assumption | simpl in |- *; right; left; reflexivity ].
+    [ assumption | simpl; right; left; reflexivity ].
   eapply StepFun_P7.
   apply H1.
   apply H2.
-  unfold adapted_couple_opt in |- *; split.
+  unfold adapted_couple_opt; split.
   apply StepFun_P7 with a a r3.
   apply H1.
   unfold adapted_couple in H2, H; decompose [and] H2; decompose [and] H;
     clear H H2; assert (H20 : r = a).
   simpl in H13; rewrite H13; apply Hyp_min.
-  unfold adapted_couple in |- *; repeat split.
-  unfold ordered_Rlist in |- *; intros; simpl in H; induction  i as [| i Hreci].
-  simpl in |- *; rewrite <- H20; apply (H11 0%nat).
-  simpl in |- *; apply lt_O_Sn.
+  unfold adapted_couple; repeat split.
+  unfold ordered_Rlist; intros; simpl in H; induction  i as [| i Hreci].
+  simpl; rewrite <- H20; apply (H11 0%nat).
+  simpl; apply lt_O_Sn.
   induction  i as [| i Hreci0].
-  simpl in |- *; assumption.
-  change (pos_Rl (cons s2 s3) i <= pos_Rl (cons s2 s3) (S i)) in |- *;
-    apply (H15 (S i)); simpl in |- *; apply lt_S_n; assumption.
-  simpl in |- *; symmetry  in |- *; apply Hyp_min.
+  simpl; assumption.
+  change (pos_Rl (cons s2 s3) i <= pos_Rl (cons s2 s3) (S i));
+    apply (H15 (S i)); simpl; apply lt_S_n; assumption.
+  simpl; symmetry ; apply Hyp_min.
   rewrite <- H17; reflexivity.
-  simpl in H19; simpl in |- *; rewrite H19; reflexivity.
-  intros; simpl in H; unfold constant_D_eq, open_interval in |- *; intros;
+  simpl in H19; simpl; rewrite H19; reflexivity.
+  intros; simpl in H; unfold constant_D_eq, open_interval; intros;
     induction  i as [| i Hreci].
-  simpl in |- *; apply (H16 0%nat).
-  simpl in |- *; apply lt_O_Sn.
-  simpl in H2; rewrite <- H20 in H2; unfold open_interval in |- *;
-    simpl in |- *; apply H2.
+  simpl; apply (H16 0%nat).
+  simpl; apply lt_O_Sn.
+  simpl in H2; rewrite <- H20 in H2; unfold open_interval;
+    simpl; apply H2.
   clear Hreci; induction  i as [| i Hreci].
-  simpl in |- *; simpl in H2; rewrite H9; apply (H21 0%nat).
-  simpl in |- *; apply lt_O_Sn.
-  unfold open_interval in |- *; simpl in |- *; elim H2; intros; split.
+  simpl; simpl in H2; rewrite H9; apply (H21 0%nat).
+  simpl; apply lt_O_Sn.
+  unfold open_interval; simpl; elim H2; intros; split.
   apply Rle_lt_trans with r1; try assumption; rewrite <- H6; apply (H11 0%nat);
-    simpl in |- *; apply lt_O_Sn.
+    simpl; apply lt_O_Sn.
   assumption.
-  clear Hreci; simpl in |- *; apply (H21 (S i)).
-  simpl in |- *; apply lt_S_n; assumption.
-  unfold open_interval in |- *; apply H2.
+  clear Hreci; simpl; apply (H21 (S i)).
+  simpl; apply lt_S_n; assumption.
+  unfold open_interval; apply H2.
   elim H3; clear H3; intros; split.
   rewrite H9;
     change
@@ -819,64 +817,64 @@ Proof.
         (i < pred (Rlength (cons r4 lf2)))%nat ->
         pos_Rl (cons r4 lf2) i <> pos_Rl (cons r4 lf2) (S i) \/
         f (pos_Rl (cons s1 (cons s2 s3)) (S i)) <> pos_Rl (cons r4 lf2) i)
-      in |- *; rewrite <- H5; apply H3.
+     ; rewrite <- H5; apply H3.
   rewrite H5 in H11; intros; simpl in H12; induction  i as [| i Hreci].
-  simpl in |- *; red in |- *; intro; rewrite H13 in H10;
+  simpl; red; intro; rewrite H13 in H10;
     elim (Rlt_irrefl _ H10).
-  clear Hreci; apply (H11 (S i)); simpl in |- *; apply H12.
+  clear Hreci; apply (H11 (S i)); simpl; apply H12.
   rewrite H9; rewrite H10; rewrite H6; apply Rplus_eq_compat_l; rewrite <- H10;
     apply H0 with r1 b.
   unfold adapted_couple in H2; decompose [and] H2; clear H2;
     replace b with (Rmax a b).
   rewrite <- H12; apply RList_P7;
-    [ assumption | simpl in |- *; right; left; reflexivity ].
+    [ assumption | simpl; right; left; reflexivity ].
   eapply StepFun_P7.
   apply H1.
   apply H2.
-  unfold adapted_couple_opt in |- *; split.
+  unfold adapted_couple_opt; split.
   apply StepFun_P7 with a a r3.
   apply H1.
   unfold adapted_couple in H2, H; decompose [and] H2; decompose [and] H;
     clear H H2; assert (H20 : r = a).
   simpl in H13; rewrite H13; apply Hyp_min.
-  unfold adapted_couple in |- *; repeat split.
-  unfold ordered_Rlist in |- *; intros; simpl in H; induction  i as [| i Hreci].
-  simpl in |- *; rewrite <- H20; apply (H11 0%nat); simpl in |- *;
+  unfold adapted_couple; repeat split.
+  unfold ordered_Rlist; intros; simpl in H; induction  i as [| i Hreci].
+  simpl; rewrite <- H20; apply (H11 0%nat); simpl;
     apply lt_O_Sn.
-  rewrite H10; apply (H15 (S i)); simpl in |- *; assumption.
-  simpl in |- *; symmetry  in |- *; apply Hyp_min.
+  rewrite H10; apply (H15 (S i)); simpl; assumption.
+  simpl; symmetry ; apply Hyp_min.
   rewrite <- H17; rewrite H10; reflexivity.
-  simpl in H19; simpl in |- *; apply H19.
-  intros; simpl in H; unfold constant_D_eq, open_interval in |- *; intros;
+  simpl in H19; simpl; apply H19.
+  intros; simpl in H; unfold constant_D_eq, open_interval; intros;
     induction  i as [| i Hreci].
-  simpl in |- *; apply (H16 0%nat).
-  simpl in |- *; apply lt_O_Sn.
-  simpl in H2; rewrite <- H20 in H2; unfold open_interval in |- *;
-    simpl in |- *; apply H2.
-  clear Hreci; simpl in |- *; apply (H21 (S i)).
-  simpl in |- *; assumption.
-  rewrite <- H10; unfold open_interval in |- *; apply H2.
+  simpl; apply (H16 0%nat).
+  simpl; apply lt_O_Sn.
+  simpl in H2; rewrite <- H20 in H2; unfold open_interval;
+    simpl; apply H2.
+  clear Hreci; simpl; apply (H21 (S i)).
+  simpl; assumption.
+  rewrite <- H10; unfold open_interval; apply H2.
   elim H3; clear H3; intros; split.
   rewrite H5 in H3; intros; apply (H3 (S i)).
-  simpl in |- *; replace (Rlength lf2) with (S (pred (Rlength lf2))).
+  simpl; replace (Rlength lf2) with (S (pred (Rlength lf2))).
   apply lt_n_S; apply H12.
-  symmetry  in |- *; apply S_pred with 0%nat; apply neq_O_lt; red in |- *;
+  symmetry ; apply S_pred with 0%nat; apply neq_O_lt; red;
     intro; rewrite <- H13 in H12; elim (lt_n_O _ H12).
   intros; simpl in H12; rewrite H10; rewrite H5 in H11; apply (H11 (S i));
-    simpl in |- *; apply lt_n_S; apply H12.
-  simpl in |- *; rewrite H9; unfold Rminus in |- *; rewrite Rplus_opp_r;
+    simpl; apply lt_n_S; apply H12.
+  simpl; rewrite H9; unfold Rminus; rewrite Rplus_opp_r;
     rewrite Rmult_0_r; rewrite Rplus_0_l;
       change
         (Int_SF lf1 (cons r1 r2) = Int_SF (cons r4 lf2) (cons s1 (cons s2 s3)))
-        in |- *; eapply H0.
+       ; eapply H0.
   apply H1.
-  2: rewrite H5 in H3; unfold adapted_couple_opt in |- *; split; assumption.
+  2: rewrite H5 in H3; unfold adapted_couple_opt; split; assumption.
   assert (H10 : r = a).
   unfold adapted_couple in H2; decompose [and] H2; clear H2; simpl in H12;
     rewrite H12; apply Hyp_min.
   rewrite <- H9; rewrite H10; apply StepFun_P7 with a r r3;
     [ apply H1
-      | pattern a at 2 in |- *; rewrite <- H10; pattern r at 2 in |- *; rewrite H9;
+      | pattern a at 2; rewrite <- H10; pattern r at 2; rewrite H9;
         apply H2 ].
 Qed.
 
@@ -920,12 +918,12 @@ Qed.
 Lemma StepFun_P18 :
   forall a b c:R, RiemannInt_SF (mkStepFun (StepFun_P4 a b c)) = c * (b - a).
 Proof.
-  intros; unfold RiemannInt_SF in |- *; case (Rle_dec a b); intro.
+  intros; unfold RiemannInt_SF; case (Rle_dec a b); intro.
   replace
   (Int_SF (subdivision_val (mkStepFun (StepFun_P4 a b c)))
     (subdivision (mkStepFun (StepFun_P4 a b c)))) with
   (Int_SF (cons c nil) (cons a (cons b nil)));
-  [ simpl in |- *; ring
+  [ simpl; ring
     | apply StepFun_P17 with (fct_cte c) a b;
       [ apply StepFun_P3; assumption
         | apply (StepFun_P1 (mkStepFun (StepFun_P4 a b c))) ] ].
@@ -933,7 +931,7 @@ Proof.
   (Int_SF (subdivision_val (mkStepFun (StepFun_P4 a b c)))
     (subdivision (mkStepFun (StepFun_P4 a b c)))) with
   (Int_SF (cons c nil) (cons b (cons a nil)));
-  [ simpl in |- *; ring
+  [ simpl; ring
     | apply StepFun_P17 with (fct_cte c) a b;
       [ apply StepFun_P2; apply StepFun_P3; auto with real
         | apply (StepFun_P1 (mkStepFun (StepFun_P4 a b c))) ] ].
@@ -945,8 +943,8 @@ Lemma StepFun_P19 :
     Int_SF (FF l1 f) l1 + l * Int_SF (FF l1 g) l1.
 Proof.
   intros; induction  l1 as [| r l1 Hrecl1];
-    [ simpl in |- *; ring
-      | induction  l1 as [| r0 l1 Hrecl0]; simpl in |- *;
+    [ simpl; ring
+      | induction  l1 as [| r0 l1 Hrecl0]; simpl;
         [ ring | simpl in Hrecl1; rewrite Hrecl1; ring ] ].
 Qed.
 
@@ -956,38 +954,38 @@ Lemma StepFun_P20 :
 Proof.
   intros l f H; induction l;
     [ elim (lt_irrefl _ H)
-      | simpl in |- *; rewrite RList_P18; rewrite RList_P14; reflexivity ].
+      | simpl; rewrite RList_P18; rewrite RList_P14; reflexivity ].
 Qed.
 
 Lemma StepFun_P21 :
   forall (a b:R) (f:R -> R) (l:Rlist),
     is_subdivision f a b l -> adapted_couple f a b l (FF l f).
 Proof.
-  intros; unfold adapted_couple in |- *; unfold is_subdivision in X;
+  intros; unfold adapted_couple; unfold is_subdivision in X;
     unfold adapted_couple in X; elim X; clear X; intros;
       decompose [and] p; clear p; repeat split; try assumption.
   apply StepFun_P20; rewrite H2; apply lt_O_Sn.
   intros; assert (H5 := H4 _ H3); unfold constant_D_eq, open_interval in H5;
-    unfold constant_D_eq, open_interval in |- *; intros;
+    unfold constant_D_eq, open_interval; intros;
       induction  l as [| r l Hrecl].
   discriminate.
-  unfold FF in |- *; rewrite RList_P12.
-  simpl in |- *;
-    change (f x0 = f (pos_Rl (mid_Rlist (cons r l) r) (S i))) in |- *;
+  unfold FF; rewrite RList_P12.
+  simpl;
+    change (f x0 = f (pos_Rl (mid_Rlist (cons r l) r) (S i)));
       rewrite RList_P13; try assumption; rewrite (H5 x0 H6);
         rewrite H5.
   reflexivity.
   split.
   apply Rmult_lt_reg_l with 2;
     [ prove_sup0
-      | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+      | unfold Rdiv; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
         rewrite <- Rinv_r_sym;
           [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; elim H6;
             intros; apply Rlt_trans with x0; assumption
             | discrR ] ].
   apply Rmult_lt_reg_l with 2;
     [ prove_sup0
-      | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+      | unfold Rdiv; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
         rewrite <- Rinv_r_sym;
           [ rewrite Rmult_1_l; rewrite double;
             rewrite (Rplus_comm (pos_Rl (cons r l) i));
@@ -1003,22 +1001,22 @@ Lemma StepFun_P22 :
     is_subdivision f a b lf ->
     is_subdivision g a b lg -> is_subdivision f a b (cons_ORlist lf lg).
 Proof.
-  unfold is_subdivision in |- *; intros a b f g lf lg Hyp X X0; elim X; elim X0;
+  unfold is_subdivision; intros a b f g lf lg Hyp X X0; elim X; elim X0;
     clear X X0; intros lg0 p lf0 p0; assert (Hyp_min : Rmin a b = a).
-  unfold Rmin in |- *; case (Rle_dec a b); intro;
+  unfold Rmin; case (Rle_dec a b); intro;
     [ reflexivity | elim n; assumption ].
   assert (Hyp_max : Rmax a b = b).
-  unfold Rmax in |- *; case (Rle_dec a b); intro;
+  unfold Rmax; case (Rle_dec a b); intro;
     [ reflexivity | elim n; assumption ].
   apply existT with (FF (cons_ORlist lf lg) f); unfold adapted_couple in p, p0;
     decompose [and] p; decompose [and] p0; clear p p0;
       rewrite Hyp_min in H6; rewrite Hyp_min in H1; rewrite Hyp_max in H0;
-        rewrite Hyp_max in H5; unfold adapted_couple in |- *;
+        rewrite Hyp_max in H5; unfold adapted_couple;
           repeat split.
   apply RList_P2; assumption.
-  rewrite Hyp_min; symmetry  in |- *; apply Rle_antisym.
+  rewrite Hyp_min; symmetry ; apply Rle_antisym.
   induction  lf as [| r lf Hreclf].
-  simpl in |- *; right; symmetry  in |- *; assumption.
+  simpl; right; symmetry ; assumption.
   assert
     (H10 :
       In (pos_Rl (cons_ORlist (cons r lf) lg) 0) (cons_ORlist (cons r lf) lg)).
@@ -1026,7 +1024,7 @@ Proof.
     (RList_P3 (cons_ORlist (cons r lf) lg)
       (pos_Rl (cons_ORlist (cons r lf) lg) 0)); intros _ H10;
     apply H10; exists 0%nat; split;
-      [ reflexivity | rewrite RList_P11; simpl in |- *; apply lt_O_Sn ].
+      [ reflexivity | rewrite RList_P11; simpl; apply lt_O_Sn ].
   elim (RList_P9 (cons r lf) lg (pos_Rl (cons_ORlist (cons r lf) lg) 0));
     intros H12 _; assert (H13 := H12 H10); elim H13; intro.
   elim (RList_P3 (cons r lf) (pos_Rl (cons_ORlist (cons r lf) lg) 0));
@@ -1039,16 +1037,16 @@ Proof.
       clear H15; intros; rewrite H15; rewrite <- H1; elim (RList_P6 lg);
         intros; apply H17; [ assumption | apply le_O_n | assumption ].
   induction  lf as [| r lf Hreclf].
-  simpl in |- *; right; assumption.
+  simpl; right; assumption.
   assert (H8 : In a (cons_ORlist (cons r lf) lg)).
   elim (RList_P9 (cons r lf) lg a); intros; apply H10; left;
     elim (RList_P3 (cons r lf) a); intros; apply H12;
       exists 0%nat; split;
-        [ symmetry  in |- *; assumption | simpl in |- *; apply lt_O_Sn ].
+        [ symmetry ; assumption | simpl; apply lt_O_Sn ].
   apply RList_P5; [ apply RList_P2; assumption | assumption ].
   rewrite Hyp_max; apply Rle_antisym.
   induction  lf as [| r lf Hreclf].
-  simpl in |- *; right; assumption.
+  simpl; right; assumption.
   assert
     (H8 :
       In
@@ -1061,7 +1059,7 @@ Proof.
         (pred (Rlength (cons_ORlist (cons r lf) lg)))));
     intros _ H10; apply H10;
       exists (pred (Rlength (cons_ORlist (cons r lf) lg)));
-        split; [ reflexivity | rewrite RList_P11; simpl in |- *; apply lt_n_Sn ].
+        split; [ reflexivity | rewrite RList_P11; simpl; apply lt_n_Sn ].
   elim
     (RList_P9 (cons r lf) lg
       (pos_Rl (cons_ORlist (cons r lf) lg)
@@ -1076,8 +1074,8 @@ Proof.
       elim H15; clear H15; intros; rewrite H15; rewrite <- H5;
         elim (RList_P6 (cons r lf)); intros; apply H17;
           [ assumption
-            | simpl in |- *; simpl in H14; apply lt_n_Sm_le; assumption
-            | simpl in |- *; apply lt_n_Sn ].
+            | simpl; simpl in H14; apply lt_n_Sm_le; assumption
+            | simpl; apply lt_n_Sn ].
   elim
     (RList_P3 lg
       (pos_Rl (cons_ORlist (cons r lf) lg)
@@ -1085,23 +1083,23 @@ Proof.
     intros H13 _; assert (H14 := H13 H12); elim H14; intros;
       elim H15; clear H15; intros.
   rewrite H15; assert (H17 : Rlength lg = S (pred (Rlength lg))).
-  apply S_pred with 0%nat; apply neq_O_lt; red in |- *; intro;
+  apply S_pred with 0%nat; apply neq_O_lt; red; intro;
     rewrite <- H17 in H16; elim (lt_n_O _ H16).
   rewrite <- H0; elim (RList_P6 lg); intros; apply H18;
     [ assumption
       | rewrite H17 in H16; apply lt_n_Sm_le; assumption
       | apply lt_pred_n_n; rewrite H17; apply lt_O_Sn ].
   induction  lf as [| r lf Hreclf].
-  simpl in |- *; right; symmetry  in |- *; assumption.
+  simpl; right; symmetry ; assumption.
   assert (H8 : In b (cons_ORlist (cons r lf) lg)).
   elim (RList_P9 (cons r lf) lg b); intros; apply H10; left;
     elim (RList_P3 (cons r lf) b); intros; apply H12;
       exists (pred (Rlength (cons r lf))); split;
-        [ symmetry  in |- *; assumption | simpl in |- *; apply lt_n_Sn ].
+        [ symmetry ; assumption | simpl; apply lt_n_Sn ].
   apply RList_P7; [ apply RList_P2; assumption | assumption ].
-  apply StepFun_P20; rewrite RList_P11; rewrite H2; rewrite H7; simpl in |- *;
+  apply StepFun_P20; rewrite RList_P11; rewrite H2; rewrite H7; simpl;
     apply lt_O_Sn.
-  intros; unfold constant_D_eq, open_interval in |- *; intros;
+  intros; unfold constant_D_eq, open_interval; intros;
     cut
       (exists l : R,
         constant_D_eq f
@@ -1111,10 +1109,10 @@ Proof.
     assert
       (Hyp_cons :
         exists r : R, (exists r0 : Rlist, cons_ORlist lf lg = cons r r0)).
-  apply RList_P19; red in |- *; intro; rewrite H13 in H8; elim (lt_n_O _ H8).
+  apply RList_P19; red; intro; rewrite H13 in H8; elim (lt_n_O _ H8).
   elim Hyp_cons; clear Hyp_cons; intros r [r0 Hyp_cons]; rewrite Hyp_cons;
-    unfold FF in |- *; rewrite RList_P12.
-  change (f x = f (pos_Rl (mid_Rlist (cons r r0) r) (S i))) in |- *;
+    unfold FF; rewrite RList_P12.
+  change (f x = f (pos_Rl (mid_Rlist (cons r r0) r) (S i)));
     rewrite <- Hyp_cons; rewrite RList_P13.
   assert (H13 := RList_P2 _ _ H _ H8); elim H13; intro.
   unfold constant_D_eq, open_interval in H11, H12; rewrite (H11 x H10);
@@ -1126,13 +1124,13 @@ Proof.
   split.
   apply Rmult_lt_reg_l with 2;
     [ prove_sup0
-      | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+      | unfold Rdiv; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
         rewrite <- Rinv_r_sym;
           [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; assumption
             | discrR ] ].
   apply Rmult_lt_reg_l with 2;
     [ prove_sup0
-      | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+      | unfold Rdiv; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
         rewrite <- Rinv_r_sym;
           [ rewrite Rmult_1_l; rewrite double;
             rewrite (Rplus_comm (pos_Rl (cons_ORlist lf lg) i));
@@ -1151,7 +1149,7 @@ Proof.
   apply le_O_n.
   apply lt_trans with (pred (Rlength (cons_ORlist lf lg)));
     [ assumption
-      | apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro;
+      | apply lt_pred_n_n; apply neq_O_lt; red; intro;
         rewrite <- H13 in H8; elim (lt_n_O _ H8) ].
   assumption.
   assumption.
@@ -1162,7 +1160,7 @@ Proof.
   elim (RList_P6 (cons_ORlist lf lg)); intros; apply H11.
   apply RList_P2; assumption.
   apply lt_n_Sm_le; apply lt_n_S; assumption.
-  apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro; rewrite <- H13 in H8;
+  apply lt_pred_n_n; apply neq_O_lt; red; intro; rewrite <- H13 in H8;
     elim (lt_n_O _ H8).
   rewrite H0; assumption.
   set
@@ -1170,24 +1168,24 @@ Proof.
       fun j:nat =>
         pos_Rl lf j <= pos_Rl (cons_ORlist lf lg) i /\ (j < Rlength lf)%nat);
     assert (H12 : Nbound I).
-  unfold Nbound in |- *; exists (Rlength lf); intros; unfold I in H12; elim H12;
+  unfold Nbound; exists (Rlength lf); intros; unfold I in H12; elim H12;
     intros; apply lt_le_weak; assumption.
   assert (H13 :  exists n : nat, I n).
-  exists 0%nat; unfold I in |- *; split.
+  exists 0%nat; unfold I; split.
   apply Rle_trans with (pos_Rl (cons_ORlist lf lg) 0).
-  right; symmetry  in |- *.
+  right; symmetry .
   apply RList_P15; try assumption; rewrite H1; assumption.
   elim (RList_P6 (cons_ORlist lf lg)); intros; apply H13.
   apply RList_P2; assumption.
   apply le_O_n.
   apply lt_trans with (pred (Rlength (cons_ORlist lf lg))).
   assumption.
-  apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro; rewrite <- H15 in H8;
+  apply lt_pred_n_n; apply neq_O_lt; red; intro; rewrite <- H15 in H8;
     elim (lt_n_O _ H8).
-  apply neq_O_lt; red in |- *; intro; rewrite <- H13 in H5;
+  apply neq_O_lt; red; intro; rewrite <- H13 in H5;
     rewrite <- H6 in H11; rewrite <- H5 in H11; elim (Rlt_irrefl _ H11).
   assert (H14 := Nzorn H13 H12); elim H14; clear H14; intros x0 H14;
-    exists (pos_Rl lf0 x0); unfold constant_D_eq, open_interval in |- *;
+    exists (pos_Rl lf0 x0); unfold constant_D_eq, open_interval;
       intros; assert (H16 := H9 x0); assert (H17 : (x0 < pred (Rlength lf))%nat).
   elim H14; clear H14; intros; unfold I in H14; elim H14; clear H14; intros;
     apply lt_S_n; replace (S (pred (Rlength lf))) with (Rlength lf).
@@ -1205,11 +1203,11 @@ Proof.
   elim (RList_P6 (cons_ORlist lf lg)); intros; apply H21.
   apply RList_P2; assumption.
   apply lt_n_Sm_le; apply lt_n_S; assumption.
-  apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro; rewrite <- H23 in H8;
+  apply lt_pred_n_n; apply neq_O_lt; red; intro; rewrite <- H23 in H8;
     elim (lt_n_O _ H8).
   right; apply RList_P16; try assumption; rewrite H0; assumption.
   rewrite <- H20; reflexivity.
-  apply S_pred with 0%nat; apply neq_O_lt; red in |- *; intro;
+  apply S_pred with 0%nat; apply neq_O_lt; red; intro;
     rewrite <- H19 in H18; elim (lt_n_O _ H18).
   assert (H18 := H16 H17); unfold constant_D_eq, open_interval in H18;
     rewrite (H18 x1).
@@ -1221,11 +1219,11 @@ Proof.
   assert (H22 : (S x0 < Rlength lf)%nat).
   replace (Rlength lf) with (S (pred (Rlength lf)));
   [ apply lt_n_S; assumption
-    | symmetry  in |- *; apply S_pred with 0%nat; apply neq_O_lt; red in |- *;
+    | symmetry ; apply S_pred with 0%nat; apply neq_O_lt; red;
       intro; rewrite <- H22 in H21; elim (lt_n_O _ H21) ].
   elim (Rle_dec (pos_Rl lf (S x0)) (pos_Rl (cons_ORlist lf lg) i)); intro.
   assert (H23 : (S x0 <= x0)%nat).
-  apply H20; unfold I in |- *; split; assumption.
+  apply H20; unfold I; split; assumption.
   elim (le_Sn_n _ H23).
   assert (H23 : pos_Rl (cons_ORlist lf lg) i < pos_Rl lf (S x0)).
   auto with real.
@@ -1255,22 +1253,22 @@ Lemma StepFun_P24 :
     is_subdivision f a b lf ->
     is_subdivision g a b lg -> is_subdivision g a b (cons_ORlist lf lg).
 Proof.
-  unfold is_subdivision in |- *; intros a b f g lf lg Hyp X X0; elim X; elim X0;
+  unfold is_subdivision; intros a b f g lf lg Hyp X X0; elim X; elim X0;
     clear X X0; intros lg0 p lf0 p0; assert (Hyp_min : Rmin a b = a).
-  unfold Rmin in |- *; case (Rle_dec a b); intro;
+  unfold Rmin; case (Rle_dec a b); intro;
     [ reflexivity | elim n; assumption ].
   assert (Hyp_max : Rmax a b = b).
-  unfold Rmax in |- *; case (Rle_dec a b); intro;
+  unfold Rmax; case (Rle_dec a b); intro;
     [ reflexivity | elim n; assumption ].
   apply existT with (FF (cons_ORlist lf lg) g); unfold adapted_couple in p, p0;
     decompose [and] p; decompose [and] p0; clear p p0;
       rewrite Hyp_min in H1; rewrite Hyp_min in H6; rewrite Hyp_max in H0;
-        rewrite Hyp_max in H5; unfold adapted_couple in |- *;
+        rewrite Hyp_max in H5; unfold adapted_couple;
           repeat split.
   apply RList_P2; assumption.
-  rewrite Hyp_min; symmetry  in |- *; apply Rle_antisym.
+  rewrite Hyp_min; symmetry ; apply Rle_antisym.
   induction  lf as [| r lf Hreclf].
-  simpl in |- *; right; symmetry  in |- *; assumption.
+  simpl; right; symmetry ; assumption.
   assert
     (H10 :
       In (pos_Rl (cons_ORlist (cons r lf) lg) 0) (cons_ORlist (cons r lf) lg)).
@@ -1278,7 +1276,7 @@ Proof.
     (RList_P3 (cons_ORlist (cons r lf) lg)
       (pos_Rl (cons_ORlist (cons r lf) lg) 0)); intros _ H10;
     apply H10; exists 0%nat; split;
-      [ reflexivity | rewrite RList_P11; simpl in |- *; apply lt_O_Sn ].
+      [ reflexivity | rewrite RList_P11; simpl; apply lt_O_Sn ].
   elim (RList_P9 (cons r lf) lg (pos_Rl (cons_ORlist (cons r lf) lg) 0));
     intros H12 _; assert (H13 := H12 H10); elim H13; intro.
   elim (RList_P3 (cons r lf) (pos_Rl (cons_ORlist (cons r lf) lg) 0));
@@ -1291,16 +1289,16 @@ Proof.
       clear H15; intros; rewrite H15; rewrite <- H1; elim (RList_P6 lg);
         intros; apply H17; [ assumption | apply le_O_n | assumption ].
   induction  lf as [| r lf Hreclf].
-  simpl in |- *; right; assumption.
+  simpl; right; assumption.
   assert (H8 : In a (cons_ORlist (cons r lf) lg)).
   elim (RList_P9 (cons r lf) lg a); intros; apply H10; left;
     elim (RList_P3 (cons r lf) a); intros; apply H12;
       exists 0%nat; split;
-        [ symmetry  in |- *; assumption | simpl in |- *; apply lt_O_Sn ].
+        [ symmetry ; assumption | simpl; apply lt_O_Sn ].
   apply RList_P5; [ apply RList_P2; assumption | assumption ].
   rewrite Hyp_max; apply Rle_antisym.
   induction  lf as [| r lf Hreclf].
-  simpl in |- *; right; assumption.
+  simpl; right; assumption.
   assert
     (H8 :
       In
@@ -1313,7 +1311,7 @@ Proof.
         (pred (Rlength (cons_ORlist (cons r lf) lg)))));
     intros _ H10; apply H10;
       exists (pred (Rlength (cons_ORlist (cons r lf) lg)));
-        split; [ reflexivity | rewrite RList_P11; simpl in |- *; apply lt_n_Sn ].
+        split; [ reflexivity | rewrite RList_P11; simpl; apply lt_n_Sn ].
   elim
     (RList_P9 (cons r lf) lg
       (pos_Rl (cons_ORlist (cons r lf) lg)
@@ -1327,8 +1325,8 @@ Proof.
       elim H15; clear H15; intros; rewrite H15; rewrite <- H5;
         elim (RList_P6 (cons r lf)); intros; apply H17;
           [ assumption
-            | simpl in |- *; simpl in H14; apply lt_n_Sm_le; assumption
-            | simpl in |- *; apply lt_n_Sn ].
+            | simpl; simpl in H14; apply lt_n_Sm_le; assumption
+            | simpl; apply lt_n_Sn ].
   elim
     (RList_P3 lg
       (pos_Rl (cons_ORlist (cons r lf) lg)
@@ -1336,23 +1334,23 @@ Proof.
     intros H13 _; assert (H14 := H13 H12); elim H14; intros;
       elim H15; clear H15; intros; rewrite H15;
         assert (H17 : Rlength lg = S (pred (Rlength lg))).
-  apply S_pred with 0%nat; apply neq_O_lt; red in |- *; intro;
+  apply S_pred with 0%nat; apply neq_O_lt; red; intro;
     rewrite <- H17 in H16; elim (lt_n_O _ H16).
   rewrite <- H0; elim (RList_P6 lg); intros; apply H18;
     [ assumption
       | rewrite H17 in H16; apply lt_n_Sm_le; assumption
       | apply lt_pred_n_n; rewrite H17; apply lt_O_Sn ].
   induction  lf as [| r lf Hreclf].
-  simpl in |- *; right; symmetry  in |- *; assumption.
+  simpl; right; symmetry ; assumption.
   assert (H8 : In b (cons_ORlist (cons r lf) lg)).
   elim (RList_P9 (cons r lf) lg b); intros; apply H10; left;
     elim (RList_P3 (cons r lf) b); intros; apply H12;
       exists (pred (Rlength (cons r lf))); split;
-        [ symmetry  in |- *; assumption | simpl in |- *; apply lt_n_Sn ].
+        [ symmetry ; assumption | simpl; apply lt_n_Sn ].
   apply RList_P7; [ apply RList_P2; assumption | assumption ].
-  apply StepFun_P20; rewrite RList_P11; rewrite H7; rewrite H2; simpl in |- *;
+  apply StepFun_P20; rewrite RList_P11; rewrite H7; rewrite H2; simpl;
     apply lt_O_Sn.
-  unfold constant_D_eq, open_interval in |- *; intros;
+  unfold constant_D_eq, open_interval; intros;
     cut
       (exists l : R,
         constant_D_eq g
@@ -1362,10 +1360,10 @@ Proof.
     assert
       (Hyp_cons :
         exists r : R, (exists r0 : Rlist, cons_ORlist lf lg = cons r r0)).
-  apply RList_P19; red in |- *; intro; rewrite H13 in H8; elim (lt_n_O _ H8).
+  apply RList_P19; red; intro; rewrite H13 in H8; elim (lt_n_O _ H8).
   elim Hyp_cons; clear Hyp_cons; intros r [r0 Hyp_cons]; rewrite Hyp_cons;
-    unfold FF in |- *; rewrite RList_P12.
-  change (g x = g (pos_Rl (mid_Rlist (cons r r0) r) (S i))) in |- *;
+    unfold FF; rewrite RList_P12.
+  change (g x = g (pos_Rl (mid_Rlist (cons r r0) r) (S i)));
     rewrite <- Hyp_cons; rewrite RList_P13.
   assert (H13 := RList_P2 _ _ H _ H8); elim H13; intro.
   unfold constant_D_eq, open_interval in H11, H12; rewrite (H11 x H10);
@@ -1377,13 +1375,13 @@ Proof.
   split.
   apply Rmult_lt_reg_l with 2;
     [ prove_sup0
-      | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+      | unfold Rdiv; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
         rewrite <- Rinv_r_sym;
           [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; assumption
             | discrR ] ].
   apply Rmult_lt_reg_l with 2;
     [ prove_sup0
-      | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+      | unfold Rdiv; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
         rewrite <- Rinv_r_sym;
           [ rewrite Rmult_1_l; rewrite double;
             rewrite (Rplus_comm (pos_Rl (cons_ORlist lf lg) i));
@@ -1402,7 +1400,7 @@ Proof.
   apply le_O_n.
   apply lt_trans with (pred (Rlength (cons_ORlist lf lg)));
     [ assumption
-      | apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro;
+      | apply lt_pred_n_n; apply neq_O_lt; red; intro;
         rewrite <- H13 in H8; elim (lt_n_O _ H8) ].
   rewrite H1; assumption.
   apply Rlt_le_trans with (pos_Rl (cons_ORlist lf lg) (S i)).
@@ -1411,7 +1409,7 @@ Proof.
   elim (RList_P6 (cons_ORlist lf lg)); intros; apply H11.
   apply RList_P2; assumption.
   apply lt_n_Sm_le; apply lt_n_S; assumption.
-  apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro; rewrite <- H13 in H8;
+  apply lt_pred_n_n; apply neq_O_lt; red; intro; rewrite <- H13 in H8;
     elim (lt_n_O _ H8).
   rewrite H0; assumption.
   set
@@ -1419,24 +1417,24 @@ Proof.
       fun j:nat =>
         pos_Rl lg j <= pos_Rl (cons_ORlist lf lg) i /\ (j < Rlength lg)%nat);
     assert (H12 : Nbound I).
-  unfold Nbound in |- *; exists (Rlength lg); intros; unfold I in H12; elim H12;
+  unfold Nbound; exists (Rlength lg); intros; unfold I in H12; elim H12;
     intros; apply lt_le_weak; assumption.
   assert (H13 :  exists n : nat, I n).
-  exists 0%nat; unfold I in |- *; split.
+  exists 0%nat; unfold I; split.
   apply Rle_trans with (pos_Rl (cons_ORlist lf lg) 0).
-  right; symmetry  in |- *; rewrite H1; rewrite <- H6; apply RList_P15;
+  right; symmetry ; rewrite H1; rewrite <- H6; apply RList_P15;
     try assumption; rewrite H1; assumption.
   elim (RList_P6 (cons_ORlist lf lg)); intros; apply H13;
     [ apply RList_P2; assumption
       | apply le_O_n
       | apply lt_trans with (pred (Rlength (cons_ORlist lf lg)));
         [ assumption
-          | apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro;
+          | apply lt_pred_n_n; apply neq_O_lt; red; intro;
             rewrite <- H15 in H8; elim (lt_n_O _ H8) ] ].
-  apply neq_O_lt; red in |- *; intro; rewrite <- H13 in H0;
+  apply neq_O_lt; red; intro; rewrite <- H13 in H0;
     rewrite <- H1 in H11; rewrite <- H0 in H11; elim (Rlt_irrefl _ H11).
   assert (H14 := Nzorn H13 H12); elim H14; clear H14; intros x0 H14;
-    exists (pos_Rl lg0 x0); unfold constant_D_eq, open_interval in |- *;
+    exists (pos_Rl lg0 x0); unfold constant_D_eq, open_interval;
       intros; assert (H16 := H4 x0); assert (H17 : (x0 < pred (Rlength lg))%nat).
   elim H14; clear H14; intros; unfold I in H14; elim H14; clear H14; intros;
     apply lt_S_n; replace (S (pred (Rlength lg))) with (Rlength lg).
@@ -1454,12 +1452,12 @@ Proof.
   elim (RList_P6 (cons_ORlist lf lg)); intros; apply H21.
   apply RList_P2; assumption.
   apply lt_n_Sm_le; apply lt_n_S; assumption.
-  apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro; rewrite <- H23 in H8;
+  apply lt_pred_n_n; apply neq_O_lt; red; intro; rewrite <- H23 in H8;
     elim (lt_n_O _ H8).
   right; rewrite H0; rewrite <- H5; apply RList_P16; try assumption.
   rewrite H0; assumption.
   rewrite <- H20; reflexivity.
-  apply S_pred with 0%nat; apply neq_O_lt; red in |- *; intro;
+  apply S_pred with 0%nat; apply neq_O_lt; red; intro;
     rewrite <- H19 in H18; elim (lt_n_O _ H18).
   assert (H18 := H16 H17); unfold constant_D_eq, open_interval in H18;
     rewrite (H18 x1).
@@ -1471,11 +1469,11 @@ Proof.
   assert (H22 : (S x0 < Rlength lg)%nat).
   replace (Rlength lg) with (S (pred (Rlength lg))).
   apply lt_n_S; assumption.
-  symmetry  in |- *; apply S_pred with 0%nat; apply neq_O_lt; red in |- *;
+  symmetry ; apply S_pred with 0%nat; apply neq_O_lt; red;
     intro; rewrite <- H22 in H21; elim (lt_n_O _ H21).
   elim (Rle_dec (pos_Rl lg (S x0)) (pos_Rl (cons_ORlist lf lg) i)); intro.
   assert (H23 : (S x0 <= x0)%nat);
-    [ apply H20; unfold I in |- *; split; assumption | elim (le_Sn_n _ H23) ].
+    [ apply H20; unfold I; split; assumption | elim (le_Sn_n _ H23) ].
   assert (H23 : pos_Rl (cons_ORlist lf lg) i < pos_Rl lg (S x0)).
   auto with real.
   clear b0; apply RList_P17; try assumption;
@@ -1511,35 +1509,35 @@ Proof.
   intros i H8 x1 H10; unfold open_interval in H10, H9, H4;
     rewrite (H9 _ H8 _ H10); rewrite (H4 _ H8 _ H10);
       assert (H11 : l1 <> nil).
-  red in |- *; intro H11; rewrite H11 in H8; elim (lt_n_O _ H8).
+  red; intro H11; rewrite H11 in H8; elim (lt_n_O _ H8).
   destruct (RList_P19 _ H11) as (r,(r0,H12));
-    rewrite H12; unfold FF in |- *;
+    rewrite H12; unfold FF;
       change
         (pos_Rl x0 i + l * pos_Rl x i =
           pos_Rl
           (app_Rlist (mid_Rlist (cons r r0) r) (fun x2:R => f x2 + l * g x2))
-          (S i)) in |- *; rewrite RList_P12.
+          (S i)); rewrite RList_P12.
   rewrite RList_P13.
   rewrite <- H12; rewrite (H9 _ H8); try rewrite (H4 _ H8);
     reflexivity ||
       (elim H10; clear H10; intros; split;
         [ apply Rmult_lt_reg_l with 2;
           [ prove_sup0
-            | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2));
+            | unfold Rdiv; rewrite <- (Rmult_comm (/ 2));
               rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym;
                 [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l;
                   apply Rlt_trans with x1; assumption
                   | discrR ] ]
           | apply Rmult_lt_reg_l with 2;
             [ prove_sup0
-              | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2));
+              | unfold Rdiv; rewrite <- (Rmult_comm (/ 2));
                 rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym;
                   [ rewrite Rmult_1_l; rewrite double;
                     rewrite (Rplus_comm (pos_Rl l1 i)); apply Rplus_lt_compat_l;
                       apply Rlt_trans with x1; assumption
                     | discrR ] ] ]).
   rewrite <- H12; assumption.
-  rewrite RList_P14; simpl in |- *; rewrite H12 in H8; simpl in H8;
+  rewrite RList_P14; simpl; rewrite H12 in H8; simpl in H8;
     apply lt_n_S; apply H8.
 Qed.
 
@@ -1558,7 +1556,7 @@ Qed.
 Lemma StepFun_P28 :
   forall (a b l:R) (f g:StepFun a b), IsStepFun (fun x:R => f x + l * g x) a b.
 Proof.
-  intros a b l f g; unfold IsStepFun in |- *; assert (H := pre f);
+  intros a b l f g; unfold IsStepFun; assert (H := pre f);
     assert (H0 := pre g); unfold IsStepFun in H, H0; elim H;
       elim H0; intros; apply existT with (cons_ORlist x0 x);
         apply StepFun_P27; assumption.
@@ -1567,7 +1565,7 @@ Qed.
 Lemma StepFun_P29 :
   forall (a b:R) (f:StepFun a b), is_subdivision f a b (subdivision f).
 Proof.
-  intros a b f; unfold is_subdivision in |- *;
+  intros a b f; unfold is_subdivision;
     apply existT with (subdivision_val f); apply StepFun_P1.
 Qed.
 
@@ -1576,7 +1574,7 @@ Lemma StepFun_P30 :
     RiemannInt_SF (mkStepFun (StepFun_P28 l f g)) =
     RiemannInt_SF f + l * RiemannInt_SF g.
 Proof.
-  intros a b l f g; unfold RiemannInt_SF in |- *; case (Rle_dec a b);
+  intros a b l f g; unfold RiemannInt_SF; case (Rle_dec a b);
     (intro;
       replace
       (Int_SF (subdivision_val (mkStepFun (StepFun_P28 l f g)))
@@ -1613,10 +1611,10 @@ Lemma StepFun_P31 :
     adapted_couple f a b l lf ->
     adapted_couple (fun x:R => Rabs (f x)) a b l (app_Rlist lf Rabs).
 Proof.
-  unfold adapted_couple in |- *; intros; decompose [and] H; clear H;
+  unfold adapted_couple; intros; decompose [and] H; clear H;
     repeat split; try assumption.
-  symmetry  in |- *; rewrite H3; rewrite RList_P18; reflexivity.
-  intros; unfold constant_D_eq, open_interval in |- *;
+  symmetry ; rewrite H3; rewrite RList_P18; reflexivity.
+  intros; unfold constant_D_eq, open_interval;
     unfold constant_D_eq, open_interval in H5; intros;
       rewrite (H5 _ H _ H4); rewrite RList_P12;
         [ reflexivity | rewrite H3 in H; simpl in H; apply H ].
@@ -1625,8 +1623,8 @@ Qed.
 Lemma StepFun_P32 :
   forall (a b:R) (f:StepFun a b), IsStepFun (fun x:R => Rabs (f x)) a b.
 Proof.
-  intros a b f; unfold IsStepFun in |- *; apply existT with (subdivision f);
-    unfold is_subdivision in |- *;
+  intros a b f; unfold IsStepFun; apply existT with (subdivision f);
+    unfold is_subdivision;
       apply existT with (app_Rlist (subdivision_val f) Rabs);
         apply StepFun_P31; apply StepFun_P1.
 Qed.
@@ -1636,8 +1634,8 @@ Lemma StepFun_P33 :
     ordered_Rlist l1 -> Rabs (Int_SF l2 l1) <= Int_SF (app_Rlist l2 Rabs) l1.
 Proof.
   simple induction l2; intros.
-  simpl in |- *; rewrite Rabs_R0; right; reflexivity.
-  simpl in |- *; induction  l1 as [| r1 l1 Hrecl1].
+  simpl; rewrite Rabs_R0; right; reflexivity.
+  simpl; induction  l1 as [| r1 l1 Hrecl1].
   rewrite Rabs_R0; right; reflexivity.
   induction  l1 as [| r2 l1 Hrecl0].
   rewrite Rabs_R0; right; reflexivity.
@@ -1645,7 +1643,7 @@ Proof.
   apply Rabs_triang.
   rewrite Rabs_mult; rewrite (Rabs_right (r2 - r1));
     [ apply Rplus_le_compat_l; apply H; apply RList_P4 with r1; assumption
-      | apply Rge_minus; apply Rle_ge; apply (H0 0%nat); simpl in |- *;
+      | apply Rge_minus; apply Rle_ge; apply (H0 0%nat); simpl;
         apply lt_O_Sn ].
 Qed.
 
@@ -1654,7 +1652,7 @@ Lemma StepFun_P34 :
     a <= b ->
     Rabs (RiemannInt_SF f) <= RiemannInt_SF (mkStepFun (StepFun_P32 f)).
 Proof.
-  intros; unfold RiemannInt_SF in |- *; case (Rle_dec a b); intro.
+  intros; unfold RiemannInt_SF; case (Rle_dec a b); intro.
   replace
   (Int_SF (subdivision_val (mkStepFun (StepFun_P32 f)))
     (subdivision (mkStepFun (StepFun_P32 f)))) with
@@ -1678,18 +1676,18 @@ Lemma StepFun_P35 :
 Proof.
   simple induction l; intros.
   right; reflexivity.
-  simpl in |- *; induction  r0 as [| r0 r1 Hrecr0].
+  simpl; induction  r0 as [| r0 r1 Hrecr0].
   right; reflexivity.
-  simpl in |- *; apply Rplus_le_compat.
+  simpl; apply Rplus_le_compat.
   case (Req_dec r r0); intro.
   rewrite H4; right; ring.
   do 2 rewrite <- (Rmult_comm (r0 - r)); apply Rmult_le_compat_l.
-  apply Rge_le; apply Rge_minus; apply Rle_ge; apply (H0 0%nat); simpl in |- *;
+  apply Rge_le; apply Rge_minus; apply Rle_ge; apply (H0 0%nat); simpl;
     apply lt_O_Sn.
   apply H3; split.
   apply Rmult_lt_reg_l with 2.
   prove_sup0.
-  unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+  unfold Rdiv; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
     rewrite <- Rinv_r_sym.
   assert (H5 : r = a).
   apply H1.
@@ -1702,7 +1700,7 @@ Proof.
   discrR.
   apply Rmult_lt_reg_l with 2.
   prove_sup0.
-  unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+  unfold Rdiv; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
     rewrite <- Rinv_r_sym.
   rewrite Rmult_1_l; rewrite double; assert (H5 : r0 <= b).
   replace b with
@@ -1710,9 +1708,9 @@ Proof.
   replace r0 with (pos_Rl (cons r (cons r0 r1)) 1).
   elim (RList_P6 (cons r (cons r0 r1))); intros; apply H5.
   assumption.
-  simpl in |- *; apply le_n_S.
+  simpl; apply le_n_S.
   apply le_O_n.
-  simpl in |- *; apply lt_n_Sn.
+  simpl; apply lt_n_Sn.
   reflexivity.
   apply Rle_lt_trans with (r + b).
   apply Rplus_le_compat_l; assumption.
@@ -1732,7 +1730,7 @@ Proof.
   intros; apply H3; elim H4; intros; split; try assumption.
   apply Rle_lt_trans with r0; try assumption.
   rewrite <- H1.
-  simpl in |- *; apply (H0 0%nat); simpl in |- *; apply lt_O_Sn.
+  simpl; apply (H0 0%nat); simpl; apply lt_O_Sn.
 Qed.
 
 Lemma StepFun_P36 :
@@ -1743,16 +1741,16 @@ Lemma StepFun_P36 :
     (forall x:R, a < x < b -> f x <= g x) ->
     RiemannInt_SF f <= RiemannInt_SF g.
 Proof.
-  intros; unfold RiemannInt_SF in |- *; case (Rle_dec a b); intro.
+  intros; unfold RiemannInt_SF; case (Rle_dec a b); intro.
   replace (Int_SF (subdivision_val f) (subdivision f)) with (Int_SF (FF l f) l).
   replace (Int_SF (subdivision_val g) (subdivision g)) with (Int_SF (FF l g) l).
   unfold is_subdivision in X; elim X; clear X; intros;
     unfold adapted_couple in p; decompose [and] p; clear p;
       assert (H5 : Rmin a b = a);
-        [ unfold Rmin in |- *; case (Rle_dec a b); intro;
+        [ unfold Rmin; case (Rle_dec a b); intro;
           [ reflexivity | elim n; assumption ]
           | assert (H7 : Rmax a b = b);
-            [ unfold Rmax in |- *; case (Rle_dec a b); intro;
+            [ unfold Rmax; case (Rle_dec a b); intro;
               [ reflexivity | elim n; assumption ]
               | rewrite H5 in H3; rewrite H7 in H2; eapply StepFun_P35 with a b;
                 assumption ] ].
@@ -1811,27 +1809,27 @@ Proof.
   assert (H7 : r1 <= b).
   rewrite <- H4; apply RList_P7; [ assumption | left; reflexivity ].
   assert (H8 : IsStepFun g' a b).
-  unfold IsStepFun in |- *; assert (H8 := pre g); unfold IsStepFun in H8;
+  unfold IsStepFun; assert (H8 := pre g); unfold IsStepFun in H8;
     elim H8; intros lg H9; unfold is_subdivision in H9;
       elim H9; clear H9; intros lg2 H9; split with (cons a lg);
-        unfold is_subdivision in |- *; split with (cons (f a) lg2);
+        unfold is_subdivision; split with (cons (f a) lg2);
           unfold adapted_couple in H9; decompose [and] H9; clear H9;
-            unfold adapted_couple in |- *; repeat split.
-  unfold ordered_Rlist in |- *; intros; simpl in H9;
+            unfold adapted_couple; repeat split.
+  unfold ordered_Rlist; intros; simpl in H9;
     induction  i as [| i Hreci].
-  simpl in |- *; rewrite H12; replace (Rmin r1 b) with r1.
-  simpl in H0; rewrite <- H0; apply (H 0%nat); simpl in |- *; apply lt_O_Sn.
-  unfold Rmin in |- *; case (Rle_dec r1 b); intro;
+  simpl; rewrite H12; replace (Rmin r1 b) with r1.
+  simpl in H0; rewrite <- H0; apply (H 0%nat); simpl; apply lt_O_Sn.
+  unfold Rmin; case (Rle_dec r1 b); intro;
     [ reflexivity | elim n; assumption ].
   apply (H10 i); apply lt_S_n.
   replace (S (pred (Rlength lg))) with (Rlength lg).
   apply H9.
   apply S_pred with 0%nat; apply neq_O_lt; intro; rewrite <- H14 in H9;
     elim (lt_n_O _ H9).
-  simpl in |- *; assert (H14 : a <= b).
+  simpl; assert (H14 : a <= b).
   rewrite <- H1; simpl in H0; rewrite <- H0; apply RList_P7;
     [ assumption | left; reflexivity ].
-  unfold Rmin in |- *; case (Rle_dec a b); intro;
+  unfold Rmin; case (Rle_dec a b); intro;
     [ reflexivity | elim n; assumption ].
   assert (H14 : a <= b).
   rewrite <- H1; simpl in H0; rewrite <- H0; apply RList_P7;
@@ -1840,30 +1838,30 @@ Proof.
   rewrite <- H11; induction  lg as [| r0 lg Hreclg].
   simpl in H13; discriminate.
   reflexivity.
-  unfold Rmax in |- *; case (Rle_dec a b); case (Rle_dec r1 b); intros;
+  unfold Rmax; case (Rle_dec a b); case (Rle_dec r1 b); intros;
     reflexivity || elim n; assumption.
-  simpl in |- *; rewrite H13; reflexivity.
+  simpl; rewrite H13; reflexivity.
   intros; simpl in H9; induction  i as [| i Hreci].
-  unfold constant_D_eq, open_interval in |- *; simpl in |- *; intros;
+  unfold constant_D_eq, open_interval; simpl; intros;
     assert (H16 : Rmin r1 b = r1).
-  unfold Rmin in |- *; case (Rle_dec r1 b); intro;
+  unfold Rmin; case (Rle_dec r1 b); intro;
     [ reflexivity | elim n; assumption ].
   rewrite H16 in H12; rewrite H12 in H14; elim H14; clear H14; intros _ H14;
-    unfold g' in |- *; case (Rle_dec r1 x); intro r3.
+    unfold g'; case (Rle_dec r1 x); intro r3.
   elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r3 H14)).
   reflexivity.
   change
     (constant_D_eq g' (open_interval (pos_Rl lg i) (pos_Rl lg (S i)))
-      (pos_Rl lg2 i)) in |- *; clear Hreci; assert (H16 := H15 i);
+      (pos_Rl lg2 i)); clear Hreci; assert (H16 := H15 i);
     assert (H17 : (i < pred (Rlength lg))%nat).
   apply lt_S_n.
   replace (S (pred (Rlength lg))) with (Rlength lg).
   assumption.
-  apply S_pred with 0%nat; apply neq_O_lt; red in |- *; intro;
+  apply S_pred with 0%nat; apply neq_O_lt; red; intro;
     rewrite <- H14 in H9; elim (lt_n_O _ H9).
   assert (H18 := H16 H17); unfold constant_D_eq, open_interval in H18;
-    unfold constant_D_eq, open_interval in |- *; intros;
-      assert (H19 := H18 _ H14); rewrite <- H19; unfold g' in |- *;
+    unfold constant_D_eq, open_interval; intros;
+      assert (H19 := H18 _ H14); rewrite <- H19; unfold g';
         case (Rle_dec r1 x); intro.
   reflexivity.
   elim n; replace r1 with (Rmin r1 b).
@@ -1874,17 +1872,17 @@ Proof.
   elim (RList_P3 lg (pos_Rl lg i)); intros; apply H21; exists i; split.
   reflexivity.
   apply lt_trans with (pred (Rlength lg)); try assumption.
-  apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro; rewrite <- H22 in H17;
+  apply lt_pred_n_n; apply neq_O_lt; red; intro; rewrite <- H22 in H17;
     elim (lt_n_O _ H17).
-  unfold Rmin in |- *; case (Rle_dec r1 b); intro;
+  unfold Rmin; case (Rle_dec r1 b); intro;
     [ reflexivity | elim n0; assumption ].
   exists (mkStepFun H8); split.
-  simpl in |- *; unfold g' in |- *; case (Rle_dec r1 b); intro.
+  simpl; unfold g'; case (Rle_dec r1 b); intro.
   assumption.
   elim n; assumption.
   intros; simpl in H9; induction  i as [| i Hreci].
-  unfold constant_D_eq, co_interval in |- *; simpl in |- *; intros; simpl in H0;
-    rewrite H0; elim H10; clear H10; intros; unfold g' in |- *;
+  unfold constant_D_eq, co_interval; simpl; intros; simpl in H0;
+    rewrite H0; elim H10; clear H10; intros; unfold g';
       case (Rle_dec r1 x); intro r3.
   elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r3 H11)).
   reflexivity.
@@ -1892,21 +1890,21 @@ Proof.
     change
       (constant_D_eq (mkStepFun H8)
         (co_interval (pos_Rl (cons r1 l) i) (pos_Rl (cons r1 l) (S i)))
-        (f (pos_Rl (cons r1 l) i))) in |- *; assert (H10 := H6 i);
+        (f (pos_Rl (cons r1 l) i))); assert (H10 := H6 i);
       assert (H11 : (i < pred (Rlength (cons r1 l)))%nat).
-  simpl in |- *; apply lt_S_n; assumption.
+  simpl; apply lt_S_n; assumption.
   assert (H12 := H10 H11); unfold constant_D_eq, co_interval in H12;
-    unfold constant_D_eq, co_interval in |- *; intros;
-      rewrite <- (H12 _ H13); simpl in |- *; unfold g' in |- *;
+    unfold constant_D_eq, co_interval; intros;
+      rewrite <- (H12 _ H13); simpl; unfold g';
         case (Rle_dec r1 x); intro.
   reflexivity.
   elim n; elim H13; clear H13; intros;
     apply Rle_trans with (pos_Rl (cons r1 l) i); try assumption;
-      change (pos_Rl (cons r1 l) 0 <= pos_Rl (cons r1 l) i) in |- *;
+      change (pos_Rl (cons r1 l) 0 <= pos_Rl (cons r1 l) i);
         elim (RList_P6 (cons r1 l)); intros; apply H15;
           [ assumption
             | apply le_O_n
-            | simpl in |- *; apply lt_trans with (Rlength l);
+            | simpl; apply lt_trans with (Rlength l);
               [ apply lt_S_n; assumption | apply lt_n_Sn ] ].
 Qed.
 
@@ -1914,7 +1912,7 @@ Lemma StepFun_P39 :
   forall (a b:R) (f:StepFun a b),
     RiemannInt_SF f = - RiemannInt_SF (mkStepFun (StepFun_P6 (pre f))).
 Proof.
-  intros; unfold RiemannInt_SF in |- *; case (Rle_dec a b); case (Rle_dec b a);
+  intros; unfold RiemannInt_SF; case (Rle_dec a b); case (Rle_dec b a);
     intros.
   assert (H : adapted_couple f a b (subdivision f) (subdivision_val f));
     [ apply StepFun_P1
@@ -1927,16 +1925,16 @@ Proof.
           | assert (H1 : a = b);
             [ apply Rle_antisym; assumption
               | rewrite (StepFun_P8 H H1); assert (H2 : b = a);
-                [ symmetry  in |- *; apply H1 | rewrite (StepFun_P8 H0 H2); ring ] ] ] ].
+                [ symmetry ; apply H1 | rewrite (StepFun_P8 H0 H2); ring ] ] ] ].
   rewrite Ropp_involutive; eapply StepFun_P17;
     [ apply StepFun_P1
       | apply StepFun_P2; set (H := StepFun_P6 (pre f)); unfold IsStepFun in H;
-        elim H; intros; unfold is_subdivision in |- *;
+        elim H; intros; unfold is_subdivision;
           elim p; intros; apply p0 ].
   apply Ropp_eq_compat; eapply StepFun_P17;
     [ apply StepFun_P1
       | apply StepFun_P2; set (H := StepFun_P6 (pre f)); unfold IsStepFun in H;
-        elim H; intros; unfold is_subdivision in |- *;
+        elim H; intros; unfold is_subdivision;
           elim p; intros; apply p0 ].
   assert (H : a < b);
     [ auto with real
@@ -1953,34 +1951,34 @@ Lemma StepFun_P40 :
     adapted_couple f a c (cons_Rlist l1 l2) (FF (cons_Rlist l1 l2) f).
 Proof.
   intros f a b c l1 l2 lf1 lf2 H H0 H1 H2; unfold adapted_couple in H1, H2;
-    unfold adapted_couple in |- *; decompose [and] H1;
+    unfold adapted_couple; decompose [and] H1;
       decompose [and] H2; clear H1 H2; repeat split.
   apply RList_P25; try assumption.
-  rewrite H10; rewrite H4; unfold Rmin, Rmax in |- *; case (Rle_dec a b);
+  rewrite H10; rewrite H4; unfold Rmin, Rmax; case (Rle_dec a b);
     case (Rle_dec b c); intros;
       (right; reflexivity) || (elim n; left; assumption).
   rewrite RList_P22.
-  rewrite H5; unfold Rmin, Rmax in |- *; case (Rle_dec a b); case (Rle_dec a c);
+  rewrite H5; unfold Rmin, Rmax; case (Rle_dec a b); case (Rle_dec a c);
     intros;
       [ reflexivity
         | elim n; apply Rle_trans with b; left; assumption
         | elim n; left; assumption
         | elim n0; left; assumption ].
-  red in |- *; intro; rewrite H1 in H6; discriminate.
+  red; intro; rewrite H1 in H6; discriminate.
   rewrite RList_P24.
-  rewrite H9; unfold Rmin, Rmax in |- *; case (Rle_dec b c); case (Rle_dec a c);
+  rewrite H9; unfold Rmin, Rmax; case (Rle_dec b c); case (Rle_dec a c);
     intros;
       [ reflexivity
         | elim n; apply Rle_trans with b; left; assumption
         | elim n; left; assumption
         | elim n0; left; assumption ].
-  red in |- *; intro; rewrite H1 in H11; discriminate.
+  red; intro; rewrite H1 in H11; discriminate.
   apply StepFun_P20.
-  rewrite RList_P23; apply neq_O_lt; red in |- *; intro.
+  rewrite RList_P23; apply neq_O_lt; red; intro.
   assert (H2 : (Rlength l1 + Rlength l2)%nat = 0%nat).
-  symmetry  in |- *; apply H1.
+  symmetry ; apply H1.
   elim (plus_is_O _ _ H2); intros; rewrite H12 in H6; discriminate.
-  unfold constant_D_eq, open_interval in |- *; intros;
+  unfold constant_D_eq, open_interval; intros;
     elim (le_or_lt (S (S i)) (Rlength l1)); intro.
   assert (H14 : pos_Rl (cons_Rlist l1 l2) i = pos_Rl l1 i).
   apply RList_P26; apply lt_S_n; apply le_lt_n_Sm; apply le_S_n;
@@ -1993,28 +1991,28 @@ Proof.
   elim (RList_P20 _ H16); intros r1 [r2 [r3 H17]]; rewrite H17;
     change
       (f x = pos_Rl (app_Rlist (mid_Rlist (cons_Rlist (cons r2 r3) l2) r1) f) i)
-      in |- *; rewrite RList_P12.
+     ; rewrite RList_P12.
   induction  i as [| i Hreci].
-  simpl in |- *; assert (H18 := H8 0%nat);
+  simpl; assert (H18 := H8 0%nat);
     unfold constant_D_eq, open_interval in H18;
       assert (H19 : (0 < pred (Rlength l1))%nat).
-  rewrite H17; simpl in |- *; apply lt_O_Sn.
+  rewrite H17; simpl; apply lt_O_Sn.
   assert (H20 := H18 H19); repeat rewrite H20.
   reflexivity.
   assert (H21 : r1 <= r2).
   rewrite H17 in H3; apply (H3 0%nat).
-  simpl in |- *; apply lt_O_Sn.
+  simpl; apply lt_O_Sn.
   elim H21; intro.
   split.
-  rewrite H17; simpl in |- *; apply Rmult_lt_reg_l with 2;
+  rewrite H17; simpl; apply Rmult_lt_reg_l with 2;
     [ prove_sup0
-      | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+      | unfold Rdiv; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
         rewrite <- Rinv_r_sym;
           [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; assumption
             | discrR ] ].
-  rewrite H17; simpl in |- *; apply Rmult_lt_reg_l with 2;
+  rewrite H17; simpl; apply Rmult_lt_reg_l with 2;
     [ prove_sup0
-      | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+      | unfold Rdiv; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
         rewrite <- Rinv_r_sym;
           [ rewrite Rmult_1_l; rewrite (Rplus_comm r1); rewrite double;
             apply Rplus_lt_compat_l; assumption
@@ -2043,13 +2041,13 @@ Proof.
   split.
   apply Rmult_lt_reg_l with 2;
     [ prove_sup0
-      | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+      | unfold Rdiv; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
         rewrite <- Rinv_r_sym;
           [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; assumption
             | discrR ] ].
   apply Rmult_lt_reg_l with 2;
     [ prove_sup0
-      | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+      | unfold Rdiv; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
         rewrite <- Rinv_r_sym;
           [ rewrite Rmult_1_l; rewrite (Rplus_comm (pos_Rl l1 (S i)));
             rewrite double; apply Rplus_lt_compat_l; assumption
@@ -2057,21 +2055,21 @@ Proof.
   elim H2; intros; rewrite H22 in H23;
     elim (Rlt_irrefl _ (Rlt_trans _ _ _ H23 H24)).
   assumption.
-  simpl in |- *; rewrite H17 in H1; simpl in H1; apply lt_S_n; assumption.
+  simpl; rewrite H17 in H1; simpl in H1; apply lt_S_n; assumption.
   rewrite RList_P14; rewrite H17 in H1; simpl in H1; apply H1.
   inversion H12.
   assert (H16 : pos_Rl (cons_Rlist l1 l2) (S i) = b).
   rewrite RList_P29.
-  rewrite H15; rewrite <- minus_n_n; rewrite H10; unfold Rmin in |- *;
+  rewrite H15; rewrite <- minus_n_n; rewrite H10; unfold Rmin;
     case (Rle_dec b c); intro; [ reflexivity | elim n; left; assumption ].
   rewrite H15; apply le_n.
   induction  l1 as [| r l1 Hrecl1].
   simpl in H15; discriminate.
-  clear Hrecl1; simpl in H1; simpl in |- *; apply lt_n_S; assumption.
+  clear Hrecl1; simpl in H1; simpl; apply lt_n_S; assumption.
   assert (H17 : pos_Rl (cons_Rlist l1 l2) i = b).
   rewrite RList_P26.
   replace i with (pred (Rlength l1));
-  [ rewrite H4; unfold Rmax in |- *; case (Rle_dec a b); intro;
+  [ rewrite H4; unfold Rmax; case (Rle_dec a b); intro;
     [ reflexivity | elim n; left; assumption ]
     | rewrite H15; reflexivity ].
   rewrite H15; apply lt_n_Sn.
@@ -2089,22 +2087,22 @@ Proof.
   apply le_S_n; apply le_trans with (S i); [ assumption | apply le_n_Sn ].
   induction  l1 as [| r l1 Hrecl1].
   simpl in H6; discriminate.
-  clear Hrecl1; simpl in H1; simpl in |- *; apply lt_n_S; assumption.
-  symmetry  in |- *; apply minus_Sn_m; apply le_S_n; assumption.
+  clear Hrecl1; simpl in H1; simpl; apply lt_n_S; assumption.
+  symmetry ; apply minus_Sn_m; apply le_S_n; assumption.
   assert (H18 : (2 <= Rlength l1)%nat).
   clear f c l2 lf2 H0 H3 H8 H7 H10 H9 H11 H13 i H1 x H2 H12 m H14 H15 H16 H17;
     induction  l1 as [| r l1 Hrecl1].
   discriminate.
   clear Hrecl1; induction  l1 as [| r0 l1 Hrecl1].
   simpl in H5; simpl in H4; assert (H0 : Rmin a b < Rmax a b).
-  unfold Rmin, Rmax in |- *; case (Rle_dec a b); intro;
+  unfold Rmin, Rmax; case (Rle_dec a b); intro;
     [ assumption | elim n; left; assumption ].
   rewrite <- H5 in H0; rewrite <- H4 in H0; elim (Rlt_irrefl _ H0).
-  clear Hrecl1; simpl in |- *; repeat apply le_n_S; apply le_O_n.
+  clear Hrecl1; simpl; repeat apply le_n_S; apply le_O_n.
   elim (RList_P20 _ H18); intros r1 [r2 [r3 H19]]; rewrite H19;
     change
       (f x = pos_Rl (app_Rlist (mid_Rlist (cons_Rlist (cons r2 r3) l2) r1) f) i)
-      in |- *; rewrite RList_P12.
+     ; rewrite RList_P12.
   induction  i as [| i Hreci].
   assert (H20 := le_S_n _ _ H15); assert (H21 := le_trans _ _ _ H18 H20);
     elim (le_Sn_O _ H21).
@@ -2122,7 +2120,7 @@ Proof.
               assert (H21 : (S i - Rlength l1 < pred (Rlength l2))%nat).
   apply lt_pred; rewrite minus_Sn_m.
   apply plus_lt_reg_l with (Rlength l1); rewrite <- le_plus_minus.
-  rewrite H19 in H1; simpl in H1; rewrite H19; simpl in |- *;
+  rewrite H19 in H1; simpl in H1; rewrite H19; simpl;
     rewrite RList_P23 in H1; apply lt_n_S; assumption.
   apply le_trans with (S i); [ apply le_S_n; assumption | apply le_n_Sn ].
   apply le_S_n; assumption.
@@ -2134,7 +2132,7 @@ Proof.
   apply H7; apply lt_pred.
   rewrite minus_Sn_m.
   apply plus_lt_reg_l with (Rlength l1); rewrite <- le_plus_minus.
-  rewrite H19 in H1; simpl in H1; rewrite H19; simpl in |- *;
+  rewrite H19 in H1; simpl in H1; rewrite H19; simpl;
     rewrite RList_P23 in H1; apply lt_n_S; assumption.
   apply le_trans with (S i); [ apply le_S_n; assumption | apply le_n_Sn ].
   apply le_S_n; assumption.
@@ -2142,13 +2140,13 @@ Proof.
   split.
   apply Rmult_lt_reg_l with 2;
     [ prove_sup0
-      | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+      | unfold Rdiv; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
         rewrite <- Rinv_r_sym;
           [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; assumption
             | discrR ] ].
   apply Rmult_lt_reg_l with 2;
     [ prove_sup0
-      | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+      | unfold Rdiv; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
         rewrite <- Rinv_r_sym;
           [ rewrite Rmult_1_l; rewrite (Rplus_comm (pos_Rl l2 (S i - Rlength l1)));
             rewrite double; apply Rplus_lt_compat_l; assumption
@@ -2159,14 +2157,14 @@ Proof.
         rewrite H17 in H26; simpl in H24; rewrite H24 in H25;
           elim (Rlt_irrefl _ (Rlt_trans _ _ _ H25 H26)).
   assert (H23 : pos_Rl (cons_Rlist l1 l2) (S i) = pos_Rl l2 (S i - Rlength l1)).
-  rewrite H19; simpl in |- *; simpl in H16; apply H16.
+  rewrite H19; simpl; simpl in H16; apply H16.
   assert
     (H24 :
       pos_Rl (cons_Rlist l1 l2) (S (S i)) = pos_Rl l2 (S (S i - Rlength l1))).
-  rewrite H19; simpl in |- *; simpl in H17; apply H17.
+  rewrite H19; simpl; simpl in H17; apply H17.
   rewrite <- H23; rewrite <- H24; assumption.
-  simpl in |- *; rewrite H19 in H1; simpl in H1; apply lt_S_n; assumption.
-  rewrite RList_P14; rewrite H19 in H1; simpl in H1; simpl in |- *; apply H1.
+  simpl; rewrite H19 in H1; simpl in H1; apply lt_S_n; assumption.
+  rewrite RList_P14; rewrite H19 in H1; simpl in H1; simpl; apply H1.
 Qed.
 
 Lemma StepFun_P41 :
@@ -2191,11 +2189,11 @@ Lemma StepFun_P42 :
     Int_SF (FF l1 f) l1 + Int_SF (FF l2 f) l2.
 Proof.
   intros l1 l2 f; induction l1 as [| r l1 IHl1]; intros H;
-    [ simpl in |- *; ring
+    [ simpl; ring
       | destruct l1 as [| r0 r1];
-        [ simpl in H; simpl in |- *; destruct l2 as [| r0 r1];
-          [ simpl in |- *; ring | simpl in |- *; simpl in H; rewrite H; ring ]
-          | simpl in |- *; rewrite Rplus_assoc; apply Rplus_eq_compat_l; apply IHl1;
+        [ simpl in H; simpl; destruct l2 as [| r0 r1];
+          [ simpl; ring | simpl; simpl in H; rewrite H; ring ]
+          | simpl; rewrite Rplus_assoc; apply Rplus_eq_compat_l; apply IHl1;
             rewrite <- H; reflexivity ] ].
 Qed.
 
@@ -2231,27 +2229,27 @@ Proof.
   (Int_SF (FF (cons_Rlist l1 l2) f) (cons_Rlist l1 l2)).
   replace (Int_SF lf1 l1) with (Int_SF (FF l1 f) l1).
   replace (Int_SF lf2 l2) with (Int_SF (FF l2 f) l2).
-  symmetry  in |- *; apply StepFun_P42.
+  symmetry ; apply StepFun_P42.
   unfold adapted_couple in H1, H2; decompose [and] H1; decompose [and] H2;
-    clear H1 H2; rewrite H11; rewrite H5; unfold Rmax, Rmin in |- *;
+    clear H1 H2; rewrite H11; rewrite H5; unfold Rmax, Rmin;
       case (Rle_dec a b); case (Rle_dec b c); intros; reflexivity || elim n;
         assumption.
   eapply StepFun_P17;
-    [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf2; apply H2;
+    [ apply StepFun_P21; unfold is_subdivision; split with lf2; apply H2;
       assumption
       | assumption ].
   eapply StepFun_P17;
-    [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf1; apply H1
+    [ apply StepFun_P21; unfold is_subdivision; split with lf1; apply H1
       | assumption ].
   eapply StepFun_P17; [ apply (StepFun_P40 H H0 H1 H2) | apply H3 ].
   replace (Int_SF lf2 l2) with 0.
   rewrite Rplus_0_r; eapply StepFun_P17;
     [ apply H1 | rewrite <- H0 in H3; apply H3 ].
-  symmetry  in |- *; eapply StepFun_P8; [ apply H2 | assumption ].
+  symmetry ; eapply StepFun_P8; [ apply H2 | assumption ].
   replace (Int_SF lf1 l1) with 0.
   rewrite Rplus_0_l; eapply StepFun_P17;
     [ apply H2 | rewrite H in H3; apply H3 ].
-  symmetry  in |- *; eapply StepFun_P8; [ apply H1 | assumption ].
+  symmetry ; eapply StepFun_P8; [ apply H1 | assumption ].
   elim n; apply Rle_trans with b; assumption.
   apply Rplus_eq_reg_l with (Int_SF lf2 l2);
     replace (Int_SF lf2 l2 + (Int_SF lf1 l1 + - Int_SF lf2 l2)) with
@@ -2266,24 +2264,24 @@ Proof.
   replace (Int_SF lf2 l2) with (Int_SF (FF l2 f) l2).
   apply StepFun_P42.
   unfold adapted_couple in H2, H3; decompose [and] H2; decompose [and] H3;
-    clear H3 H2; rewrite H10; rewrite H6; unfold Rmax, Rmin in |- *;
+    clear H3 H2; rewrite H10; rewrite H6; unfold Rmax, Rmin;
       case (Rle_dec a c); case (Rle_dec b c); intros;
         [ elim n; assumption
           | reflexivity
           | elim n0; assumption
           | elim n1; assumption ].
   eapply StepFun_P17;
-    [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf2; apply H2
+    [ apply StepFun_P21; unfold is_subdivision; split with lf2; apply H2
       | assumption ].
   eapply StepFun_P17;
-    [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf3; apply H3
+    [ apply StepFun_P21; unfold is_subdivision; split with lf3; apply H3
       | assumption ].
   eapply StepFun_P17;
     [ apply (StepFun_P40 H0 H H3 (StepFun_P2 H2)) | apply H1 ].
   replace (Int_SF lf3 l3) with 0.
   rewrite Rplus_0_r; eapply StepFun_P17;
     [ apply H1 | apply StepFun_P2; rewrite <- H0 in H2; apply H2 ].
-  symmetry  in |- *; eapply StepFun_P8; [ apply H3 | assumption ].
+  symmetry ; eapply StepFun_P8; [ apply H3 | assumption ].
   replace (Int_SF lf2 l2) with (Int_SF lf3 l3 + Int_SF lf1 l1).
   ring.
   elim r; intro.
@@ -2291,19 +2289,19 @@ Proof.
   (Int_SF (FF (cons_Rlist l3 l1) f) (cons_Rlist l3 l1)).
   replace (Int_SF lf3 l3) with (Int_SF (FF l3 f) l3).
   replace (Int_SF lf1 l1) with (Int_SF (FF l1 f) l1).
-  symmetry  in |- *; apply StepFun_P42.
+  symmetry ; apply StepFun_P42.
   unfold adapted_couple in H1, H3; decompose [and] H1; decompose [and] H3;
-    clear H3 H1; rewrite H9; rewrite H5; unfold Rmax, Rmin in |- *;
+    clear H3 H1; rewrite H9; rewrite H5; unfold Rmax, Rmin;
       case (Rle_dec a c); case (Rle_dec a b); intros;
         [ elim n; assumption
           | elim n1; assumption
           | reflexivity
           | elim n1; assumption ].
   eapply StepFun_P17;
-    [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf1; apply H1
+    [ apply StepFun_P21; unfold is_subdivision; split with lf1; apply H1
       | assumption ].
   eapply StepFun_P17;
-    [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf3; apply H3
+    [ apply StepFun_P21; unfold is_subdivision; split with lf3; apply H3
       | assumption ].
   eapply StepFun_P17.
   assert (H0 : c < a).
@@ -2313,7 +2311,7 @@ Proof.
   replace (Int_SF lf1 l1) with 0.
   rewrite Rplus_0_r; eapply StepFun_P17;
     [ apply H3 | rewrite <- H in H2; apply H2 ].
-  symmetry  in |- *; eapply StepFun_P8; [ apply H1 | assumption ].
+  symmetry ; eapply StepFun_P8; [ apply H1 | assumption ].
   assert (H : b < a).
   auto with real.
   replace (Int_SF lf2 l2) with (Int_SF lf3 l3 + Int_SF lf1 l1).
@@ -2323,19 +2321,19 @@ Proof.
   (Int_SF (FF (cons_Rlist l1 l3) f) (cons_Rlist l1 l3)).
   replace (Int_SF lf3 l3) with (Int_SF (FF l3 f) l3).
   replace (Int_SF lf1 l1) with (Int_SF (FF l1 f) l1).
-  symmetry  in |- *; apply StepFun_P42.
+  symmetry ; apply StepFun_P42.
   unfold adapted_couple in H1, H3; decompose [and] H1; decompose [and] H3;
-    clear H3 H1; rewrite H11; rewrite H5; unfold Rmax, Rmin in |- *;
+    clear H3 H1; rewrite H11; rewrite H5; unfold Rmax, Rmin;
       case (Rle_dec a c); case (Rle_dec a b); intros;
         [ elim n; assumption
           | reflexivity
           | elim n0; assumption
           | elim n1; assumption ].
   eapply StepFun_P17;
-    [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf1; apply H1
+    [ apply StepFun_P21; unfold is_subdivision; split with lf1; apply H1
       | assumption ].
   eapply StepFun_P17;
-    [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf3; apply H3
+    [ apply StepFun_P21; unfold is_subdivision; split with lf3; apply H3
       | assumption ].
   eapply StepFun_P17.
   apply (StepFun_P40 H H0 (StepFun_P2 H1) H3).
@@ -2343,7 +2341,7 @@ Proof.
   replace (Int_SF lf3 l3) with 0.
   rewrite Rplus_0_r; eapply StepFun_P17;
     [ apply H1 | rewrite <- H0 in H2; apply StepFun_P2; apply H2 ].
-  symmetry  in |- *; eapply StepFun_P8; [ apply H3 | assumption ].
+  symmetry ; eapply StepFun_P8; [ apply H3 | assumption ].
   assert (H : c < a).
   auto with real.
   replace (Int_SF lf1 l1) with (Int_SF lf2 l2 + Int_SF lf3 l3).
@@ -2353,19 +2351,19 @@ Proof.
   (Int_SF (FF (cons_Rlist l2 l3) f) (cons_Rlist l2 l3)).
   replace (Int_SF lf3 l3) with (Int_SF (FF l3 f) l3).
   replace (Int_SF lf2 l2) with (Int_SF (FF l2 f) l2).
-  symmetry  in |- *; apply StepFun_P42.
+  symmetry ; apply StepFun_P42.
   unfold adapted_couple in H2, H3; decompose [and] H2; decompose [and] H3;
-    clear H3 H2; rewrite H11; rewrite H5; unfold Rmax, Rmin in |- *;
+    clear H3 H2; rewrite H11; rewrite H5; unfold Rmax, Rmin;
       case (Rle_dec a c); case (Rle_dec b c); intros;
         [ elim n; assumption
           | elim n1; assumption
           | reflexivity
           | elim n1; assumption ].
   eapply StepFun_P17;
-    [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf2; apply H2
+    [ apply StepFun_P21; unfold is_subdivision; split with lf2; apply H2
       | assumption ].
   eapply StepFun_P17;
-    [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf3; apply H3
+    [ apply StepFun_P21; unfold is_subdivision; split with lf3; apply H3
       | assumption ].
   eapply StepFun_P17.
   apply (StepFun_P40 H0 H H2 (StepFun_P2 H3)).
@@ -2373,7 +2371,7 @@ Proof.
   replace (Int_SF lf2 l2) with 0.
   rewrite Rplus_0_l; eapply StepFun_P17;
     [ apply H3 | rewrite H0 in H1; apply H1 ].
-  symmetry  in |- *; eapply StepFun_P8; [ apply H2 | assumption ].
+  symmetry ; eapply StepFun_P8; [ apply H2 | assumption ].
   elim n; apply Rle_trans with a; try assumption.
   auto with real.
   assert (H : c < b).
@@ -2386,56 +2384,56 @@ Proof.
   (Int_SF (FF (cons_Rlist l2 l1) f) (cons_Rlist l2 l1)).
   replace (Int_SF lf1 l1) with (Int_SF (FF l1 f) l1).
   replace (Int_SF lf2 l2) with (Int_SF (FF l2 f) l2).
-  symmetry  in |- *; apply StepFun_P42.
+  symmetry ; apply StepFun_P42.
   unfold adapted_couple in H2, H1; decompose [and] H2; decompose [and] H1;
-    clear H1 H2; rewrite H11; rewrite H5; unfold Rmax, Rmin in |- *;
+    clear H1 H2; rewrite H11; rewrite H5; unfold Rmax, Rmin;
       case (Rle_dec a b); case (Rle_dec b c); intros;
         [ elim n1; assumption
           | elim n1; assumption
           | elim n0; assumption
           | reflexivity ].
   eapply StepFun_P17;
-    [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf2; apply H2
+    [ apply StepFun_P21; unfold is_subdivision; split with lf2; apply H2
       | assumption ].
   eapply StepFun_P17;
-    [ apply StepFun_P21; unfold is_subdivision in |- *; split with lf1; apply H1
+    [ apply StepFun_P21; unfold is_subdivision; split with lf1; apply H1
       | assumption ].
   eapply StepFun_P17.
   apply (StepFun_P40 H H0 (StepFun_P2 H2) (StepFun_P2 H1)).
   apply StepFun_P2; apply H3.
-  unfold RiemannInt_SF in |- *; case (Rle_dec a c); intro.
+  unfold RiemannInt_SF; case (Rle_dec a c); intro.
   eapply StepFun_P17.
   apply H3.
   change
     (adapted_couple (mkStepFun pr3) a c (subdivision (mkStepFun pr3))
-      (subdivision_val (mkStepFun pr3))) in |- *; apply StepFun_P1.
+      (subdivision_val (mkStepFun pr3))); apply StepFun_P1.
   apply Ropp_eq_compat; eapply StepFun_P17.
   apply H3.
   change
     (adapted_couple (mkStepFun pr3) a c (subdivision (mkStepFun pr3))
-      (subdivision_val (mkStepFun pr3))) in |- *; apply StepFun_P1.
-  unfold RiemannInt_SF in |- *; case (Rle_dec b c); intro.
+      (subdivision_val (mkStepFun pr3))); apply StepFun_P1.
+  unfold RiemannInt_SF; case (Rle_dec b c); intro.
   eapply StepFun_P17.
   apply H2.
   change
     (adapted_couple (mkStepFun pr2) b c (subdivision (mkStepFun pr2))
-      (subdivision_val (mkStepFun pr2))) in |- *; apply StepFun_P1.
+      (subdivision_val (mkStepFun pr2))); apply StepFun_P1.
   apply Ropp_eq_compat; eapply StepFun_P17.
   apply H2.
   change
     (adapted_couple (mkStepFun pr2) b c (subdivision (mkStepFun pr2))
-      (subdivision_val (mkStepFun pr2))) in |- *; apply StepFun_P1.
-  unfold RiemannInt_SF in |- *; case (Rle_dec a b); intro.
+      (subdivision_val (mkStepFun pr2))); apply StepFun_P1.
+  unfold RiemannInt_SF; case (Rle_dec a b); intro.
   eapply StepFun_P17.
   apply H1.
   change
     (adapted_couple (mkStepFun pr1) a b (subdivision (mkStepFun pr1))
-      (subdivision_val (mkStepFun pr1))) in |- *; apply StepFun_P1.
+      (subdivision_val (mkStepFun pr1))); apply StepFun_P1.
   apply Ropp_eq_compat; eapply StepFun_P17.
   apply H1.
   change
     (adapted_couple (mkStepFun pr1) a b (subdivision (mkStepFun pr1))
-      (subdivision_val (mkStepFun pr1))) in |- *; apply StepFun_P1.
+      (subdivision_val (mkStepFun pr1))); apply StepFun_P1.
 Qed.
 
 Lemma StepFun_P44 :
@@ -2451,7 +2449,7 @@ Proof.
           adapted_couple f a b l1 lf1 ->
           a <= c <= b ->
           { l:Rlist & { l0:Rlist & adapted_couple f a c l l0 } }).
-  intro X; unfold IsStepFun in |- *; unfold is_subdivision in |- *; eapply X.
+  intro X; unfold IsStepFun; unfold is_subdivision; eapply X.
   apply H2.
   split; assumption.
   clear f a b c H0 H H1 H2 l1 lf1; simple induction l1.
@@ -2463,11 +2461,11 @@ Proof.
     simpl in H2; assert (H7 : a <= b).
   elim H0; intros; apply Rle_trans with c; assumption.
   replace a with (Rmin a b).
-  pattern b at 2 in |- *; replace b with (Rmax a b).
+  pattern b at 2; replace b with (Rmax a b).
   rewrite <- H2; rewrite H3; reflexivity.
-  unfold Rmax in |- *; case (Rle_dec a b); intro;
+  unfold Rmax; case (Rle_dec a b); intro;
     [ reflexivity | elim n; assumption ].
-  unfold Rmin in |- *; case (Rle_dec a b); intro;
+  unfold Rmin; case (Rle_dec a b); intro;
     [ reflexivity | elim n; assumption ].
   split with (cons r nil); split with lf1; assert (H2 : c = b).
   rewrite H1 in H0; elim H0; intros; apply Rle_antisym; assumption.
@@ -2481,22 +2479,22 @@ Proof.
   split with (cons r (cons c nil)); split with (cons r3 nil);
     unfold adapted_couple in H; decompose [and] H; clear H;
       assert (H6 : r = a).
-  simpl in H4; rewrite H4; unfold Rmin in |- *; case (Rle_dec a b); intro;
+  simpl in H4; rewrite H4; unfold Rmin; case (Rle_dec a b); intro;
     [ reflexivity
       | elim n; elim H0; intros; apply Rle_trans with c; assumption ].
-  elim H0; clear H0; intros; unfold adapted_couple in |- *; repeat split.
-  rewrite H6; unfold ordered_Rlist in |- *; intros; simpl in H8; inversion H8;
-    [ simpl in |- *; assumption | elim (le_Sn_O _ H10) ].
-  simpl in |- *; unfold Rmin in |- *; case (Rle_dec a c); intro;
+  elim H0; clear H0; intros; unfold adapted_couple; repeat split.
+  rewrite H6; unfold ordered_Rlist; intros; simpl in H8; inversion H8;
+    [ simpl; assumption | elim (le_Sn_O _ H10) ].
+  simpl; unfold Rmin; case (Rle_dec a c); intro;
     [ assumption | elim n; assumption ].
-  simpl in |- *; unfold Rmax in |- *; case (Rle_dec a c); intro;
+  simpl; unfold Rmax; case (Rle_dec a c); intro;
     [ reflexivity | elim n; assumption ].
-  unfold constant_D_eq, open_interval in |- *; intros; simpl in H8;
+  unfold constant_D_eq, open_interval; intros; simpl in H8;
     inversion H8.
-  simpl in |- *; assert (H10 := H7 0%nat);
+  simpl; assert (H10 := H7 0%nat);
     assert (H12 : (0 < pred (Rlength (cons r (cons r1 r2))))%nat).
-  simpl in |- *; apply lt_O_Sn.
-  apply (H10 H12); unfold open_interval in |- *; simpl in |- *;
+  simpl; apply lt_O_Sn.
+  apply (H10 H12); unfold open_interval; simpl;
     rewrite H11 in H9; simpl in H9; elim H9; clear H9;
       intros; split; try assumption.
   apply Rlt_le_trans with c; assumption.
@@ -2510,42 +2508,42 @@ Proof.
         assert (H14 : a <= b).
   elim H0; intros; apply Rle_trans with c; assumption.
   assert (H16 : r = a).
-  simpl in H7; rewrite H7; unfold Rmin in |- *; case (Rle_dec a b); intro;
+  simpl in H7; rewrite H7; unfold Rmin; case (Rle_dec a b); intro;
     [ reflexivity | elim n; assumption ].
   induction  l1' as [| r4 l1' Hrecl1'].
   simpl in H13; discriminate.
-  clear Hrecl1'; unfold adapted_couple in |- *; repeat split.
-  unfold ordered_Rlist in |- *; intros; simpl in H; induction  i as [| i Hreci].
-  simpl in |- *; replace r4 with r1.
+  clear Hrecl1'; unfold adapted_couple; repeat split.
+  unfold ordered_Rlist; intros; simpl in H; induction  i as [| i Hreci].
+  simpl; replace r4 with r1.
   apply (H5 0%nat).
-  simpl in |- *; apply lt_O_Sn.
-  simpl in H12; rewrite H12; unfold Rmin in |- *; case (Rle_dec r1 c); intro;
+  simpl; apply lt_O_Sn.
+  simpl in H12; rewrite H12; unfold Rmin; case (Rle_dec r1 c); intro;
     [ reflexivity | elim n; left; assumption ].
-  apply (H9 i); simpl in |- *; apply lt_S_n; assumption.
-  simpl in |- *; unfold Rmin in |- *; case (Rle_dec a c); intro;
+  apply (H9 i); simpl; apply lt_S_n; assumption.
+  simpl; unfold Rmin; case (Rle_dec a c); intro;
     [ assumption | elim n; elim H0; intros; assumption ].
   replace (Rmax a c) with (Rmax r1 c).
   rewrite <- H11; reflexivity.
-  unfold Rmax in |- *; case (Rle_dec r1 c); case (Rle_dec a c); intros;
+  unfold Rmax; case (Rle_dec r1 c); case (Rle_dec a c); intros;
     [ reflexivity
       | elim n; elim H0; intros; assumption
       | elim n; left; assumption
       | elim n0; left; assumption ].
-  simpl in |- *; simpl in H13; rewrite H13; reflexivity.
-  intros; simpl in H; unfold constant_D_eq, open_interval in |- *; intros;
+  simpl; simpl in H13; rewrite H13; reflexivity.
+  intros; simpl in H; unfold constant_D_eq, open_interval; intros;
     induction  i as [| i Hreci].
-  simpl in |- *; assert (H17 := H10 0%nat);
+  simpl; assert (H17 := H10 0%nat);
     assert (H18 : (0 < pred (Rlength (cons r (cons r1 r2))))%nat).
-  simpl in |- *; apply lt_O_Sn.
-  apply (H17 H18); unfold open_interval in |- *; simpl in |- *; simpl in H4;
+  simpl; apply lt_O_Sn.
+  apply (H17 H18); unfold open_interval; simpl; simpl in H4;
     elim H4; clear H4; intros; split; try assumption;
       replace r1 with r4.
   assumption.
-  simpl in H12; rewrite H12; unfold Rmin in |- *; case (Rle_dec r1 c); intro;
+  simpl in H12; rewrite H12; unfold Rmin; case (Rle_dec r1 c); intro;
     [ reflexivity | elim n; left; assumption ].
-  clear Hreci; simpl in |- *; apply H15.
-  simpl in |- *; apply lt_S_n; assumption.
-  unfold open_interval in |- *; apply H4.
+  clear Hreci; simpl; apply H15.
+  simpl; apply lt_S_n; assumption.
+  unfold open_interval; apply H4.
   split.
   left; assumption.
   elim H0; intros; assumption.
@@ -2567,7 +2565,7 @@ Proof.
           adapted_couple f a b l1 lf1 ->
           a <= c <= b ->
           { l:Rlist & { l0:Rlist & adapted_couple f c b l l0 } }).
-  intro X; unfold IsStepFun in |- *; unfold is_subdivision in |- *; eapply X;
+  intro X; unfold IsStepFun; unfold is_subdivision; eapply X;
     [ apply H2 | split; assumption ].
   clear f a b c H0 H H1 H2 l1 lf1; simple induction l1.
   intros; unfold adapted_couple in H; decompose [and] H; clear H; simpl in H4;
@@ -2578,11 +2576,11 @@ Proof.
     simpl in H2; assert (H7 : a <= b).
   elim H0; intros; apply Rle_trans with c; assumption.
   replace a with (Rmin a b).
-  pattern b at 2 in |- *; replace b with (Rmax a b).
+  pattern b at 2; replace b with (Rmax a b).
   rewrite <- H2; rewrite H3; reflexivity.
-  unfold Rmax in |- *; case (Rle_dec a b); intro;
+  unfold Rmax; case (Rle_dec a b); intro;
     [ reflexivity | elim n; assumption ].
-  unfold Rmin in |- *; case (Rle_dec a b); intro;
+  unfold Rmin; case (Rle_dec a b); intro;
     [ reflexivity | elim n; assumption ].
   split with (cons r nil); split with lf1; assert (H2 : c = b).
   rewrite H1 in H0; elim H0; intros; apply Rle_antisym; assumption.
@@ -2595,32 +2593,32 @@ Proof.
   elim H1; intro.
   split with (cons c (cons r1 r2)); split with (cons r3 lf1);
     unfold adapted_couple in H; decompose [and] H; clear H;
-      unfold adapted_couple in |- *; repeat split.
-  unfold ordered_Rlist in |- *; intros; simpl in H; induction  i as [| i Hreci].
-  simpl in |- *; assumption.
-  clear Hreci; apply (H2 (S i)); simpl in |- *; assumption.
-  simpl in |- *; unfold Rmin in |- *; case (Rle_dec c b); intro;
+      unfold adapted_couple; repeat split.
+  unfold ordered_Rlist; intros; simpl in H; induction  i as [| i Hreci].
+  simpl; assumption.
+  clear Hreci; apply (H2 (S i)); simpl; assumption.
+  simpl; unfold Rmin; case (Rle_dec c b); intro;
     [ reflexivity | elim n; elim H0; intros; assumption ].
   replace (Rmax c b) with (Rmax a b).
   rewrite <- H3; reflexivity.
-  unfold Rmax in |- *; case (Rle_dec a b); case (Rle_dec c b); intros;
+  unfold Rmax; case (Rle_dec a b); case (Rle_dec c b); intros;
     [ reflexivity
       | elim n; elim H0; intros; assumption
       | elim n; elim H0; intros; apply Rle_trans with c; assumption
       | elim n0; elim H0; intros; apply Rle_trans with c; assumption ].
-  simpl in |- *; simpl in H5; apply H5.
+  simpl; simpl in H5; apply H5.
   intros; simpl in H; induction  i as [| i Hreci].
-  unfold constant_D_eq, open_interval in |- *; intros; simpl in |- *;
+  unfold constant_D_eq, open_interval; intros; simpl;
     apply (H7 0%nat).
-  simpl in |- *; apply lt_O_Sn.
-  unfold open_interval in |- *; simpl in |- *; simpl in H6; elim H6; clear H6;
+  simpl; apply lt_O_Sn.
+  unfold open_interval; simpl; simpl in H6; elim H6; clear H6;
     intros; split; try assumption; apply Rle_lt_trans with c;
       try assumption; replace r with a.
   elim H0; intros; assumption.
-  simpl in H4; rewrite H4; unfold Rmin in |- *; case (Rle_dec a b); intros;
+  simpl in H4; rewrite H4; unfold Rmin; case (Rle_dec a b); intros;
     [ reflexivity
       | elim n; elim H0; intros; apply Rle_trans with c; assumption ].
-  clear Hreci; apply (H7 (S i)); simpl in |- *; assumption.
+  clear Hreci; apply (H7 (S i)); simpl; assumption.
   cut (adapted_couple f r1 b (cons r1 r2) lf1).
   cut (r1 <= c <= b).
   intros; elim (X0 _ _ _ _ _ H3 H2); intros l1' [lf1' H4]; split with l1';
diff --git a/theories/Reals/Rlimit.v b/theories/Reals/Rlimit.v
index d2d935b7..c5ee828a 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-2012     *)
 (*   \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,9 +13,8 @@
 
 Require Import Rbase.
 Require Import Rfunctions.
-Require Import Classical_Prop.
 Require Import Fourier.
-Open Local Scope R_scope.
+Local Open Scope R_scope.
 
 (*******************************)
 (** *   Calculus               *)
@@ -34,7 +31,7 @@ Proof.
   intro esp.
   assert (H := double_var esp).
   unfold Rdiv in H.
-  symmetry  in |- *; exact H.
+  symmetry ; exact H.
 Qed.
 
 (*********)
@@ -42,9 +39,9 @@ Lemma eps4 : forall eps:R, eps * / (2 + 2) + eps * / (2 + 2) = eps * / 2.
 Proof.
   intro eps.
   replace (2 + 2) with 4.
-  pattern eps at 3 in |- *; rewrite double_var.
+  pattern eps at 3; rewrite double_var.
   rewrite (Rmult_plus_distr_r (eps / 2) (eps / 2) (/ 2)).
-  unfold Rdiv in |- *.
+  unfold Rdiv.
   repeat rewrite Rmult_assoc.
   rewrite <- Rinv_mult_distr.
   reflexivity.
@@ -57,7 +54,7 @@ Qed.
 Lemma Rlt_eps2_eps : forall eps:R, eps > 0 -> eps * / 2 < eps.
 Proof.
   intros.
-  pattern eps at 2 in |- *; rewrite <- Rmult_1_r.
+  pattern eps at 2; rewrite <- Rmult_1_r.
   repeat rewrite (Rmult_comm eps).
   apply Rmult_lt_compat_r.
   exact H.
@@ -73,7 +70,7 @@ Lemma Rlt_eps4_eps : forall eps:R, eps > 0 -> eps * / (2 + 2) < eps.
 Proof.
   intros.
   replace (2 + 2) with 4.
-  pattern eps at 2 in |- *; rewrite <- Rmult_1_r.
+  pattern eps at 2; rewrite <- Rmult_1_r.
   repeat rewrite (Rmult_comm eps).
   apply Rmult_lt_compat_r.
   exact H.
@@ -116,10 +113,10 @@ Qed.
 (*********)
 Lemma mul_factor_gt : forall eps l l':R, eps > 0 -> eps * mul_factor l l' > 0.
 Proof.
-  intros; unfold Rgt in |- *; rewrite <- (Rmult_0_r eps);
+  intros; unfold Rgt; rewrite <- (Rmult_0_r eps);
     apply Rmult_lt_compat_l.
   assumption.
-  unfold mul_factor in |- *; apply Rinv_0_lt_compat;
+  unfold mul_factor; apply Rinv_0_lt_compat;
     cut (1 <= 1 + (Rabs l + Rabs l')).
   cut (0 < 1).
   exact (Rlt_le_trans _ _ _).
@@ -199,7 +196,7 @@ Proof.
   case (H0 (dist R_met (f x0) l)); auto.
   intros alpha1 [H2 H3]; apply H3; auto; split; auto.
   case (dist_refl R_met x0 x0); intros Hr1 Hr2; rewrite Hr2; auto.
-  case (dist_refl R_met (f x0) l); intros Hr1 Hr2; apply sym_eq; auto.
+  case (dist_refl R_met (f x0) l); intros Hr1 Hr2; symmetry; auto.
 Qed.
 
 (*********)
@@ -213,7 +210,7 @@ Qed.
 (*********)
 Lemma lim_x : forall (D:R -> Prop) (x0:R), limit1_in (fun x:R => x) D x0 x0.
 Proof.
-  unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *; intros;
+  unfold limit1_in; unfold limit_in; simpl; intros;
     split with eps; split; auto; intros; elim H0; intros;
       auto.
 Qed.
@@ -224,9 +221,9 @@ Lemma limit_plus :
     limit1_in f D l x0 ->
     limit1_in g D l' x0 -> limit1_in (fun x:R => f x + g x) D (l + l') x0.
 Proof.
-  intros; unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *;
+  intros; unfold limit1_in; unfold limit_in; simpl;
     intros; elim (H (eps * / 2) (eps2_Rgt_R0 eps H1));
-      elim (H0 (eps * / 2) (eps2_Rgt_R0 eps H1)); simpl in |- *;
+      elim (H0 (eps * / 2) (eps2_Rgt_R0 eps H1)); simpl;
         clear H H0; intros; elim H; elim H0; clear H H0; intros;
           split with (Rmin x1 x); split.
   exact (Rmin_Rgt_r x1 x 0 (conj H H2)).
@@ -247,12 +244,12 @@ Lemma limit_Ropp :
   forall (f:R -> R) (D:R -> Prop) (l x0:R),
     limit1_in f D l x0 -> limit1_in (fun x:R => - f x) D (- l) x0.
 Proof.
-  unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *; intros;
+  unfold limit1_in; unfold limit_in; simpl; intros;
     elim (H eps H0); clear H; intros; elim H; clear H;
       intros; split with x; split; auto; intros; generalize (H1 x1 H2);
-        clear H1; intro; unfold R_dist in |- *; unfold Rminus in |- *;
+        clear H1; intro; unfold R_dist; unfold Rminus;
           rewrite (Ropp_involutive l); rewrite (Rplus_comm (- f x1) l);
-            fold (l - f x1) in |- *; fold (R_dist l (f x1)) in |- *;
+            fold (l - f x1); fold (R_dist l (f x1));
               rewrite R_dist_sym; assumption.
 Qed.
 
@@ -262,7 +259,7 @@ Lemma limit_minus :
     limit1_in f D l x0 ->
     limit1_in g D l' x0 -> limit1_in (fun x:R => f x - g x) D (l - l') x0.
 Proof.
-  intros; unfold Rminus in |- *; generalize (limit_Ropp g D l' x0 H0); intro;
+  intros; unfold Rminus; generalize (limit_Ropp g D l' x0 H0); intro;
     exact (limit_plus f (fun x:R => - g x) D l (- l') x0 H H1).
 Qed.
 
@@ -271,9 +268,9 @@ Lemma limit_free :
   forall (f:R -> R) (D:R -> Prop) (x x0:R),
     limit1_in (fun h:R => f x) D (f x) x0.
 Proof.
-  unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *; intros;
+  unfold limit1_in; unfold limit_in; simpl; intros;
     split with eps; split; auto; intros; elim (R_dist_refl (f x) (f x));
-      intros a b; rewrite (b (refl_equal (f x))); unfold Rgt in H;
+      intros a b; rewrite (b (eq_refl (f x))); unfold Rgt in H;
         assumption.
 Qed.
 
@@ -283,14 +280,14 @@ Lemma limit_mul :
     limit1_in f D l x0 ->
     limit1_in g D l' x0 -> limit1_in (fun x:R => f x * g x) D (l * l') x0.
 Proof.
-  intros; unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *;
+  intros; unfold limit1_in; unfold limit_in; simpl;
     intros;
       elim (H (Rmin 1 (eps * mul_factor l l')) (mul_factor_gt_f eps l l' H1));
         elim (H0 (eps * mul_factor l l') (mul_factor_gt eps l l' H1));
-          clear H H0; simpl in |- *; intros; elim H; elim H0;
+          clear H H0; simpl; intros; elim H; elim H0;
             clear H H0; intros; split with (Rmin x1 x); split.
   exact (Rmin_Rgt_r x1 x 0 (conj H H2)).
-  intros; elim H4; clear H4; intros; unfold R_dist in |- *;
+  intros; elim H4; clear H4; intros; unfold R_dist;
     replace (f x2 * g x2 - l * l') with (f x2 * (g x2 - l') + l' * (f x2 - l)).
   cut (Rabs (f x2 * (g x2 - l')) + Rabs (l' * (f x2 - l)) < eps).
   cut
@@ -312,7 +309,7 @@ Proof.
   apply Rmult_ge_0_gt_0_lt_compat.
   apply Rle_ge.
   exact (Rabs_pos (g x2 - l')).
-  rewrite (Rplus_comm 1 (Rabs l)); unfold Rgt in |- *; apply Rle_lt_0_plus_1;
+  rewrite (Rplus_comm 1 (Rabs l)); unfold Rgt; apply Rle_lt_0_plus_1;
     exact (Rabs_pos l).
   unfold R_dist in H9;
     apply (Rplus_lt_reg_r (- Rabs l) (Rabs (f x2)) (1 + Rabs l)).
@@ -326,13 +323,13 @@ Proof.
   generalize (H3 x2 (conj H4 H6)); trivial.
   apply Rmult_le_compat_l.
   exact (Rabs_pos l').
-  unfold Rle in |- *; left; assumption.
+  unfold Rle; left; assumption.
   rewrite (Rmult_comm (1 + Rabs l) (eps * mul_factor l l'));
     rewrite (Rmult_comm (Rabs l') (eps * mul_factor l l'));
       rewrite <-
         (Rmult_plus_distr_l (eps * mul_factor l l') (1 + Rabs l) (Rabs l'))
         ; rewrite (Rmult_assoc eps (mul_factor l l') (1 + Rabs l + Rabs l'));
-          rewrite (Rplus_assoc 1 (Rabs l) (Rabs l')); unfold mul_factor in |- *;
+          rewrite (Rplus_assoc 1 (Rabs l) (Rabs l')); unfold mul_factor;
             rewrite (Rinv_l (1 + (Rabs l + Rabs l')) (mul_factor_wd l l'));
               rewrite (proj1 (Rmult_ne eps)); apply Req_le; trivial.
   ring.
@@ -347,10 +344,10 @@ Lemma single_limit :
   forall (f:R -> R) (D:R -> Prop) (l l' x0:R),
     adhDa D x0 -> limit1_in f D l x0 -> limit1_in f D l' x0 -> l = l'.
 Proof.
-  unfold limit1_in in |- *; unfold limit_in in |- *; intros.
+  unfold limit1_in; unfold limit_in; intros.
   cut (forall eps:R, eps > 0 -> dist R_met l l' < 2 * eps).
-  clear H0 H1; unfold dist in |- *; unfold R_met in |- *; unfold R_dist in |- *;
-    unfold Rabs in |- *; case (Rcase_abs (l - l')); intros.
+  clear H0 H1; unfold dist; unfold R_met; unfold R_dist;
+    unfold Rabs; case (Rcase_abs (l - l')); intros.
   cut (forall eps:R, eps > 0 -> - (l - l') < eps).
   intro; generalize (prop_eps (- (l - l')) H1); intro;
     generalize (Ropp_gt_lt_0_contravar (l - l') r); intro;
@@ -361,10 +358,10 @@ Proof.
     rewrite <- (Rmult_assoc 2 (/ 2) eps); rewrite (Rinv_r 2).
   elim (Rmult_ne eps); intros a b; rewrite b; clear a b; trivial.
   apply (Rlt_dichotomy_converse 2 0); right; generalize Rlt_0_1; intro;
-    unfold Rgt in |- *; generalize (Rplus_lt_compat_l 1 0 1 H3);
+    unfold Rgt; generalize (Rplus_lt_compat_l 1 0 1 H3);
       intro; elim (Rplus_ne 1); intros a b; rewrite a in H4;
         clear a b; apply (Rlt_trans 0 1 2 H3 H4).
-  unfold Rgt in |- *; unfold Rgt in H1; rewrite (Rmult_comm eps (/ 2));
+  unfold Rgt; unfold Rgt in H1; rewrite (Rmult_comm eps (/ 2));
     rewrite <- (Rmult_0_r (/ 2)); apply (Rmult_lt_compat_l (/ 2) 0 eps);
       auto.
   apply (Rinv_0_lt_compat 2); cut (1 < 2).
@@ -383,10 +380,10 @@ Proof.
     rewrite <- (Rmult_assoc 2 (/ 2) eps); rewrite (Rinv_r 2).
   elim (Rmult_ne eps); intros a b; rewrite b; clear a b; trivial.
   apply (Rlt_dichotomy_converse 2 0); right; generalize Rlt_0_1; intro;
-    unfold Rgt in |- *; generalize (Rplus_lt_compat_l 1 0 1 H3);
+    unfold Rgt; generalize (Rplus_lt_compat_l 1 0 1 H3);
       intro; elim (Rplus_ne 1); intros a b; rewrite a in H4;
         clear a b; apply (Rlt_trans 0 1 2 H3 H4).
-  unfold Rgt in |- *; unfold Rgt in H1; rewrite (Rmult_comm eps (/ 2));
+  unfold Rgt; unfold Rgt in H1; rewrite (Rmult_comm eps (/ 2));
     rewrite <- (Rmult_0_r (/ 2)); apply (Rmult_lt_compat_l (/ 2) 0 eps);
       auto.
   apply (Rinv_0_lt_compat 2); cut (1 < 2).
@@ -396,7 +393,7 @@ Proof.
 (**)
   intros; unfold adhDa in H; elim (H0 eps H2); intros; elim (H1 eps H2); intros;
     clear H0 H1; elim H3; elim H4; clear H3 H4; intros;
-      simpl in |- *; simpl in H1, H4; generalize (Rmin_Rgt x x1 0);
+      simpl; simpl in H1, H4; generalize (Rmin_Rgt x x1 0);
         intro; elim H5; intros; clear H5; elim (H (Rmin x x1) (H7 (conj H3 H0)));
           intros; elim H5; intros; clear H5 H H6 H7;
             generalize (Rmin_Rgt x x1 (R_dist x2 x0)); intro;
@@ -406,10 +403,10 @@ Proof.
                     intros;
                       generalize
                         (Rplus_lt_compat (R_dist (f x2) l) eps (R_dist (f x2) l') eps H H0);
-                        unfold R_dist in |- *; intros; rewrite (Rabs_minus_sym (f x2) l) in H1;
+                        unfold R_dist; intros; rewrite (Rabs_minus_sym (f x2) l) in H1;
                           rewrite (Rmult_comm 2 eps); rewrite (Rmult_plus_distr_l eps 1 1);
                             elim (Rmult_ne eps); intros a b; rewrite a; clear a b;
-                              generalize (R_dist_tri l l' (f x2)); unfold R_dist in |- *;
+                              generalize (R_dist_tri l l' (f x2)); unfold R_dist;
                                 intros;
                                   apply
                                     (Rle_lt_trans (Rabs (l - l')) (Rabs (l - f x2) + Rabs (f x2 - l'))
@@ -422,7 +419,7 @@ Lemma limit_comp :
     limit1_in f Df l x0 ->
     limit1_in g Dg l' l -> limit1_in (fun x:R => g (f x)) (Dgf Df Dg f) l' x0.
 Proof.
-  unfold limit1_in, limit_in, Dgf in |- *; simpl in |- *.
+  unfold limit1_in, limit_in, Dgf; simpl.
   intros f g Df Dg l l' x0 Hf Hg eps eps_pos.
   elim (Hg eps eps_pos).
   intros alpg lg.
@@ -439,12 +436,12 @@ Lemma limit_inv :
   forall (f:R -> R) (D:R -> Prop) (l x0:R),
     limit1_in f D l x0 -> l <> 0 -> limit1_in (fun x:R => / f x) D (/ l) x0.
 Proof.
-  unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *;
-    unfold R_dist in |- *; intros; elim (H (Rabs l / 2)).
+  unfold limit1_in; unfold limit_in; simpl;
+    unfold R_dist; intros; elim (H (Rabs l / 2)).
   intros delta1 H2; elim (H (eps * (Rsqr l / 2))).
   intros delta2 H3; elim H2; elim H3; intros; exists (Rmin delta1 delta2);
     split.
-  unfold Rmin in |- *; case (Rle_dec delta1 delta2); intro; assumption.
+  unfold Rmin; case (Rle_dec delta1 delta2); intro; assumption.
   intro; generalize (H5 x); clear H5; intro H5; generalize (H7 x); clear H7;
     intro H7; intro H10; elim H10; intros; cut (D x /\ Rabs (x - x0) < delta1).
   cut (D x /\ Rabs (x - x0) < delta2).
@@ -458,7 +455,7 @@ Proof.
               (Rplus_lt_compat_l (Rabs (f x) - Rabs l / 2) (Rabs l - Rabs (f x))
                 (Rabs l / 2) H14);
               replace (Rabs (f x) - Rabs l / 2 + (Rabs l - Rabs (f x))) with (Rabs l / 2).
-  unfold Rminus in |- *; rewrite Rplus_assoc; rewrite Rplus_opp_l;
+  unfold Rminus; rewrite Rplus_assoc; rewrite Rplus_opp_l;
     rewrite Rplus_0_r; intro; cut (f x <> 0).
   intro; replace (/ f x + - / l) with ((l - f x) * / (l * f x)).
   rewrite Rabs_mult; rewrite Rabs_Rinv.
@@ -470,7 +467,7 @@ Proof.
         (/ Rabs (l * f x)) (2 / Rsqr l) (Rabs_pos (l - f x)) H18 H5 H17);
       replace (eps * (Rsqr l / 2) * (2 / Rsqr l)) with eps.
   intro; assumption.
-  unfold Rdiv in |- *; unfold Rsqr in |- *; rewrite Rinv_mult_distr.
+  unfold Rdiv; unfold Rsqr; rewrite Rinv_mult_distr.
   repeat rewrite Rmult_assoc.
   rewrite (Rmult_comm l).
   repeat rewrite Rmult_assoc.
@@ -490,7 +487,7 @@ Proof.
   left; apply Rinv_0_lt_compat; apply Rabs_pos_lt; apply prod_neq_R0;
     assumption.
   rewrite Rmult_comm; rewrite Rabs_mult; rewrite Rinv_mult_distr.
-  rewrite (Rsqr_abs l); unfold Rsqr in |- *; unfold Rdiv in |- *;
+  rewrite (Rsqr_abs l); unfold Rsqr; unfold Rdiv;
     rewrite Rinv_mult_distr.
   repeat rewrite <- Rmult_assoc; apply Rmult_lt_compat_r.
   apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption.
@@ -499,7 +496,7 @@ Proof.
   apply Rabs_pos_lt; assumption.
   apply Rabs_pos_lt; assumption.
   apply Rinv_0_lt_compat; cut (0%nat <> 2%nat);
-    [ intro H17; generalize (lt_INR_0 2 (neq_O_lt 2 H17)); unfold INR in |- *;
+    [ intro H17; generalize (lt_INR_0 2 (neq_O_lt 2 H17)); unfold INR;
       intro H18; assumption
       | discriminate ].
   replace (Rabs (f x) * Rabs l * / 2 * / Rabs (f x)) with (Rabs l / 2).
@@ -515,7 +512,7 @@ Proof.
   discrR.
   apply Rabs_no_R0.
   assumption.
-  unfold Rdiv in |- *.
+  unfold Rdiv.
   repeat rewrite Rmult_assoc.
   rewrite (Rmult_comm (Rabs (f x))).
   repeat rewrite Rmult_assoc.
@@ -529,7 +526,7 @@ Proof.
   apply Rabs_no_R0; assumption.
   apply prod_neq_R0; assumption.
   rewrite (Rinv_mult_distr _ _ H0 H16).
-  unfold Rminus in |- *; rewrite Rmult_plus_distr_r.
+  unfold Rminus; rewrite Rmult_plus_distr_r.
   rewrite <- Rmult_assoc.
   rewrite <- Rinv_r_sym.
   rewrite Rmult_1_l.
@@ -541,16 +538,16 @@ Proof.
   reflexivity.
   assumption.
   assumption.
-  red in |- *; intro; rewrite H16 in H15; rewrite Rabs_R0 in H15;
+  red; intro; rewrite H16 in H15; rewrite Rabs_R0 in H15;
     cut (0 < Rabs l / 2).
   intro; elim (Rlt_irrefl 0 (Rlt_trans 0 (Rabs l / 2) 0 H17 H15)).
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+  unfold Rdiv; apply Rmult_lt_0_compat.
   apply Rabs_pos_lt; assumption.
   apply Rinv_0_lt_compat; cut (0%nat <> 2%nat);
-    [ intro H17; generalize (lt_INR_0 2 (neq_O_lt 2 H17)); unfold INR in |- *;
+    [ intro H17; generalize (lt_INR_0 2 (neq_O_lt 2 H17)); unfold INR;
       intro; assumption
       | discriminate ].
-  pattern (Rabs l) at 3 in |- *; rewrite double_var.
+  pattern (Rabs l) at 3; rewrite double_var.
   ring.
   split;
     [ assumption
@@ -560,18 +557,18 @@ Proof.
     [ assumption
       | apply Rlt_le_trans with (Rmin delta1 delta2);
         [ assumption | apply Rmin_l ] ].
-  change (0 < eps * (Rsqr l / 2)) in |- *; unfold Rdiv in |- *;
+  change (0 < eps * (Rsqr l / 2)); unfold Rdiv;
     repeat rewrite Rmult_assoc; apply Rmult_lt_0_compat.
   assumption.
   apply Rmult_lt_0_compat. apply Rsqr_pos_lt; assumption.
   apply Rinv_0_lt_compat; cut (0%nat <> 2%nat);
-    [ intro H3; generalize (lt_INR_0 2 (neq_O_lt 2 H3)); unfold INR in |- *;
+    [ intro H3; generalize (lt_INR_0 2 (neq_O_lt 2 H3)); unfold INR;
       intro; assumption
       | discriminate ].
-  change (0 < Rabs l / 2) in |- *; unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+  change (0 < Rabs l / 2); unfold Rdiv; apply Rmult_lt_0_compat;
     [ apply Rabs_pos_lt; assumption
       | apply Rinv_0_lt_compat; cut (0%nat <> 2%nat);
-        [ intro H3; generalize (lt_INR_0 2 (neq_O_lt 2 H3)); unfold INR in |- *;
+        [ intro H3; generalize (lt_INR_0 2 (neq_O_lt 2 H3)); unfold INR;
           intro; assumption
           | discriminate ] ].
 Qed.
diff --git a/theories/Reals/Rlogic.v b/theories/Reals/Rlogic.v
index b7ffec2b..0b892a76 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-2012     *)
 (*   \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
@@ -266,10 +271,10 @@ assert (H2 : ~ is_upper_bound E M').
   intro H5.
   assert (M <= M')%R by (apply H4; exact H5).
   apply (Rlt_not_le M M').
-    unfold M' in |- *.
-    pattern M at 2 in |- *.
+    unfold M'.
+    pattern M at 2.
     rewrite <- Rplus_0_l.
-    pattern (0 + M)%R in |- *.
+    pattern (0 + M)%R.
     rewrite Rplus_comm.
     rewrite <- (Rplus_opp_r 1).
     apply Rplus_lt_compat_l.
@@ -279,7 +284,7 @@ assert (H2 : ~ is_upper_bound E M').
 apply H2.
 intros N (n,H7).
 rewrite H7.
-unfold M' in |- *.
+unfold M'.
 assert (H5 : (INR (S n) <= M)%R) by (apply H3; exists (S n); reflexivity).
 rewrite S_INR in H5.
 assert (H6 : (INR n + 1 + -1 <= M + -1)%R).
diff --git a/theories/Reals/Rminmax.v b/theories/Reals/Rminmax.v
index c9faee0c..da3c6ddd 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-2012     *)
 (*   \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..cd94169f 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-2012     *)
 (*   \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..43f326a0 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-2012     *)
 (*   \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*)
 
 (************************************************************)
@@ -16,25 +15,25 @@
 Require Import Rbase.
 Require Import Rfunctions.
 Require Import SeqSeries.
-Require Import Rtrigo.
+Require Import Rtrigo1.
 Require Import Ranalysis1.
 Require Import Exp_prop.
 Require Import Rsqrt_def.
 Require Import R_sqrt.
 Require Import MVT.
 Require Import Ranalysis4.
-Open Local Scope R_scope.
+Local Open Scope R_scope.
 
 Lemma P_Rmin : forall (P:R -> Prop) (x y:R), P x -> P y -> P (Rmin x y).
 Proof.
-  intros P x y H1 H2; unfold Rmin in |- *; case (Rle_dec x y); intro;
+  intros P x y H1 H2; unfold Rmin; case (Rle_dec x y); intro;
     assumption.
 Qed.
 
 Lemma exp_le_3 : exp 1 <= 3.
 Proof.
   assert (exp_1 : exp 1 <> 0).
-  assert (H0 := exp_pos 1); red in |- *; intro; rewrite H in H0;
+  assert (H0 := exp_pos 1); red; intro; rewrite H in H0;
     elim (Rlt_irrefl _ H0).
   apply Rmult_le_reg_l with (/ exp 1).
   apply Rinv_0_lt_compat; apply exp_pos.
@@ -44,7 +43,7 @@ Proof.
   rewrite Rmult_1_r; rewrite <- (Rmult_comm 3); rewrite <- Rmult_assoc;
     rewrite <- Rinv_l_sym.
   rewrite Rmult_1_l; replace (/ exp 1) with (exp (-1)).
-  unfold exp in |- *; case (exist_exp (-1)); intros; simpl in |- *;
+  unfold exp; case (exist_exp (-1)); intros; simpl;
     unfold exp_in in e;
       assert (H := alternated_series_ineq (fun i:nat => / INR (fact i)) x 1).
   cut
@@ -74,7 +73,7 @@ Proof.
   ring.
   discrR.
   apply H.
-  unfold Un_decreasing in |- *; intros;
+  unfold Un_decreasing; intros;
     apply Rmult_le_reg_l with (INR (fact n)).
   apply INR_fact_lt_0.
   apply Rmult_le_reg_l with (INR (fact (S n))).
@@ -85,13 +84,13 @@ Proof.
   rewrite Rmult_1_r; apply le_INR; apply fact_le; apply le_n_Sn.
   apply INR_fact_neq_0.
   apply INR_fact_neq_0.
-  assert (H0 := cv_speed_pow_fact 1); unfold Un_cv in |- *; unfold Un_cv in H0;
+  assert (H0 := cv_speed_pow_fact 1); unfold Un_cv; unfold Un_cv in H0;
     intros; elim (H0 _ H1); intros; exists x0; intros;
-      unfold R_dist in H2; unfold R_dist in |- *;
+      unfold R_dist in H2; unfold R_dist;
         replace (/ INR (fact n)) with (1 ^ n / INR (fact n)).
   apply (H2 _ H3).
-  unfold Rdiv in |- *; rewrite pow1; rewrite Rmult_1_l; reflexivity.
-  unfold infinite_sum in e; unfold Un_cv, tg_alt in |- *; intros; elim (e _ H0);
+  unfold Rdiv; rewrite pow1; rewrite Rmult_1_l; reflexivity.
+  unfold infinite_sum in e; unfold Un_cv, tg_alt; intros; elim (e _ H0);
     intros; exists x0; intros;
       replace (sum_f_R0 (fun i:nat => (-1) ^ i * / INR (fact i)) n) with
       (sum_f_R0 (fun i:nat => / INR (fact i) * (-1) ^ i) n).
@@ -122,7 +121,7 @@ Proof.
   intro.
   replace (derive_pt exp x0 (H0 x0)) with (exp x0).
   apply exp_pos.
-  symmetry  in |- *; apply derive_pt_eq_0.
+  symmetry ; apply derive_pt_eq_0.
   apply (derivable_pt_lim_exp x0).
   apply H.
 Qed.
@@ -144,11 +143,11 @@ Proof.
         rewrite Ropp_0; rewrite Rplus_0_r;
           replace (derive_pt exp x0 (derivable_exp x0)) with (exp x0).
   rewrite exp_0; rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l;
-    pattern x at 1 in |- *; rewrite <- Rmult_1_r; rewrite (Rmult_comm (exp x0));
+    pattern x at 1; rewrite <- Rmult_1_r; rewrite (Rmult_comm (exp x0));
       apply Rmult_lt_compat_l.
   apply H.
   rewrite <- exp_0; apply exp_increasing; elim H3; intros; assumption.
-  symmetry  in |- *; apply derive_pt_eq_0; apply derivable_pt_lim_exp.
+  symmetry ; apply derive_pt_eq_0; apply derivable_pt_lim_exp.
 Qed.
 
 Lemma ln_exists1 : forall y:R, 1 <= y -> { z:R | y = exp z }.
@@ -161,18 +160,18 @@ Proof.
   cut (f 0 * f y <= 0); [intro H4|].
   pose proof (IVT_cor f 0 y H2 (Rlt_le _ _ H0) H4) as (t,(_,H7));
     exists t; unfold f in H7; apply Rminus_diag_uniq_sym; exact H7.
-  pattern 0 at 2 in |- *; rewrite <- (Rmult_0_r (f y));
+  pattern 0 at 2; rewrite <- (Rmult_0_r (f y));
     rewrite (Rmult_comm (f 0)); apply Rmult_le_compat_l;
       assumption.
-  unfold f in |- *; apply Rplus_le_reg_l with y; left;
+  unfold f; apply Rplus_le_reg_l with y; left;
     apply Rlt_trans with (1 + y).
   rewrite <- (Rplus_comm y); apply Rplus_lt_compat_l; apply Rlt_0_1.
   replace (y + (exp y - y)) with (exp y); [ apply (exp_ineq1 y H0) | ring ].
-  unfold f in |- *; change (continuity (exp - fct_cte y)) in |- *;
+  unfold f; change (continuity (exp - fct_cte y));
     apply continuity_minus;
       [ apply derivable_continuous; apply derivable_exp
         | apply derivable_continuous; apply derivable_const ].
-  unfold f in |- *; rewrite exp_0; apply Rplus_le_reg_l with y;
+  unfold f; rewrite exp_0; apply Rplus_le_reg_l with y;
     rewrite Rplus_0_r; replace (y + (1 - y)) with 1; [ apply H | ring ].
 Qed.
 
@@ -186,18 +185,18 @@ Proof.
   apply H.
   rewrite <- Rinv_r_sym.
   rewrite Rmult_1_r; left; apply (Rnot_le_lt _ _ n).
-  red in |- *; intro; rewrite H0 in H; elim (Rlt_irrefl _ H).
+  red; intro; rewrite H0 in H; elim (Rlt_irrefl _ H).
   destruct (ln_exists1 _ H0) as (x,p); exists (- x);
     apply Rmult_eq_reg_l with (exp x / y).
-  unfold Rdiv in |- *; rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
+  unfold Rdiv; rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
   rewrite Rmult_1_r; rewrite <- (Rmult_comm (/ y)); rewrite Rmult_assoc;
     rewrite <- exp_plus; rewrite Rplus_opp_r; rewrite exp_0;
-      rewrite Rmult_1_r; symmetry  in |- *; apply p.
-  red in |- *; intro H3; rewrite H3 in H; elim (Rlt_irrefl _ H).
-  unfold Rdiv in |- *; apply prod_neq_R0.
-  assert (H3 := exp_pos x); red in |- *; intro H4; rewrite H4 in H3;
+      rewrite Rmult_1_r; symmetry ; apply p.
+  red; intro H3; rewrite H3 in H; elim (Rlt_irrefl _ H).
+  unfold Rdiv; apply prod_neq_R0.
+  assert (H3 := exp_pos x); red; intro H4; rewrite H4 in H3;
     elim (Rlt_irrefl _ H3).
-  apply Rinv_neq_0_compat; red in |- *; intro H3; rewrite H3 in H;
+  apply Rinv_neq_0_compat; red; intro H3; rewrite H3 in H;
     elim (Rlt_irrefl _ H).
 Qed.
 
@@ -214,11 +213,11 @@ Definition ln (x:R) : R :=
 
 Lemma exp_ln : forall x:R, 0 < x -> exp (ln x) = x.
 Proof.
-  intros; unfold ln in |- *; case (Rlt_dec 0 x); intro.
-  unfold Rln in |- *;
+  intros; unfold ln; case (Rlt_dec 0 x); intro.
+  unfold Rln;
     case (ln_exists (mkposreal x r) (cond_pos (mkposreal x r)));
     intros.
-  simpl in e; symmetry  in |- *; apply e.
+  simpl in e; symmetry ; apply e.
   elim n; apply H.
 Qed.
 
@@ -232,7 +231,7 @@ Qed.
 Theorem exp_Ropp : forall x:R, exp (- x) = / exp x.
 Proof.
   intros x; assert (H : exp x <> 0).
-  assert (H := exp_pos x); red in |- *; intro; rewrite H0 in H;
+  assert (H := exp_pos x); red; intro; rewrite H0 in H;
     elim (Rlt_irrefl _ H).
   apply Rmult_eq_reg_l with (r := exp x).
   rewrite <- exp_plus; rewrite Rplus_opp_r; rewrite exp_0.
@@ -307,11 +306,11 @@ Theorem ln_continue :
   forall y:R, 0 < y -> continue_in ln (fun x:R => 0 < x) y.
 Proof.
   intros y H.
-  unfold continue_in, limit1_in, limit_in in |- *; intros eps Heps.
+  unfold continue_in, limit1_in, limit_in; intros eps Heps.
   cut (1 < exp eps); [ intros H1 | idtac ].
   cut (exp (- eps) < 1); [ intros H2 | idtac ].
   exists (Rmin (y * (exp eps - 1)) (y * (1 - exp (- eps)))); split.
-  red in |- *; apply P_Rmin.
+  red; apply P_Rmin.
   apply Rmult_lt_0_compat.
   assumption.
   apply Rplus_lt_reg_r with 1.
@@ -322,7 +321,7 @@ Proof.
   apply Rplus_lt_reg_r with (exp (- eps)).
   rewrite Rplus_0_r; replace (exp (- eps) + (1 - exp (- eps))) with 1;
     [ apply H2 | ring ].
-  unfold dist, R_met, R_dist in |- *; simpl in |- *.
+  unfold dist, R_met, R_dist; simpl.
   intros x [[H3 H4] H5].
   cut (y * (x * / y) = x).
   intro Hxyy.
@@ -352,7 +351,7 @@ Proof.
   rewrite Hxyy; rewrite Rmult_1_r; apply Hxy.
   rewrite Hxy; rewrite Rinv_r.
   rewrite ln_1; rewrite Rabs_R0; apply Heps.
-  red in |- *; intro; rewrite H0 in H; elim (Rlt_irrefl _ H).
+  red; intro; rewrite H0 in H; elim (Rlt_irrefl _ H).
   rewrite Rabs_right.
   apply exp_lt_inv.
   rewrite exp_ln.
@@ -367,7 +366,7 @@ Proof.
   left; apply (Rgt_minus _ _ Hxy).
   apply Rmult_lt_0_compat; [ apply H3 | apply (Rinv_0_lt_compat _ H) ].
   rewrite <- ln_1.
-  apply Rgt_ge; red in |- *; apply ln_increasing.
+  apply Rgt_ge; red; apply ln_increasing.
   apply Rlt_0_1.
   apply Rmult_lt_reg_l with (r := y).
   apply H.
@@ -380,7 +379,7 @@ Proof.
   apply Rinv_0_lt_compat; assumption.
   rewrite (Rmult_comm x); rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym.
   ring.
-  red in |- *; intro; rewrite H0 in H; elim (Rlt_irrefl _ H).
+  red; intro; rewrite H0 in H; elim (Rlt_irrefl _ H).
   apply Rmult_lt_reg_l with (exp eps).
   apply exp_pos.
   rewrite <- exp_plus; rewrite Rmult_1_r; rewrite Rplus_opp_r; rewrite exp_0;
@@ -395,7 +394,7 @@ Qed.
 
 Definition Rpower (x y:R) := exp (y * ln x).
 
-Infix Local "^R" := Rpower (at level 30, right associativity) : R_scope.
+Local Infix "^R" := Rpower (at level 30, right associativity) : R_scope.
 
 (******************************************************************)
 (** *                     Properties of  Rpower                   *)
@@ -413,13 +412,13 @@ Infix Local "^R" := Rpower (at level 30, right associativity) : R_scope.
 
 Theorem Rpower_plus : forall x y z:R, z ^R (x + y) = z ^R x * z ^R y.
 Proof.
-  intros x y z; unfold Rpower in |- *.
+  intros x y z; unfold Rpower.
   rewrite Rmult_plus_distr_r; rewrite exp_plus; auto.
 Qed.
 
 Theorem Rpower_mult : forall x y z:R, (x ^R y) ^R z = x ^R (y * z).
 Proof.
-  intros x y z; unfold Rpower in |- *.
+  intros x y z; unfold Rpower.
   rewrite ln_exp.
   replace (z * (y * ln x)) with (y * z * ln x).
   reflexivity.
@@ -428,22 +427,22 @@ Qed.
 
 Theorem Rpower_O : forall x:R, 0 < x -> x ^R 0 = 1.
 Proof.
-  intros x _; unfold Rpower in |- *.
+  intros x _; unfold Rpower.
   rewrite Rmult_0_l; apply exp_0.
 Qed.
 
 Theorem Rpower_1 : forall x:R, 0 < x -> x ^R 1 = x.
 Proof.
-  intros x H; unfold Rpower in |- *.
+  intros x H; unfold Rpower.
   rewrite Rmult_1_l; apply exp_ln; apply H.
 Qed.
 
 Theorem Rpower_pow : forall (n:nat) (x:R), 0 < x -> x ^R INR n = x ^ n.
 Proof.
-  intros n; elim n; simpl in |- *; auto; fold INR in |- *.
+  intros n; elim n; simpl; auto; fold INR.
   intros x H; apply Rpower_O; auto.
   intros n1; case n1.
-  intros H x H0; simpl in |- *; rewrite Rmult_1_r; apply Rpower_1; auto.
+  intros H x H0; simpl; rewrite Rmult_1_r; apply Rpower_1; auto.
   intros n0 H x H0; rewrite Rpower_plus; rewrite H; try rewrite Rpower_1;
     try apply Rmult_comm || assumption.
 Qed.
@@ -452,7 +451,7 @@ Theorem Rpower_lt :
   forall x y z:R, 1 < x -> 0 <= y -> y < z -> x ^R y < x ^R z.
 Proof.
   intros x y z H H0 H1.
-  unfold Rpower in |- *.
+  unfold Rpower.
   apply exp_increasing.
   apply Rmult_lt_compat_r.
   rewrite <- ln_1; apply ln_increasing.
@@ -465,18 +464,18 @@ Theorem Rpower_sqrt : forall x:R, 0 < x -> x ^R (/ 2) = sqrt x.
 Proof.
   intros x H.
   apply ln_inv.
-  unfold Rpower in |- *; apply exp_pos.
+  unfold Rpower; apply exp_pos.
   apply sqrt_lt_R0; apply H.
   apply Rmult_eq_reg_l with (INR 2).
   apply exp_inv.
-  fold Rpower in |- *.
+  fold Rpower.
   cut ((x ^R (/ INR 2)) ^R INR 2 = sqrt x ^R INR 2).
-  unfold Rpower in |- *; auto.
+  unfold Rpower; auto.
   rewrite Rpower_mult.
   rewrite Rinv_l.
   replace 1 with (INR 1); auto.
-  repeat rewrite Rpower_pow; simpl in |- *.
-  pattern x at 1 in |- *; rewrite <- (sqrt_sqrt x (Rlt_le _ _ H)).
+  repeat rewrite Rpower_pow; simpl.
+  pattern x at 1; rewrite <- (sqrt_sqrt x (Rlt_le _ _ H)).
   ring.
   apply sqrt_lt_R0; apply H.
   apply H.
@@ -486,7 +485,7 @@ Qed.
 
 Theorem Rpower_Ropp : forall x y:R, x ^R (- y) = / x ^R y.
 Proof.
-  unfold Rpower in |- *.
+  unfold Rpower.
   intros x y; rewrite Ropp_mult_distr_l_reverse.
   apply exp_Ropp.
 Qed.
@@ -506,11 +505,11 @@ Proof.
   rewrite Rinv_r.
   apply exp_lt_inv.
   apply Rle_lt_trans with (1 := exp_le_3).
-  change (3 < 2 ^R 2) in |- *.
+  change (3 < 2 ^R 2).
   repeat rewrite Rpower_plus; repeat rewrite Rpower_1.
   repeat rewrite Rmult_plus_distr_r; repeat rewrite Rmult_plus_distr_l;
     repeat rewrite Rmult_1_l.
-  pattern 3 at 1 in |- *; rewrite <- Rplus_0_r; replace (2 + 2) with (3 + 1);
+  pattern 3 at 1; rewrite <- Rplus_0_r; replace (2 + 2) with (3 + 1);
     [ apply Rplus_lt_compat_l; apply Rlt_0_1 | ring ].
   prove_sup0.
   discrR.
@@ -524,7 +523,7 @@ Theorem limit1_ext :
   forall (f g:R -> R) (D:R -> Prop) (l x:R),
     (forall x:R, D x -> f x = g x) -> limit1_in f D l x -> limit1_in g D l x.
 Proof.
-  intros f g D l x H; unfold limit1_in, limit_in in |- *.
+  intros f g D l x H; unfold limit1_in, limit_in.
   intros H0 eps H1; case (H0 eps); auto.
   intros x0 [H2 H3]; exists x0; split; auto.
   intros x1 [H4 H5]; rewrite <- H; auto.
@@ -534,7 +533,7 @@ Theorem limit1_imp :
   forall (f:R -> R) (D D1:R -> Prop) (l x:R),
     (forall x:R, D1 x -> D x) -> limit1_in f D l x -> limit1_in f D1 l x.
 Proof.
-  intros f D D1 l x H; unfold limit1_in, limit_in in |- *.
+  intros f D D1 l x H; unfold limit1_in, limit_in.
   intros H0 eps H1; case (H0 eps H1); auto.
   intros alpha [H2 H3]; exists alpha; split; auto.
   intros d [H4 H5]; apply H3; split; auto.
@@ -542,7 +541,7 @@ Qed.
 
 Theorem Rinv_Rdiv : forall x y:R, x <> 0 -> y <> 0 -> / (x / y) = y / x.
 Proof.
-  intros x y H1 H2; unfold Rdiv in |- *; rewrite Rinv_mult_distr.
+  intros x y H1 H2; unfold Rdiv; rewrite Rinv_mult_distr.
   rewrite Rinv_involutive.
   apply Rmult_comm.
   assumption.
@@ -552,18 +551,18 @@ Qed.
 
 Theorem Dln : forall y:R, 0 < y -> D_in ln Rinv (fun x:R => 0 < x) y.
 Proof.
-  intros y Hy; unfold D_in in |- *.
+  intros y Hy; unfold D_in.
   apply limit1_ext with
     (f := fun x:R => / ((exp (ln x) - exp (ln y)) / (ln x - ln y))).
   intros x [HD1 HD2]; repeat rewrite exp_ln.
-  unfold Rdiv in |- *; rewrite Rinv_mult_distr.
+  unfold Rdiv; rewrite Rinv_mult_distr.
   rewrite Rinv_involutive.
   apply Rmult_comm.
   apply Rminus_eq_contra.
-  red in |- *; intros H2; case HD2.
-  symmetry  in |- *; apply (ln_inv _ _ HD1 Hy H2).
-  apply Rminus_eq_contra; apply (sym_not_eq HD2).
-  apply Rinv_neq_0_compat; apply Rminus_eq_contra; red in |- *; intros H2;
+  red; intros H2; case HD2.
+  symmetry ; apply (ln_inv _ _ HD1 Hy H2).
+  apply Rminus_eq_contra; apply (not_eq_sym HD2).
+  apply Rinv_neq_0_compat; apply Rminus_eq_contra; red; intros H2;
     case HD2; apply ln_inv; auto.
   assumption.
   assumption.
@@ -575,62 +574,62 @@ Proof.
   intros x [H1 H2]; split.
   split; auto.
   split; auto.
-  red in |- *; intros H3; case H2; apply ln_inv; auto.
+  red; intros H3; case H2; apply ln_inv; auto.
   apply limit_comp with
     (l := ln y) (g := fun x:R => (exp x - exp (ln y)) / (x - ln y)) (f := ln).
   apply ln_continue; auto.
   assert (H0 := derivable_pt_lim_exp (ln y)); unfold derivable_pt_lim in H0;
-    unfold limit1_in in |- *; unfold limit_in in |- *;
-      simpl in |- *; unfold R_dist in |- *; intros; elim (H0 _ H);
+    unfold limit1_in; unfold limit_in;
+      simpl; unfold R_dist; intros; elim (H0 _ H);
         intros; exists (pos x); split.
   apply (cond_pos x).
-  intros; pattern y at 3 in |- *; rewrite <- exp_ln.
-  pattern x0 at 1 in |- *; replace x0 with (ln y + (x0 - ln y));
+  intros; pattern y at 3; rewrite <- exp_ln.
+  pattern x0 at 1; replace x0 with (ln y + (x0 - ln y));
     [ idtac | ring ].
   apply H1.
   elim H2; intros H3 _; unfold D_x in H3; elim H3; clear H3; intros _ H3;
-    apply Rminus_eq_contra; apply (sym_not_eq (A:=R));
+    apply Rminus_eq_contra; apply (not_eq_sym (A:=R));
       apply H3.
   elim H2; clear H2; intros _ H2; apply H2.
   assumption.
-  red in |- *; intro; rewrite H in Hy; elim (Rlt_irrefl _ Hy).
+  red; intro; rewrite H in Hy; elim (Rlt_irrefl _ Hy).
 Qed.
 
 Lemma derivable_pt_lim_ln : forall x:R, 0 < x -> derivable_pt_lim ln x (/ x).
 Proof.
   intros; assert (H0 := Dln x H); unfold D_in in H0; unfold limit1_in in H0;
     unfold limit_in in H0; simpl in H0; unfold R_dist in H0;
-      unfold derivable_pt_lim in |- *; intros; elim (H0 _ H1);
+      unfold derivable_pt_lim; intros; elim (H0 _ H1);
         intros; elim H2; clear H2; intros; set (alp := Rmin x0 (x / 2));
           assert (H4 : 0 < alp).
-  unfold alp in |- *; unfold Rmin in |- *; case (Rle_dec x0 (x / 2)); intro.
+  unfold alp; unfold Rmin; case (Rle_dec x0 (x / 2)); intro.
   apply H2.
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+  unfold Rdiv; apply Rmult_lt_0_compat;
     [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
-  exists (mkposreal _ H4); intros; pattern h at 2 in |- *;
+  exists (mkposreal _ H4); intros; pattern h at 2;
     replace h with (x + h - x); [ idtac | ring ].
   apply H3; split.
-  unfold D_x in |- *; split.
+  unfold D_x; split.
   case (Rcase_abs h); intro.
   assert (H7 : Rabs h < x / 2).
   apply Rlt_le_trans with alp.
   apply H6.
-  unfold alp in |- *; apply Rmin_r.
+  unfold alp; apply Rmin_r.
   apply Rlt_trans with (x / 2).
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+  unfold Rdiv; apply Rmult_lt_0_compat;
     [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
   rewrite Rabs_left in H7.
   apply Rplus_lt_reg_r with (- h - x / 2).
   replace (- h - x / 2 + x / 2) with (- h); [ idtac | ring ].
-  pattern x at 2 in |- *; rewrite double_var.
+  pattern x at 2; rewrite double_var.
   replace (- h - x / 2 + (x / 2 + x / 2 + h)) with (x / 2); [ apply H7 | ring ].
   apply r.
   apply Rplus_lt_le_0_compat; [ assumption | apply Rge_le; apply r ].
-  apply (sym_not_eq (A:=R)); apply Rminus_not_eq; replace (x + h - x) with h;
+  apply (not_eq_sym (A:=R)); apply Rminus_not_eq; replace (x + h - x) with h;
     [ apply H5 | ring ].
   replace (x + h - x) with h;
   [ apply Rlt_le_trans with alp;
-    [ apply H6 | unfold alp in |- *; apply Rmin_l ]
+    [ apply H6 | unfold alp; apply Rmin_l ]
     | ring ].
 Qed.
 
@@ -638,7 +637,7 @@ Theorem D_in_imp :
   forall (f g:R -> R) (D D1:R -> Prop) (x:R),
     (forall x:R, D1 x -> D x) -> D_in f g D x -> D_in f g D1 x.
 Proof.
-  intros f g D D1 x H; unfold D_in in |- *.
+  intros f g D D1 x H; unfold D_in.
   intros H0; apply limit1_imp with (D := D_x D x); auto.
   intros x1 [H1 H2]; split; auto.
 Qed.
@@ -647,7 +646,7 @@ Theorem D_in_ext :
   forall (f g h:R -> R) (D:R -> Prop) (x:R),
     f x = g x -> D_in h f D x -> D_in h g D x.
 Proof.
-  intros f g h D x H; unfold D_in in |- *.
+  intros f g h D x H; unfold D_in.
   rewrite H; auto.
 Qed.
 
@@ -662,7 +661,7 @@ Proof.
   intros x H0; repeat split.
   assumption.
   apply D_in_ext with (f := fun x:R => / x * (z * exp (z * ln x))).
-  unfold Rminus in |- *; rewrite Rpower_plus; rewrite Rpower_Ropp;
+  unfold Rminus; rewrite Rpower_plus; rewrite Rpower_Ropp;
     rewrite (Rpower_1 _ H); unfold Rpower; ring.
   apply Dcomp with
     (f := ln)
@@ -675,7 +674,7 @@ Proof.
   intros x H1; repeat split; auto.
   apply
     (Dcomp (fun _:R => True) (fun _:R => True) (fun x => z) exp
-      (fun x:R => z * x) exp); simpl in |- *.
+      (fun x:R => z * x) exp); simpl.
   apply D_in_ext with (f := fun x:R => z * 1).
   apply Rmult_1_r.
   apply (Dmult_const (fun x => True) (fun x => x) (fun x => 1)); apply Dx.
@@ -688,16 +687,16 @@ Theorem derivable_pt_lim_power :
     0 < x -> derivable_pt_lim (fun x => x ^R y) x (y * x ^R (y - 1)).
 Proof.
   intros x y H.
-  unfold Rminus in |- *; rewrite Rpower_plus.
+  unfold Rminus; rewrite Rpower_plus.
   rewrite Rpower_Ropp.
   rewrite Rpower_1; auto.
   rewrite <- Rmult_assoc.
-  unfold Rpower in |- *.
+  unfold Rpower.
   apply derivable_pt_lim_comp with (f1 := ln) (f2 := fun x => exp (y * x)).
   apply derivable_pt_lim_ln; assumption.
   rewrite (Rmult_comm y).
   apply derivable_pt_lim_comp with (f1 := fun x => y * x) (f2 := exp).
-  pattern y at 2 in |- *; replace y with (0 * ln x + y * 1).
+  pattern y at 2; replace y with (0 * ln x + y * 1).
   apply derivable_pt_lim_mult with (f1 := fun x:R => y) (f2 := fun x:R => x).
   apply derivable_pt_lim_const with (a := y).
   apply derivable_pt_lim_id.
diff --git a/theories/Reals/Rprod.v b/theories/Reals/Rprod.v
index 947dbb11..88c4de23 100644
--- a/theories/Reals/Rprod.v
+++ b/theories/Reals/Rprod.v
@@ -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-2012     *)
 (*   \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.
 Require Import Rseries.
 Require Import PartSum.
 Require Import Binomial.
-Open Local Scope R_scope.
+Local Open 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)
@@ -38,7 +36,7 @@ Proof.
   replace (S n - k - 1)%nat with O; [rewrite H1; simpl|omega].
   replace (n+1+0)%nat with (S n); ring.
   replace (S n - k-1)%nat with (S (n - k-1));[idtac|omega].
-  simpl in |- *; replace (k + S (n - k))%nat with (S n).
+  simpl; replace (k + S (n - k))%nat with (S n).
   replace (k + 1 + S (n - k - 1))%nat with (S n).
   rewrite Hrecn; [ ring | assumption ].
   omega.
@@ -51,8 +49,8 @@ Lemma prod_SO_pos :
     (forall n:nat, (n <= N)%nat -> 0 <= An n) -> 0 <= prod_f_R0 An N.
 Proof.
   intros; induction  N as [| N HrecN].
-  simpl in |- *; apply H; trivial.
-  simpl in |- *; apply Rmult_le_pos.
+  simpl; apply H; trivial.
+  simpl; apply Rmult_le_pos.
   apply HrecN; intros; apply H; apply le_trans with N;
     [ assumption | apply le_n_Sn ].
   apply H; apply le_n.
@@ -66,7 +64,7 @@ Lemma prod_SO_Rle :
 Proof.
   intros; induction  N as [| N HrecN].
   elim  H with O; trivial.
-  simpl in |- *; apply Rle_trans with (prod_f_R0 An N * Bn (S N)).
+  simpl; apply Rle_trans with (prod_f_R0 An N * Bn (S N)).
   apply Rmult_le_compat_l.
   apply prod_SO_pos; intros; elim (H n (le_trans _ _ _ H0 (le_n_Sn N))); intros;
     assumption.
@@ -116,7 +114,7 @@ Proof.
      (if eq_nat_dec n 0 then 1 else INR n) = INR n).
   intros n; case (eq_nat_dec n 0); auto with real.
   intros; absurd (0 < n)%nat; omega.
-  intros; unfold Rsqr in |- *; repeat rewrite fact_prodSO.
+  intros; unfold Rsqr; repeat rewrite fact_prodSO.
   cut ((k=N)%nat \/ (k < N)%nat \/ (N < k)%nat).
   intro H2; elim H2; intro H3.
   rewrite H3; replace (2*N-N)%nat with N;[right; ring|omega].
@@ -166,14 +164,14 @@ Qed.
 (**********)
 Lemma INR_fact_lt_0 : forall n:nat, 0 < INR (fact n).
 Proof.
-  intro; apply lt_INR_0; apply neq_O_lt; red in |- *; intro;
-    elim (fact_neq_0 n); symmetry  in |- *; assumption.
+  intro; apply lt_INR_0; apply neq_O_lt; red; intro;
+    elim (fact_neq_0 n); symmetry ; assumption.
 Qed.
 
 (** We have the following inequality : (C 2N k) <= (C 2N N) forall k in [|O;2N|] *)
 Lemma C_maj : forall N k:nat, (k <= 2 * N)%nat -> C (2 * N) k <= C (2 * N) N.
 Proof.
-  intros; unfold C in |- *; unfold Rdiv in |- *; apply Rmult_le_compat_l.
+  intros; unfold C; unfold Rdiv; apply Rmult_le_compat_l.
   apply pos_INR.
   replace (2 * N - N)%nat with N.
   apply Rmult_le_reg_l with (INR (fact N) * INR (fact N)).
diff --git a/theories/Reals/Rseries.v b/theories/Reals/Rseries.v
index db0fddad..3c10725b 100644
--- a/theories/Reals/Rseries.v
+++ b/theories/Reals/Rseries.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-2012     *)
 (*   \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.
+Local Open Scope R_scope.
 
 Implicit Type r : R.
 
@@ -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)
@@ -57,20 +54,20 @@ Section sequence.
 (*********)
   Lemma EUn_noempty :  exists r : R, EUn r.
   Proof.
-    unfold EUn in |- *; split with (Un 0); split with 0%nat; trivial.
+    unfold EUn; split with (Un 0); split with 0%nat; trivial.
   Qed.
 
 (*********)
   Lemma Un_in_EUn : forall n:nat, EUn (Un n).
   Proof.
-    intro; unfold EUn in |- *; split with n; trivial.
+    intro; unfold EUn; split with n; trivial.
   Qed.
 
 (*********)
   Lemma Un_bound_imp :
     forall x:R, (forall n:nat, Un n <= x) -> is_upper_bound EUn x.
   Proof.
-    intros; unfold is_upper_bound in |- *; intros; unfold EUn in H0; elim H0;
+    intros; unfold is_upper_bound; intros; unfold EUn in H0; elim H0;
       clear H0; intros; generalize (H x1); intro; rewrite <- H0 in H1;
         trivial.
   Qed.
@@ -80,7 +77,7 @@ Section sequence.
     forall n m:nat, Un_growing -> (n >= m)%nat -> Un n >= Un m.
   Proof.
     double induction n m; intros.
-    unfold Rge in |- *; right; trivial.
+    unfold Rge; right; trivial.
     exfalso; unfold ge in H1; generalize (le_Sn_O n0); intro; auto.
     cut (n0 >= 0)%nat.
     generalize H0; intros; unfold Un_growing in H0;
@@ -92,7 +89,7 @@ Section sequence.
     elim y; clear y; intro y.
     unfold ge in H2; generalize (le_not_lt n0 n1 (le_S_n n0 n1 H2)); intro;
       exfalso; auto.
-    rewrite y; unfold Rge in |- *; right; trivial.
+    rewrite y; unfold Rge; right; trivial.
     unfold ge in H0; generalize (H0 (S n0) H1 (lt_le_S n0 n1 y)); intro;
       unfold Un_growing in H1;
         apply
@@ -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 _ _ (eq_refl _))).
+    apply Rle_antisym with (2 := proj1 (Hsum n)).
+    now rewrite <- Hm.
+
+    assert (Hub: forall n, Un n <= l - eps).
+    intros n.
+    generalize (eq_refl (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 eq_refl.
+    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.
 
 (*********)
@@ -149,20 +272,20 @@ Section sequence.
   Proof.
     intro; induction  N as [| N HrecN].
     split with (Un 0); intros; rewrite (le_n_O_eq n H);
-      apply (Req_le (Un n) (Un n) (refl_equal (Un n))).
+      apply (Req_le (Un n) (Un n) (eq_refl (Un n))).
     elim HrecN; clear HrecN; intros; split with (Rmax (Un (S N)) x); intros;
       elim (Rmax_Rle (Un (S N)) x (Un n)); intros; clear H1;
         inversion H0.
     rewrite <- H1; rewrite <- H1 in H2;
       apply
-        (H2 (or_introl (Un n <= x) (Req_le (Un n) (Un n) (refl_equal (Un n))))).
+        (H2 (or_introl (Un n <= x) (Req_le (Un n) (Un n) (eq_refl (Un n))))).
     apply (H2 (or_intror (Un n <= Un (S N)) (H n H3))).
   Qed.
 
 (*********)
   Lemma cauchy_bound : Cauchy_crit -> bound EUn.
   Proof.
-    unfold Cauchy_crit, bound in |- *; intros; unfold is_upper_bound in |- *;
+    unfold Cauchy_crit, bound; intros; unfold is_upper_bound;
       unfold Rgt in H; elim (H 1 Rlt_0_1); clear H; intros;
         generalize (H x); intro; generalize (le_dec x); intro;
           elim (finite_greater x); intros; split with (Rmax x0 (Un x + 1));
@@ -201,12 +324,12 @@ End Isequence.
 Lemma GP_infinite :
   forall x:R, Rabs x < 1 -> Pser (fun n:nat => 1) x (/ (1 - x)).
 Proof.
-  intros; unfold Pser in |- *; unfold infinite_sum in |- *; intros;
+  intros; unfold Pser; unfold infinite_sum; intros;
     elim (Req_dec x 0).
   intros; exists 0%nat; intros; rewrite H1; rewrite Rminus_0_r; rewrite Rinv_1;
     cut (sum_f_R0 (fun n0:nat => 1 * 0 ^ n0) n = 1).
   intros; rewrite H3; rewrite R_dist_eq; auto.
-  elim n; simpl in |- *.
+  elim n; simpl.
   ring.
   intros; rewrite H3; ring.
   intro; cut (0 < eps * (Rabs (1 - x) * Rabs (/ x))).
@@ -221,11 +344,11 @@ Proof.
   apply Rabs_pos_lt.
   apply Rminus_eq_contra.
   apply Rlt_dichotomy_converse.
-  right; unfold Rgt in |- *.
+  right; unfold Rgt.
   apply (Rle_lt_trans x (Rabs x) 1).
   apply RRle_abs.
   assumption.
-  unfold R_dist in |- *; rewrite <- Rabs_mult.
+  unfold R_dist; rewrite <- Rabs_mult.
   rewrite Rmult_minus_distr_l.
   cut
     ((1 - x) * sum_f_R0 (fun n0:nat => x ^ n0) n =
@@ -236,7 +359,7 @@ Proof.
   cut (- (x ^ (n + 1) - 1) - 1 = - x ^ (n + 1)).
   intro; rewrite H7.
   rewrite Rabs_Ropp; cut ((n + 1)%nat = S n); auto.
-  intro H8; rewrite H8; simpl in |- *; rewrite Rabs_mult;
+  intro H8; rewrite H8; simpl; rewrite Rabs_mult;
     apply
       (Rlt_le_trans (Rabs x * Rabs (x ^ n))
         (Rabs x * (eps * (Rabs (1 - x) * Rabs (/ x)))) (
@@ -250,7 +373,7 @@ Proof.
       Rabs x * Rabs (/ x) * (eps * Rabs (1 - x))).
   clear H8; intros; rewrite H8; rewrite <- Rabs_mult; rewrite Rinv_r.
   rewrite Rabs_R1; cut (1 * (eps * Rabs (1 - x)) = Rabs (1 - x) * eps).
-  intros; rewrite H9; unfold Rle in |- *; right; reflexivity.
+  intros; rewrite H9; unfold Rle; right; reflexivity.
   ring.
   assumption.
   ring.
@@ -258,12 +381,12 @@ Proof.
   ring.
   apply Rminus_eq_contra.
   apply Rlt_dichotomy_converse.
-  right; unfold Rgt in |- *.
+  right; unfold Rgt.
   apply (Rle_lt_trans x (Rabs x) 1).
   apply RRle_abs.
   assumption.
   ring; ring.
-  elim n; simpl in |- *.
+  elim n; simpl.
   ring.
   intros; rewrite H5.
   ring.
@@ -273,7 +396,7 @@ Proof.
   apply Rabs_pos_lt.
   apply Rminus_eq_contra.
   apply Rlt_dichotomy_converse.
-  right; unfold Rgt in |- *.
+  right; unfold Rgt.
   apply (Rle_lt_trans x (Rabs x) 1).
   apply RRle_abs.
   assumption.
diff --git a/theories/Reals/Rsigma.v b/theories/Reals/Rsigma.v
index fad19ed2..76b44d96 100644
--- a/theories/Reals/Rsigma.v
+++ b/theories/Reals/Rsigma.v
@@ -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-2012     *)
 (*   \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.
 Require Import PartSum.
-Open Local Scope R_scope.
+Local Open Scope R_scope.
 
 Set Implicit Arguments.
 
@@ -30,8 +28,8 @@ Section Sigma.
   Proof.
     intros; induction  k as [| k Hreck].
     cut (low = 0%nat).
-    intro; rewrite H1; unfold sigma in |- *; rewrite <- minus_n_n;
-      rewrite <- minus_n_O; simpl in |- *; replace (high - 1)%nat with (pred high).
+    intro; rewrite H1; unfold sigma; rewrite <- minus_n_n;
+      rewrite <- minus_n_O; simpl; replace (high - 1)%nat with (pred high).
     apply (decomp_sum (fun k:nat => f k)).
     assumption.
     apply pred_of_minus.
@@ -44,8 +42,8 @@ Section Sigma.
     apply Hreck.
     assumption.
     apply lt_trans with (S k); [ apply lt_n_Sn | assumption ].
-    unfold sigma in |- *; replace (high - S (S k))%nat with (pred (high - S k)).
-    pattern (S k) at 3 in |- *; replace (S k) with (S k + 0)%nat;
+    unfold sigma; replace (high - S (S k))%nat with (pred (high - S k)).
+    pattern (S k) at 3; replace (S k) with (S k + 0)%nat;
       [ idtac | ring ].
     replace (sum_f_R0 (fun k0:nat => f (S (S k) + k0)) (pred (high - S k))) with
     (sum_f_R0 (fun k0:nat => f (S k + S k0)) (pred (high - S k))).
@@ -57,12 +55,12 @@ Section Sigma.
     replace (high - S (S k))%nat with (high - S k - 1)%nat.
     apply pred_of_minus.
     omega.
-    unfold sigma in |- *; replace (S k - low)%nat with (S (k - low)).
-    pattern (S k) at 1 in |- *; replace (S k) with (low + S (k - low))%nat.
-    symmetry  in |- *; apply (tech5 (fun i:nat => f (low + i))).
+    unfold sigma; replace (S k - low)%nat with (S (k - low)).
+    pattern (S k) at 1; replace (S k) with (low + S (k - low))%nat.
+    symmetry ; apply (tech5 (fun i:nat => f (low + i))).
     omega.
     omega.
-    rewrite <- H2; unfold sigma in |- *; rewrite <- minus_n_n; simpl in |- *;
+    rewrite <- H2; unfold sigma; rewrite <- minus_n_n; simpl;
       replace (high - S low)%nat with (pred (high - low)).
     replace (sum_f_R0 (fun k0:nat => f (S (low + k0))) (pred (high - low))) with
     (sum_f_R0 (fun k0:nat => f (low + S k0)) (pred (high - low))).
@@ -81,7 +79,7 @@ Section Sigma.
       (low <= k)%nat ->
       (k < high)%nat -> sigma low high - sigma low k = sigma (S k) high.
   Proof.
-    intros low high k H1 H2; symmetry  in |- *; rewrite (sigma_split H1 H2); ring.
+    intros low high k H1 H2; symmetry ; rewrite (sigma_split H1 H2); ring.
   Qed.
 
   Theorem sigma_diff_neg :
@@ -102,8 +100,8 @@ Section Sigma.
     apply sigma_split.
     apply le_n.
     assumption.
-    unfold sigma in |- *; rewrite <- minus_n_n.
-    simpl in |- *.
+    unfold sigma; rewrite <- minus_n_n.
+    simpl.
     replace (low + 0)%nat with low; [ reflexivity | ring ].
   Qed.
 
@@ -115,20 +113,20 @@ Section Sigma.
       generalize (lt_le_weak low high H1); intro H3;
         replace (f high) with (sigma high high).
     rewrite Rplus_comm; cut (high = S (pred high)).
-    intro; pattern high at 3 in |- *; rewrite H.
+    intro; pattern high at 3; rewrite H.
     apply sigma_split.
     apply le_S_n; rewrite <- H; apply lt_le_S; assumption.
     apply lt_pred_n_n; apply le_lt_trans with low; [ apply le_O_n | assumption ].
     apply S_pred with 0%nat; apply le_lt_trans with low;
       [ apply le_O_n | assumption ].
-    unfold sigma in |- *; rewrite <- minus_n_n; simpl in |- *;
+    unfold sigma; rewrite <- minus_n_n; simpl;
       replace (high + 0)%nat with high; [ reflexivity | ring ].
   Qed.
 
   Theorem sigma_eq_arg : forall low:nat, sigma low low = f low.
   Proof.
-    intro; unfold sigma in |- *; rewrite <- minus_n_n.
-    simpl in |- *; replace (low + 0)%nat with low; [ reflexivity | ring ].
+    intro; unfold sigma; rewrite <- minus_n_n.
+    simpl; replace (low + 0)%nat with low; [ reflexivity | ring ].
   Qed.
 
 End Sigma.
diff --git a/theories/Reals/Rsqrt_def.v b/theories/Reals/Rsqrt_def.v
index f2095982..a6e48f83 100644
--- a/theories/Reals/Rsqrt_def.v
+++ b/theories/Reals/Rsqrt_def.v
@@ -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-2012     *)
 (*   \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.
 Require Import SeqSeries.
 Require Import Ranalysis1.
-Open Local Scope R_scope.
+Local Open 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 =>
@@ -43,20 +41,20 @@ Lemma dicho_comp :
 Proof.
   intros.
   induction  n as [| n Hrecn].
-  simpl in |- *; assumption.
-  simpl in |- *.
+  simpl; assumption.
+  simpl.
   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.
+  unfold Rdiv; apply Rmult_le_reg_l with 2.
   prove_sup0.
-  pattern 2 at 1 in |- *; rewrite Rmult_comm.
+  pattern 2 at 1; rewrite Rmult_comm.
   rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ idtac | discrR ].
   rewrite Rmult_1_r.
   rewrite double.
   apply Rplus_le_compat_l.
   assumption.
-  unfold Rdiv in |- *; apply Rmult_le_reg_l with 2.
+  unfold Rdiv; 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.
@@ -69,14 +67,14 @@ Lemma dicho_lb_growing :
   forall (x y:R) (P:R -> bool), x <= y -> Un_growing (dicho_lb x y P).
 Proof.
   intros.
-  unfold Un_growing in |- *.
+  unfold Un_growing.
   intro.
-  simpl in |- *.
+  simpl.
   case (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2)).
   right; reflexivity.
-  unfold Rdiv in |- *; apply Rmult_le_reg_l with 2.
+  unfold Rdiv; apply Rmult_le_reg_l with 2.
   prove_sup0.
-  pattern 2 at 1 in |- *; rewrite Rmult_comm.
+  pattern 2 at 1; rewrite Rmult_comm.
   rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ idtac | discrR ].
   rewrite Rmult_1_r.
   rewrite double.
@@ -89,13 +87,13 @@ Lemma dicho_up_decreasing :
   forall (x y:R) (P:R -> bool), x <= y -> Un_decreasing (dicho_up x y P).
 Proof.
   intros.
-  unfold Un_decreasing in |- *.
+  unfold Un_decreasing.
   intro.
-  simpl in |- *.
+  simpl.
   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.
+  unfold Rdiv; 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.
@@ -114,17 +112,17 @@ Lemma dicho_lb_maj_y :
 Proof.
   intros.
   induction  n as [| n Hrecn].
-  simpl in |- *; assumption.
-  simpl in |- *.
+  simpl; assumption.
+  simpl.
   case (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2)).
   assumption.
-  unfold Rdiv in |- *; apply Rmult_le_reg_l with 2.
+  unfold Rdiv; 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.
-  pattern y at 2 in |- *; replace y with (Dichotomy_ub x y P 0);
+  pattern y at 2; replace y with (Dichotomy_ub x y P 0);
     [ idtac | reflexivity ].
   apply decreasing_prop.
   assert (H0 := dicho_up_decreasing x y P H).
@@ -138,10 +136,10 @@ Proof.
   intros.
   cut (forall n:nat, dicho_lb x y P n <= y).
   intro.
-  unfold has_ub in |- *.
-  unfold bound in |- *.
+  unfold has_ub.
+  unfold bound.
   exists y.
-  unfold is_upper_bound in |- *.
+  unfold is_upper_bound.
   intros.
   elim H1; intros.
   rewrite H2; apply H0.
@@ -153,15 +151,15 @@ Lemma dicho_up_min_x :
 Proof.
   intros.
   induction  n as [| n Hrecn].
-  simpl in |- *; assumption.
-  simpl in |- *.
+  simpl; assumption.
+  simpl.
   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.
+  unfold Rdiv; apply Rmult_le_reg_l with 2.
   prove_sup0.
-  pattern 2 at 1 in |- *; rewrite Rmult_comm.
+  pattern 2 at 1; rewrite Rmult_comm.
   rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ rewrite Rmult_1_r | discrR ].
   rewrite double; apply Rplus_le_compat.
-  pattern x at 1 in |- *; replace x with (Dichotomy_lb x y P 0);
+  pattern x at 1; replace x with (Dichotomy_lb x y P 0);
     [ idtac | reflexivity ].
   apply tech9.
   assert (H0 := dicho_lb_growing x y P H).
@@ -177,14 +175,14 @@ Proof.
   intros.
   cut (forall n:nat, x <= dicho_up x y P n).
   intro.
-  unfold has_lb in |- *.
-  unfold bound in |- *.
+  unfold has_lb.
+  unfold bound.
   exists (- x).
-  unfold is_upper_bound in |- *.
+  unfold is_upper_bound.
   intros.
   elim H1; intros.
   rewrite H2.
-  unfold opp_seq in |- *.
+  unfold opp_seq.
   apply Ropp_le_contravar.
   apply H0.
   apply dicho_up_min_x; assumption.
@@ -216,35 +214,35 @@ Lemma dicho_lb_dicho_up :
 Proof.
   intros.
   induction  n as [| n Hrecn].
-  simpl in |- *.
-  unfold Rdiv in |- *; rewrite Rinv_1; ring.
-  simpl in |- *.
+  simpl.
+  unfold Rdiv; rewrite Rinv_1; ring.
+  simpl.
   case (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2)).
-  unfold Rdiv in |- *.
+  unfold Rdiv.
   replace
   ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) * / 2 - Dichotomy_lb x y P n)
     with ((dicho_up x y P n - dicho_lb x y P n) / 2).
-  unfold Rdiv in |- *; rewrite Hrecn.
-  unfold Rdiv in |- *.
+  unfold Rdiv; rewrite Hrecn.
+  unfold Rdiv.
   rewrite Rinv_mult_distr.
   ring.
   discrR.
   apply pow_nonzero; discrR.
-  pattern (Dichotomy_lb x y P n) at 2 in |- *;
+  pattern (Dichotomy_lb x y P n) at 2;
     rewrite (double_var (Dichotomy_lb x y P n));
-      unfold dicho_up, dicho_lb, Rminus, Rdiv in |- *; ring.
+      unfold dicho_up, dicho_lb, Rminus, Rdiv; ring.
   replace
   (Dichotomy_ub x y P n - (Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2)
     with ((dicho_up x y P n - dicho_lb x y P n) / 2).
-  unfold Rdiv in |- *; rewrite Hrecn.
-  unfold Rdiv in |- *.
+  unfold Rdiv; rewrite Hrecn.
+  unfold Rdiv.
   rewrite Rinv_mult_distr.
   ring.
   discrR.
   apply pow_nonzero; discrR.
-  pattern (Dichotomy_ub x y P n) at 1 in |- *;
+  pattern (Dichotomy_ub x y P n) at 1;
     rewrite (double_var (Dichotomy_ub x y P n));
-      unfold dicho_up, dicho_lb, Rminus, Rdiv in |- *; ring.
+      unfold dicho_up, dicho_lb, Rminus, Rdiv; ring.
 Qed.
 
 Definition pow_2_n (n:nat) := 2 ^ n.
@@ -252,23 +250,23 @@ Definition pow_2_n (n:nat) := 2 ^ n.
 Lemma pow_2_n_neq_R0 : forall n:nat, pow_2_n n <> 0.
 Proof.
   intro.
-  unfold pow_2_n in |- *.
+  unfold pow_2_n.
   apply pow_nonzero.
   discrR.
 Qed.
 
 Lemma pow_2_n_growing : Un_growing pow_2_n.
 Proof.
-  unfold Un_growing in |- *.
+  unfold Un_growing.
   intro.
   replace (S n) with (n + 1)%nat;
-  [ unfold pow_2_n in |- *; rewrite pow_add | ring ].
-  pattern (2 ^ n) at 1 in |- *; rewrite <- Rmult_1_r.
+  [ unfold pow_2_n; rewrite pow_add | ring ].
+  pattern (2 ^ n) at 1; rewrite <- Rmult_1_r.
   apply Rmult_le_compat_l.
   left; apply pow_lt; prove_sup0.
-  simpl in |- *.
+  simpl.
   rewrite Rmult_1_r.
-  pattern 1 at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left;
+  pattern 1 at 1; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left;
     apply Rlt_0_1.
 Qed.
 
@@ -276,7 +274,7 @@ Lemma pow_2_n_infty : cv_infty pow_2_n.
 Proof.
   cut (forall N:nat, INR N <= 2 ^ N).
   intros.
-  unfold cv_infty in |- *.
+  unfold cv_infty.
   intro.
   case (total_order_T 0 M); intro.
   elim s; intro.
@@ -289,41 +287,41 @@ Proof.
   apply Rlt_le_trans with (INR N0).
   rewrite INR_IZR_INZ.
   rewrite <- H1.
-  unfold N in |- *.
+  unfold N.
   assert (H3 := archimed M).
   elim H3; intros; assumption.
   apply Rle_trans with (pow_2_n N0).
-  unfold pow_2_n in |- *; apply H.
+  unfold pow_2_n; apply H.
   apply Rge_le.
   apply growing_prop.
   apply pow_2_n_growing.
   assumption.
   apply le_IZR.
-  unfold N in |- *.
-  simpl in |- *.
+  unfold N.
+  simpl.
   assert (H0 := archimed M); elim H0; intros.
   left; apply Rlt_trans with M; assumption.
   exists 0%nat; intros.
   rewrite <- b.
-  unfold pow_2_n in |- *; apply pow_lt; prove_sup0.
+  unfold pow_2_n; apply pow_lt; prove_sup0.
   exists 0%nat; intros.
   apply Rlt_trans with 0.
   assumption.
-  unfold pow_2_n in |- *; apply pow_lt; prove_sup0.
+  unfold pow_2_n; apply pow_lt; prove_sup0.
   simple induction N.
-  simpl in |- *.
+  simpl.
   left; apply Rlt_0_1.
   intros.
-  pattern (S n) at 2 in |- *; replace (S n) with (n + 1)%nat; [ idtac | ring ].
+  pattern (S n) at 2; replace (S n) with (n + 1)%nat; [ idtac | ring ].
   rewrite S_INR; rewrite pow_add.
-  simpl in |- *.
+  simpl.
   rewrite Rmult_1_r.
   apply Rle_trans with (2 ^ n).
   rewrite <- (Rplus_comm 1).
   rewrite <- (Rmult_1_r (INR n)).
   apply (poly n 1).
   apply Rlt_0_1.
-  pattern (2 ^ n) at 1 in |- *; rewrite <- Rplus_0_r.
+  pattern (2 ^ n) at 1; rewrite <- Rplus_0_r.
   rewrite <- (Rmult_comm 2).
   rewrite double.
   apply Rplus_le_compat_l.
@@ -340,8 +338,8 @@ Proof.
   cut (Un_cv (fun i:nat => dicho_lb x y P i - dicho_up x y P i) 0).
   intro.
   assert (H4 := UL_sequence _ _ _ H2 H3).
-  symmetry  in |- *; apply Rminus_diag_uniq_sym; assumption.
-  unfold Un_cv in |- *; unfold R_dist in |- *.
+  symmetry ; apply Rminus_diag_uniq_sym; assumption.
+  unfold Un_cv; unfold R_dist.
   intros.
   assert (H4 := cv_infty_cv_R0 pow_2_n pow_2_n_neq_R0 pow_2_n_infty).
   case (total_order_T x y); intro.
@@ -358,7 +356,7 @@ Proof.
   rewrite <- Rabs_Ropp.
   rewrite Ropp_minus_distr'.
   rewrite dicho_lb_dicho_up.
-  unfold Rdiv in |- *; rewrite Rabs_mult.
+  unfold Rdiv; rewrite Rabs_mult.
   rewrite (Rabs_right (y - x)).
   apply Rmult_lt_reg_l with (/ (y - x)).
   apply Rinv_0_lt_compat; assumption.
@@ -368,12 +366,12 @@ Proof.
   [ unfold pow_2_n, Rdiv in H6; rewrite <- (Rmult_comm eps); apply H6;
     assumption
     | ring ].
-  red in |- *; intro; rewrite H8 in Hyp; elim (Rlt_irrefl _ Hyp).
+  red; intro; rewrite H8 in Hyp; elim (Rlt_irrefl _ Hyp).
   apply Rle_ge.
   apply Rplus_le_reg_l with x; rewrite Rplus_0_r.
   replace (x + (y - x)) with y; [ assumption | ring ].
   assumption.
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+  unfold Rdiv; apply Rmult_lt_0_compat;
     [ assumption | apply Rinv_0_lt_compat; assumption ].
   apply Rplus_lt_reg_r with x; rewrite Rplus_0_r.
   replace (x + (y - x)) with y; [ assumption | ring ].
@@ -384,7 +382,7 @@ Proof.
   rewrite Ropp_minus_distr'.
   rewrite dicho_lb_dicho_up.
   rewrite b.
-  unfold Rminus, Rdiv in |- *; rewrite Rplus_opp_r; rewrite Rmult_0_l;
+  unfold Rminus, Rdiv; rewrite Rplus_opp_r; rewrite Rmult_0_l;
     rewrite Rabs_R0; assumption.
   assumption.
   elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)).
@@ -401,26 +399,26 @@ Lemma continuity_seq :
   forall (f:R -> R) (Un:nat -> R) (l:R),
     continuity_pt f l -> Un_cv Un l -> Un_cv (fun i:nat => f (Un i)) (f l).
 Proof.
-  unfold continuity_pt, Un_cv in |- *; unfold continue_in in |- *.
-  unfold limit1_in in |- *.
-  unfold limit_in in |- *.
-  unfold dist in |- *.
-  simpl in |- *.
-  unfold R_dist in |- *.
+  unfold continuity_pt, Un_cv; unfold continue_in.
+  unfold limit1_in.
+  unfold limit_in.
+  unfold dist.
+  simpl.
+  unfold R_dist.
   intros.
   elim (H eps H1); intros alp H2.
   elim H2; intros.
   elim (H0 alp H3); intros N H5.
   exists N; intros.
   case (Req_dec (Un n) l); intro.
-  rewrite H7; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+  rewrite H7; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0;
     assumption.
   apply H4.
   split.
-  unfold D_x, no_cond in |- *.
+  unfold D_x, no_cond.
   split.
   trivial.
-  apply (sym_not_eq (A:=R)); assumption.
+  apply (not_eq_sym (A:=R)); assumption.
   apply H5; assumption.
 Qed.
 
@@ -430,9 +428,9 @@ Lemma dicho_lb_car :
 Proof.
   intros.
   induction  n as [| n Hrecn].
-  simpl in |- *.
+  simpl.
   assumption.
-  simpl in |- *.
+  simpl.
   assert
     (X :=
       sumbool_of_bool (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2))).
@@ -449,9 +447,9 @@ Lemma dicho_up_car :
 Proof.
   intros.
   induction  n as [| n Hrecn].
-  simpl in |- *.
+  simpl.
   assumption.
-  simpl in |- *.
+  simpl.
   assert
     (X :=
       sumbool_of_bool (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2))).
@@ -482,7 +480,7 @@ Proof.
   split.
   split.
   apply Rle_trans with (dicho_lb x y (fun z:R => cond_positivity (f z)) 0).
-  simpl in |- *.
+  simpl.
   right; reflexivity.
   apply growing_ineq.
   apply dicho_lb_growing; assumption.
@@ -505,7 +503,7 @@ Proof.
   assert (H10 := H5 H7).
   apply Rle_antisym; assumption.
   intro.
-  unfold Wn in |- *.
+  unfold Wn.
   cut (forall z:R, cond_positivity z = true <-> 0 <= z).
   intro.
   assert (H8 := dicho_up_car x y (fun z:R => cond_positivity (f z)) n).
@@ -516,7 +514,7 @@ Proof.
   apply H12.
   left; assumption.
   intro.
-  unfold cond_positivity in |- *.
+  unfold cond_positivity.
   case (Rle_dec 0 z); intro.
   split.
   intro; assumption.
@@ -525,7 +523,7 @@ Proof.
   intro feqt;discriminate feqt.
   intro.
   elim n0; assumption.
-  unfold Vn in |- *.
+  unfold Vn.
   cut (forall z:R, cond_positivity z = false <-> z < 0).
   intros.
   assert (H8 := dicho_lb_car x y (fun z:R => cond_positivity (f z)) n).
@@ -537,7 +535,7 @@ Proof.
   apply H12.
   assumption.
   intro.
-  unfold cond_positivity in |- *.
+  unfold cond_positivity.
   case (Rle_dec 0 z); intro.
   split.
   intro feqt; discriminate feqt.
@@ -556,7 +554,7 @@ Proof.
   cut (0 < - f x0).
   intro.
   elim (H7 (- f x0) H8); intros.
-  cut (x2 >= x2)%nat; [ intro | unfold ge in |- *; apply le_n ].
+  cut (x2 >= x2)%nat; [ intro | unfold ge; apply le_n ].
   assert (H11 := H9 x2 H10).
   rewrite Rabs_right in H11.
   pattern (- f x0) at 1 in H11; rewrite <- Rplus_0_r in H11.
@@ -564,11 +562,11 @@ Proof.
   assert (H12 := Rplus_lt_reg_r _ _ _ H11).
   assert (H13 := H6 x2).
   elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H13 H12)).
-  apply Rle_ge; left; unfold Rminus in |- *; apply Rplus_le_lt_0_compat.
+  apply Rle_ge; left; unfold Rminus; apply Rplus_le_lt_0_compat.
   apply H6.
   exact H8.
   apply Ropp_0_gt_lt_contravar; assumption.
-  unfold Wn in |- *; assumption.
+  unfold Wn; assumption.
   cut (Un_cv Vn x0).
   intros.
   assert (H7 := continuity_seq f Vn x0 (H x0) H5).
@@ -576,7 +574,7 @@ Proof.
   elim s; intro.
   unfold Un_cv in H7; unfold R_dist in H7.
   elim (H7 (f x0) a); intros.
-  cut (x2 >= x2)%nat; [ intro | unfold ge in |- *; apply le_n ].
+  cut (x2 >= x2)%nat; [ intro | unfold ge; apply le_n ].
   assert (H10 := H8 x2 H9).
   rewrite Rabs_left in H10.
   pattern (f x0) at 2 in H10; rewrite <- Rplus_0_r in H10.
@@ -591,12 +589,12 @@ Proof.
   apply Ropp_0_gt_lt_contravar; assumption.
   apply Rplus_lt_reg_r with (f x0 - f (Vn x2)).
   rewrite Rplus_0_r; replace (f x0 - f (Vn x2) + (f (Vn x2) - f x0)) with 0;
-    [ unfold Rminus in |- *; apply Rplus_lt_le_0_compat | ring ].
+    [ unfold Rminus; apply Rplus_lt_le_0_compat | ring ].
   assumption.
   apply Ropp_0_ge_le_contravar; apply Rle_ge; apply H6.
   right; rewrite <- b; reflexivity.
   left; assumption.
-  unfold Vn in |- *; assumption.
+  unfold Vn; assumption.
 Qed.
 
 Lemma IVT_cor :
@@ -615,11 +613,11 @@ Proof.
   exists y.
   split.
   split; [ assumption | right; reflexivity ].
-  symmetry  in |- *; exact b.
+  symmetry ; exact b.
   exists x.
   split.
   split; [ right; reflexivity | assumption ].
-  symmetry  in |- *; exact b.
+  symmetry ; exact b.
   elim s; intro.
   cut (x < y).
   intro.
@@ -635,8 +633,8 @@ Proof.
   unfold opp_fct in H7.
   rewrite <- (Ropp_involutive (f x0)).
   apply Ropp_eq_0_compat; assumption.
-  unfold opp_fct in |- *; apply Ropp_0_gt_lt_contravar; assumption.
-  unfold opp_fct in |- *.
+  unfold opp_fct; apply Ropp_0_gt_lt_contravar; assumption.
+  unfold opp_fct.
   apply Rplus_lt_reg_r with (f x); rewrite Rplus_opp_r; rewrite Rplus_0_r;
     assumption.
   inversion H0.
@@ -646,7 +644,7 @@ Proof.
   exists x.
   split.
   split; [ right; reflexivity | assumption ].
-  symmetry  in |- *; assumption.
+  symmetry ; assumption.
   case (total_order_T 0 (f y)); intro.
   elim s; intro.
   cut (x < y).
@@ -659,7 +657,7 @@ Proof.
   exists y.
   split.
   split; [ assumption | right; reflexivity ].
-  symmetry  in |- *; assumption.
+  symmetry ; assumption.
   cut (0 < f x * f y).
   intro.
   elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H2 H1)).
@@ -692,18 +690,18 @@ Proof.
   elim H5; intros; assumption.
   unfold f in H6.
   apply Rminus_diag_uniq_sym; exact H6.
-  rewrite Rmult_comm; pattern 0 at 2 in |- *; rewrite <- (Rmult_0_r (f 1)).
+  rewrite Rmult_comm; pattern 0 at 2; rewrite <- (Rmult_0_r (f 1)).
   apply Rmult_le_compat_l; assumption.
-  unfold f in |- *.
+  unfold f.
   rewrite Rsqr_1.
   apply Rplus_le_reg_l with y.
-  rewrite Rplus_0_r; rewrite Rplus_comm; unfold Rminus in |- *;
+  rewrite Rplus_0_r; rewrite Rplus_comm; unfold Rminus;
     rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r;
       left; assumption.
   exists 1.
   split.
   left; apply Rlt_0_1.
-  rewrite b; symmetry  in |- *; apply Rsqr_1.
+  rewrite b; symmetry ; apply Rsqr_1.
   cut (0 <= f y).
   intro.
   cut (f 0 * f y <= 0).
@@ -716,14 +714,14 @@ Proof.
   elim H5; intros; assumption.
   unfold f in H6.
   apply Rminus_diag_uniq_sym; exact H6.
-  rewrite Rmult_comm; pattern 0 at 2 in |- *; rewrite <- (Rmult_0_r (f y)).
+  rewrite Rmult_comm; pattern 0 at 2; rewrite <- (Rmult_0_r (f y)).
   apply Rmult_le_compat_l; assumption.
-  unfold f in |- *.
+  unfold f.
   apply Rplus_le_reg_l with y.
-  rewrite Rplus_0_r; rewrite Rplus_comm; unfold Rminus in |- *;
+  rewrite Rplus_0_r; rewrite Rplus_comm; unfold Rminus;
     rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r.
-  pattern y at 1 in |- *; rewrite <- Rmult_1_r.
-  unfold Rsqr in |- *; apply Rmult_le_compat_l.
+  pattern y at 1; rewrite <- Rmult_1_r.
+  unfold Rsqr; apply Rmult_le_compat_l.
   assumption.
   left; exact r.
   replace f with (Rsqr - fct_cte y)%F.
@@ -731,8 +729,8 @@ Proof.
   apply derivable_continuous; apply derivable_Rsqr.
   apply derivable_continuous; apply derivable_const.
   reflexivity.
-  unfold f in |- *; rewrite Rsqr_0.
-  unfold Rminus in |- *; rewrite Rplus_0_l.
+  unfold f; rewrite Rsqr_0.
+  unfold Rminus; rewrite Rplus_0_l.
   apply Rge_le.
   apply Ropp_0_le_ge_contravar; assumption.
 Qed.
@@ -751,7 +749,7 @@ Proof.
   intros.
   elim p; intros.
   rewrite H in H0; assumption.
-  unfold Rsqrt in |- *.
+  unfold Rsqrt.
   case (Rsqrt_exists x (cond_nonneg x)).
   intros.
   elim p; elim a; intros.
@@ -772,7 +770,7 @@ Proof.
   rewrite <- H.
   elim p; intros.
   rewrite H1; reflexivity.
-  unfold Rsqrt in |- *.
+  unfold Rsqrt.
   case (Rsqrt_exists x (cond_nonneg x)).
   intros.
   elim p; elim a; intros.
diff --git a/theories/Reals/Rtopology.v b/theories/Reals/Rtopology.v
index 8e9b2bb3..51d0b99e 100644
--- a/theories/Reals/Rtopology.v
+++ b/theories/Reals/Rtopology.v
@@ -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-2012     *)
 (*   \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.
 Require Import RList.
 Require Import Classical_Prop.
 Require Import Classical_Pred_Type.
-Open Local Scope R_scope.
+Local Open Scope R_scope.
 
 (** * General definitions and propositions *)
 
@@ -32,16 +30,16 @@ Definition interior (D:R -> Prop) (x:R) : Prop := neighbourhood D x.
 
 Lemma interior_P1 : forall D:R -> Prop, included (interior D) D.
 Proof.
-  intros; unfold included in |- *; unfold interior in |- *; intros;
+  intros; unfold included; unfold interior; intros;
     unfold neighbourhood in H; elim H; intros; unfold included in H0;
-      apply H0; unfold disc in |- *; unfold Rminus in |- *;
+      apply H0; unfold disc; unfold Rminus;
         rewrite Rplus_opp_r; rewrite Rabs_R0; apply (cond_pos x0).
 Qed.
 
 Lemma interior_P2 : forall D:R -> Prop, open_set D -> included D (interior D).
 Proof.
-  intros; unfold open_set in H; unfold included in |- *; intros;
-    assert (H1 := H _ H0); unfold interior in |- *; apply H1.
+  intros; unfold open_set in H; unfold included; intros;
+    assert (H1 := H _ H0); unfold interior; apply H1.
 Qed.
 
 Definition point_adherent (D:R -> Prop) (x:R) : Prop :=
@@ -51,11 +49,11 @@ Definition adherence (D:R -> Prop) (x:R) : Prop := point_adherent D x.
 
 Lemma adherence_P1 : forall D:R -> Prop, included D (adherence D).
 Proof.
-  intro; unfold included in |- *; intros; unfold adherence in |- *;
-    unfold point_adherent in |- *; intros; exists x;
-      unfold intersection_domain in |- *; split.
+  intro; unfold included; intros; unfold adherence;
+    unfold point_adherent; intros; exists x;
+      unfold intersection_domain; split.
   unfold neighbourhood in H0; elim H0; intros; unfold included in H1; apply H1;
-    unfold disc in |- *; unfold Rminus in |- *; rewrite Rplus_opp_r;
+    unfold disc; unfold Rminus; rewrite Rplus_opp_r;
       rewrite Rabs_R0; apply (cond_pos x0).
   apply H.
 Qed.
@@ -64,29 +62,29 @@ Lemma included_trans :
   forall D1 D2 D3:R -> Prop,
     included D1 D2 -> included D2 D3 -> included D1 D3.
 Proof.
-  unfold included in |- *; intros; apply H0; apply H; apply H1.
+  unfold included; intros; apply H0; apply H; apply H1.
 Qed.
 
 Lemma interior_P3 : forall D:R -> Prop, open_set (interior D).
 Proof.
-  intro; unfold open_set, interior in |- *; unfold neighbourhood in |- *;
+  intro; unfold open_set, interior; unfold neighbourhood;
     intros; elim H; intros.
-  exists x0; unfold included in |- *; intros.
+  exists x0; unfold included; intros.
   set (del := x0 - Rabs (x - x1)).
   cut (0 < del).
   intro; exists (mkposreal del H2); intros.
   cut (included (disc x1 (mkposreal del H2)) (disc x x0)).
   intro; assert (H5 := included_trans _ _ _ H4 H0).
   apply H5; apply H3.
-  unfold included in |- *; unfold disc in |- *; intros.
+  unfold included; unfold disc; intros.
   apply Rle_lt_trans with (Rabs (x3 - x1) + Rabs (x1 - x)).
   replace (x3 - x) with (x3 - x1 + (x1 - x)); [ apply Rabs_triang | ring ].
   replace (pos x0) with (del + Rabs (x1 - x)).
   do 2 rewrite <- (Rplus_comm (Rabs (x1 - x))); apply Rplus_lt_compat_l;
     apply H4.
-  unfold del in |- *; rewrite <- (Rabs_Ropp (x - x1)); rewrite Ropp_minus_distr;
+  unfold del; rewrite <- (Rabs_Ropp (x - x1)); rewrite Ropp_minus_distr;
     ring.
-  unfold del in |- *; apply Rplus_lt_reg_r with (Rabs (x - x1));
+  unfold del; apply Rplus_lt_reg_r with (Rabs (x - x1));
     rewrite Rplus_0_r;
       replace (Rabs (x - x1) + (x0 - Rabs (x - x1))) with (pos x0);
       [ idtac | ring ].
@@ -97,7 +95,7 @@ Lemma complementary_P1 :
   forall D:R -> Prop,
     ~ (exists y : R, intersection_domain D (complementary D) y).
 Proof.
-  intro; red in |- *; intro; elim H; intros;
+  intro; red; intro; elim H; intros;
     unfold intersection_domain, complementary in H0; elim H0;
       intros; elim H2; assumption.
 Qed.
@@ -105,8 +103,8 @@ Qed.
 Lemma adherence_P2 :
   forall D:R -> Prop, closed_set D -> included (adherence D) D.
 Proof.
-  unfold closed_set in |- *; unfold open_set, complementary in |- *; intros;
-    unfold included, adherence in |- *; intros; assert (H1 := classic (D x));
+  unfold closed_set; unfold open_set, complementary; intros;
+    unfold included, adherence; intros; assert (H1 := classic (D x));
       elim H1; intro.
   assumption.
   assert (H3 := H _ H2); assert (H4 := H0 _ H3); elim H4; intros;
@@ -116,8 +114,8 @@ Qed.
 
 Lemma adherence_P3 : forall D:R -> Prop, closed_set (adherence D).
 Proof.
-  intro; unfold closed_set, adherence in |- *;
-    unfold open_set, complementary, point_adherent in |- *;
+  intro; unfold closed_set, adherence;
+    unfold open_set, complementary, point_adherent;
       intros;
         set
           (P :=
@@ -125,21 +123,21 @@ Proof.
               neighbourhood V x ->  exists y : R, intersection_domain V D y);
           assert (H0 := not_all_ex_not _ P H); elim H0; intros V0 H1;
             unfold P in H1; assert (H2 := imply_to_and _ _ H1);
-              unfold neighbourhood in |- *; elim H2; intros; unfold neighbourhood in H3;
-                elim H3; intros; exists x0; unfold included in |- *;
-                  intros; red in |- *; intro.
+              unfold neighbourhood; elim H2; intros; unfold neighbourhood in H3;
+                elim H3; intros; exists x0; unfold included;
+                  intros; red; intro.
   assert (H8 := H7 V0);
     cut (exists delta : posreal, (forall x:R, disc x1 delta x -> V0 x)).
   intro; assert (H10 := H8 H9); elim H4; assumption.
   cut (0 < x0 - Rabs (x - x1)).
   intro; set (del := mkposreal _ H9); exists del; intros;
-    unfold included in H5; apply H5; unfold disc in |- *;
+    unfold included in H5; apply H5; unfold disc;
       apply Rle_lt_trans with (Rabs (x2 - x1) + Rabs (x1 - x)).
   replace (x2 - x) with (x2 - x1 + (x1 - x)); [ apply Rabs_triang | ring ].
   replace (pos x0) with (del + Rabs (x1 - x)).
   do 2 rewrite <- (Rplus_comm (Rabs (x1 - x))); apply Rplus_lt_compat_l;
     apply H10.
-  unfold del in |- *; simpl in |- *; rewrite <- (Rabs_Ropp (x - x1));
+  unfold del; simpl; rewrite <- (Rabs_Ropp (x - x1));
     rewrite Ropp_minus_distr; ring.
   apply Rplus_lt_reg_r with (Rabs (x - x1)); rewrite Rplus_0_r;
     replace (Rabs (x - x1) + (x0 - Rabs (x - x1))) with (pos x0);
@@ -154,10 +152,10 @@ Infix "=_D" := eq_Dom (at level 70, no associativity).
 Lemma open_set_P1 : forall D:R -> Prop, open_set D <-> D =_D interior D.
 Proof.
   intro; split.
-  intro; unfold eq_Dom in |- *; split.
+  intro; unfold eq_Dom; split.
   apply interior_P2; assumption.
   apply interior_P1.
-  intro; unfold eq_Dom in H; elim H; clear H; intros; unfold open_set in |- *;
+  intro; unfold eq_Dom in H; elim H; clear H; intros; unfold open_set;
     intros; unfold included, interior in H; unfold included in H0;
       apply (H _ H1).
 Qed.
@@ -165,20 +163,20 @@ Qed.
 Lemma closed_set_P1 : forall D:R -> Prop, closed_set D <-> D =_D adherence D.
 Proof.
   intro; split.
-  intro; unfold eq_Dom in |- *; split.
+  intro; unfold eq_Dom; split.
   apply adherence_P1.
   apply adherence_P2; assumption.
-  unfold eq_Dom in |- *; unfold included in |- *; intros;
+  unfold eq_Dom; unfold included; intros;
     assert (H0 := adherence_P3 D); unfold closed_set in H0;
-      unfold closed_set in |- *; unfold open_set in |- *;
+      unfold closed_set; unfold open_set;
         unfold open_set in H0; intros; assert (H2 : complementary (adherence D) x).
-  unfold complementary in |- *; unfold complementary in H1; red in |- *; intro;
+  unfold complementary; unfold complementary in H1; red; intro;
     elim H; clear H; intros _ H; elim H1; apply (H _ H2).
-  assert (H3 := H0 _ H2); unfold neighbourhood in |- *;
+  assert (H3 := H0 _ H2); unfold neighbourhood;
     unfold neighbourhood in H3; elim H3; intros; exists x0;
-      unfold included in |- *; unfold included in H4; intros;
+      unfold included; unfold included in H4; intros;
         assert (H6 := H4 _ H5); unfold complementary in H6;
-          unfold complementary in |- *; red in |- *; intro;
+          unfold complementary; red; intro;
             elim H; clear H; intros H _; elim H6; apply (H _ H7).
 Qed.
 
@@ -186,8 +184,8 @@ Lemma neighbourhood_P1 :
   forall (D1 D2:R -> Prop) (x:R),
     included D1 D2 -> neighbourhood D1 x -> neighbourhood D2 x.
 Proof.
-  unfold included, neighbourhood in |- *; intros; elim H0; intros; exists x0;
-    intros; unfold included in |- *; unfold included in H1;
+  unfold included, neighbourhood; intros; elim H0; intros; exists x0;
+    intros; unfold included; unfold included in H1;
       intros; apply (H _ (H1 _ H2)).
 Qed.
 
@@ -195,12 +193,12 @@ Lemma open_set_P2 :
   forall D1 D2:R -> Prop,
     open_set D1 -> open_set D2 -> open_set (union_domain D1 D2).
 Proof.
-  unfold open_set in |- *; intros; unfold union_domain in H1; elim H1; intro.
+  unfold open_set; intros; unfold union_domain in H1; elim H1; intro.
   apply neighbourhood_P1 with D1.
-  unfold included, union_domain in |- *; tauto.
+  unfold included, union_domain; tauto.
   apply H; assumption.
   apply neighbourhood_P1 with D2.
-  unfold included, union_domain in |- *; tauto.
+  unfold included, union_domain; tauto.
   apply H0; assumption.
 Qed.
 
@@ -208,53 +206,53 @@ Lemma open_set_P3 :
   forall D1 D2:R -> Prop,
     open_set D1 -> open_set D2 -> open_set (intersection_domain D1 D2).
 Proof.
-  unfold open_set in |- *; intros; unfold intersection_domain in H1; elim H1;
+  unfold open_set; intros; unfold intersection_domain in H1; elim H1;
     intros.
   assert (H4 := H _ H2); assert (H5 := H0 _ H3);
-    unfold intersection_domain in |- *; unfold neighbourhood in H4, H5;
+    unfold intersection_domain; unfold neighbourhood in H4, H5;
       elim H4; clear H; intros del1 H; elim H5; clear H0;
         intros del2 H0; cut (0 < Rmin del1 del2).
   intro; set (del := mkposreal _ H6).
-  exists del; unfold included in |- *; intros; unfold included in H, H0;
+  exists del; unfold included; intros; unfold included in H, H0;
     unfold disc in H, H0, H7.
   split.
   apply H; apply Rlt_le_trans with (pos del).
   apply H7.
-  unfold del in |- *; simpl in |- *; apply Rmin_l.
+  unfold del; simpl; apply Rmin_l.
   apply H0; apply Rlt_le_trans with (pos del).
   apply H7.
-  unfold del in |- *; simpl in |- *; apply Rmin_r.
-  unfold Rmin in |- *; case (Rle_dec del1 del2); intro.
+  unfold del; simpl; apply Rmin_r.
+  unfold Rmin; case (Rle_dec del1 del2); intro.
   apply (cond_pos del1).
   apply (cond_pos del2).
 Qed.
 
 Lemma open_set_P4 : open_set (fun x:R => False).
 Proof.
-  unfold open_set in |- *; intros; elim H.
+  unfold open_set; intros; elim H.
 Qed.
 
 Lemma open_set_P5 : open_set (fun x:R => True).
 Proof.
-  unfold open_set in |- *; intros; unfold neighbourhood in |- *.
-  exists (mkposreal 1 Rlt_0_1); unfold included in |- *; intros; trivial.
+  unfold open_set; intros; unfold neighbourhood.
+  exists (mkposreal 1 Rlt_0_1); unfold included; intros; trivial.
 Qed.
 
 Lemma disc_P1 : forall (x:R) (del:posreal), open_set (disc x del).
 Proof.
   intros; assert (H := open_set_P1 (disc x del)).
   elim H; intros; apply H1.
-  unfold eq_Dom in |- *; split.
-  unfold included, interior, disc in |- *; intros;
+  unfold eq_Dom; split.
+  unfold included, interior, disc; intros;
     cut (0 < del - Rabs (x - x0)).
   intro; set (del2 := mkposreal _ H3).
-  exists del2; unfold included in |- *; intros.
+  exists del2; unfold included; intros.
   apply Rle_lt_trans with (Rabs (x1 - x0) + Rabs (x0 - x)).
   replace (x1 - x) with (x1 - x0 + (x0 - x)); [ apply Rabs_triang | ring ].
   replace (pos del) with (del2 + Rabs (x0 - x)).
   do 2 rewrite <- (Rplus_comm (Rabs (x0 - x))); apply Rplus_lt_compat_l.
   apply H4.
-  unfold del2 in |- *; simpl in |- *; rewrite <- (Rabs_Ropp (x - x0));
+  unfold del2; simpl; rewrite <- (Rabs_Ropp (x - x0));
     rewrite Ropp_minus_distr; ring.
   apply Rplus_lt_reg_r with (Rabs (x - x0)); rewrite Rplus_0_r;
     replace (Rabs (x - x0) + (del - Rabs (x - x0))) with (pos del);
@@ -280,19 +278,19 @@ Proof.
   elim H3; intros.
   exists (disc x (mkposreal del2 H4)).
   intros; unfold included in H1; split.
-  unfold neighbourhood, disc in |- *.
+  unfold neighbourhood, disc.
   exists (mkposreal del2 H4).
-  unfold included in |- *; intros; assumption.
-  intros; apply H1; unfold disc in |- *; case (Req_dec y x); intro.
-  rewrite H7; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+  unfold included; intros; assumption.
+  intros; apply H1; unfold disc; case (Req_dec y x); intro.
+  rewrite H7; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0;
     apply (cond_pos del1).
   apply H5; split.
-  unfold D_x, no_cond in |- *; split.
+  unfold D_x, no_cond; split.
   trivial.
-  apply (sym_not_eq (A:=R)); apply H7.
+  apply (not_eq_sym (A:=R)); apply H7.
   unfold disc in H6; apply H6.
-  intros; unfold continuity_pt in |- *; unfold continue_in in |- *;
-    unfold limit1_in in |- *; unfold limit_in in |- *;
+  intros; unfold continuity_pt; unfold continue_in;
+    unfold limit1_in; unfold limit_in;
       intros.
   assert (H1 := H (disc (f x) (mkposreal eps H0))).
   cut (neighbourhood (disc (f x) (mkposreal eps H0)) (f x)).
@@ -301,10 +299,10 @@ Proof.
     intros del1 H7.
   exists (pos del1); split.
   apply (cond_pos del1).
-  intros; elim H8; intros; simpl in H10; unfold R_dist in H10; simpl in |- *;
-    unfold R_dist in |- *; apply (H6 _ (H7 _ H10)).
-  unfold neighbourhood, disc in |- *; exists (mkposreal eps H0);
-    unfold included in |- *; intros; assumption.
+  intros; elim H8; intros; simpl in H10; unfold R_dist in H10; simpl;
+    unfold R_dist; apply (H6 _ (H7 _ H10)).
+  unfold neighbourhood, disc; exists (mkposreal eps H0);
+    unfold included; intros; assumption.
 Qed.
 
 Definition image_rec (f:R -> R) (D:R -> Prop) (x:R) : Prop := D (f x).
@@ -314,13 +312,13 @@ Lemma continuity_P2 :
   forall (f:R -> R) (D:R -> Prop),
     continuity f -> open_set D -> open_set (image_rec f D).
 Proof.
-  intros; unfold open_set in H0; unfold open_set in |- *; intros;
+  intros; unfold open_set in H0; unfold open_set; intros;
     assert (H2 := continuity_P1 f x); elim H2; intros H3 _;
-      assert (H4 := H3 (H x)); unfold neighbourhood, image_rec in |- *;
+      assert (H4 := H3 (H x)); unfold neighbourhood, image_rec;
         unfold image_rec in H1; assert (H5 := H4 D (H0 (f x) H1));
           elim H5; intros V0 H6; elim H6; intros; unfold neighbourhood in H7;
             elim H7; intros del H9; exists del; unfold included in H9;
-              unfold included in |- *; intros; apply (H8 _ (H9 _ H10)).
+              unfold included; intros; apply (H8 _ (H9 _ H10)).
 Qed.
 
 (**********)
@@ -331,9 +329,9 @@ Lemma continuity_P3 :
 Proof.
   intros; split.
   intros; apply continuity_P2; assumption.
-  intros; unfold continuity in |- *; unfold continuity_pt in |- *;
-    unfold continue_in in |- *; unfold limit1_in in |- *;
-      unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *;
+  intros; unfold continuity; unfold continuity_pt;
+    unfold continue_in; unfold limit1_in;
+      unfold limit_in; simpl; unfold R_dist;
         intros; cut (open_set (disc (f x) (mkposreal _ H0))).
   intro; assert (H2 := H _ H1).
   unfold open_set, image_rec in H2; cut (disc (f x) (mkposreal _ H0) (f x)).
@@ -342,7 +340,7 @@ Proof.
   exists (pos del); split.
   apply (cond_pos del).
   intros; unfold included in H5; apply H5; elim H6; intros; apply H8.
-  unfold disc in |- *; unfold Rminus in |- *; rewrite Rplus_opp_r;
+  unfold disc; unfold Rminus; rewrite Rplus_opp_r;
     rewrite Rabs_R0; apply H0.
   apply disc_P1.
 Qed.
@@ -360,23 +358,23 @@ Proof.
   cut (0 < D / 2).
   intro; exists (disc x (mkposreal _ H)).
   exists (disc y (mkposreal _ H)); split.
-  unfold neighbourhood in |- *; exists (mkposreal _ H); unfold included in |- *;
+  unfold neighbourhood; exists (mkposreal _ H); unfold included;
     tauto.
   split.
-  unfold neighbourhood in |- *; exists (mkposreal _ H); unfold included in |- *;
+  unfold neighbourhood; exists (mkposreal _ H); unfold included;
     tauto.
-  red in |- *; intro; elim H0; intros; unfold intersection_domain in H1;
+  red; intro; elim H0; intros; unfold intersection_domain in H1;
     elim H1; intros.
   cut (D < D).
   intro; elim (Rlt_irrefl _ H4).
-  change (Rabs (x - y) < D) in |- *;
+  change (Rabs (x - y) < D);
     apply Rle_lt_trans with (Rabs (x - x0) + Rabs (x0 - y)).
   replace (x - y) with (x - x0 + (x0 - y)); [ apply Rabs_triang | ring ].
   rewrite (double_var D); apply Rplus_lt_compat.
   rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H2.
   apply H3.
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat.
-  unfold D in |- *; apply Rabs_pos_lt; apply (Rminus_eq_contra _ _ Hsep).
+  unfold Rdiv; apply Rmult_lt_0_compat.
+  unfold D; apply Rabs_pos_lt; apply (Rminus_eq_contra _ _ Hsep).
   apply Rinv_0_lt_compat; prove_sup0.
 Qed.
 
@@ -406,7 +404,7 @@ Lemma restriction_family :
     (exists y : R, (fun z1 z2:R => f z1 z2 /\ D z1) x y) ->
     intersection_domain (ind f) D x.
 Proof.
-  intros; elim H; intros; unfold intersection_domain in |- *; elim H0; intros;
+  intros; elim H; intros; unfold intersection_domain; elim H0; intros;
     split.
   apply (cond_fam f0); exists x0; assumption.
   assumption.
@@ -426,19 +424,19 @@ Lemma family_P1 :
   forall (f:family) (D:R -> Prop),
     family_open_set f -> family_open_set (subfamily f D).
 Proof.
-  unfold family_open_set in |- *; intros; unfold subfamily in |- *;
-    simpl in |- *; assert (H0 := classic (D x)).
+  unfold family_open_set; intros; unfold subfamily;
+    simpl; assert (H0 := classic (D x)).
   elim H0; intro.
   cut (open_set (f0 x) -> open_set (fun y:R => f0 x y /\ D x)).
   intro; apply H2; apply H.
-  unfold open_set in |- *; unfold neighbourhood in |- *; intros; elim H3;
+  unfold open_set; unfold neighbourhood; intros; elim H3;
     intros; assert (H6 := H2 _ H4); elim H6; intros; exists x1;
-      unfold included in |- *; intros; split.
+      unfold included; intros; split.
   apply (H7 _ H8).
   assumption.
   cut (open_set (fun y:R => False) -> open_set (fun y:R => f0 x y /\ D x)).
   intro; apply H2; apply open_set_P4.
-  unfold open_set in |- *; unfold neighbourhood in |- *; intros; elim H3;
+  unfold open_set; unfold neighbourhood; intros; elim H3;
     intros; elim H1; assumption.
 Qed.
 
@@ -448,7 +446,7 @@ Definition bounded (D:R -> Prop) : Prop :=
 Lemma open_set_P6 :
   forall D1 D2:R -> Prop, open_set D1 -> D1 =_D D2 -> open_set D2.
 Proof.
-  unfold open_set in |- *; unfold neighbourhood in |- *; intros.
+  unfold open_set; unfold neighbourhood; intros.
   unfold eq_Dom in H0; elim H0; intros.
   assert (H4 := H _ (H3 _ H1)).
   elim H4; intros.
@@ -467,7 +465,7 @@ Proof.
   intro; assert (H3 := H1 H2); elim H3; intros D' H4;
     unfold covering_finite in H4; elim H4; intros; unfold family_finite in H6;
       unfold domain_finite in H6; elim H6; intros l H7;
-        unfold bounded in |- *; set (r := MaxRlist l).
+        unfold bounded; set (r := MaxRlist l).
   exists (- r); exists r; intros.
   unfold covering in H5; assert (H9 := H5 _ H8); elim H9; intros;
     unfold subfamily in H10; simpl in H10; elim H10; intros;
@@ -486,25 +484,25 @@ Proof.
   left; apply H11.
   assumption.
   apply (MaxRlist_P1 l x0 H16).
-  unfold intersection_domain, D in |- *; tauto.
-  unfold covering_open_set in |- *; split.
-  unfold covering in |- *; intros; simpl in |- *; exists (Rabs x + 1);
-    unfold g in |- *; pattern (Rabs x) at 1 in |- *; rewrite <- Rplus_0_r;
+  unfold intersection_domain, D; tauto.
+  unfold covering_open_set; split.
+  unfold covering; intros; simpl; exists (Rabs x + 1);
+    unfold g; pattern (Rabs x) at 1; rewrite <- Rplus_0_r;
       apply Rplus_lt_compat_l; apply Rlt_0_1.
-  unfold family_open_set in |- *; intro; case (Rtotal_order 0 x); intro.
+  unfold family_open_set; intro; case (Rtotal_order 0 x); intro.
   apply open_set_P6 with (disc 0 (mkposreal _ H2)).
   apply disc_P1.
-  unfold eq_Dom in |- *; unfold f0 in |- *; simpl in |- *;
-    unfold g, disc in |- *; split.
-  unfold included in |- *; intros; unfold Rminus in H3; rewrite Ropp_0 in H3;
+  unfold eq_Dom; unfold f0; simpl;
+    unfold g, disc; split.
+  unfold included; intros; unfold Rminus in H3; rewrite Ropp_0 in H3;
     rewrite Rplus_0_r in H3; apply H3.
-  unfold included in |- *; intros; unfold Rminus in |- *; rewrite Ropp_0;
+  unfold included; intros; unfold Rminus; rewrite Ropp_0;
     rewrite Rplus_0_r; apply H3.
   apply open_set_P6 with (fun x:R => False).
   apply open_set_P4.
-  unfold eq_Dom in |- *; split.
-  unfold included in |- *; intros; elim H3.
-  unfold included, f0 in |- *; simpl in |- *; unfold g in |- *; intros; elim H2;
+  unfold eq_Dom; split.
+  unfold included; intros; elim H3.
+  unfold included, f0; simpl; unfold g; intros; elim H2;
     intro;
       [ rewrite <- H4 in H3; assert (H5 := Rabs_pos x0);
         elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H5 H3))
@@ -517,10 +515,10 @@ Lemma compact_P2 : forall X:R -> Prop, compact X -> closed_set X.
 Proof.
   intros; assert (H0 := closed_set_P1 X); elim H0; clear H0; intros _ H0;
     apply H0; clear H0.
-  unfold eq_Dom in |- *; split.
+  unfold eq_Dom; split.
   apply adherence_P1.
-  unfold included in |- *; unfold adherence in |- *;
-    unfold point_adherent in |- *; intros; unfold compact in H;
+  unfold included; unfold adherence;
+    unfold point_adherent; intros; unfold compact in H;
       assert (H1 := classic (X x)); elim H1; clear H1; intro.
   assumption.
   cut (forall y:R, X y -> 0 < Rabs (y - x) / 2).
@@ -550,44 +548,44 @@ Proof.
   replace (y0 - x) with (y0 - y + (y - x)); [ apply Rabs_triang | ring ].
   rewrite (double_var (Rabs (y0 - x))); apply Rplus_lt_compat; assumption.
   apply (MinRlist_P1 (AbsList l x) (Rabs (y0 - x) / 2)); apply AbsList_P1;
-    elim (H8 y0); clear H8; intros; apply H8; unfold intersection_domain in |- *;
+    elim (H8 y0); clear H8; intros; apply H8; unfold intersection_domain;
       split; assumption.
   assert (H11 := disc_P1 x (mkposreal alp H9)); unfold open_set in H11;
     apply H11.
-  unfold disc in |- *; unfold Rminus in |- *; rewrite Rplus_opp_r;
+  unfold disc; unfold Rminus; rewrite Rplus_opp_r;
     rewrite Rabs_R0; apply H9.
-  unfold alp in |- *; apply MinRlist_P2; intros;
+  unfold alp; apply MinRlist_P2; intros;
     assert (H10 := AbsList_P2 _ _ _ H9); elim H10; clear H10;
       intros z H10; elim H10; clear H10; intros; rewrite H11;
         apply H2; elim (H8 z); clear H8; intros; assert (H13 := H12 H10);
           unfold intersection_domain, D in H13; elim H13; clear H13;
             intros; assumption.
-  unfold covering_open_set in |- *; split.
-  unfold covering in |- *; intros; exists x0; simpl in |- *; unfold g in |- *;
+  unfold covering_open_set; split.
+  unfold covering; intros; exists x0; simpl; unfold g;
     split.
-  unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+  unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0;
     unfold Rminus in H2; apply (H2 _ H5).
   apply H5.
-  unfold family_open_set in |- *; intro; simpl in |- *; unfold g in |- *;
+  unfold family_open_set; intro; simpl; unfold g;
     elim (classic (D x0)); intro.
   apply open_set_P6 with (disc x0 (mkposreal _ (H2 _ H5))).
   apply disc_P1.
-  unfold eq_Dom in |- *; split.
-  unfold included, disc in |- *; simpl in |- *; intros; split.
+  unfold eq_Dom; split.
+  unfold included, disc; simpl; intros; split.
   rewrite <- (Rabs_Ropp (x0 - x1)); rewrite Ropp_minus_distr; apply H6.
   apply H5.
-  unfold included, disc in |- *; simpl in |- *; intros; elim H6; intros;
+  unfold included, disc; simpl; intros; elim H6; intros;
     rewrite <- (Rabs_Ropp (x1 - x0)); rewrite Ropp_minus_distr;
       apply H7.
   apply open_set_P6 with (fun z:R => False).
   apply open_set_P4.
-  unfold eq_Dom in |- *; split.
-  unfold included in |- *; intros; elim H6.
-  unfold included in |- *; intros; elim H6; intros; elim H5; assumption.
+  unfold eq_Dom; split.
+  unfold included; intros; elim H6.
+  unfold included; intros; elim H6; intros; elim H5; assumption.
   intros; elim H3; intros; unfold g in H4; elim H4; clear H4; intros _ H4;
     apply H4.
-  intros; unfold Rdiv in |- *; apply Rmult_lt_0_compat.
-  apply Rabs_pos_lt; apply Rminus_eq_contra; red in |- *; intro;
+  intros; unfold Rdiv; apply Rmult_lt_0_compat.
+  apply Rabs_pos_lt; apply Rminus_eq_contra; red; intro;
     rewrite H3 in H2; elim H1; apply H2.
   apply Rinv_0_lt_compat; prove_sup0.
 Qed.
@@ -595,29 +593,29 @@ Qed.
 (**********)
 Lemma compact_EMP : compact (fun _:R => False).
 Proof.
-  unfold compact in |- *; intros; exists (fun x:R => False);
-    unfold covering_finite in |- *; split.
-  unfold covering in |- *; intros; elim H0.
-  unfold family_finite in |- *; unfold domain_finite in |- *; exists nil; intro.
+  unfold compact; intros; exists (fun x:R => False);
+    unfold covering_finite; split.
+  unfold covering; intros; elim H0.
+  unfold family_finite; unfold domain_finite; exists nil; intro.
   split.
-  simpl in |- *; unfold intersection_domain in |- *; intros; elim H0.
+  simpl; unfold intersection_domain; intros; elim H0.
   elim H0; clear H0; intros _ H0; elim H0.
-  simpl in |- *; intro; elim H0.
+  simpl; intro; elim H0.
 Qed.
 
 Lemma compact_eqDom :
   forall X1 X2:R -> Prop, compact X1 -> X1 =_D X2 -> compact X2.
 Proof.
-  unfold compact in |- *; intros; unfold eq_Dom in H0; elim H0; clear H0;
-    unfold included in |- *; intros; assert (H3 : covering_open_set X1 f0).
-  unfold covering_open_set in |- *; unfold covering_open_set in H1; elim H1;
+  unfold compact; intros; unfold eq_Dom in H0; elim H0; clear H0;
+    unfold included; intros; assert (H3 : covering_open_set X1 f0).
+  unfold covering_open_set; unfold covering_open_set in H1; elim H1;
     clear H1; intros; split.
-  unfold covering in H1; unfold covering in |- *; intros;
+  unfold covering in H1; unfold covering; intros;
     apply (H1 _ (H0 _ H4)).
   apply H3.
-  elim (H _ H3); intros D H4; exists D; unfold covering_finite in |- *;
+  elim (H _ H3); intros D H4; exists D; unfold covering_finite;
     unfold covering_finite in H4; elim H4; intros; split.
-  unfold covering in H5; unfold covering in |- *; intros;
+  unfold covering in H5; unfold covering; intros;
     apply (H5 _ (H2 _ H7)).
   apply H6.
 Qed.
@@ -626,7 +624,7 @@ Qed.
 Lemma compact_P3 : forall a b:R, compact (fun c:R => a <= c <= b).
 Proof.
   intros; case (Rle_dec a b); intro.
-  unfold compact in |- *; intros;
+  unfold compact; intros;
     set
       (A :=
         fun x:R =>
@@ -649,92 +647,92 @@ Proof.
   rewrite H11 in H10; rewrite H11 in H8; unfold A in H9; elim H9; clear H9;
     intros; elim H12; clear H12; intros Dx H12;
       set (Db := fun x:R => Dx x \/ x = y0); exists Db;
-        unfold covering_finite in |- *; split.
-  unfold covering in |- *; unfold covering_finite in H12; elim H12; clear H12;
+        unfold covering_finite; split.
+  unfold covering; unfold covering_finite in H12; elim H12; clear H12;
     intros; unfold covering in H12; case (Rle_dec x0 x);
       intro.
   cut (a <= x0 <= x).
   intro; assert (H16 := H12 x0 H15); elim H16; clear H16; intros; exists x1;
-    simpl in H16; simpl in |- *; unfold Db in |- *; elim H16;
+    simpl in H16; simpl; unfold Db; elim H16;
       clear H16; intros; split; [ apply H16 | left; apply H17 ].
   split.
   elim H14; intros; assumption.
   assumption.
-  exists y0; simpl in |- *; split.
-  apply H8; unfold disc in |- *; rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr;
+  exists y0; simpl; split.
+  apply H8; unfold disc; rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr;
     rewrite Rabs_right.
   apply Rlt_trans with (b - x).
-  unfold Rminus in |- *; apply Rplus_lt_compat_l; apply Ropp_lt_gt_contravar;
+  unfold Rminus; apply Rplus_lt_compat_l; apply Ropp_lt_gt_contravar;
     auto with real.
   elim H10; intros H15 _; apply Rplus_lt_reg_r with (x - eps);
     replace (x - eps + (b - x)) with (b - eps);
     [ replace (x - eps + eps) with x; [ apply H15 | ring ] | ring ].
   apply Rge_minus; apply Rle_ge; elim H14; intros _ H15; apply H15.
-  unfold Db in |- *; right; reflexivity.
-  unfold family_finite in |- *; unfold domain_finite in |- *;
+  unfold Db; right; reflexivity.
+  unfold family_finite; unfold domain_finite;
     unfold covering_finite in H12; elim H12; clear H12;
       intros; unfold family_finite in H13; unfold domain_finite in H13;
         elim H13; clear H13; intros l H13; exists (cons y0 l);
           intro; split.
   intro; simpl in H14; unfold intersection_domain in H14; elim (H13 x0);
     clear H13; intros; case (Req_dec x0 y0); intro.
-  simpl in |- *; left; apply H16.
-  simpl in |- *; right; apply H13.
-  simpl in |- *; unfold intersection_domain in |- *; unfold Db in H14;
+  simpl; left; apply H16.
+  simpl; right; apply H13.
+  simpl; unfold intersection_domain; unfold Db in H14;
     decompose [and or] H14.
   split; assumption.
   elim H16; assumption.
-  intro; simpl in H14; elim H14; intro; simpl in |- *;
-    unfold intersection_domain in |- *.
+  intro; simpl in H14; elim H14; intro; simpl;
+    unfold intersection_domain.
   split.
   apply (cond_fam f0); rewrite H15; exists m; apply H6.
-  unfold Db in |- *; right; assumption.
-  simpl in |- *; unfold intersection_domain in |- *; elim (H13 x0).
+  unfold Db; right; assumption.
+  simpl; unfold intersection_domain; elim (H13 x0).
   intros _ H16; assert (H17 := H16 H15); simpl in H17;
     unfold intersection_domain in H17; split.
   elim H17; intros; assumption.
-  unfold Db in |- *; left; elim H17; intros; assumption.
+  unfold Db; left; elim H17; intros; assumption.
   set (m' := Rmin (m + eps / 2) b); cut (A m').
   intro; elim H3; intros; unfold is_upper_bound in H13;
     assert (H15 := H13 m' H12); cut (m < m').
   intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H15 H16)).
-  unfold m' in |- *; unfold Rmin in |- *; case (Rle_dec (m + eps / 2) b); intro.
-  pattern m at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
-    unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+  unfold m'; unfold Rmin; case (Rle_dec (m + eps / 2) b); intro.
+  pattern m at 1; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
+    unfold Rdiv; apply Rmult_lt_0_compat;
       [ apply (cond_pos eps) | apply Rinv_0_lt_compat; prove_sup0 ].
   elim H4; intros.
   elim H17; intro.
   assumption.
   elim H11; assumption.
-  unfold A in |- *; split.
+  unfold A; split.
   split.
   apply Rle_trans with m.
   elim H4; intros; assumption.
-  unfold m' in |- *; unfold Rmin in |- *; case (Rle_dec (m + eps / 2) b); intro.
-  pattern m at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left;
-    unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+  unfold m'; unfold Rmin; case (Rle_dec (m + eps / 2) b); intro.
+  pattern m at 1; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left;
+    unfold Rdiv; apply Rmult_lt_0_compat;
       [ apply (cond_pos eps) | apply Rinv_0_lt_compat; prove_sup0 ].
   elim H4; intros.
   elim H13; intro.
   assumption.
   elim H11; assumption.
-  unfold m' in |- *; apply Rmin_r.
+  unfold m'; apply Rmin_r.
   unfold A in H9; elim H9; clear H9; intros; elim H12; clear H12; intros Dx H12;
     set (Db := fun x:R => Dx x \/ x = y0); exists Db;
-      unfold covering_finite in |- *; split.
-  unfold covering in |- *; unfold covering_finite in H12; elim H12; clear H12;
+      unfold covering_finite; split.
+  unfold covering; unfold covering_finite in H12; elim H12; clear H12;
     intros; unfold covering in H12; case (Rle_dec x0 x);
       intro.
   cut (a <= x0 <= x).
   intro; assert (H16 := H12 x0 H15); elim H16; clear H16; intros; exists x1;
-    simpl in H16; simpl in |- *; unfold Db in |- *.
+    simpl in H16; simpl; unfold Db.
   elim H16; clear H16; intros; split; [ apply H16 | left; apply H17 ].
   elim H14; intros; split; assumption.
-  exists y0; simpl in |- *; split.
-  apply H8; unfold disc in |- *; unfold Rabs in |- *; case (Rcase_abs (x0 - m));
+  exists y0; simpl; split.
+  apply H8; unfold disc; unfold Rabs; case (Rcase_abs (x0 - m));
     intro.
   rewrite Ropp_minus_distr; apply Rlt_trans with (m - x).
-  unfold Rminus in |- *; apply Rplus_lt_compat_l; apply Ropp_lt_gt_contravar;
+  unfold Rminus; apply Rplus_lt_compat_l; apply Ropp_lt_gt_contravar;
     auto with real.
   apply Rplus_lt_reg_r with (x - eps);
     replace (x - eps + (m - x)) with (m - eps).
@@ -743,56 +741,56 @@ Proof.
   ring.
   ring.
   apply Rle_lt_trans with (m' - m).
-  unfold Rminus in |- *; do 2 rewrite <- (Rplus_comm (- m));
+  unfold Rminus; do 2 rewrite <- (Rplus_comm (- m));
     apply Rplus_le_compat_l; elim H14; intros; assumption.
   apply Rplus_lt_reg_r with m; replace (m + (m' - m)) with m'.
   apply Rle_lt_trans with (m + eps / 2).
-  unfold m' in |- *; apply Rmin_l.
+  unfold m'; apply Rmin_l.
   apply Rplus_lt_compat_l; apply Rmult_lt_reg_l with 2.
   prove_sup0.
-  unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
+  unfold Rdiv; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
     rewrite <- Rinv_r_sym.
-  rewrite Rmult_1_l; pattern (pos eps) at 1 in |- *; rewrite <- Rplus_0_r;
+  rewrite Rmult_1_l; pattern (pos eps) at 1; rewrite <- Rplus_0_r;
     rewrite double; apply Rplus_lt_compat_l; apply (cond_pos eps).
   discrR.
   ring.
-  unfold Db in |- *; right; reflexivity.
-  unfold family_finite in |- *; unfold domain_finite in |- *;
+  unfold Db; right; reflexivity.
+  unfold family_finite; unfold domain_finite;
     unfold covering_finite in H12; elim H12; clear H12;
       intros; unfold family_finite in H13; unfold domain_finite in H13;
         elim H13; clear H13; intros l H13; exists (cons y0 l);
           intro; split.
   intro; simpl in H14; unfold intersection_domain in H14; elim (H13 x0);
     clear H13; intros; case (Req_dec x0 y0); intro.
-  simpl in |- *; left; apply H16.
-  simpl in |- *; right; apply H13; simpl in |- *;
-    unfold intersection_domain in |- *; unfold Db in H14;
+  simpl; left; apply H16.
+  simpl; right; apply H13; simpl;
+    unfold intersection_domain; unfold Db in H14;
       decompose [and or] H14.
   split; assumption.
   elim H16; assumption.
-  intro; simpl in H14; elim H14; intro; simpl in |- *;
-    unfold intersection_domain in |- *.
+  intro; simpl in H14; elim H14; intro; simpl;
+    unfold intersection_domain.
   split.
   apply (cond_fam f0); rewrite H15; exists m; apply H6.
-  unfold Db in |- *; right; assumption.
+  unfold Db; right; assumption.
   elim (H13 x0); intros _ H16.
   assert (H17 := H16 H15).
   simpl in H17.
   unfold intersection_domain in H17.
   split.
   elim H17; intros; assumption.
-  unfold Db in |- *; left; elim H17; intros; assumption.
+  unfold Db; left; elim H17; intros; assumption.
   elim (classic (exists x : R, A x /\ m - eps < x <= m)); intro.
   assumption.
   elim H3; intros; cut (is_upper_bound A (m - eps)).
   intro; assert (H13 := H11 _ H12); cut (m - eps < m).
   intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H13 H14)).
-  pattern m at 2 in |- *; rewrite <- Rplus_0_r; unfold Rminus in |- *;
+  pattern m at 2; rewrite <- Rplus_0_r; unfold Rminus;
     apply Rplus_lt_compat_l; apply Ropp_lt_cancel; rewrite Ropp_involutive;
       rewrite Ropp_0; apply (cond_pos eps).
   set (P := fun n:R => A n /\ m - eps < n <= m);
     assert (H12 := not_ex_all_not _ P H9); unfold P in H12;
-      unfold is_upper_bound in |- *; intros;
+      unfold is_upper_bound; intros;
         assert (H14 := not_and_or _ _ (H12 x)); elim H14;
           intro.
   elim H15; apply H13.
@@ -805,44 +803,44 @@ Proof.
   unfold is_upper_bound in H3.
   split.
   apply (H3 _ H0).
-  apply (H4 b); unfold is_upper_bound in |- *; intros; unfold A in H5; elim H5;
+  apply (H4 b); unfold is_upper_bound; intros; unfold A in H5; elim H5;
     clear H5; intros H5 _; elim H5; clear H5; intros _ H5;
       apply H5.
   exists a; apply H0.
-  unfold bound in |- *; exists b; unfold is_upper_bound in |- *; intros;
+  unfold bound; exists b; unfold is_upper_bound; intros;
     unfold A in H1; elim H1; clear H1; intros H1 _; elim H1;
       clear H1; intros _ H1; apply H1.
-  unfold A in |- *; split.
+  unfold A; split.
   split; [ right; reflexivity | apply r ].
   unfold covering_open_set in H; elim H; clear H; intros; unfold covering in H;
     cut (a <= a <= b).
   intro; elim (H _ H1); intros y0 H2; set (D' := fun x:R => x = y0); exists D';
-    unfold covering_finite in |- *; split.
-  unfold covering in |- *; simpl in |- *; intros; cut (x = a).
+    unfold covering_finite; split.
+  unfold covering; simpl; intros; cut (x = a).
   intro; exists y0; split.
   rewrite H4; apply H2.
-  unfold D' in |- *; reflexivity.
+  unfold D'; reflexivity.
   elim H3; intros; apply Rle_antisym; assumption.
-  unfold family_finite in |- *; unfold domain_finite in |- *;
+  unfold family_finite; unfold domain_finite;
     exists (cons y0 nil); intro; split.
-  simpl in |- *; unfold intersection_domain in |- *; intro; elim H3; clear H3;
+  simpl; unfold intersection_domain; intro; elim H3; clear H3;
     intros; unfold D' in H4; left; apply H4.
-  simpl in |- *; unfold intersection_domain in |- *; intro; elim H3; intro.
+  simpl; unfold intersection_domain; intro; elim H3; intro.
   split; [ rewrite H4; apply (cond_fam f0); exists a; apply H2 | apply H4 ].
   elim H4.
   split; [ right; reflexivity | apply r ].
   apply compact_eqDom with (fun c:R => False).
   apply compact_EMP.
-  unfold eq_Dom in |- *; split.
-  unfold included in |- *; intros; elim H.
-  unfold included in |- *; intros; elim H; clear H; intros;
+  unfold eq_Dom; split.
+  unfold included; intros; elim H.
+  unfold included; intros; elim H; clear H; intros;
     assert (H1 := Rle_trans _ _ _ H H0); elim n; apply H1.
 Qed.
 
 Lemma compact_P4 :
   forall X F:R -> Prop, compact X -> closed_set F -> included F X -> compact F.
 Proof.
-  unfold compact in |- *; intros; elim (classic (exists z : R, F z));
+  unfold compact; intros; elim (classic (exists z : R, F z));
     intro Hyp_F_NE.
   set (D := ind f0); set (g := f f0); unfold closed_set in H0.
   set (g' := fun x y:R => f0 x y \/ complementary F y /\ D x).
@@ -850,61 +848,61 @@ Proof.
   cut (forall x:R, (exists y : R, g' x y) -> D' x).
   intro; set (f' := mkfamily D' g' H3); cut (covering_open_set X f').
   intro; elim (H _ H4); intros DX H5; exists DX.
-  unfold covering_finite in |- *; unfold covering_finite in H5; elim H5;
+  unfold covering_finite; unfold covering_finite in H5; elim H5;
     clear H5; intros.
   split.
-  unfold covering in |- *; unfold covering in H5; intros.
-  elim (H5 _ (H1 _ H7)); intros y0 H8; exists y0; simpl in H8; simpl in |- *;
+  unfold covering; unfold covering in H5; intros.
+  elim (H5 _ (H1 _ H7)); intros y0 H8; exists y0; simpl in H8; simpl;
     elim H8; clear H8; intros.
   split.
   unfold g' in H8; elim H8; intro.
   apply H10.
   elim H10; intros H11 _; unfold complementary in H11; elim H11; apply H7.
   apply H9.
-  unfold family_finite in |- *; unfold domain_finite in |- *;
+  unfold family_finite; unfold domain_finite;
     unfold family_finite in H6; unfold domain_finite in H6;
       elim H6; clear H6; intros l H6; exists l; intro; assert (H7 := H6 x);
         elim H7; clear H7; intros.
   split.
-  intro; apply H7; simpl in |- *; unfold intersection_domain in |- *;
-    simpl in H9; unfold intersection_domain in H9; unfold D' in |- *;
+  intro; apply H7; simpl; unfold intersection_domain;
+    simpl in H9; unfold intersection_domain in H9; unfold D';
       apply H9.
   intro; assert (H10 := H8 H9); simpl in H10; unfold intersection_domain in H10;
-    simpl in |- *; unfold intersection_domain in |- *;
+    simpl; unfold intersection_domain;
       unfold D' in H10; apply H10.
-  unfold covering_open_set in |- *; unfold covering_open_set in H2; elim H2;
+  unfold covering_open_set; unfold covering_open_set in H2; elim H2;
     clear H2; intros.
   split.
-  unfold covering in |- *; unfold covering in H2; intros.
+  unfold covering; unfold covering in H2; intros.
   elim (classic (F x)); intro.
-  elim (H2 _ H6); intros y0 H7; exists y0; simpl in |- *; unfold g' in |- *;
+  elim (H2 _ H6); intros y0 H7; exists y0; simpl; unfold g';
     left; assumption.
   cut (exists z : R, D z).
-  intro; elim H7; clear H7; intros x0 H7; exists x0; simpl in |- *;
-    unfold g' in |- *; right.
+  intro; elim H7; clear H7; intros x0 H7; exists x0; simpl;
+    unfold g'; right.
   split.
-  unfold complementary in |- *; apply H6.
+  unfold complementary; apply H6.
   apply H7.
   elim Hyp_F_NE; intros z0 H7.
   assert (H8 := H2 _ H7).
   elim H8; clear H8; intros t H8; exists t; apply (cond_fam f0); exists z0;
     apply H8.
-  unfold family_open_set in |- *; intro; simpl in |- *; unfold g' in |- *;
+  unfold family_open_set; intro; simpl; unfold g';
     elim (classic (D x)); intro.
   apply open_set_P6 with (union_domain (f0 x) (complementary F)).
   apply open_set_P2.
   unfold family_open_set in H4; apply H4.
   apply H0.
-  unfold eq_Dom in |- *; split.
-  unfold included, union_domain, complementary in |- *; intros.
+  unfold eq_Dom; split.
+  unfold included, union_domain, complementary; intros.
   elim H6; intro; [ left; apply H7 | right; split; assumption ].
-  unfold included, union_domain, complementary in |- *; intros.
+  unfold included, union_domain, complementary; intros.
   elim H6; intro; [ left; apply H7 | right; elim H7; intros; apply H8 ].
   apply open_set_P6 with (f0 x).
   unfold family_open_set in H4; apply H4.
-  unfold eq_Dom in |- *; split.
-  unfold included, complementary in |- *; intros; left; apply H6.
-  unfold included, complementary in |- *; intros.
+  unfold eq_Dom; split.
+  unfold included, complementary; intros; left; apply H6.
+  unfold included, complementary; intros.
   elim H6; intro.
   apply H7.
   elim H7; intros _ H8; elim H5; apply H8.
@@ -916,9 +914,9 @@ Proof.
   intro; apply (H3 f0 H2).
   apply compact_eqDom with (fun _:R => False).
   apply compact_EMP.
-  unfold eq_Dom in |- *; split.
-  unfold included in |- *; intros; elim H3.
-  assert (H3 := not_ex_all_not _ _ Hyp_F_NE); unfold included in |- *; intros;
+  unfold eq_Dom; split.
+  unfold included; intros; elim H3.
+  assert (H3 := not_ex_all_not _ _ Hyp_F_NE); unfold included; intros;
     elim (H3 x); apply H4.
 Qed.
 
@@ -949,7 +947,7 @@ Lemma continuity_compact :
   forall (f:R -> R) (X:R -> Prop),
     (forall x:R, continuity_pt f x) -> compact X -> compact (image_dir f X).
 Proof.
-  unfold compact in |- *; intros; unfold covering_open_set in H1.
+  unfold compact; intros; unfold covering_open_set in H1.
   elim H1; clear H1; intros.
   set (D := ind f1).
   set (g := fun x y:R => image_rec f0 (f1 x) y).
@@ -958,24 +956,24 @@ Proof.
   cut (covering_open_set X f').
   intro; elim (H0 f' H4); intros D' H5; exists D'.
   unfold covering_finite in H5; elim H5; clear H5; intros;
-    unfold covering_finite in |- *; split.
-  unfold covering, image_dir in |- *; simpl in |- *; unfold covering in H5;
+    unfold covering_finite; split.
+  unfold covering, image_dir; simpl; unfold covering in H5;
     intros; elim H7; intros y H8; elim H8; intros; assert (H11 := H5 _ H10);
       simpl in H11; elim H11; intros z H12; exists z; unfold g in H12;
         unfold image_rec in H12; rewrite H9; apply H12.
   unfold family_finite in H6; unfold domain_finite in H6;
-    unfold family_finite in |- *; unfold domain_finite in |- *;
+    unfold family_finite; unfold domain_finite;
       elim H6; intros l H7; exists l; intro; elim (H7 x);
         intros; split; intro.
-  apply H8; simpl in H10; simpl in |- *; apply H10.
+  apply H8; simpl in H10; simpl; apply H10.
   apply (H9 H10).
-  unfold covering_open_set in |- *; split.
-  unfold covering in |- *; intros; simpl in |- *; unfold covering in H1;
-    unfold image_dir in H1; unfold g in |- *; unfold image_rec in |- *;
+  unfold covering_open_set; split.
+  unfold covering; intros; simpl; unfold covering in H1;
+    unfold image_dir in H1; unfold g; unfold image_rec;
       apply H1.
   exists x; split; [ reflexivity | apply H4 ].
-  unfold family_open_set in |- *; unfold family_open_set in H2; intro;
-    simpl in |- *; unfold g in |- *;
+  unfold family_open_set; unfold family_open_set in H2; intro;
+    simpl; unfold g;
       cut ((fun y:R => image_rec f0 (f1 x) y) = image_rec f0 (f1 x)).
   intro; rewrite H4.
   apply (continuity_P2 f0 (f1 x) H (H2 x)).
@@ -1012,16 +1010,16 @@ Proof.
   assert (H2 : 0 < b - a).
   apply Rlt_Rminus; assumption.
   exists h; split.
-  unfold continuity in |- *; intro; case (Rtotal_order x a); intro.
-  unfold continuity_pt in |- *; unfold continue_in in |- *;
-    unfold limit1_in in |- *; unfold limit_in in |- *;
-      simpl in |- *; unfold R_dist in |- *; intros; exists (a - x);
+  unfold continuity; intro; case (Rtotal_order x a); intro.
+  unfold continuity_pt; unfold continue_in;
+    unfold limit1_in; unfold limit_in;
+      simpl; unfold R_dist; intros; exists (a - x);
         split.
-  change (0 < a - x) in |- *; apply Rlt_Rminus; assumption.
-  intros; elim H5; clear H5; intros _ H5; unfold h in |- *.
+  change (0 < a - x); apply Rlt_Rminus; assumption.
+  intros; elim H5; clear H5; intros _ H5; unfold h.
   case (Rle_dec x a); intro.
   case (Rle_dec x0 a); intro.
-  unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption.
+  unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption.
   elim n; left; apply Rplus_lt_reg_r with (- x);
     do 2 rewrite (Rplus_comm (- x)); apply Rle_lt_trans with (Rabs (x0 - x)).
   apply RRle_abs.
@@ -1032,23 +1030,23 @@ Proof.
   split; [ right; reflexivity | left; assumption ].
   assert (H6 := H0 _ H5); unfold continuity_pt in H6; unfold continue_in in H6;
     unfold limit1_in in H6; unfold limit_in in H6; simpl in H6;
-      unfold R_dist in H6; unfold continuity_pt in |- *;
-        unfold continue_in in |- *; unfold limit1_in in |- *;
-          unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *;
+      unfold R_dist in H6; unfold continuity_pt;
+        unfold continue_in; unfold limit1_in;
+          unfold limit_in; simpl; unfold R_dist;
             intros; elim (H6 _ H7); intros; exists (Rmin x0 (b - a));
               split.
-  unfold Rmin in |- *; case (Rle_dec x0 (b - a)); intro.
+  unfold Rmin; case (Rle_dec x0 (b - a)); intro.
   elim H8; intros; assumption.
-  change (0 < b - a) in |- *; apply Rlt_Rminus; assumption.
+  change (0 < b - a); apply Rlt_Rminus; assumption.
   intros; elim H9; clear H9; intros _ H9; cut (x1 < b).
-  intro; unfold h in |- *; case (Rle_dec x a); intro.
+  intro; unfold h; case (Rle_dec x a); intro.
   case (Rle_dec x1 a); intro.
-  unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption.
+  unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption.
   case (Rle_dec x1 b); intro.
   elim H8; intros; apply H12; split.
-  unfold D_x, no_cond in |- *; split.
+  unfold D_x, no_cond; split.
   trivial.
-  red in |- *; intro; elim n; right; symmetry  in |- *; assumption.
+  red; intro; elim n; right; symmetry ; assumption.
   apply Rlt_le_trans with (Rmin x0 (b - a)).
   rewrite H4 in H9; apply H9.
   apply Rmin_l.
@@ -1065,9 +1063,9 @@ Proof.
   split; left; assumption.
   assert (H7 := H0 _ H6); unfold continuity_pt in H7; unfold continue_in in H7;
     unfold limit1_in in H7; unfold limit_in in H7; simpl in H7;
-      unfold R_dist in H7; unfold continuity_pt in |- *;
-        unfold continue_in in |- *; unfold limit1_in in |- *;
-          unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *;
+      unfold R_dist in H7; unfold continuity_pt;
+        unfold continue_in; unfold limit1_in;
+          unfold limit_in; simpl; unfold R_dist;
             intros; elim (H7 _ H8); intros; elim H9; clear H9;
               intros.
   assert (H11 : 0 < x - a).
@@ -1075,7 +1073,7 @@ Proof.
   assert (H12 : 0 < b - x).
   apply Rlt_Rminus; assumption.
   exists (Rmin x0 (Rmin (x - a) (b - x))); split.
-  unfold Rmin in |- *; case (Rle_dec (x - a) (b - x)); intro.
+  unfold Rmin; case (Rle_dec (x - a) (b - x)); intro.
   case (Rle_dec x0 (x - a)); intro.
   assumption.
   assumption.
@@ -1083,7 +1081,7 @@ Proof.
   assumption.
   assumption.
   intros; elim H13; clear H13; intros; cut (a < x1 < b).
-  intro; elim H15; clear H15; intros; unfold h in |- *; case (Rle_dec x a);
+  intro; elim H15; clear H15; intros; unfold h; case (Rle_dec x a);
     intro.
   elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H4)).
   case (Rle_dec x b); intro.
@@ -1117,16 +1115,16 @@ Proof.
   split; [ left; assumption | right; reflexivity ].
   assert (H8 := H0 _ H7); unfold continuity_pt in H8; unfold continue_in in H8;
     unfold limit1_in in H8; unfold limit_in in H8; simpl in H8;
-      unfold R_dist in H8; unfold continuity_pt in |- *;
-        unfold continue_in in |- *; unfold limit1_in in |- *;
-          unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *;
+      unfold R_dist in H8; unfold continuity_pt;
+        unfold continue_in; unfold limit1_in;
+          unfold limit_in; simpl; unfold R_dist;
             intros; elim (H8 _ H9); intros; exists (Rmin x0 (b - a));
               split.
-  unfold Rmin in |- *; case (Rle_dec x0 (b - a)); intro.
+  unfold Rmin; case (Rle_dec x0 (b - a)); intro.
   elim H10; intros; assumption.
-  change (0 < b - a) in |- *; apply Rlt_Rminus; assumption.
+  change (0 < b - a); apply Rlt_Rminus; assumption.
   intros; elim H11; clear H11; intros _ H11; cut (a < x1).
-  intro; unfold h in |- *; case (Rle_dec x a); intro.
+  intro; unfold h; case (Rle_dec x a); intro.
   elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H4)).
   case (Rle_dec x1 a); intro.
   elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H12)).
@@ -1134,15 +1132,15 @@ Proof.
   case (Rle_dec x1 b); intro.
   rewrite H6; elim H10; intros; elim r0; intro.
   apply H14; split.
-  unfold D_x, no_cond in |- *; split.
+  unfold D_x, no_cond; split.
   trivial.
-  red in |- *; intro; rewrite <- H16 in H15; elim (Rlt_irrefl _ H15).
+  red; intro; rewrite <- H16 in H15; elim (Rlt_irrefl _ H15).
   rewrite H6 in H11; apply Rlt_le_trans with (Rmin x0 (b - a)).
   apply H11.
   apply Rmin_l.
-  rewrite H15; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+  rewrite H15; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0;
     assumption.
-  rewrite H6; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+  rewrite H6; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0;
     assumption.
   elim n1; right; assumption.
   rewrite H6 in H11; apply Ropp_lt_cancel; apply Rplus_lt_reg_r with b;
@@ -1151,18 +1149,18 @@ Proof.
   apply Rlt_le_trans with (Rmin x0 (b - a)).
   assumption.
   apply Rmin_r.
-  unfold continuity_pt in |- *; unfold continue_in in |- *;
-    unfold limit1_in in |- *; unfold limit_in in |- *;
-      simpl in |- *; unfold R_dist in |- *; intros; exists (x - b);
+  unfold continuity_pt; unfold continue_in;
+    unfold limit1_in; unfold limit_in;
+      simpl; unfold R_dist; intros; exists (x - b);
         split.
-  change (0 < x - b) in |- *; apply Rlt_Rminus; assumption.
+  change (0 < x - b); apply Rlt_Rminus; assumption.
   intros; elim H8; clear H8; intros.
   assert (H10 : b < x0).
   apply Ropp_lt_cancel; apply Rplus_lt_reg_r with x;
     apply Rle_lt_trans with (Rabs (x0 - x)).
   rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply RRle_abs.
   assumption.
-  unfold h in |- *; case (Rle_dec x a); intro.
+  unfold h; case (Rle_dec x a); intro.
   elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H4)).
   case (Rle_dec x b); intro.
   elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H6)).
@@ -1170,8 +1168,8 @@ Proof.
   elim (Rlt_irrefl _ (Rlt_trans _ _ _ H1 (Rlt_le_trans _ _ _ H10 r))).
   case (Rle_dec x0 b); intro.
   elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H10)).
-  unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption.
-  intros; elim H3; intros; unfold h in |- *; case (Rle_dec c a); intro.
+  unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption.
+  intros; elim H3; intros; unfold h; case (Rle_dec c a); intro.
   elim r; intro.
   elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H4 H6)).
   rewrite H6; reflexivity.
@@ -1212,7 +1210,7 @@ Proof.
   intros; rewrite <- (Heq c H10); rewrite <- (Heq Mxx H9); intros;
     rewrite <- H8; unfold is_lub in H7; elim H7; clear H7;
       intros H7 _; unfold is_upper_bound in H7; apply H7;
-        unfold image_dir in |- *; exists c; split; [ reflexivity | apply H10 ].
+        unfold image_dir; exists c; split; [ reflexivity | apply H10 ].
   apply H9.
   elim (classic (image_dir g (fun c:R => a <= c <= b) M)); intro.
   assumption.
@@ -1227,13 +1225,13 @@ Proof.
       cut (is_upper_bound (image_dir g (fun c:R => a <= c <= b)) (M - eps)).
   intro; assert (H12 := H10 _ H11); cut (M - eps < M).
   intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H12 H13)).
-  pattern M at 2 in |- *; rewrite <- Rplus_0_r; unfold Rminus in |- *;
+  pattern M at 2; rewrite <- Rplus_0_r; unfold Rminus;
     apply Rplus_lt_compat_l; apply Ropp_lt_cancel; rewrite Ropp_0;
       rewrite Ropp_involutive; apply (cond_pos eps).
-  unfold is_upper_bound, image_dir in |- *; intros; cut (x <= M).
+  unfold is_upper_bound, image_dir; intros; cut (x <= M).
   intro; case (Rle_dec x (M - eps)); intro.
   apply r.
-  elim (H9 x); unfold intersection_domain, disc, image_dir in |- *; split.
+  elim (H9 x); unfold intersection_domain, disc, image_dir; split.
   rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; rewrite Rabs_right.
   apply Rplus_lt_reg_r with (x - eps);
     replace (x - eps + (M - x)) with (M - eps).
@@ -1251,8 +1249,8 @@ Proof.
         ~ intersection_domain V (image_dir g (fun c:R => a <= c <= b)) y)).
   intro; elim H9; intros V H10; elim H10; clear H10; intros.
   unfold neighbourhood in H10; elim H10; intros del H12; exists del; intros;
-    red in |- *; intro; elim (H11 y).
-  unfold intersection_domain in |- *; unfold intersection_domain in H13;
+    red; intro; elim (H11 y).
+  unfold intersection_domain; unfold intersection_domain in H13;
     elim H13; clear H13; intros; split.
   apply (H12 _ H13).
   apply H14.
@@ -1270,18 +1268,18 @@ Proof.
   split.
   apply H12.
   apply (not_ex_all_not _ _ H13).
-  red in |- *; intro; cut (adherence (image_dir g (fun c:R => a <= c <= b)) M).
+  red; intro; cut (adherence (image_dir g (fun c:R => a <= c <= b)) M).
   intro; elim (closed_set_P1 (image_dir g (fun c:R => a <= c <= b)));
     intros H11 _; assert (H12 := H11 H3).
   elim H8.
   unfold eq_Dom in H12; elim H12; clear H12; intros.
   apply (H13 _ H10).
   apply H9.
-  exists (g a); unfold image_dir in |- *; exists a; split.
+  exists (g a); unfold image_dir; exists a; split.
   reflexivity.
   split; [ right; reflexivity | apply H ].
-  unfold bound in |- *; unfold bounded in H4; elim H4; clear H4; intros m H4;
-    elim H4; clear H4; intros M H4; exists M; unfold is_upper_bound in |- *;
+  unfold bound; unfold bounded in H4; elim H4; clear H4; intros m H4;
+    elim H4; clear H4; intros M H4; exists M; unfold is_upper_bound;
       intros; elim (H4 _ H5); intros _ H6; apply H6.
   apply prolongement_C0; assumption.
 Qed.
@@ -1329,8 +1327,8 @@ Proof.
   intros; elim H; intros; unfold f in H0; unfold adherence in H0;
     unfold point_adherent in H0;
       assert (H1 : neighbourhood (disc x0 (mkposreal _ Rlt_0_1)) x0).
-  unfold neighbourhood, disc in |- *; exists (mkposreal _ Rlt_0_1);
-    unfold included in |- *; trivial.
+  unfold neighbourhood, disc; exists (mkposreal _ Rlt_0_1);
+    unfold included; trivial.
   elim (H0 _ H1); intros; unfold intersection_domain in H2; elim H2; intros;
     elim H4; intros; apply H6.
 Qed.
@@ -1347,17 +1345,17 @@ Lemma ValAdh_un_prop :
   forall (un:nat -> R) (x:R), ValAdh un x <-> ValAdh_un un x.
 Proof.
   intros; split; intro.
-  unfold ValAdh in H; unfold ValAdh_un in |- *;
-    unfold intersection_family in |- *; simpl in |- *;
-      intros; elim H0; intros N H1; unfold adherence in |- *;
-        unfold point_adherent in |- *; intros; elim (H V N H2);
-          intros; exists (un x0); unfold intersection_domain in |- *;
+  unfold ValAdh in H; unfold ValAdh_un;
+    unfold intersection_family; simpl;
+      intros; elim H0; intros N H1; unfold adherence;
+        unfold point_adherent; intros; elim (H V N H2);
+          intros; exists (un x0); unfold intersection_domain;
             elim H3; clear H3; intros; split.
   assumption.
   split.
   exists x0; split; [ reflexivity | rewrite H1; apply (le_INR _ _ H3) ].
   exists N; assumption.
-  unfold ValAdh in |- *; intros; unfold ValAdh_un in H;
+  unfold ValAdh; intros; unfold ValAdh_un in H;
     unfold intersection_family in H; simpl in H;
       assert
         (H1 :
@@ -1378,8 +1376,8 @@ Qed.
 Lemma adherence_P4 :
   forall F G:R -> Prop, included F G -> included (adherence F) (adherence G).
 Proof.
-  unfold adherence, included in |- *; unfold point_adherent in |- *; intros;
-    elim (H0 _ H1); unfold intersection_domain in |- *;
+  unfold adherence, included; unfold point_adherent; intros;
+    elim (H0 _ H1); unfold intersection_domain;
       intros; elim H2; clear H2; intros; exists x0; split;
         [ assumption | apply (H _ H3) ].
 Qed.
@@ -1412,36 +1410,36 @@ Proof.
   intros; elim H2; intros; unfold f' in H3; elim H3; intros; assumption.
   set (f0 := mkfamily D' f' H2).
   unfold compact in H; assert (H3 : covering_open_set X f0).
-  unfold covering_open_set in |- *; split.
-  unfold covering in |- *; intros; unfold intersection_vide_in in H1;
+  unfold covering_open_set; split.
+  unfold covering; intros; unfold intersection_vide_in in H1;
     elim (H1 x); intros; unfold intersection_family in H5;
       assert
         (H6 := not_ex_all_not _ (fun y:R => forall y0:R, ind g y0 -> g y0 y) H5 x);
         assert (H7 := not_all_ex_not _ (fun y0:R => ind g y0 -> g y0 x) H6);
           elim H7; intros; exists x0; elim (imply_to_and _ _ H8);
-            intros; unfold f0 in |- *; simpl in |- *; unfold f' in |- *;
+            intros; unfold f0; simpl; unfold f';
               split; [ apply H10 | apply H9 ].
-  unfold family_open_set in |- *; intro; elim (classic (D' x)); intro.
+  unfold family_open_set; intro; elim (classic (D' x)); intro.
   apply open_set_P6 with (complementary (g x)).
   unfold family_closed_set in H0; unfold closed_set in H0; apply H0.
-  unfold f0 in |- *; simpl in |- *; unfold f' in |- *; unfold eq_Dom in |- *;
+  unfold f0; simpl; unfold f'; unfold eq_Dom;
     split.
-  unfold included in |- *; intros; split; [ apply H4 | apply H3 ].
-  unfold included in |- *; intros; elim H4; intros; assumption.
+  unfold included; intros; split; [ apply H4 | apply H3 ].
+  unfold included; intros; elim H4; intros; assumption.
   apply open_set_P6 with (fun _:R => False).
   apply open_set_P4.
-  unfold eq_Dom in |- *; unfold included in |- *; split; intros;
+  unfold eq_Dom; unfold included; split; intros;
     [ elim H4
       | simpl in H4; unfold f' in H4; elim H4; intros; elim H3; assumption ].
   elim (H _ H3); intros SF H4; exists SF;
-    unfold intersection_vide_finite_in in |- *; split.
-  unfold intersection_vide_in in |- *; simpl in |- *; intros; split.
-  intros; unfold included in |- *; intros; unfold intersection_vide_in in H1;
+    unfold intersection_vide_finite_in; split.
+  unfold intersection_vide_in; simpl; intros; split.
+  intros; unfold included; intros; unfold intersection_vide_in in H1;
     elim (H1 x); intros; elim H6; intros; apply H7.
   unfold intersection_domain in H5; elim H5; intros; assumption.
   assumption.
   elim (classic (exists y : R, intersection_domain (ind g) SF y)); intro Hyp'.
-  red in |- *; intro; elim H5; intros; unfold intersection_family in H6;
+  red; intro; elim H5; intros; unfold intersection_family in H6;
     simpl in H6.
   cut (X x0).
   intro; unfold covering_finite in H4; elim H4; clear H4; intros H4 _;
@@ -1464,16 +1462,16 @@ Proof.
     cut (exists z : R, X z).
   intro; elim H5; clear H5; intros; unfold covering in H4; elim (H4 x0 H5);
     intros; simpl in H6; elim Hyp'; exists x1; elim H6;
-      intros; unfold intersection_domain in |- *; split.
+      intros; unfold intersection_domain; split.
   apply (cond_fam f0); exists x0; apply H7.
   apply H8.
   apply Hyp.
   unfold covering_finite in H4; elim H4; clear H4; intros;
     unfold family_finite in H5; unfold domain_finite in H5;
-      unfold family_finite in |- *; unfold domain_finite in |- *;
+      unfold family_finite; unfold domain_finite;
         elim H5; clear H5; intros l H5; exists l; intro; elim (H5 x);
           intros; split; intro;
-            [ apply H6; simpl in |- *; simpl in H8; apply H8 | apply (H7 H8) ].
+            [ apply H6; simpl; simpl in H8; apply H8 | apply (H7 H8) ].
 Qed.
 
 Theorem Bolzano_Weierstrass :
@@ -1494,8 +1492,8 @@ Proof.
   intros; elim H2; intros; unfold g in H3; unfold adherence in H3;
     unfold point_adherent in H3.
   assert (H4 : neighbourhood (disc x0 (mkposreal _ Rlt_0_1)) x0).
-  unfold neighbourhood in |- *; exists (mkposreal _ Rlt_0_1);
-    unfold included in |- *; trivial.
+  unfold neighbourhood; exists (mkposreal _ Rlt_0_1);
+    unfold included; trivial.
   elim (H3 _ H4); intros; unfold intersection_domain in H5; decompose [and] H5;
     assumption.
   set (f0 := mkfamily D g H2).
@@ -1511,19 +1509,19 @@ Proof.
         unfold domain_finite in H9; elim H9; clear H9; intros l H9;
           set (r := MaxRlist l); cut (D r).
   intro; unfold D in H11; elim H11; intros; exists (un x);
-    unfold intersection_family in |- *; simpl in |- *;
-      unfold intersection_domain in |- *; intros; split.
-  unfold g in |- *; apply adherence_P1; split.
+    unfold intersection_family; simpl;
+      unfold intersection_domain; intros; split.
+  unfold g; apply adherence_P1; split.
   exists x; split;
     [ reflexivity
-      | rewrite <- H12; unfold r in |- *; apply MaxRlist_P1; elim (H9 y); intros;
-        apply H14; simpl in |- *; apply H13 ].
+      | rewrite <- H12; unfold r; apply MaxRlist_P1; elim (H9 y); intros;
+        apply H14; simpl; apply H13 ].
   elim H13; intros; assumption.
   elim H13; intros; assumption.
   elim (H9 r); intros.
   simpl in H12; unfold intersection_domain in H12; cut (In r l).
   intro; elim (H12 H13); intros; assumption.
-  unfold r in |- *; apply MaxRlist_P2;
+  unfold r; apply MaxRlist_P2;
     cut (exists z : R, intersection_domain (ind f0) SF z).
   intro; elim H13; intros; elim (H9 x); intros; simpl in H15;
     assert (H17 := H15 H14); exists x; apply H17.
@@ -1543,16 +1541,16 @@ Proof.
                 not_all_ex_not _ (fun y:R => intersection_domain D SF y -> g y x /\ SF y)
                 H18); elim H19; intros; assert (H21 := imply_to_and _ _ H20);
               elim (H17 x0); elim H21; intros; assumption.
-  unfold intersection_vide_in in |- *; intros; split.
-  intro; simpl in H6; unfold f0 in |- *; simpl in |- *; unfold g in |- *;
+  unfold intersection_vide_in; intros; split.
+  intro; simpl in H6; unfold f0; simpl; unfold g;
     apply included_trans with (adherence X).
   apply adherence_P4.
-  unfold included in |- *; intros; elim H7; intros; elim H8; intros; elim H10;
+  unfold included; intros; elim H7; intros; elim H8; intros; elim H10;
     intros; rewrite H11; apply H0.
   apply adherence_P2; apply compact_P2; assumption.
   apply H4.
-  unfold family_closed_set in |- *; unfold f0 in |- *; simpl in |- *;
-    unfold g in |- *; intro; apply adherence_P3.
+  unfold family_closed_set; unfold f0; simpl;
+    unfold g; intro; apply adherence_P3.
 Qed.
 
 (********************************************************)
@@ -1568,7 +1566,7 @@ Definition uniform_continuity (f:R -> R) (X:R -> Prop) : Prop :=
 Lemma is_lub_u :
   forall (E:R -> Prop) (x y:R), is_lub E x -> is_lub E y -> x = y.
 Proof.
-  unfold is_lub in |- *; intros; elim H; elim H0; intros; apply Rle_antisym;
+  unfold is_lub; intros; elim H; elim H0; intros; apply Rle_antisym;
     [ apply (H4 _ H1) | apply (H2 _ H3) ].
 Qed.
 
@@ -1583,7 +1581,7 @@ Proof.
   right; elim H1; intros; elim H2; intros; exists x; exists x0; intros.
   split;
     [ assumption
-      | split; [ assumption | apply (sym_not_eq (A:=R)); assumption ] ].
+      | split; [ assumption | apply (not_eq_sym (A:=R)); assumption ] ].
   left; exists x; split.
   assumption.
   intros; case (Req_dec x0 x); intro.
@@ -1599,14 +1597,14 @@ Theorem Heine :
 Proof.
   intros f0 X H0 H; elim (domain_P1 X); intro Hyp.
 (* X is empty *)
-  unfold uniform_continuity in |- *; intros; exists (mkposreal _ Rlt_0_1);
+  unfold uniform_continuity; intros; exists (mkposreal _ Rlt_0_1);
     intros; elim Hyp; exists x; assumption.
   elim Hyp; clear Hyp; intro Hyp.
 (* X has only one element *)
-  unfold uniform_continuity in |- *; intros; exists (mkposreal _ Rlt_0_1);
+  unfold uniform_continuity; intros; exists (mkposreal _ Rlt_0_1);
     intros; elim Hyp; clear Hyp; intros; elim H4; clear H4;
       intros; assert (H6 := H5 _ H1); assert (H7 := H5 _ H2);
-        rewrite H6; rewrite H7; unfold Rminus in |- *; rewrite Rplus_opp_r;
+        rewrite H6; rewrite H7; unfold Rminus; rewrite Rplus_opp_r;
           rewrite Rabs_R0; apply (cond_pos eps).
 (* X has at least two distinct elements *)
   assert
@@ -1626,9 +1624,9 @@ Proof.
   elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ (Rle_trans _ _ _ H13 H14) r)).
   elim X_enc; clear X_enc; intros m X_enc; elim X_enc; clear X_enc;
     intros M X_enc; elim X_enc; clear X_enc Hyp; intros X_enc Hyp;
-      unfold uniform_continuity in |- *; intro;
+      unfold uniform_continuity; intro;
         assert (H1 : forall t:posreal, 0 < t / 2).
-  intro; unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+  intro; unfold Rdiv; apply Rmult_lt_0_compat;
     [ apply (cond_pos t) | apply Rinv_0_lt_compat; prove_sup0 ].
   set
     (g :=
@@ -1646,8 +1644,8 @@ Proof.
     apply H3.
   set (f' := mkfamily X g H2); unfold compact in H0;
     assert (H3 : covering_open_set X f').
-  unfold covering_open_set in |- *; split.
-  unfold covering in |- *; intros; exists x; simpl in |- *; unfold g in |- *;
+  unfold covering_open_set; split.
+  unfold covering; intros; exists x; simpl; unfold g;
     split.
   assumption.
   assert (H4 := H _ H3); unfold continuity_pt in H4; unfold continue_in in H4;
@@ -1660,22 +1658,22 @@ Proof.
                 0 < zeta <= M - m /\
                 (forall z:R, Rabs (z - x) < zeta -> Rabs (f0 z - f0 x) < eps / 2));
             assert (H6 : bound E).
-  unfold bound in |- *; exists (M - m); unfold is_upper_bound in |- *;
-    unfold E in |- *; intros; elim H6; clear H6; intros H6 _;
+  unfold bound; exists (M - m); unfold is_upper_bound;
+    unfold E; intros; elim H6; clear H6; intros H6 _;
       elim H6; clear H6; intros _ H6; apply H6.
   assert (H7 :  exists x : R, E x).
-  elim H5; clear H5; intros; exists (Rmin x0 (M - m)); unfold E in |- *; intros;
+  elim H5; clear H5; intros; exists (Rmin x0 (M - m)); unfold E; intros;
     split.
   split.
-  unfold Rmin in |- *; case (Rle_dec x0 (M - m)); intro.
+  unfold Rmin; case (Rle_dec x0 (M - m)); intro.
   apply H5.
   apply Rlt_Rminus; apply Hyp.
   apply Rmin_r.
   intros; case (Req_dec x z); intro.
-  rewrite H9; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+  rewrite H9; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0;
     apply (H1 eps).
   apply H7; split.
-  unfold D_x, no_cond in |- *; split; [ trivial | assumption ].
+  unfold D_x, no_cond; split; [ trivial | assumption ].
   apply Rlt_le_trans with (Rmin x0 (M - m)); [ apply H8 | apply Rmin_l ].
   assert (H8 := completeness _ H6 H7); elim H8; clear H8; intros;
     cut (0 < x1 <= M - m).
@@ -1692,15 +1690,15 @@ Proof.
     unfold is_lub in p; elim p; intros; cut (is_upper_bound E (Rabs (z - x))).
   intro; assert (H16 := H14 _ H15);
     elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H10 H16)).
-  unfold is_upper_bound in |- *; intros; unfold is_upper_bound in H13;
+  unfold is_upper_bound; intros; unfold is_upper_bound in H13;
     assert (H16 := H13 _ H15); case (Rle_dec x2 (Rabs (z - x)));
       intro.
   assumption.
   elim (H12 x2); split; [ split; [ auto with real | assumption ] | assumption ].
   split.
   apply p.
-  unfold disc in |- *; unfold Rminus in |- *; rewrite Rplus_opp_r;
-    rewrite Rabs_R0; simpl in |- *; unfold Rdiv in |- *;
+  unfold disc; unfold Rminus; rewrite Rplus_opp_r;
+    rewrite Rabs_R0; simpl; unfold Rdiv;
       apply Rmult_lt_0_compat; [ apply H8 | apply Rinv_0_lt_compat; prove_sup0 ].
   elim H7; intros; unfold E in H8; elim H8; intros H9 _; elim H9; intros H10 _;
     unfold is_lub in p; elim p; intros; unfold is_upper_bound in H12;
@@ -1708,13 +1706,13 @@ Proof.
   apply Rlt_le_trans with x2; [ assumption | apply (H11 _ H8) ].
   apply H12; intros; unfold E in H13; elim H13; intros; elim H14; intros;
     assumption.
-  unfold family_open_set in |- *; intro; simpl in |- *; elim (classic (X x));
+  unfold family_open_set; intro; simpl; elim (classic (X x));
     intro.
-  unfold g in |- *; unfold open_set in |- *; intros; elim H4; clear H4;
+  unfold g; unfold open_set; intros; elim H4; clear H4;
     intros _ H4; elim H4; clear H4; intros; elim H4; clear H4;
-      intros; unfold neighbourhood in |- *; case (Req_dec x x0);
+      intros; unfold neighbourhood; case (Req_dec x x0);
         intro.
-  exists (mkposreal _ (H1 x1)); rewrite <- H6; unfold included in |- *; intros;
+  exists (mkposreal _ (H1 x1)); rewrite <- H6; unfold included; intros;
     split.
   assumption.
   exists x1; split.
@@ -1723,24 +1721,24 @@ Proof.
   elim H5; intros; apply H8.
   apply H7.
   set (d := x1 / 2 - Rabs (x0 - x)); assert (H7 : 0 < d).
-  unfold d in |- *; apply Rlt_Rminus; elim H5; clear H5; intros;
+  unfold d; apply Rlt_Rminus; elim H5; clear H5; intros;
     unfold disc in H7; apply H7.
-  exists (mkposreal _ H7); unfold included in |- *; intros; split.
+  exists (mkposreal _ H7); unfold included; intros; split.
   assumption.
   exists x1; split.
   apply H4.
   elim H5; intros; split.
   assumption.
-  unfold disc in H8; simpl in H8; unfold disc in |- *; simpl in |- *;
+  unfold disc in H8; simpl in H8; unfold disc; simpl;
     unfold disc in H10; simpl in H10;
       apply Rle_lt_trans with (Rabs (x2 - x0) + Rabs (x0 - x)).
   replace (x2 - x) with (x2 - x0 + (x0 - x)); [ apply Rabs_triang | ring ].
-  replace (x1 / 2) with (d + Rabs (x0 - x)); [ idtac | unfold d in |- *; ring ].
+  replace (x1 / 2) with (d + Rabs (x0 - x)); [ idtac | unfold d; ring ].
   do 2 rewrite <- (Rplus_comm (Rabs (x0 - x))); apply Rplus_lt_compat_l;
     apply H8.
   apply open_set_P6 with (fun _:R => False).
   apply open_set_P4.
-  unfold eq_Dom in |- *; unfold included in |- *; intros; split.
+  unfold eq_Dom; unfold included; intros; split.
   intros; elim H4.
   intros; unfold g in H4; elim H4; clear H4; intros H4 _; elim H3; apply H4.
   elim (H0 _ H3); intros DF H4; unfold covering_finite in H4; elim H4; clear H4;
@@ -1778,10 +1776,10 @@ Proof.
       apply Rlt_trans with (pos_Rl l' i / 2).
   apply H21.
   elim H13; clear H13; intros; assumption.
-  unfold Rdiv in |- *; apply Rmult_lt_reg_l with 2.
+  unfold Rdiv; apply Rmult_lt_reg_l with 2.
   prove_sup0.
   rewrite Rmult_comm; rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
-  rewrite Rmult_1_r; pattern (pos_Rl l' i) at 1 in |- *; rewrite <- Rplus_0_r;
+  rewrite Rmult_1_r; pattern (pos_Rl l' i) at 1; rewrite <- Rplus_0_r;
     rewrite double; apply Rplus_lt_compat_l; apply H19.
   discrR.
   assert (H19 := H8 i H17); elim H19; clear H19; intros; rewrite <- H18 in H20;
@@ -1793,15 +1791,15 @@ Proof.
   rewrite (double_var (pos_Rl l' i)); apply Rplus_lt_compat.
   apply Rlt_le_trans with (D / 2).
   rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H12.
-  unfold Rdiv in |- *; do 2 rewrite <- (Rmult_comm (/ 2));
+  unfold Rdiv; do 2 rewrite <- (Rmult_comm (/ 2));
     apply Rmult_le_compat_l.
   left; apply Rinv_0_lt_compat; prove_sup0.
-  unfold D in |- *; apply MinRlist_P1; elim (pos_Rl_P2 l' (pos_Rl l' i));
+  unfold D; apply MinRlist_P1; elim (pos_Rl_P2 l' (pos_Rl l' i));
     intros; apply H26; exists i; split;
       [ rewrite <- H7; assumption | reflexivity ].
   assumption.
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
-    [ unfold D in |- *; apply MinRlist_P2; intros; elim (pos_Rl_P2 l' y); intros;
+  unfold Rdiv; apply Rmult_lt_0_compat;
+    [ unfold D; apply MinRlist_P2; intros; elim (pos_Rl_P2 l' y); intros;
       elim (H10 H9); intros; elim H12; intros; rewrite H14;
         rewrite <- H7 in H13; elim (H8 x H13); intros;
           apply H15
@@ -1813,25 +1811,25 @@ Proof.
           0 < zeta <= M - m /\
           (forall z:R, Rabs (z - x) < zeta -> Rabs (f0 z - f0 x) < eps / 2));
       assert (H11 : bound E).
-  unfold bound in |- *; exists (M - m); unfold is_upper_bound in |- *;
-    unfold E in |- *; intros; elim H11; clear H11; intros H11 _;
+  unfold bound; exists (M - m); unfold is_upper_bound;
+    unfold E; intros; elim H11; clear H11; intros H11 _;
       elim H11; clear H11; intros _ H11; apply H11.
   assert (H12 :  exists x : R, E x).
   assert (H13 := H _ H9); unfold continuity_pt in H13;
     unfold continue_in in H13; unfold limit1_in in H13;
       unfold limit_in in H13; simpl in H13; unfold R_dist in H13;
         elim (H13 _ (H1 eps)); intros; elim H12; clear H12;
-          intros; exists (Rmin x0 (M - m)); unfold E in |- *;
+          intros; exists (Rmin x0 (M - m)); unfold E;
             intros; split.
   split;
-    [ unfold Rmin in |- *; case (Rle_dec x0 (M - m)); intro;
+    [ unfold Rmin; case (Rle_dec x0 (M - m)); intro;
       [ apply H12 | apply Rlt_Rminus; apply Hyp ]
       | apply Rmin_r ].
   intros; case (Req_dec x z); intro.
-  rewrite H16; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
+  rewrite H16; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0;
     apply (H1 eps).
   apply H14; split;
-    [ unfold D_x, no_cond in |- *; split; [ trivial | assumption ]
+    [ unfold D_x, no_cond; split; [ trivial | assumption ]
       | apply Rlt_le_trans with (Rmin x0 (M - m)); [ apply H15 | apply Rmin_l ] ].
   assert (H13 := completeness _ H11 H12); elim H13; clear H13; intros;
     cut (0 < x0 <= M - m).
@@ -1849,14 +1847,14 @@ Proof.
     unfold is_lub in p; elim p; intros; cut (is_upper_bound E (Rabs (z - x))).
   intro; assert (H21 := H19 _ H20);
     elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H15 H21)).
-  unfold is_upper_bound in |- *; intros; unfold is_upper_bound in H18;
+  unfold is_upper_bound; intros; unfold is_upper_bound in H18;
     assert (H21 := H18 _ H20); case (Rle_dec x1 (Rabs (z - x)));
       intro.
   assumption.
   elim (H17 x1); split.
   split; [ auto with real | assumption ].
   assumption.
-  unfold included, g in |- *; intros; elim H15; intros; elim H17; intros;
+  unfold included, g; intros; elim H15; intros; elim H17; intros;
     decompose [and] H18; cut (x0 = x2).
   intro; rewrite H20; apply H22.
   unfold E in p; eapply is_lub_u.
diff --git a/theories/Reals/Rtrigo.v b/theories/Reals/Rtrigo.v
index 3499ea24..32c4d7d3 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-2012     *)
 (*   \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.
@@ -19,1785 +17,10 @@ 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.
-
-(** sin_PI2 is the only remaining axiom **)
-Axiom sin_PI2 : sin (PI / 2) = 1.
-
-(**********)
-Lemma PI_neq0 : PI <> 0.
-Proof.
-  red in |- *; intro; assert (H0 := PI_RGT_0); rewrite H in H0;
-    elim (Rlt_irrefl _ H0).
-Qed.
-
-(**********)
-Lemma cos_minus : forall x y:R, cos (x - y) = cos x * cos y + sin x * sin y.
-Proof.
-  intros; unfold Rminus in |- *; rewrite cos_plus.
-  rewrite <- cos_sym; rewrite sin_antisym; ring.
-Qed.
-
-(**********)
-Lemma sin2_cos2 : forall x:R, Rsqr (sin x) + Rsqr (cos x) = 1.
-Proof.
-  intro; unfold Rsqr in |- *; rewrite Rplus_comm; rewrite <- (cos_minus x x);
-    unfold Rminus in |- *; rewrite Rplus_opp_r; apply cos_0.
-Qed.
-
-Lemma cos2 : forall x:R, Rsqr (cos x) = 1 - Rsqr (sin x).
-Proof.
-  intro x; generalize (sin2_cos2 x); intro H1; rewrite <- H1;
-    unfold Rminus in |- *; rewrite <- (Rplus_comm (Rsqr (cos x)));
-      rewrite Rplus_assoc; rewrite Rplus_opp_r; symmetry  in |- *;
-        apply Rplus_0_r.
-Qed.
-
-(**********)
-Lemma cos_PI2 : cos (PI / 2) = 0.
-Proof.
-  apply Rsqr_eq_0; rewrite cos2; rewrite sin_PI2; rewrite Rsqr_1;
-    unfold Rminus in |- *; apply Rplus_opp_r.
-Qed.
-
-(**********)
-Lemma cos_PI : cos PI = -1.
-Proof.
-  replace PI with (PI / 2 + PI / 2).
-  rewrite cos_plus.
-  rewrite sin_PI2; rewrite cos_PI2.
-  ring.
-  symmetry  in |- *; apply double_var.
-Qed.
-
-Lemma sin_PI : sin PI = 0.
-Proof.
-  assert (H := sin2_cos2 PI).
-  rewrite cos_PI in H.
-  rewrite <- Rsqr_neg in H.
-  rewrite Rsqr_1 in H.
-  cut (Rsqr (sin PI) = 0).
-  intro; apply (Rsqr_eq_0 _ H0).
-  apply Rplus_eq_reg_l with 1.
-  rewrite Rplus_0_r; rewrite Rplus_comm; exact H.
-Qed.
-
-(**********)
-Lemma neg_cos : forall x:R, cos (x + PI) = - cos x.
-Proof.
-  intro x; rewrite cos_plus; rewrite sin_PI; rewrite cos_PI; ring.
-Qed.
-
-(**********)
-Lemma sin_cos : forall x:R, sin x = - cos (PI / 2 + x).
-Proof.
-  intro x; rewrite cos_plus; rewrite sin_PI2; rewrite cos_PI2; ring.
-Qed.
-
-(**********)
-Lemma sin_plus : forall x y:R, sin (x + y) = sin x * cos y + cos x * sin y.
-Proof.
-  intros.
-  rewrite (sin_cos (x + y)).
-  replace (PI / 2 + (x + y)) with (PI / 2 + x + y); [ rewrite cos_plus | ring ].
-  rewrite (sin_cos (PI / 2 + x)).
-  replace (PI / 2 + (PI / 2 + x)) with (x + PI).
-  rewrite neg_cos.
-  replace (cos (PI / 2 + x)) with (- sin x).
-  ring.
-  rewrite sin_cos; rewrite Ropp_involutive; reflexivity.
-  pattern PI at 1 in |- *; rewrite (double_var PI); ring.
-Qed.
-
-Lemma sin_minus : forall x y:R, sin (x - y) = sin x * cos y - cos x * sin y.
-Proof.
-  intros; unfold Rminus in |- *; rewrite sin_plus.
-  rewrite <- cos_sym; rewrite sin_antisym; ring.
-Qed.
-
-(**********)
-Definition tan (x:R) : R := sin x / cos x.
-
-Lemma tan_plus :
-  forall x y:R,
-    cos x <> 0 ->
-    cos y <> 0 ->
-    cos (x + y) <> 0 ->
-    1 - tan x * tan y <> 0 ->
-    tan (x + y) = (tan x + tan y) / (1 - tan x * tan y).
-Proof.
-  intros; unfold tan in |- *; rewrite sin_plus; rewrite cos_plus;
-    unfold Rdiv in |- *;
-      replace (cos x * cos y - sin x * sin y) with
-      (cos x * cos y * (1 - sin x * / cos x * (sin y * / cos y))).
-  rewrite Rinv_mult_distr.
-  repeat rewrite <- Rmult_assoc;
-    replace ((sin x * cos y + cos x * sin y) * / (cos x * cos y)) with
-    (sin x * / cos x + sin y * / cos y).
-  reflexivity.
-  rewrite Rmult_plus_distr_r; rewrite Rinv_mult_distr.
-  repeat rewrite Rmult_assoc; repeat rewrite (Rmult_comm (sin x));
-    repeat rewrite <- Rmult_assoc.
-  repeat rewrite Rinv_r_simpl_m; [ reflexivity | assumption | assumption ].
-  assumption.
-  assumption.
-  apply prod_neq_R0; assumption.
-  assumption.
-  unfold Rminus in |- *; rewrite Rmult_plus_distr_l; rewrite Rmult_1_r;
-    apply Rplus_eq_compat_l; repeat rewrite Rmult_assoc;
-      rewrite (Rmult_comm (sin x)); rewrite (Rmult_comm (cos y));
-        rewrite <- Ropp_mult_distr_r_reverse; repeat rewrite <- Rmult_assoc;
-          rewrite <- Rinv_r_sym.
-  rewrite Rmult_1_l; rewrite (Rmult_comm (sin x));
-    rewrite <- Ropp_mult_distr_r_reverse; repeat rewrite Rmult_assoc;
-      apply Rmult_eq_compat_l; rewrite (Rmult_comm (/ cos y));
-        rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
-  apply Rmult_1_r.
-  assumption.
-  assumption.
-Qed.
-
-(*******************************************************)
-(** * Some properties of cos, sin and tan              *)
-(*******************************************************)
-
-Lemma sin2 : forall x:R, Rsqr (sin x) = 1 - Rsqr (cos x).
-Proof.
-  intro x; generalize (cos2 x); intro H1; rewrite H1.
-  unfold Rminus in |- *; rewrite Ropp_plus_distr; rewrite <- Rplus_assoc;
-    rewrite Rplus_opp_r; rewrite Rplus_0_l; symmetry  in |- *;
-      apply Ropp_involutive.
-Qed.
-
-Lemma sin_2a : forall x:R, sin (2 * x) = 2 * sin x * cos x.
-Proof.
-  intro x; rewrite double; rewrite sin_plus.
-  rewrite <- (Rmult_comm (sin x)); symmetry  in |- *; rewrite Rmult_assoc;
-    apply double.
-Qed.
-
-Lemma cos_2a : forall x:R, cos (2 * x) = cos x * cos x - sin x * sin x.
-Proof.
-  intro x; rewrite double; apply cos_plus.
-Qed.
-
-Lemma cos_2a_cos : forall x:R, cos (2 * x) = 2 * cos x * cos x - 1.
-Proof.
-  intro x; rewrite double; unfold Rminus in |- *; rewrite Rmult_assoc;
-    rewrite cos_plus; generalize (sin2_cos2 x); rewrite double;
-      intro H1; rewrite <- H1; ring_Rsqr.
-Qed.
-
-Lemma cos_2a_sin : forall x:R, cos (2 * x) = 1 - 2 * sin x * sin x.
-Proof.
-  intro x; rewrite Rmult_assoc; unfold Rminus in |- *; repeat rewrite double.
-  generalize (sin2_cos2 x); intro H1; rewrite <- H1; rewrite cos_plus;
-    ring_Rsqr.
-Qed.
-
-Lemma tan_2a :
-  forall x:R,
-    cos x <> 0 ->
-    cos (2 * x) <> 0 ->
-    1 - tan x * tan x <> 0 -> tan (2 * x) = 2 * tan x / (1 - tan x * tan x).
-Proof.
-  repeat rewrite double; intros; repeat rewrite double; rewrite double in H0;
-    apply tan_plus; assumption.
-Qed.
-
-Lemma sin_neg : forall x:R, sin (- x) = - sin x.
-Proof.
-  apply sin_antisym.
-Qed.
-
-Lemma cos_neg : forall x:R, cos (- x) = cos x.
-Proof.
-  intro; symmetry  in |- *; apply cos_sym.
-Qed.
-
-Lemma tan_0 : tan 0 = 0.
-Proof.
-  unfold tan in |- *; rewrite sin_0; rewrite cos_0.
-  unfold Rdiv in |- *; apply Rmult_0_l.
-Qed.
-
-Lemma tan_neg : forall x:R, tan (- x) = - tan x.
-Proof.
-  intros x; unfold tan in |- *; rewrite sin_neg; rewrite cos_neg;
-    unfold Rdiv in |- *.
-  apply Ropp_mult_distr_l_reverse.
-Qed.
-
-Lemma tan_minus :
-  forall x y:R,
-    cos x <> 0 ->
-    cos y <> 0 ->
-    cos (x - y) <> 0 ->
-    1 + tan x * tan y <> 0 ->
-    tan (x - y) = (tan x - tan y) / (1 + tan x * tan y).
-Proof.
-  intros; unfold Rminus in |- *; rewrite tan_plus.
-  rewrite tan_neg; unfold Rminus in |- *; rewrite <- Ropp_mult_distr_l_reverse;
-    rewrite Rmult_opp_opp; reflexivity.
-  assumption.
-  rewrite cos_neg; assumption.
-  assumption.
-  rewrite tan_neg; unfold Rminus in |- *; rewrite <- Ropp_mult_distr_l_reverse;
-    rewrite Rmult_opp_opp; assumption.
-Qed.
-
-Lemma cos_3PI2 : cos (3 * (PI / 2)) = 0.
-Proof.
-  replace (3 * (PI / 2)) with (PI + PI / 2).
-  rewrite cos_plus; rewrite sin_PI; rewrite cos_PI2; ring.
-  pattern PI at 1 in |- *; rewrite (double_var PI).
-  ring.
-Qed.
-
-Lemma sin_2PI : sin (2 * PI) = 0.
-Proof.
-  rewrite sin_2a; rewrite sin_PI; ring.
-Qed.
-
-Lemma cos_2PI : cos (2 * PI) = 1.
-Proof.
-  rewrite cos_2a; rewrite sin_PI; rewrite cos_PI; ring.
-Qed.
-
-Lemma neg_sin : forall x:R, sin (x + PI) = - sin x.
-Proof.
-  intro x; rewrite sin_plus; rewrite sin_PI; rewrite cos_PI; ring.
-Qed.
-
-Lemma sin_PI_x : forall x:R, sin (PI - x) = sin x.
-Proof.
-  intro x; rewrite sin_minus; rewrite sin_PI; rewrite cos_PI; rewrite Rmult_0_l;
-    unfold Rminus in |- *; rewrite Rplus_0_l; rewrite Ropp_mult_distr_l_reverse;
-      rewrite Ropp_involutive; apply Rmult_1_l.
-Qed.
-
-Lemma sin_period : forall (x:R) (k:nat), sin (x + 2 * INR k * PI) = sin x.
-Proof.
-  intros x k; induction  k as [| k Hreck].
-  simpl in |- *;  ring_simplify (x + 2 * 0 * PI).
-  trivial.
-
-  replace (x + 2 * INR (S k) * PI) with (x + 2 * INR k * PI + 2 * PI).
-  rewrite sin_plus in |- *; rewrite sin_2PI in |- *; rewrite cos_2PI in |- *.
-  ring_simplify; trivial.
-  rewrite S_INR in |- *;  ring.
-Qed.
-
-Lemma cos_period : forall (x:R) (k:nat), cos (x + 2 * INR k * PI) = cos x.
-Proof.
-  intros x k; induction  k as [| k Hreck].
-  simpl in |- *;  ring_simplify (x + 2 * 0 * PI).
-  trivial.
-
-  replace (x + 2 * INR (S k) * PI) with (x + 2 * INR k * PI + 2 * PI).
-  rewrite cos_plus in |- *; rewrite sin_2PI in |- *; rewrite cos_2PI in |- *.
-  ring_simplify; trivial.
-  rewrite S_INR in |- *;  ring.
-Qed.
-
-Lemma sin_shift : forall x:R, sin (PI / 2 - x) = cos x.
-Proof.
-  intro x; rewrite sin_minus; rewrite sin_PI2; rewrite cos_PI2; ring.
-Qed.
-
-Lemma cos_shift : forall x:R, cos (PI / 2 - x) = sin x.
-Proof.
-  intro x; rewrite cos_minus; rewrite sin_PI2; rewrite cos_PI2; ring.
-Qed.
-
-Lemma cos_sin : forall x:R, cos x = sin (PI / 2 + x).
-Proof.
-  intro x; rewrite sin_plus; rewrite sin_PI2; rewrite cos_PI2; ring.
-Qed.
-
-Lemma PI2_RGT_0 : 0 < PI / 2.
-Proof.
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
-    [ apply PI_RGT_0 | apply Rinv_0_lt_compat; prove_sup ].
-Qed.
-
-Lemma SIN_bound : forall x:R, -1 <= sin x <= 1.
-Proof.
-  intro; case (Rle_dec (-1) (sin x)); intro.
-  case (Rle_dec (sin x) 1); intro.
-  split; assumption.
-  cut (1 < sin x).
-  intro;
-    generalize
-      (Rsqr_incrst_1 1 (sin x) H (Rlt_le 0 1 Rlt_0_1)
-        (Rlt_le 0 (sin x) (Rlt_trans 0 1 (sin x) Rlt_0_1 H)));
-      rewrite Rsqr_1; intro; rewrite sin2 in H0; unfold Rminus in H0;
-        generalize (Rplus_lt_compat_l (-1) 1 (1 + - Rsqr (cos x)) H0);
-          repeat rewrite <- Rplus_assoc; repeat rewrite Rplus_opp_l;
-            rewrite Rplus_0_l; intro; rewrite <- Ropp_0 in H1;
-              generalize (Ropp_lt_gt_contravar (-0) (- Rsqr (cos x)) H1);
-                repeat rewrite Ropp_involutive; intro; generalize (Rle_0_sqr (cos x));
-                  intro; elim (Rlt_irrefl 0 (Rle_lt_trans 0 (Rsqr (cos x)) 0 H3 H2)).
-  auto with real.
-  cut (sin x < -1).
-  intro; generalize (Ropp_lt_gt_contravar (sin x) (-1) H);
-    rewrite Ropp_involutive; clear H; intro;
-      generalize
-        (Rsqr_incrst_1 1 (- sin x) H (Rlt_le 0 1 Rlt_0_1)
-          (Rlt_le 0 (- sin x) (Rlt_trans 0 1 (- sin x) Rlt_0_1 H)));
-        rewrite Rsqr_1; intro; rewrite <- Rsqr_neg in H0;
-          rewrite sin2 in H0; unfold Rminus in H0;
-            generalize (Rplus_lt_compat_l (-1) 1 (1 + - Rsqr (cos x)) H0);
-              repeat rewrite <- Rplus_assoc; repeat rewrite Rplus_opp_l;
-                rewrite Rplus_0_l; intro; rewrite <- Ropp_0 in H1;
-                  generalize (Ropp_lt_gt_contravar (-0) (- Rsqr (cos x)) H1);
-                    repeat rewrite Ropp_involutive; intro; generalize (Rle_0_sqr (cos x));
-                      intro; elim (Rlt_irrefl 0 (Rle_lt_trans 0 (Rsqr (cos x)) 0 H3 H2)).
-  auto with real.
-Qed.
-
-Lemma COS_bound : forall x:R, -1 <= cos x <= 1.
-Proof.
-  intro; rewrite <- sin_shift; apply SIN_bound.
-Qed.
-
-Lemma cos_sin_0 : forall x:R, ~ (cos x = 0 /\ sin x = 0).
-Proof.
-  intro; red in |- *; intro; elim H; intros; generalize (sin2_cos2 x); intro;
-    rewrite H0 in H2; rewrite H1 in H2; repeat rewrite Rsqr_0 in H2;
-      rewrite Rplus_0_r in H2; generalize Rlt_0_1; intro;
-        rewrite <- H2 in H3; elim (Rlt_irrefl 0 H3).
-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.
-Qed.
-
-(*****************************************************************)
-(** * Using series definitions of cos and sin                    *)
-(*****************************************************************)
-
-Definition sin_lb (a:R) : R := sin_approx a 3.
-Definition sin_ub (a:R) : R := sin_approx a 4.
-Definition cos_lb (a:R) : R := cos_approx a 3.
-Definition cos_ub (a:R) : R := cos_approx a 4.
-
-Lemma sin_lb_gt_0 : forall a:R, 0 < a -> a <= PI / 2 -> 0 < sin_lb a.
-Proof.
-  intros.
-  unfold sin_lb in |- *; unfold sin_approx in |- *; unfold sin_term in |- *.
-  set (Un := fun i:nat => a ^ (2 * i + 1) / INR (fact (2 * i + 1))).
-  replace
-  (sum_f_R0
-    (fun i:nat => (-1) ^ i * (a ^ (2 * i + 1) / INR (fact (2 * i + 1)))) 3)
-    with (sum_f_R0 (fun i:nat => (-1) ^ i * Un i) 3);
-      [ idtac | apply sum_eq; intros; unfold Un in |- *; reflexivity ].
-  cut (forall n:nat, Un (S n) < Un n).
-  intro; simpl in |- *.
-  repeat rewrite Rmult_1_l; repeat rewrite Rmult_1_r;
-    replace (-1 * Un 1%nat) with (- Un 1%nat); [ idtac | ring ];
-    replace (-1 * -1 * Un 2%nat) with (Un 2%nat); [ idtac | ring ];
-    replace (-1 * (-1 * -1) * Un 3%nat) with (- Un 3%nat);
-    [ idtac | ring ];
-    replace (Un 0%nat + - Un 1%nat + Un 2%nat + - Un 3%nat) with
-    (Un 0%nat - Un 1%nat + (Un 2%nat - Un 3%nat)); [ idtac | ring ].
-  apply Rplus_lt_0_compat.
-  unfold Rminus in |- *; apply Rplus_lt_reg_r with (Un 1%nat);
-    rewrite Rplus_0_r; rewrite (Rplus_comm (Un 1%nat));
-      rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r;
-        apply H1.
-  unfold Rminus in |- *; apply Rplus_lt_reg_r with (Un 3%nat);
-    rewrite Rplus_0_r; rewrite (Rplus_comm (Un 3%nat));
-      rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r;
-        apply H1.
-  intro; unfold Un in |- *.
-  cut ((2 * S n + 1)%nat = (2 * n + 1 + 2)%nat).
-  intro; rewrite H1.
-  rewrite pow_add; unfold Rdiv in |- *; rewrite Rmult_assoc;
-    apply Rmult_lt_compat_l.
-  apply pow_lt; assumption.
-  rewrite <- H1; apply Rmult_lt_reg_l with (INR (fact (2 * n + 1))).
-  apply lt_INR_0; apply neq_O_lt.
-  assert (H2 := fact_neq_0 (2 * n + 1)).
-  red in |- *; intro; elim H2; symmetry  in |- *; assumption.
-  rewrite <- Rinv_r_sym.
-  apply Rmult_lt_reg_l with (INR (fact (2 * S n + 1))).
-  apply lt_INR_0; apply neq_O_lt.
-  assert (H2 := fact_neq_0 (2 * S n + 1)).
-  red in |- *; intro; elim H2; symmetry  in |- *; assumption.
-  rewrite (Rmult_comm (INR (fact (2 * S n + 1)))); repeat rewrite Rmult_assoc;
-    rewrite <- Rinv_l_sym.
-  do 2 rewrite Rmult_1_r; apply Rle_lt_trans with (INR (fact (2 * n + 1)) * 4).
-  apply Rmult_le_compat_l.
-  replace 0 with (INR 0); [ idtac | reflexivity ]; apply le_INR; apply le_O_n.
-  simpl in |- *; rewrite Rmult_1_r; replace 4 with (Rsqr 2);
-    [ idtac | ring_Rsqr ]; replace (a * a) with (Rsqr a);
-    [ idtac | reflexivity ]; apply Rsqr_incr_1.
-  apply Rle_trans with (PI / 2);
-    [ assumption
-      | unfold Rdiv in |- *; apply Rmult_le_reg_l with 2;
-        [ prove_sup0
-          | rewrite <- Rmult_assoc; rewrite Rinv_r_simpl_m;
-            [ replace 4 with 4; [ apply PI_4 | ring ] | discrR ] ] ].
-  left; assumption.
-  left; prove_sup0.
-  rewrite H1; replace (2 * n + 1 + 2)%nat with (S (S (2 * n + 1))).
-  do 2 rewrite fact_simpl; do 2 rewrite mult_INR.
-  repeat rewrite <- Rmult_assoc.
-  rewrite <- (Rmult_comm (INR (fact (2 * n + 1)))).
-  rewrite Rmult_assoc.
-  apply Rmult_lt_compat_l.
-  apply lt_INR_0; apply neq_O_lt.
-  assert (H2 := fact_neq_0 (2 * n + 1)).
-  red in |- *; intro; elim H2; symmetry  in |- *; assumption.
-  do 2 rewrite S_INR; rewrite plus_INR; rewrite mult_INR; set (x := INR n);
-    unfold INR in |- *.
-  replace ((2 * x + 1 + 1 + 1) * (2 * x + 1 + 1)) with (4 * x * x + 10 * x + 6);
-  [ idtac | ring ].
-  apply Rplus_lt_reg_r with (-4); rewrite Rplus_opp_l;
-    replace (-4 + (4 * x * x + 10 * x + 6)) with (4 * x * x + 10 * x + 2);
-    [ idtac | ring ].
-  apply Rplus_le_lt_0_compat.
-  cut (0 <= x).
-  intro; apply Rplus_le_le_0_compat; repeat apply Rmult_le_pos;
-    assumption || left; prove_sup.
-  unfold x in |- *; replace 0 with (INR 0);
-    [ apply le_INR; apply le_O_n | reflexivity ].
-  prove_sup0.
-  ring.
-  apply INR_fact_neq_0.
-  apply INR_fact_neq_0.
-  ring.
-Qed.
-
-Lemma SIN : forall a:R, 0 <= a -> a <= PI -> sin_lb a <= sin a <= sin_ub a.
-  intros; unfold sin_lb, sin_ub in |- *; apply (sin_bound a 1 H H0).
-Qed.
-
-Lemma COS :
-  forall a:R, - PI / 2 <= a -> a <= PI / 2 -> cos_lb a <= cos a <= cos_ub a.
-  intros; unfold cos_lb, cos_ub in |- *; apply (cos_bound a 1 H H0).
-Qed.
-
-(**********)
-Lemma _PI2_RLT_0 : - (PI / 2) < 0.
-Proof.
-  rewrite <- Ropp_0; apply Ropp_lt_contravar; apply PI2_RGT_0.
-Qed.
-
-Lemma PI4_RLT_PI2 : PI / 4 < PI / 2.
-Proof.
-  unfold Rdiv in |- *; apply Rmult_lt_compat_l.
-  apply PI_RGT_0.
-  apply Rinv_lt_contravar.
-  apply Rmult_lt_0_compat; prove_sup0.
-  pattern 2 at 1 in |- *; rewrite <- Rplus_0_r.
-  replace 4 with (2 + 2); [ apply Rplus_lt_compat_l; prove_sup0 | ring ].
-Qed.
-
-Lemma PI2_Rlt_PI : PI / 2 < PI.
-Proof.
-  unfold Rdiv in |- *; pattern PI at 2 in |- *; rewrite <- Rmult_1_r.
-  apply Rmult_lt_compat_l.
-  apply PI_RGT_0.
-  pattern 1 at 3 in |- *; rewrite <- Rinv_1; apply Rinv_lt_contravar.
-  rewrite Rmult_1_l; prove_sup0.
-  pattern 1 at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
-    apply Rlt_0_1.
-Qed.
-
-(***************************************************)
-(** * Increasing and decreasing of [cos] and [sin] *)
-(***************************************************)
-Theorem sin_gt_0 : forall x:R, 0 < x -> x < PI -> 0 < sin x.
-Proof.
-  intros; elim (SIN x (Rlt_le 0 x H) (Rlt_le x PI H0)); intros H1 _;
-    case (Rtotal_order x (PI / 2)); intro H2.
-  apply Rlt_le_trans with (sin_lb x).
-  apply sin_lb_gt_0; [ assumption | left; assumption ].
-  assumption.
-  elim H2; intro H3.
-  rewrite H3; rewrite sin_PI2; apply Rlt_0_1.
-  rewrite <- sin_PI_x; generalize (Ropp_gt_lt_contravar x (PI / 2) H3);
-    intro H4; generalize (Rplus_lt_compat_l PI (- x) (- (PI / 2)) H4).
-  replace (PI + - x) with (PI - x).
-  replace (PI + - (PI / 2)) with (PI / 2).
-  intro H5; generalize (Ropp_lt_gt_contravar x PI H0); intro H6;
-    change (- PI < - x) in H6; generalize (Rplus_lt_compat_l PI (- PI) (- x) H6).
-  rewrite Rplus_opp_r.
-  replace (PI + - x) with (PI - x).
-  intro H7;
-    elim
-      (SIN (PI - x) (Rlt_le 0 (PI - x) H7)
-        (Rlt_le (PI - x) PI (Rlt_trans (PI - x) (PI / 2) PI H5 PI2_Rlt_PI)));
-      intros H8 _;
-        generalize (sin_lb_gt_0 (PI - x) H7 (Rlt_le (PI - x) (PI / 2) H5));
-          intro H9; apply (Rlt_le_trans 0 (sin_lb (PI - x)) (sin (PI - x)) H9 H8).
-  reflexivity.
-  pattern PI at 2 in |- *; rewrite double_var; ring.
-  reflexivity.
-Qed.
-
-Theorem cos_gt_0 : forall x:R, - (PI / 2) < x -> x < PI / 2 -> 0 < cos x.
-Proof.
-  intros; rewrite cos_sin;
-    generalize (Rplus_lt_compat_l (PI / 2) (- (PI / 2)) x H).
-  rewrite Rplus_opp_r; intro H1;
-    generalize (Rplus_lt_compat_l (PI / 2) x (PI / 2) H0);
-      rewrite <- double_var; intro H2; apply (sin_gt_0 (PI / 2 + x) H1 H2).
-Qed.
-
-Lemma sin_ge_0 : forall x:R, 0 <= x -> x <= PI -> 0 <= sin x.
-Proof.
-  intros x H1 H2; elim H1; intro H3;
-    [ elim H2; intro H4;
-      [ left; apply (sin_gt_0 x H3 H4)
-        | rewrite H4; right; symmetry  in |- *; apply sin_PI ]
-      | rewrite <- H3; right; symmetry  in |- *; apply sin_0 ].
-Qed.
-
-Lemma cos_ge_0 : forall x:R, - (PI / 2) <= x -> x <= PI / 2 -> 0 <= cos x.
-Proof.
-  intros x H1 H2; elim H1; intro H3;
-    [ elim H2; intro H4;
-      [ left; apply (cos_gt_0 x H3 H4)
-        | rewrite H4; right; symmetry  in |- *; apply cos_PI2 ]
-      | rewrite <- H3; rewrite cos_neg; right; symmetry  in |- *; apply cos_PI2 ].
-Qed.
-
-Lemma sin_le_0 : forall x:R, PI <= x -> x <= 2 * PI -> sin x <= 0.
-Proof.
-  intros x H1 H2; apply Rge_le; rewrite <- Ropp_0;
-    rewrite <- (Ropp_involutive (sin x)); apply Ropp_le_ge_contravar;
-      rewrite <- neg_sin; replace (x + PI) with (x - PI + 2 * INR 1 * PI);
-        [ rewrite (sin_period (x - PI) 1); apply sin_ge_0;
-          [ replace (x - PI) with (x + - PI);
-            [ rewrite Rplus_comm; replace 0 with (- PI + PI);
-              [ apply Rplus_le_compat_l; assumption | ring ]
-              | ring ]
-            | replace (x - PI) with (x + - PI); rewrite Rplus_comm;
-              [ pattern PI at 2 in |- *; replace PI with (- PI + 2 * PI);
-                [ apply Rplus_le_compat_l; assumption | ring ]
-                | ring ] ]
-          | unfold INR in |- *; ring ].
-Qed.
-
-Lemma cos_le_0 : forall x:R, PI / 2 <= x -> x <= 3 * (PI / 2) -> cos x <= 0.
-Proof.
-  intros x H1 H2; apply Rge_le; rewrite <- Ropp_0;
-    rewrite <- (Ropp_involutive (cos x)); apply Ropp_le_ge_contravar;
-      rewrite <- neg_cos; replace (x + PI) with (x - PI + 2 * INR 1 * PI).
-  rewrite cos_period; apply cos_ge_0.
-  replace (- (PI / 2)) with (- PI + PI / 2).
-  unfold Rminus in |- *; rewrite (Rplus_comm x); apply Rplus_le_compat_l;
-    assumption.
-  pattern PI at 1 in |- *; rewrite (double_var PI); rewrite Ropp_plus_distr;
-    ring.
-  unfold Rminus in |- *; rewrite Rplus_comm;
-    replace (PI / 2) with (- PI + 3 * (PI / 2)).
-  apply Rplus_le_compat_l; assumption.
-  pattern PI at 1 in |- *; rewrite (double_var PI); rewrite Ropp_plus_distr;
-    ring.
-  unfold INR in |- *; ring.
-Qed.
-
-Lemma sin_lt_0 : forall x:R, PI < x -> x < 2 * PI -> sin x < 0.
-Proof.
-  intros x H1 H2; rewrite <- Ropp_0; rewrite <- (Ropp_involutive (sin x));
-    apply Ropp_lt_gt_contravar; rewrite <- neg_sin;
-      replace (x + PI) with (x - PI + 2 * INR 1 * PI);
-      [ rewrite (sin_period (x - PI) 1); apply sin_gt_0;
-        [ replace (x - PI) with (x + - PI);
-          [ rewrite Rplus_comm; replace 0 with (- PI + PI);
-            [ apply Rplus_lt_compat_l; assumption | ring ]
-            | ring ]
-          | replace (x - PI) with (x + - PI); rewrite Rplus_comm;
-            [ pattern PI at 2 in |- *; replace PI with (- PI + 2 * PI);
-              [ apply Rplus_lt_compat_l; assumption | ring ]
-              | ring ] ]
-        | unfold INR in |- *; ring ].
-Qed.
-
-Lemma sin_lt_0_var : forall x:R, - PI < x -> x < 0 -> sin x < 0.
-Proof.
-  intros; generalize (Rplus_lt_compat_l (2 * PI) (- PI) x H);
-    replace (2 * PI + - PI) with PI;
-    [ intro H1; rewrite Rplus_comm in H1;
-      generalize (Rplus_lt_compat_l (2 * PI) x 0 H0);
-        intro H2; rewrite (Rplus_comm (2 * PI)) in H2;
-          rewrite <- (Rplus_comm 0) in H2; rewrite Rplus_0_l in H2;
-            rewrite <- (sin_period x 1); unfold INR in |- *;
-              replace (2 * 1 * PI) with (2 * PI);
-              [ apply (sin_lt_0 (x + 2 * PI) H1 H2) | ring ]
-      | ring ].
-Qed.
-
-Lemma cos_lt_0 : forall x:R, PI / 2 < x -> x < 3 * (PI / 2) -> cos x < 0.
-Proof.
-  intros x H1 H2; rewrite <- Ropp_0; rewrite <- (Ropp_involutive (cos x));
-    apply Ropp_lt_gt_contravar; rewrite <- neg_cos;
-      replace (x + PI) with (x - PI + 2 * INR 1 * PI).
-  rewrite cos_period; apply cos_gt_0.
-  replace (- (PI / 2)) with (- PI + PI / 2).
-  unfold Rminus in |- *; rewrite (Rplus_comm x); apply Rplus_lt_compat_l;
-    assumption.
-  pattern PI at 1 in |- *; rewrite (double_var PI); rewrite Ropp_plus_distr;
-    ring.
-  unfold Rminus in |- *; rewrite Rplus_comm;
-    replace (PI / 2) with (- PI + 3 * (PI / 2)).
-  apply Rplus_lt_compat_l; assumption.
-  pattern PI at 1 in |- *; rewrite (double_var PI); rewrite Ropp_plus_distr;
-    ring.
-  unfold INR in |- *; ring.
-Qed.
-
-Lemma tan_gt_0 : forall x:R, 0 < x -> x < PI / 2 -> 0 < tan x.
-Proof.
-  intros x H1 H2; unfold tan in |- *; generalize _PI2_RLT_0;
-    generalize (Rlt_trans 0 x (PI / 2) H1 H2); intros;
-      generalize (Rlt_trans (- (PI / 2)) 0 x H0 H1); intro H5;
-        generalize (Rlt_trans x (PI / 2) PI H2 PI2_Rlt_PI);
-          intro H7; unfold Rdiv in |- *; apply Rmult_lt_0_compat.
-  apply sin_gt_0; assumption.
-  apply Rinv_0_lt_compat; apply cos_gt_0; assumption.
-Qed.
-
-Lemma tan_lt_0 : forall x:R, - (PI / 2) < x -> x < 0 -> tan x < 0.
-Proof.
-  intros x H1 H2; unfold tan in |- *;
-    generalize (cos_gt_0 x H1 (Rlt_trans x 0 (PI / 2) H2 PI2_RGT_0));
-      intro H3; rewrite <- Ropp_0;
-        replace (sin x / cos x) with (- (- sin x / cos x)).
-  rewrite <- sin_neg; apply Ropp_gt_lt_contravar;
-    change (0 < sin (- x) / cos x) in |- *; unfold Rdiv in |- *;
-      apply Rmult_lt_0_compat.
-  apply sin_gt_0.
-  rewrite <- Ropp_0; apply Ropp_gt_lt_contravar; assumption.
-  apply Rlt_trans with (PI / 2).
-  rewrite <- (Ropp_involutive (PI / 2)); apply Ropp_gt_lt_contravar; assumption.
-  apply PI2_Rlt_PI.
-  apply Rinv_0_lt_compat; assumption.
-  unfold Rdiv in |- *; ring.
-Qed.
-
-Lemma cos_ge_0_3PI2 :
-  forall x:R, 3 * (PI / 2) <= x -> x <= 2 * PI -> 0 <= cos x.
-Proof.
-  intros; rewrite <- cos_neg; rewrite <- (cos_period (- x) 1);
-    unfold INR in |- *; replace (- x + 2 * 1 * PI) with (2 * PI - x).
-  generalize (Ropp_le_ge_contravar x (2 * PI) H0); intro H1;
-    generalize (Rge_le (- x) (- (2 * PI)) H1); clear H1;
-      intro H1; generalize (Rplus_le_compat_l (2 * PI) (- (2 * PI)) (- x) H1).
-  rewrite Rplus_opp_r.
-  intro H2; generalize (Ropp_le_ge_contravar (3 * (PI / 2)) x H); intro H3;
-    generalize (Rge_le (- (3 * (PI / 2))) (- x) H3); clear H3;
-      intro H3;
-        generalize (Rplus_le_compat_l (2 * PI) (- x) (- (3 * (PI / 2))) H3).
-  replace (2 * PI + - (3 * (PI / 2))) with (PI / 2).
-  intro H4;
-    apply
-      (cos_ge_0 (2 * PI - x)
-        (Rlt_le (- (PI / 2)) (2 * PI - x)
-          (Rlt_le_trans (- (PI / 2)) 0 (2 * PI - x) _PI2_RLT_0 H2)) H4).
-  rewrite double; pattern PI at 2 3 in |- *; rewrite double_var; ring.
-  ring.
-Qed.
-
-Lemma form1 :
-  forall p q:R, cos p + cos q = 2 * cos ((p - q) / 2) * cos ((p + q) / 2).
-Proof.
-  intros p q; pattern p at 1 in |- *;
-    replace p with ((p - q) / 2 + (p + q) / 2).
-  rewrite <- (cos_neg q); replace (- q) with ((p - q) / 2 - (p + q) / 2).
-  rewrite cos_plus; rewrite cos_minus; ring.
-  pattern q at 3 in |- *; rewrite double_var; unfold Rdiv in |- *; ring.
-  pattern p at 3 in |- *; rewrite double_var; unfold Rdiv in |- *; ring.
-Qed.
-
-Lemma form2 :
-  forall p q:R, cos p - cos q = -2 * sin ((p - q) / 2) * sin ((p + q) / 2).
-Proof.
-  intros p q; pattern p at 1 in |- *;
-    replace p with ((p - q) / 2 + (p + q) / 2).
-  rewrite <- (cos_neg q); replace (- q) with ((p - q) / 2 - (p + q) / 2).
-  rewrite cos_plus; rewrite cos_minus; ring.
-  pattern q at 3 in |- *; rewrite double_var; unfold Rdiv in |- *; ring.
-  pattern p at 3 in |- *; rewrite double_var; unfold Rdiv in |- *; ring.
-Qed.
-
-Lemma form3 :
-  forall p q:R, sin p + sin q = 2 * cos ((p - q) / 2) * sin ((p + q) / 2).
-Proof.
-  intros p q; pattern p at 1 in |- *;
-    replace p with ((p - q) / 2 + (p + q) / 2).
-  pattern q at 3 in |- *; replace q with ((p + q) / 2 - (p - q) / 2).
-  rewrite sin_plus; rewrite sin_minus; ring.
-  pattern q at 3 in |- *; rewrite double_var; unfold Rdiv in |- *; ring.
-  pattern p at 3 in |- *; rewrite double_var; unfold Rdiv in |- *; ring.
-Qed.
-
-Lemma form4 :
-  forall p q:R, sin p - sin q = 2 * cos ((p + q) / 2) * sin ((p - q) / 2).
-Proof.
-  intros p q; pattern p at 1 in |- *;
-    replace p with ((p - q) / 2 + (p + q) / 2).
-  pattern q at 3 in |- *; replace q with ((p + q) / 2 - (p - q) / 2).
-  rewrite sin_plus; rewrite sin_minus; ring.
-  pattern q at 3 in |- *; rewrite double_var; unfold Rdiv in |- *; ring.
-  pattern p at 3 in |- *; rewrite double_var; unfold Rdiv in |- *; ring.
-
-Qed.
-
-Lemma sin_increasing_0 :
-  forall x y:R,
-    - (PI / 2) <= x ->
-    x <= PI / 2 -> - (PI / 2) <= y -> y <= PI / 2 -> sin x < sin y -> x < y.
-Proof.
-  intros; cut (sin ((x - y) / 2) < 0).
-  intro H4; case (Rtotal_order ((x - y) / 2) 0); intro H5.
-  assert (Hyp : 0 < 2).
-  prove_sup0.
-  generalize (Rmult_lt_compat_l 2 ((x - y) / 2) 0 Hyp H5).
-  unfold Rdiv in |- *.
-  rewrite <- Rmult_assoc.
-  rewrite Rinv_r_simpl_m.
-  rewrite Rmult_0_r.
-  clear H5; intro H5; apply Rminus_lt; assumption.
-  discrR.
-  elim H5; intro H6.
-  rewrite H6 in H4; rewrite sin_0 in H4; elim (Rlt_irrefl 0 H4).
-  change (0 < (x - y) / 2) in H6;
-    generalize (Ropp_le_ge_contravar (- (PI / 2)) y H1).
-  rewrite Ropp_involutive.
-  intro H7; generalize (Rge_le (PI / 2) (- y) H7); clear H7; intro H7;
-    generalize (Rplus_le_compat x (PI / 2) (- y) (PI / 2) H0 H7).
-  rewrite <- double_var.
-  intro H8.
-  assert (Hyp : 0 < 2).
-  prove_sup0.
-  generalize
-    (Rmult_le_compat_l (/ 2) (x - y) PI
-      (Rlt_le 0 (/ 2) (Rinv_0_lt_compat 2 Hyp)) H8).
-  repeat rewrite (Rmult_comm (/ 2)).
-  intro H9;
-    generalize
-      (sin_gt_0 ((x - y) / 2) H6
-        (Rle_lt_trans ((x - y) / 2) (PI / 2) PI H9 PI2_Rlt_PI));
-      intro H10;
-        elim
-          (Rlt_irrefl (sin ((x - y) / 2))
-            (Rlt_trans (sin ((x - y) / 2)) 0 (sin ((x - y) / 2)) H4 H10)).
-  generalize (Rlt_minus (sin x) (sin y) H3); clear H3; intro H3;
-    rewrite form4 in H3;
-      generalize (Rplus_le_compat x (PI / 2) y (PI / 2) H0 H2).
-  rewrite <- double_var.
-  assert (Hyp : 0 < 2).
-  prove_sup0.
-  intro H4;
-    generalize
-      (Rmult_le_compat_l (/ 2) (x + y) PI
-        (Rlt_le 0 (/ 2) (Rinv_0_lt_compat 2 Hyp)) H4).
-  repeat rewrite (Rmult_comm (/ 2)).
-  clear H4; intro H4;
-    generalize (Rplus_le_compat (- (PI / 2)) x (- (PI / 2)) y H H1);
-      replace (- (PI / 2) + - (PI / 2)) with (- PI).
-  intro H5;
-    generalize
-      (Rmult_le_compat_l (/ 2) (- PI) (x + y)
-        (Rlt_le 0 (/ 2) (Rinv_0_lt_compat 2 Hyp)) H5).
-  replace (/ 2 * (x + y)) with ((x + y) / 2).
-  replace (/ 2 * - PI) with (- (PI / 2)).
-  clear H5; intro H5; elim H4; intro H40.
-  elim H5; intro H50.
-  generalize (cos_gt_0 ((x + y) / 2) H50 H40); intro H6;
-    generalize (Rmult_lt_compat_l 2 0 (cos ((x + y) / 2)) Hyp H6).
-  rewrite Rmult_0_r.
-  clear H6; intro H6; case (Rcase_abs (sin ((x - y) / 2))); intro H7.
-  assumption.
-  generalize (Rge_le (sin ((x - y) / 2)) 0 H7); clear H7; intro H7;
-    generalize
-      (Rmult_le_pos (2 * cos ((x + y) / 2)) (sin ((x - y) / 2))
-        (Rlt_le 0 (2 * cos ((x + y) / 2)) H6) H7); intro H8;
-      generalize
-        (Rle_lt_trans 0 (2 * cos ((x + y) / 2) * sin ((x - y) / 2)) 0 H8 H3);
-        intro H9; elim (Rlt_irrefl 0 H9).
-  rewrite <- H50 in H3; rewrite cos_neg in H3; rewrite cos_PI2 in H3;
-    rewrite Rmult_0_r in H3; rewrite Rmult_0_l in H3;
-      elim (Rlt_irrefl 0 H3).
-  unfold Rdiv in H3.
-  rewrite H40 in H3; assert (H50 := cos_PI2); unfold Rdiv in H50;
-    rewrite H50 in H3; rewrite Rmult_0_r in H3; rewrite Rmult_0_l in H3;
-      elim (Rlt_irrefl 0 H3).
-  unfold Rdiv in |- *.
-  rewrite <- Ropp_mult_distr_l_reverse.
-  apply Rmult_comm.
-  unfold Rdiv in |- *; apply Rmult_comm.
-  pattern PI at 1 in |- *; rewrite double_var.
-  rewrite Ropp_plus_distr.
-  reflexivity.
-Qed.
-
-Lemma sin_increasing_1 :
-  forall x y:R,
-    - (PI / 2) <= x ->
-    x <= PI / 2 -> - (PI / 2) <= y -> y <= PI / 2 -> x < y -> sin x < sin y.
-Proof.
-  intros; generalize (Rplus_lt_compat_l x x y H3); intro H4;
-    generalize (Rplus_le_compat (- (PI / 2)) x (- (PI / 2)) x H H);
-      replace (- (PI / 2) + - (PI / 2)) with (- PI).
-  assert (Hyp : 0 < 2).
-  prove_sup0.
-  intro H5; generalize (Rle_lt_trans (- PI) (x + x) (x + y) H5 H4); intro H6;
-    generalize
-      (Rmult_lt_compat_l (/ 2) (- PI) (x + y) (Rinv_0_lt_compat 2 Hyp) H6);
-      replace (/ 2 * - PI) with (- (PI / 2)).
-  replace (/ 2 * (x + y)) with ((x + y) / 2).
-  clear H4 H5 H6; intro H4; generalize (Rplus_lt_compat_l y x y H3); intro H5;
-    rewrite Rplus_comm in H5;
-      generalize (Rplus_le_compat y (PI / 2) y (PI / 2) H2 H2).
-  rewrite <- double_var.
-  intro H6; generalize (Rlt_le_trans (x + y) (y + y) PI H5 H6); intro H7;
-    generalize (Rmult_lt_compat_l (/ 2) (x + y) PI (Rinv_0_lt_compat 2 Hyp) H7);
-      replace (/ 2 * PI) with (PI / 2).
-  replace (/ 2 * (x + y)) with ((x + y) / 2).
-  clear H5 H6 H7; intro H5; generalize (Ropp_le_ge_contravar (- (PI / 2)) y H1);
-    rewrite Ropp_involutive; clear H1; intro H1;
-      generalize (Rge_le (PI / 2) (- y) H1); clear H1; intro H1;
-        generalize (Ropp_le_ge_contravar y (PI / 2) H2); clear H2;
-          intro H2; generalize (Rge_le (- y) (- (PI / 2)) H2);
-            clear H2; intro H2; generalize (Rplus_lt_compat_l (- y) x y H3);
-              replace (- y + x) with (x - y).
-  rewrite Rplus_opp_l.
-  intro H6;
-    generalize (Rmult_lt_compat_l (/ 2) (x - y) 0 (Rinv_0_lt_compat 2 Hyp) H6);
-      rewrite Rmult_0_r; replace (/ 2 * (x - y)) with ((x - y) / 2).
-  clear H6; intro H6;
-    generalize (Rplus_le_compat (- (PI / 2)) x (- (PI / 2)) (- y) H H2);
-      replace (- (PI / 2) + - (PI / 2)) with (- PI).
-  replace (x + - y) with (x - y).
-  intro H7;
-    generalize
-      (Rmult_le_compat_l (/ 2) (- PI) (x - y)
-        (Rlt_le 0 (/ 2) (Rinv_0_lt_compat 2 Hyp)) H7);
-      replace (/ 2 * - PI) with (- (PI / 2)).
-  replace (/ 2 * (x - y)) with ((x - y) / 2).
-  clear H7; intro H7; clear H H0 H1 H2; apply Rminus_lt; rewrite form4;
-    generalize (cos_gt_0 ((x + y) / 2) H4 H5); intro H8;
-      generalize (Rmult_lt_0_compat 2 (cos ((x + y) / 2)) Hyp H8);
-        clear H8; intro H8; cut (- PI < - (PI / 2)).
-  intro H9;
-    generalize
-      (sin_lt_0_var ((x - y) / 2)
-        (Rlt_le_trans (- PI) (- (PI / 2)) ((x - y) / 2) H9 H7) H6);
-      intro H10;
-        generalize
-          (Rmult_lt_gt_compat_neg_l (sin ((x - y) / 2)) 0 (
-            2 * cos ((x + y) / 2)) H10 H8); intro H11; rewrite Rmult_0_r in H11;
-          rewrite Rmult_comm; assumption.
-  apply Ropp_lt_gt_contravar; apply PI2_Rlt_PI.
-  unfold Rdiv in |- *; apply Rmult_comm.
-  unfold Rdiv in |- *; rewrite <- Ropp_mult_distr_l_reverse; apply Rmult_comm.
-  reflexivity.
-  pattern PI at 1 in |- *; rewrite double_var.
-  rewrite Ropp_plus_distr.
-  reflexivity.
-  unfold Rdiv in |- *; apply Rmult_comm.
-  unfold Rminus in |- *; apply Rplus_comm.
-  unfold Rdiv in |- *; apply Rmult_comm.
-  unfold Rdiv in |- *; apply Rmult_comm.
-  unfold Rdiv in |- *; apply Rmult_comm.
-  unfold Rdiv in |- *.
-  rewrite <- Ropp_mult_distr_l_reverse.
-  apply Rmult_comm.
-  pattern PI at 1 in |- *; rewrite double_var.
-  rewrite Ropp_plus_distr.
-  reflexivity.
-Qed.
-
-Lemma sin_decreasing_0 :
-  forall x y:R,
-    x <= 3 * (PI / 2) ->
-    PI / 2 <= x -> y <= 3 * (PI / 2) -> PI / 2 <= y -> sin x < sin y -> y < x.
-Proof.
-  intros; rewrite <- (sin_PI_x x) in H3; rewrite <- (sin_PI_x y) in H3;
-    generalize (Ropp_lt_gt_contravar (sin (PI - x)) (sin (PI - y)) H3);
-      repeat rewrite <- sin_neg;
-        generalize (Rplus_le_compat_l (- PI) x (3 * (PI / 2)) H);
-          generalize (Rplus_le_compat_l (- PI) (PI / 2) x H0);
-            generalize (Rplus_le_compat_l (- PI) y (3 * (PI / 2)) H1);
-              generalize (Rplus_le_compat_l (- PI) (PI / 2) y H2);
-                replace (- PI + x) with (x - PI).
-  replace (- PI + PI / 2) with (- (PI / 2)).
-  replace (- PI + y) with (y - PI).
-  replace (- PI + 3 * (PI / 2)) with (PI / 2).
-  replace (- (PI - x)) with (x - PI).
-  replace (- (PI - y)) with (y - PI).
-  intros; change (sin (y - PI) < sin (x - PI)) in H8;
-    apply Rplus_lt_reg_r with (- PI); rewrite Rplus_comm;
-      replace (y + - PI) with (y - PI).
-  rewrite Rplus_comm; replace (x + - PI) with (x - PI).
-  apply (sin_increasing_0 (y - PI) (x - PI) H4 H5 H6 H7 H8).
-  reflexivity.
-  reflexivity.
-  unfold Rminus in |- *; rewrite Ropp_plus_distr.
-  rewrite Ropp_involutive.
-  apply Rplus_comm.
-  unfold Rminus in |- *; rewrite Ropp_plus_distr.
-  rewrite Ropp_involutive.
-  apply Rplus_comm.
-  pattern PI at 2 in |- *; rewrite double_var.
-  rewrite Ropp_plus_distr.
-  ring.
-  unfold Rminus in |- *; apply Rplus_comm.
-  pattern PI at 2 in |- *; rewrite double_var.
-  rewrite Ropp_plus_distr.
-  ring.
-  unfold Rminus in |- *; apply Rplus_comm.
-Qed.
-
-Lemma sin_decreasing_1 :
-  forall x y:R,
-    x <= 3 * (PI / 2) ->
-    PI / 2 <= x -> y <= 3 * (PI / 2) -> PI / 2 <= y -> x < y -> sin y < sin x.
-Proof.
-  intros; rewrite <- (sin_PI_x x); rewrite <- (sin_PI_x y);
-    generalize (Rplus_le_compat_l (- PI) x (3 * (PI / 2)) H);
-      generalize (Rplus_le_compat_l (- PI) (PI / 2) x H0);
-        generalize (Rplus_le_compat_l (- PI) y (3 * (PI / 2)) H1);
-          generalize (Rplus_le_compat_l (- PI) (PI / 2) y H2);
-            generalize (Rplus_lt_compat_l (- PI) x y H3);
-              replace (- PI + PI / 2) with (- (PI / 2)).
-  replace (- PI + y) with (y - PI).
-  replace (- PI + 3 * (PI / 2)) with (PI / 2).
-  replace (- PI + x) with (x - PI).
-  intros; apply Ropp_lt_cancel; repeat rewrite <- sin_neg;
-    replace (- (PI - x)) with (x - PI).
-  replace (- (PI - y)) with (y - PI).
-  apply (sin_increasing_1 (x - PI) (y - PI) H7 H8 H5 H6 H4).
-  unfold Rminus in |- *; rewrite Ropp_plus_distr.
-  rewrite Ropp_involutive.
-  apply Rplus_comm.
-  unfold Rminus in |- *; rewrite Ropp_plus_distr.
-  rewrite Ropp_involutive.
-  apply Rplus_comm.
-  unfold Rminus in |- *; apply Rplus_comm.
-  pattern PI at 2 in |- *; rewrite double_var; ring.
-  unfold Rminus in |- *; apply Rplus_comm.
-  pattern PI at 2 in |- *; rewrite double_var; ring.
-Qed.
-
-Lemma cos_increasing_0 :
-  forall x y:R,
-    PI <= x -> x <= 2 * PI -> PI <= y -> y <= 2 * PI -> cos x < cos y -> x < y.
-Proof.
-  intros x y H1 H2 H3 H4; rewrite <- (cos_neg x); rewrite <- (cos_neg y);
-    rewrite <- (cos_period (- x) 1); rewrite <- (cos_period (- y) 1);
-      unfold INR in |- *;
-        replace (- x + 2 * 1 * PI) with (PI / 2 - (x - 3 * (PI / 2))).
-  replace (- y + 2 * 1 * PI) with (PI / 2 - (y - 3 * (PI / 2))).
-  repeat rewrite cos_shift; intro H5;
-    generalize (Rplus_le_compat_l (-3 * (PI / 2)) PI x H1);
-      generalize (Rplus_le_compat_l (-3 * (PI / 2)) x (2 * PI) H2);
-        generalize (Rplus_le_compat_l (-3 * (PI / 2)) PI y H3);
-          generalize (Rplus_le_compat_l (-3 * (PI / 2)) y (2 * PI) H4).
-  replace (-3 * (PI / 2) + y) with (y - 3 * (PI / 2)).
-  replace (-3 * (PI / 2) + x) with (x - 3 * (PI / 2)).
-  replace (-3 * (PI / 2) + 2 * PI) with (PI / 2).
-  replace (-3 * (PI / 2) + PI) with (- (PI / 2)).
-  clear H1 H2 H3 H4; intros H1 H2 H3 H4;
-    apply Rplus_lt_reg_r with (-3 * (PI / 2));
-      replace (-3 * (PI / 2) + x) with (x - 3 * (PI / 2)).
-  replace (-3 * (PI / 2) + y) with (y - 3 * (PI / 2)).
-  apply (sin_increasing_0 (x - 3 * (PI / 2)) (y - 3 * (PI / 2)) H4 H3 H2 H1 H5).
-  unfold Rminus in |- *.
-  rewrite Ropp_mult_distr_l_reverse.
-  apply Rplus_comm.
-  unfold Rminus in |- *.
-  rewrite Ropp_mult_distr_l_reverse.
-  apply Rplus_comm.
-  pattern PI at 3 in |- *; rewrite double_var.
-  ring.
-  rewrite double; pattern PI at 3 4 in |- *; rewrite double_var.
-  ring.
-  unfold Rminus in |- *.
-  rewrite Ropp_mult_distr_l_reverse.
-  apply Rplus_comm.
-  unfold Rminus in |- *.
-  rewrite Ropp_mult_distr_l_reverse.
-  apply Rplus_comm.
-  rewrite Rmult_1_r.
-  rewrite (double PI); pattern PI at 3 4 in |- *; rewrite double_var.
-  ring.
-  rewrite Rmult_1_r.
-  rewrite (double PI); pattern PI at 3 4 in |- *; rewrite double_var.
-  ring.
-Qed.
-
-Lemma cos_increasing_1 :
-  forall x y:R,
-    PI <= x -> x <= 2 * PI -> PI <= y -> y <= 2 * PI -> x < y -> cos x < cos y.
-Proof.
-  intros x y H1 H2 H3 H4 H5;
-    generalize (Rplus_le_compat_l (-3 * (PI / 2)) PI x H1);
-      generalize (Rplus_le_compat_l (-3 * (PI / 2)) x (2 * PI) H2);
-        generalize (Rplus_le_compat_l (-3 * (PI / 2)) PI y H3);
-          generalize (Rplus_le_compat_l (-3 * (PI / 2)) y (2 * PI) H4);
-            generalize (Rplus_lt_compat_l (-3 * (PI / 2)) x y H5);
-              rewrite <- (cos_neg x); rewrite <- (cos_neg y);
-                rewrite <- (cos_period (- x) 1); rewrite <- (cos_period (- y) 1);
-                  unfold INR in |- *; replace (-3 * (PI / 2) + x) with (x - 3 * (PI / 2)).
-  replace (-3 * (PI / 2) + y) with (y - 3 * (PI / 2)).
-  replace (-3 * (PI / 2) + PI) with (- (PI / 2)).
-  replace (-3 * (PI / 2) + 2 * PI) with (PI / 2).
-  clear H1 H2 H3 H4 H5; intros H1 H2 H3 H4 H5;
-    replace (- x + 2 * 1 * PI) with (PI / 2 - (x - 3 * (PI / 2))).
-  replace (- y + 2 * 1 * PI) with (PI / 2 - (y - 3 * (PI / 2))).
-  repeat rewrite cos_shift;
-    apply
-      (sin_increasing_1 (x - 3 * (PI / 2)) (y - 3 * (PI / 2)) H5 H4 H3 H2 H1).
-  rewrite Rmult_1_r.
-  rewrite (double PI); pattern PI at 3 4 in |- *; rewrite double_var.
-  ring.
-  rewrite Rmult_1_r.
-  rewrite (double PI); pattern PI at 3 4 in |- *; rewrite double_var.
-  ring.
-  rewrite (double PI); pattern PI at 3 4 in |- *; rewrite double_var.
-  ring.
-  pattern PI at 3 in |- *; rewrite double_var; ring.
-  unfold Rminus in |- *.
-  rewrite <- Ropp_mult_distr_l_reverse.
-  apply Rplus_comm.
-  unfold Rminus in |- *.
-  rewrite <- Ropp_mult_distr_l_reverse.
-  apply Rplus_comm.
-Qed.
-
-Lemma cos_decreasing_0 :
-  forall x y:R,
-    0 <= x -> x <= PI -> 0 <= y -> y <= PI -> cos x < cos y -> y < x.
-Proof.
-  intros; generalize (Ropp_lt_gt_contravar (cos x) (cos y) H3);
-    repeat rewrite <- neg_cos; intro H4;
-      change (cos (y + PI) < cos (x + PI)) in H4; rewrite (Rplus_comm x) in H4;
-        rewrite (Rplus_comm y) in H4; generalize (Rplus_le_compat_l PI 0 x H);
-          generalize (Rplus_le_compat_l PI x PI H0);
-            generalize (Rplus_le_compat_l PI 0 y H1);
-              generalize (Rplus_le_compat_l PI y PI H2); rewrite Rplus_0_r.
-  rewrite <- double.
-  clear H H0 H1 H2 H3; intros; apply Rplus_lt_reg_r with PI;
-    apply (cos_increasing_0 (PI + y) (PI + x) H0 H H2 H1 H4).
-Qed.
-
-Lemma cos_decreasing_1 :
-  forall x y:R,
-    0 <= x -> x <= PI -> 0 <= y -> y <= PI -> x < y -> cos y < cos x.
-Proof.
-  intros; apply Ropp_lt_cancel; repeat rewrite <- neg_cos;
-    rewrite (Rplus_comm x); rewrite (Rplus_comm y);
-      generalize (Rplus_le_compat_l PI 0 x H);
-        generalize (Rplus_le_compat_l PI x PI H0);
-          generalize (Rplus_le_compat_l PI 0 y H1);
-            generalize (Rplus_le_compat_l PI y PI H2); rewrite Rplus_0_r.
-  rewrite <- double.
-  generalize (Rplus_lt_compat_l PI x y H3); clear H H0 H1 H2 H3; intros;
-    apply (cos_increasing_1 (PI + x) (PI + y) H3 H2 H1 H0 H).
-Qed.
-
-Lemma tan_diff :
-  forall x y:R,
-    cos x <> 0 -> cos y <> 0 -> tan x - tan y = sin (x - y) / (cos x * cos y).
-Proof.
-  intros; unfold tan in |- *; rewrite sin_minus.
-  unfold Rdiv in |- *.
-  unfold Rminus in |- *.
-  rewrite Rmult_plus_distr_r.
-  rewrite Rinv_mult_distr.
-  repeat rewrite (Rmult_comm (sin x)).
-  repeat rewrite Rmult_assoc.
-  rewrite (Rmult_comm (cos y)).
-  repeat rewrite Rmult_assoc.
-  rewrite <- Rinv_l_sym.
-  rewrite Rmult_1_r.
-  rewrite (Rmult_comm (sin x)).
-  apply Rplus_eq_compat_l.
-  rewrite <- Ropp_mult_distr_l_reverse.
-  rewrite <- Ropp_mult_distr_r_reverse.
-  rewrite (Rmult_comm (/ cos x)).
-  repeat rewrite Rmult_assoc.
-  rewrite (Rmult_comm (cos x)).
-  repeat rewrite Rmult_assoc.
-  rewrite <- Rinv_l_sym.
-  rewrite Rmult_1_r.
-  reflexivity.
-  assumption.
-  assumption.
-  assumption.
-  assumption.
-Qed.
-
-Lemma tan_increasing_0 :
-  forall x y:R,
-    - (PI / 4) <= x ->
-    x <= PI / 4 -> - (PI / 4) <= y -> y <= PI / 4 -> tan x < tan y -> x < y.
-Proof.
-  intros; generalize PI4_RLT_PI2; intro H4;
-    generalize (Ropp_lt_gt_contravar (PI / 4) (PI / 2) H4);
-      intro H5; change (- (PI / 2) < - (PI / 4)) in H5;
-        generalize
-          (cos_gt_0 x (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) x H5 H)
-            (Rle_lt_trans x (PI / 4) (PI / 2) H0 H4)); intro HP1;
-          generalize
-            (cos_gt_0 y (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) y H5 H1)
-              (Rle_lt_trans y (PI / 4) (PI / 2) H2 H4)); intro HP2;
-            generalize
-              (sym_not_eq
-                (Rlt_not_eq 0 (cos x)
-                  (cos_gt_0 x (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) x H5 H)
-                    (Rle_lt_trans x (PI / 4) (PI / 2) H0 H4))));
-              intro H6;
-                generalize
-                  (sym_not_eq
-                    (Rlt_not_eq 0 (cos y)
-                      (cos_gt_0 y (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) y H5 H1)
-                        (Rle_lt_trans y (PI / 4) (PI / 2) H2 H4))));
-                  intro H7; generalize (tan_diff x y H6 H7); intro H8;
-                    generalize (Rlt_minus (tan x) (tan y) H3); clear H3;
-                      intro H3; rewrite H8 in H3; cut (sin (x - y) < 0).
-  intro H9; generalize (Ropp_le_ge_contravar (- (PI / 4)) y H1);
-    rewrite Ropp_involutive; intro H10; generalize (Rge_le (PI / 4) (- y) H10);
-      clear H10; intro H10; generalize (Ropp_le_ge_contravar y (PI / 4) H2);
-        intro H11; generalize (Rge_le (- y) (- (PI / 4)) H11);
-          clear H11; intro H11;
-            generalize (Rplus_le_compat (- (PI / 4)) x (- (PI / 4)) (- y) H H11);
-              generalize (Rplus_le_compat x (PI / 4) (- y) (PI / 4) H0 H10);
-                replace (x + - y) with (x - y).
-  replace (PI / 4 + PI / 4) with (PI / 2).
-  replace (- (PI / 4) + - (PI / 4)) with (- (PI / 2)).
-  intros; case (Rtotal_order 0 (x - y)); intro H14.
-  generalize
-    (sin_gt_0 (x - y) H14 (Rle_lt_trans (x - y) (PI / 2) PI H12 PI2_Rlt_PI));
-    intro H15; elim (Rlt_irrefl 0 (Rlt_trans 0 (sin (x - y)) 0 H15 H9)).
-  elim H14; intro H15.
-  rewrite <- H15 in H9; rewrite sin_0 in H9; elim (Rlt_irrefl 0 H9).
-  apply Rminus_lt; assumption.
-  pattern PI at 1 in |- *; rewrite double_var.
-  unfold Rdiv in |- *.
-  rewrite Rmult_plus_distr_r.
-  repeat rewrite Rmult_assoc.
-  rewrite <- Rinv_mult_distr.
-  rewrite Ropp_plus_distr.
-  replace 4 with 4.
-  reflexivity.
-  ring.
-  discrR.
-  discrR.
-  pattern PI at 1 in |- *; rewrite double_var.
-  unfold Rdiv in |- *.
-  rewrite Rmult_plus_distr_r.
-  repeat rewrite Rmult_assoc.
-  rewrite <- Rinv_mult_distr.
-  replace 4 with 4.
-  reflexivity.
-  ring.
-  discrR.
-  discrR.
-  reflexivity.
-  case (Rcase_abs (sin (x - y))); intro H9.
-  assumption.
-  generalize (Rge_le (sin (x - y)) 0 H9); clear H9; intro H9;
-    generalize (Rinv_0_lt_compat (cos x) HP1); intro H10;
-      generalize (Rinv_0_lt_compat (cos y) HP2); intro H11;
-        generalize (Rmult_lt_0_compat (/ cos x) (/ cos y) H10 H11);
-          replace (/ cos x * / cos y) with (/ (cos x * cos y)).
-  intro H12;
-    generalize
-      (Rmult_le_pos (sin (x - y)) (/ (cos x * cos y)) H9
-        (Rlt_le 0 (/ (cos x * cos y)) H12)); intro H13;
-      elim
-        (Rlt_irrefl 0 (Rle_lt_trans 0 (sin (x - y) * / (cos x * cos y)) 0 H13 H3)).
-  rewrite Rinv_mult_distr.
-  reflexivity.
-  assumption.
-  assumption.
-Qed.
-
-Lemma tan_increasing_1 :
-  forall x y:R,
-    - (PI / 4) <= x ->
-    x <= PI / 4 -> - (PI / 4) <= y -> y <= PI / 4 -> x < y -> tan x < tan y.
-Proof.
-  intros; apply Rminus_lt; generalize PI4_RLT_PI2; intro H4;
-    generalize (Ropp_lt_gt_contravar (PI / 4) (PI / 2) H4);
-      intro H5; change (- (PI / 2) < - (PI / 4)) in H5;
-        generalize
-          (cos_gt_0 x (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) x H5 H)
-            (Rle_lt_trans x (PI / 4) (PI / 2) H0 H4)); intro HP1;
-          generalize
-            (cos_gt_0 y (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) y H5 H1)
-              (Rle_lt_trans y (PI / 4) (PI / 2) H2 H4)); intro HP2;
-            generalize
-              (sym_not_eq
-                (Rlt_not_eq 0 (cos x)
-                  (cos_gt_0 x (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) x H5 H)
-                    (Rle_lt_trans x (PI / 4) (PI / 2) H0 H4))));
-              intro H6;
-                generalize
-                  (sym_not_eq
-                    (Rlt_not_eq 0 (cos y)
-                      (cos_gt_0 y (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) y H5 H1)
-                        (Rle_lt_trans y (PI / 4) (PI / 2) H2 H4))));
-                  intro H7; rewrite (tan_diff x y H6 H7);
-                    generalize (Rinv_0_lt_compat (cos x) HP1); intro H10;
-                      generalize (Rinv_0_lt_compat (cos y) HP2); intro H11;
-                        generalize (Rmult_lt_0_compat (/ cos x) (/ cos y) H10 H11);
-                          replace (/ cos x * / cos y) with (/ (cos x * cos y)).
-  clear H10 H11; intro H8; generalize (Ropp_le_ge_contravar y (PI / 4) H2);
-    intro H11; generalize (Rge_le (- y) (- (PI / 4)) H11);
-      clear H11; intro H11;
-        generalize (Rplus_le_compat (- (PI / 4)) x (- (PI / 4)) (- y) H H11);
-          replace (x + - y) with (x - y).
-  replace (- (PI / 4) + - (PI / 4)) with (- (PI / 2)).
-  clear H11; intro H9; generalize (Rlt_minus x y H3); clear H3; intro H3;
-    clear H H0 H1 H2 H4 H5 HP1 HP2; generalize PI2_Rlt_PI;
-      intro H1; generalize (Ropp_lt_gt_contravar (PI / 2) PI H1);
-        clear H1; intro H1;
-          generalize
-            (sin_lt_0_var (x - y) (Rlt_le_trans (- PI) (- (PI / 2)) (x - y) H1 H9) H3);
-            intro H2;
-              generalize
-                (Rmult_lt_gt_compat_neg_l (sin (x - y)) 0 (/ (cos x * cos y)) H2 H8);
-                rewrite Rmult_0_r; intro H4; assumption.
-  pattern PI at 1 in |- *; rewrite double_var.
-  unfold Rdiv in |- *.
-  rewrite Rmult_plus_distr_r.
-  repeat rewrite Rmult_assoc.
-  rewrite <- Rinv_mult_distr.
-  replace 4 with 4.
-  rewrite Ropp_plus_distr.
-  reflexivity.
-  ring.
-  discrR.
-  discrR.
-  reflexivity.
-  apply Rinv_mult_distr; assumption.
-Qed.
-
-Lemma sin_incr_0 :
-  forall x y:R,
-    - (PI / 2) <= x ->
-    x <= PI / 2 -> - (PI / 2) <= y -> y <= PI / 2 -> sin x <= sin y -> x <= y.
-Proof.
-  intros; case (Rtotal_order (sin x) (sin y)); intro H4;
-    [ left; apply (sin_increasing_0 x y H H0 H1 H2 H4)
-      | elim H4; intro H5;
-        [ case (Rtotal_order x y); intro H6;
-          [ left; assumption
-            | elim H6; intro H7;
-              [ right; assumption
-                | generalize (sin_increasing_1 y x H1 H2 H H0 H7); intro H8;
-                  rewrite H5 in H8; elim (Rlt_irrefl (sin y) H8) ] ]
-          | elim (Rlt_irrefl (sin x) (Rle_lt_trans (sin x) (sin y) (sin x) H3 H5)) ] ].
-Qed.
-
-Lemma sin_incr_1 :
-  forall x y:R,
-    - (PI / 2) <= x ->
-    x <= PI / 2 -> - (PI / 2) <= y -> y <= PI / 2 -> x <= y -> sin x <= sin y.
-Proof.
-  intros; case (Rtotal_order x y); intro H4;
-    [ left; apply (sin_increasing_1 x y H H0 H1 H2 H4)
-      | elim H4; intro H5;
-        [ case (Rtotal_order (sin x) (sin y)); intro H6;
-          [ left; assumption
-            | elim H6; intro H7;
-              [ right; assumption
-                | generalize (sin_increasing_0 y x H1 H2 H H0 H7); intro H8;
-                  rewrite H5 in H8; elim (Rlt_irrefl y H8) ] ]
-          | elim (Rlt_irrefl x (Rle_lt_trans x y x H3 H5)) ] ].
-Qed.
-
-Lemma sin_decr_0 :
-  forall x y:R,
-    x <= 3 * (PI / 2) ->
-    PI / 2 <= x ->
-    y <= 3 * (PI / 2) -> PI / 2 <= y -> sin x <= sin y -> y <= x.
-Proof.
-  intros; case (Rtotal_order (sin x) (sin y)); intro H4;
-    [ left; apply (sin_decreasing_0 x y H H0 H1 H2 H4)
-      | elim H4; intro H5;
-        [ case (Rtotal_order x y); intro H6;
-          [ generalize (sin_decreasing_1 x y H H0 H1 H2 H6); intro H8;
-            rewrite H5 in H8; elim (Rlt_irrefl (sin y) H8)
-            | elim H6; intro H7;
-              [ right; symmetry  in |- *; assumption | left; assumption ] ]
-          | elim (Rlt_irrefl (sin x) (Rle_lt_trans (sin x) (sin y) (sin x) H3 H5)) ] ].
-Qed.
-
-Lemma sin_decr_1 :
-  forall x y:R,
-    x <= 3 * (PI / 2) ->
-    PI / 2 <= x ->
-    y <= 3 * (PI / 2) -> PI / 2 <= y -> x <= y -> sin y <= sin x.
-Proof.
-  intros; case (Rtotal_order x y); intro H4;
-    [ left; apply (sin_decreasing_1 x y H H0 H1 H2 H4)
-      | elim H4; intro H5;
-        [ case (Rtotal_order (sin x) (sin y)); intro H6;
-          [ generalize (sin_decreasing_0 x y H H0 H1 H2 H6); intro H8;
-            rewrite H5 in H8; elim (Rlt_irrefl y H8)
-            | elim H6; intro H7;
-              [ right; symmetry  in |- *; assumption | left; assumption ] ]
-          | elim (Rlt_irrefl x (Rle_lt_trans x y x H3 H5)) ] ].
-Qed.
-
-Lemma cos_incr_0 :
-  forall x y:R,
-    PI <= x ->
-    x <= 2 * PI -> PI <= y -> y <= 2 * PI -> cos x <= cos y -> x <= y.
-Proof.
-  intros; case (Rtotal_order (cos x) (cos y)); intro H4;
-    [ left; apply (cos_increasing_0 x y H H0 H1 H2 H4)
-      | elim H4; intro H5;
-        [ case (Rtotal_order x y); intro H6;
-          [ left; assumption
-            | elim H6; intro H7;
-              [ right; assumption
-                | generalize (cos_increasing_1 y x H1 H2 H H0 H7); intro H8;
-                  rewrite H5 in H8; elim (Rlt_irrefl (cos y) H8) ] ]
-          | elim (Rlt_irrefl (cos x) (Rle_lt_trans (cos x) (cos y) (cos x) H3 H5)) ] ].
-Qed.
-
-Lemma cos_incr_1 :
-  forall x y:R,
-    PI <= x ->
-    x <= 2 * PI -> PI <= y -> y <= 2 * PI -> x <= y -> cos x <= cos y.
-Proof.
-  intros; case (Rtotal_order x y); intro H4;
-    [ left; apply (cos_increasing_1 x y H H0 H1 H2 H4)
-      | elim H4; intro H5;
-        [ case (Rtotal_order (cos x) (cos y)); intro H6;
-          [ left; assumption
-            | elim H6; intro H7;
-              [ right; assumption
-                | generalize (cos_increasing_0 y x H1 H2 H H0 H7); intro H8;
-                  rewrite H5 in H8; elim (Rlt_irrefl y H8) ] ]
-          | elim (Rlt_irrefl x (Rle_lt_trans x y x H3 H5)) ] ].
-Qed.
-
-Lemma cos_decr_0 :
-  forall x y:R,
-    0 <= x -> x <= PI -> 0 <= y -> y <= PI -> cos x <= cos y -> y <= x.
-Proof.
-  intros; case (Rtotal_order (cos x) (cos y)); intro H4;
-    [ left; apply (cos_decreasing_0 x y H H0 H1 H2 H4)
-      | elim H4; intro H5;
-        [ case (Rtotal_order x y); intro H6;
-          [ generalize (cos_decreasing_1 x y H H0 H1 H2 H6); intro H8;
-            rewrite H5 in H8; elim (Rlt_irrefl (cos y) H8)
-            | elim H6; intro H7;
-              [ right; symmetry  in |- *; assumption | left; assumption ] ]
-          | elim (Rlt_irrefl (cos x) (Rle_lt_trans (cos x) (cos y) (cos x) H3 H5)) ] ].
-Qed.
-
-Lemma cos_decr_1 :
-  forall x y:R,
-    0 <= x -> x <= PI -> 0 <= y -> y <= PI -> x <= y -> cos y <= cos x.
-Proof.
-  intros; case (Rtotal_order x y); intro H4;
-    [ left; apply (cos_decreasing_1 x y H H0 H1 H2 H4)
-      | elim H4; intro H5;
-        [ case (Rtotal_order (cos x) (cos y)); intro H6;
-          [ generalize (cos_decreasing_0 x y H H0 H1 H2 H6); intro H8;
-            rewrite H5 in H8; elim (Rlt_irrefl y H8)
-            | elim H6; intro H7;
-              [ right; symmetry  in |- *; assumption | left; assumption ] ]
-          | elim (Rlt_irrefl x (Rle_lt_trans x y x H3 H5)) ] ].
-Qed.
-
-Lemma tan_incr_0 :
-  forall x y:R,
-    - (PI / 4) <= x ->
-    x <= PI / 4 -> - (PI / 4) <= y -> y <= PI / 4 -> tan x <= tan y -> x <= y.
-Proof.
-  intros; case (Rtotal_order (tan x) (tan y)); intro H4;
-    [ left; apply (tan_increasing_0 x y H H0 H1 H2 H4)
-      | elim H4; intro H5;
-        [ case (Rtotal_order x y); intro H6;
-          [ left; assumption
-            | elim H6; intro H7;
-              [ right; assumption
-                | generalize (tan_increasing_1 y x H1 H2 H H0 H7); intro H8;
-                  rewrite H5 in H8; elim (Rlt_irrefl (tan y) H8) ] ]
-          | elim (Rlt_irrefl (tan x) (Rle_lt_trans (tan x) (tan y) (tan x) H3 H5)) ] ].
-Qed.
-
-Lemma tan_incr_1 :
-  forall x y:R,
-    - (PI / 4) <= x ->
-    x <= PI / 4 -> - (PI / 4) <= y -> y <= PI / 4 -> x <= y -> tan x <= tan y.
-Proof.
-  intros; case (Rtotal_order x y); intro H4;
-    [ left; apply (tan_increasing_1 x y H H0 H1 H2 H4)
-      | elim H4; intro H5;
-        [ case (Rtotal_order (tan x) (tan y)); intro H6;
-          [ left; assumption
-            | elim H6; intro H7;
-              [ right; assumption
-                | generalize (tan_increasing_0 y x H1 H2 H H0 H7); intro H8;
-                  rewrite H5 in H8; elim (Rlt_irrefl y H8) ] ]
-          | elim (Rlt_irrefl x (Rle_lt_trans x y x H3 H5)) ] ].
-Qed.
-
-(**********)
-Lemma sin_eq_0_1 : forall x:R, (exists k : Z, x = IZR k * PI) -> sin x = 0.
-Proof.
-  intros.
-  elim H; intros.
-  apply (Zcase_sign x0).
-  intro.
-  rewrite H1 in H0.
-  simpl in H0.
-  rewrite H0; rewrite Rmult_0_l; apply sin_0.
-  intro.
-  cut (0 <= x0)%Z.
-  intro.
-  elim (IZN x0 H2); intros.
-  rewrite H3 in H0.
-  rewrite <- INR_IZR_INZ in H0.
-  rewrite H0.
-  elim (even_odd_cor x1); intros.
-  elim H4; intro.
-  rewrite H5.
-  rewrite mult_INR.
-  simpl in |- *.
-  rewrite <- (Rplus_0_l (2 * INR x2 * PI)).
-  rewrite sin_period.
-  apply sin_0.
-  rewrite H5.
-  rewrite S_INR; rewrite mult_INR.
-  simpl in |- *.
-  rewrite Rmult_plus_distr_r.
-  rewrite Rmult_1_l; rewrite sin_plus.
-  rewrite sin_PI.
-  rewrite Rmult_0_r.
-  rewrite <- (Rplus_0_l (2 * INR x2 * PI)).
-  rewrite sin_period.
-  rewrite sin_0; ring.
-  apply le_IZR.
-  left; apply IZR_lt.
-  assert (H2 := Zorder.Zgt_iff_lt).
-  elim (H2 x0 0%Z); intros.
-  apply H3; assumption.
-  intro.
-  rewrite H0.
-  replace (sin (IZR x0 * PI)) with (- sin (- IZR x0 * PI)).
-  cut (0 <= - x0)%Z.
-  intro.
-  rewrite <- Ropp_Ropp_IZR.
-  elim (IZN (- x0) H2); intros.
-  rewrite H3.
-  rewrite <- INR_IZR_INZ.
-  elim (even_odd_cor x1); intros.
-  elim H4; intro.
-  rewrite H5.
-  rewrite mult_INR.
-  simpl in |- *.
-  rewrite <- (Rplus_0_l (2 * INR x2 * PI)).
-  rewrite sin_period.
-  rewrite sin_0; ring.
-  rewrite H5.
-  rewrite S_INR; rewrite mult_INR.
-  simpl in |- *.
-  rewrite Rmult_plus_distr_r.
-  rewrite Rmult_1_l; rewrite sin_plus.
-  rewrite sin_PI.
-  rewrite Rmult_0_r.
-  rewrite <- (Rplus_0_l (2 * INR x2 * PI)).
-  rewrite sin_period.
-  rewrite sin_0; ring.
-  apply le_IZR.
-  apply Rplus_le_reg_l with (IZR x0).
-  rewrite Rplus_0_r.
-  rewrite Ropp_Ropp_IZR.
-  rewrite Rplus_opp_r.
-  left; replace 0 with (IZR 0); [ apply IZR_lt | reflexivity ].
-  assumption.
-  rewrite <- sin_neg.
-  rewrite Ropp_mult_distr_l_reverse.
-  rewrite Ropp_involutive.
-  reflexivity.
-Qed.
-
-Lemma sin_eq_0_0 : forall x:R, sin x = 0 ->  exists k : Z, x = IZR k * PI.
-Proof.
-  intros.
-  assert (H0 := euclidian_division x PI PI_neq0).
-  elim H0; intros q H1.
-  elim H1; intros r H2.
-  exists q.
-  cut (r = 0).
-  intro.
-  elim H2; intros H4 _; rewrite H4; rewrite H3.
-  apply Rplus_0_r.
-  elim H2; intros.
-  rewrite H3 in H.
-  rewrite sin_plus in H.
-  cut (sin (IZR q * PI) = 0).
-  intro.
-  rewrite H5 in H.
-  rewrite Rmult_0_l in H.
-  rewrite Rplus_0_l in H.
-  assert (H6 := Rmult_integral _ _ H).
-  elim H6; intro.
-  assert (H8 := sin2_cos2 (IZR q * PI)).
-  rewrite H5 in H8; rewrite H7 in H8.
-  rewrite Rsqr_0 in H8.
-  rewrite Rplus_0_r in H8.
-  elim R1_neq_R0; symmetry  in |- *; assumption.
-  cut (r = 0 \/ 0 < r < PI).
-  intro; elim H8; intro.
-  assumption.
-  elim H9; intros.
-  assert (H12 := sin_gt_0 _ H10 H11).
-  rewrite H7 in H12; elim (Rlt_irrefl _ H12).
-  rewrite Rabs_right in H4.
-  elim H4; intros.
-  case (Rtotal_order 0 r); intro.
-  right; split; assumption.
-  elim H10; intro.
-  left; symmetry  in |- *; assumption.
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H8 H11)).
-  apply Rle_ge.
-  left; apply PI_RGT_0.
-  apply sin_eq_0_1.
-  exists q; reflexivity.
-Qed.
-
-Lemma cos_eq_0_0 :
-  forall x:R, cos x = 0 ->  exists k : Z, x = IZR k * PI + PI / 2.
-Proof.
-  intros x H; rewrite cos_sin in H; generalize (sin_eq_0_0 (PI / INR 2 + x) H);
-    intro H2; elim H2; intros x0 H3; exists (x0 - Z_of_nat 1)%Z;
-      rewrite <- Z_R_minus; simpl.
-unfold INR in H3. field_simplify [(sym_eq H3)]. field.
-(**
-  ring_simplify.
- (* rewrite (Rmult_comm PI);*) (* old ring compat *)
-        rewrite <- H3; simpl;
-          field;repeat split; discrR.
-*)
-Qed.
-
-Lemma cos_eq_0_1 :
-  forall x:R, (exists k : Z, x = IZR k * PI + PI / 2) -> cos x = 0.
-Proof.
-  intros x H1; rewrite cos_sin; elim H1; intros x0 H2; rewrite H2;
-    replace (PI / 2 + (IZR x0 * PI + PI / 2)) with (IZR x0 * PI + PI).
-  rewrite neg_sin; rewrite <- Ropp_0.
-  apply Ropp_eq_compat; apply sin_eq_0_1; exists x0; reflexivity.
-  pattern PI at 2 in |- *; rewrite (double_var PI); ring.
-Qed.
-
-Lemma sin_eq_O_2PI_0 :
-  forall x:R,
-    0 <= x -> x <= 2 * PI -> sin x = 0 -> x = 0 \/ x = PI \/ x = 2 * PI.
-Proof.
-  intros; generalize (sin_eq_0_0 x H1); intro.
-  elim H2; intros k0 H3.
-  case (Rtotal_order PI x); intro.
-  rewrite H3 in H4; rewrite H3 in H0.
-  right; right.
-  generalize
-    (Rmult_lt_compat_r (/ PI) PI (IZR k0 * PI) (Rinv_0_lt_compat PI PI_RGT_0) H4);
-    rewrite Rmult_assoc; repeat rewrite <- Rinv_r_sym.
-  rewrite Rmult_1_r; intro;
-    generalize
-      (Rmult_le_compat_r (/ PI) (IZR k0 * PI) (2 * PI)
-        (Rlt_le 0 (/ PI) (Rinv_0_lt_compat PI PI_RGT_0)) H0);
-      repeat rewrite Rmult_assoc; repeat rewrite <- Rinv_r_sym.
-  repeat rewrite Rmult_1_r; intro;
-    generalize (Rplus_lt_compat_l (IZR (-2)) 1 (IZR k0) H5);
-      rewrite <- plus_IZR.
-  replace (IZR (-2) + 1) with (-1).
-  intro; generalize (Rplus_le_compat_l (IZR (-2)) (IZR k0) 2 H6);
-    rewrite <- plus_IZR.
-  replace (IZR (-2) + 2) with 0.
-  intro; cut (-1 < IZR (-2 + k0) < 1).
-  intro; generalize (one_IZR_lt1 (-2 + k0) H9); intro.
-  cut (k0 = 2%Z).
-  intro; rewrite H11 in H3; rewrite H3; simpl in |- *.
-  reflexivity.
-  rewrite <- (Zplus_opp_l 2) in H10; generalize (Zplus_reg_l (-2) k0 2 H10);
-    intro; assumption.
-  split.
-  assumption.
-  apply Rle_lt_trans with 0.
-  assumption.
-  apply Rlt_0_1.
-  simpl in |- *; ring.
-  simpl in |- *; ring.
-  apply PI_neq0.
-  apply PI_neq0.
-  elim H4; intro.
-  right; left.
-  symmetry  in |- *; assumption.
-  left.
-  rewrite H3 in H5; rewrite H3 in H;
-    generalize
-      (Rmult_lt_compat_r (/ PI) (IZR k0 * PI) PI (Rinv_0_lt_compat PI PI_RGT_0)
-        H5); rewrite Rmult_assoc; repeat rewrite <- Rinv_r_sym.
-  rewrite Rmult_1_r; intro;
-    generalize
-      (Rmult_le_compat_r (/ PI) 0 (IZR k0 * PI)
-        (Rlt_le 0 (/ PI) (Rinv_0_lt_compat PI PI_RGT_0)) H);
-      repeat rewrite Rmult_assoc; repeat rewrite <- Rinv_r_sym.
-  rewrite Rmult_1_r; rewrite Rmult_0_l; intro.
-  cut (-1 < IZR k0 < 1).
-  intro; generalize (one_IZR_lt1 k0 H8); intro; rewrite H9 in H3; rewrite H3;
-    simpl in |- *; apply Rmult_0_l.
-  split.
-  apply Rlt_le_trans with 0.
-  rewrite <- Ropp_0; apply Ropp_gt_lt_contravar; apply Rlt_0_1.
-  assumption.
-  assumption.
-  apply PI_neq0.
-  apply PI_neq0.
-Qed.
-
-Lemma sin_eq_O_2PI_1 :
-  forall x:R,
-    0 <= x -> x <= 2 * PI -> x = 0 \/ x = PI \/ x = 2 * PI -> sin x = 0.
-Proof.
-  intros x H1 H2 H3; elim H3; intro H4;
-    [ rewrite H4; rewrite sin_0; reflexivity
-      | elim H4; intro H5;
-        [ rewrite H5; rewrite sin_PI; reflexivity
-          | rewrite H5; rewrite sin_2PI; reflexivity ] ].
-Qed.
-
-Lemma cos_eq_0_2PI_0 :
-  forall x:R,
-    0 <= x -> x <= 2 * PI -> cos x = 0 -> x = PI / 2 \/ x = 3 * (PI / 2).
-Proof.
-  intros; case (Rtotal_order x (3 * (PI / 2))); intro.
-  rewrite cos_sin in H1.
-  cut (0 <= PI / 2 + x).
-  cut (PI / 2 + x <= 2 * PI).
-  intros; generalize (sin_eq_O_2PI_0 (PI / 2 + x) H4 H3 H1); intros.
-  decompose [or] H5.
-  generalize (Rplus_le_compat_l (PI / 2) 0 x H); rewrite Rplus_0_r; rewrite H6;
-    intro.
-  elim (Rlt_irrefl 0 (Rlt_le_trans 0 (PI / 2) 0 PI2_RGT_0 H7)).
-  left.
-  generalize (Rplus_eq_compat_l (- (PI / 2)) (PI / 2 + x) PI H7).
-  replace (- (PI / 2) + (PI / 2 + x)) with x.
-  replace (- (PI / 2) + PI) with (PI / 2).
-  intro; assumption.
-  pattern PI at 3 in |- *; rewrite (double_var PI); ring.
-  ring.
-  right.
-  generalize (Rplus_eq_compat_l (- (PI / 2)) (PI / 2 + x) (2 * PI) H7).
-  replace (- (PI / 2) + (PI / 2 + x)) with x.
-  replace (- (PI / 2) + 2 * PI) with (3 * (PI / 2)).
-  intro; assumption.
-  rewrite double; pattern PI at 3 4 in |- *; rewrite (double_var PI); ring.
-  ring.
-  left; replace (2 * PI) with (PI / 2 + 3 * (PI / 2)).
-  apply Rplus_lt_compat_l; assumption.
-  rewrite (double PI); pattern PI at 3 4 in |- *; rewrite (double_var PI); ring.
-  apply Rplus_le_le_0_compat.
-  left; unfold Rdiv in |- *; apply Rmult_lt_0_compat.
-  apply PI_RGT_0.
-  apply Rinv_0_lt_compat; prove_sup0.
-  assumption.
-  elim H2; intro.
-  right; assumption.
-  generalize (cos_eq_0_0 x H1); intro; elim H4; intros k0 H5.
-  rewrite H5 in H3; rewrite H5 in H0;
-    generalize
-      (Rplus_lt_compat_l (- (PI / 2)) (3 * (PI / 2)) (IZR k0 * PI + PI / 2) H3);
-      generalize
-        (Rplus_le_compat_l (- (PI / 2)) (IZR k0 * PI + PI / 2) (2 * PI) H0).
-  replace (- (PI / 2) + 3 * (PI / 2)) with PI.
-  replace (- (PI / 2) + (IZR k0 * PI + PI / 2)) with (IZR k0 * PI).
-  replace (- (PI / 2) + 2 * PI) with (3 * (PI / 2)).
-  intros;
-    generalize
-      (Rmult_lt_compat_l (/ PI) PI (IZR k0 * PI) (Rinv_0_lt_compat PI PI_RGT_0)
-        H7);
-      generalize
-        (Rmult_le_compat_l (/ PI) (IZR k0 * PI) (3 * (PI / 2))
-          (Rlt_le 0 (/ PI) (Rinv_0_lt_compat PI PI_RGT_0)) H6).
-  replace (/ PI * (IZR k0 * PI)) with (IZR k0).
-  replace (/ PI * (3 * (PI / 2))) with (3 * / 2).
-  rewrite <- Rinv_l_sym.
-  intros; generalize (Rplus_lt_compat_l (IZR (-2)) 1 (IZR k0) H9);
-    rewrite <- plus_IZR.
-  replace (IZR (-2) + 1) with (-1).
-  intro; generalize (Rplus_le_compat_l (IZR (-2)) (IZR k0) (3 * / 2) H8);
-    rewrite <- plus_IZR.
-  replace (IZR (-2) + 2) with 0.
-  intro; cut (-1 < IZR (-2 + k0) < 1).
-  intro; generalize (one_IZR_lt1 (-2 + k0) H12); intro.
-  cut (k0 = 2%Z).
-  intro; rewrite H14 in H8.
-  assert (Hyp : 0 < 2).
-  prove_sup0.
-  generalize (Rmult_le_compat_l 2 (IZR 2) (3 * / 2) (Rlt_le 0 2 Hyp) H8);
-    simpl in |- *.
-  replace 4 with 4.
-  replace (2 * (3 * / 2)) with 3.
-  intro; cut (3 < 4).
-  intro; elim (Rlt_irrefl 3 (Rlt_le_trans 3 4 3 H16 H15)).
-  generalize (Rplus_lt_compat_l 3 0 1 Rlt_0_1); rewrite Rplus_0_r.
-  replace (3 + 1) with 4.
-  intro; assumption.
-  ring.
-  symmetry  in |- *; rewrite <- Rmult_assoc; apply Rinv_r_simpl_m.
-  discrR.
-  ring.
-  rewrite <- (Zplus_opp_l 2) in H13; generalize (Zplus_reg_l (-2) k0 2 H13);
-    intro; assumption.
-  split.
-  assumption.
-  apply Rle_lt_trans with (IZR (-2) + 3 * / 2).
-  assumption.
-  simpl in |- *; replace (-2 + 3 * / 2) with (- (1 * / 2)).
-  apply Rlt_trans with 0.
-  rewrite <- Ropp_0; apply Ropp_lt_gt_contravar.
-  apply Rmult_lt_0_compat;
-    [ apply Rlt_0_1 | apply Rinv_0_lt_compat; prove_sup0 ].
-  apply Rlt_0_1.
-  rewrite Rmult_1_l; apply Rmult_eq_reg_l with 2.
-  rewrite Ropp_mult_distr_r_reverse; rewrite <- Rinv_r_sym.
-  rewrite Rmult_plus_distr_l; rewrite <- Rmult_assoc; rewrite Rinv_r_simpl_m.
-  ring.
-  discrR.
-  discrR.
-  discrR.
-  simpl in |- *; ring.
-  simpl in |- *; ring.
-  apply PI_neq0.
-  unfold Rdiv in |- *; pattern 3 at 1 in |- *; rewrite (Rmult_comm 3);
-    repeat rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
-  rewrite Rmult_1_l; apply Rmult_comm.
-  apply PI_neq0.
-  symmetry  in |- *; rewrite (Rmult_comm (/ PI)); rewrite Rmult_assoc;
-    rewrite <- Rinv_r_sym.
-  apply Rmult_1_r.
-  apply PI_neq0.
-  rewrite double; pattern PI at 3 4 in |- *; rewrite double_var; ring.
-  ring.
-  pattern PI at 1 in |- *; rewrite double_var; ring.
-Qed.
-
-Lemma cos_eq_0_2PI_1 :
-  forall x:R,
-    0 <= x -> x <= 2 * PI -> x = PI / 2 \/ x = 3 * (PI / 2) -> cos x = 0.
-Proof.
-  intros x H1 H2 H3; elim H3; intro H4;
-    [ rewrite H4; rewrite cos_PI2; reflexivity
-      | rewrite H4; rewrite cos_3PI2; reflexivity ].
-Qed.
+Require Import Fourier.
+Require Import Ranalysis1.
+Require Import Rsqrt_def. 
+Require Import PSeries_reg.
+Require Export Rtrigo1.
+Require Export Ratan.
+Require Export Machin.
\ No newline at end of file
diff --git a/theories/Reals/Rtrigo1.v b/theories/Reals/Rtrigo1.v
new file mode 100644
index 00000000..6174ef32
--- /dev/null
+++ b/theories/Reals/Rtrigo1.v
@@ -0,0 +1,1933 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+Require Import Rbase.
+Require Import Rfunctions.
+Require Import SeqSeries.
+Require Export Rtrigo_fun.
+Require Export Rtrigo_def.
+Require Export Rtrigo_alt.
+Require Export Cos_rel.
+Require Export Cos_plus.
+Require Import ZArith_base.
+Require Import Zcomplements.
+Require Import Classical_Prop.
+Require Import Fourier.
+Require Import Ranalysis1.
+Require Import Rsqrt_def. 
+Require Import PSeries_reg.
+
+Local Open Scope nat_scope.
+Local Open Scope R_scope.
+
+Lemma CVN_R_cos :
+  forall fn:nat -> R -> R,
+    fn = (fun (N:nat) (x:R) => (-1) ^ N / INR (fact (2 * N)) * x ^ (2 * N)) ->
+    CVN_R fn.
+Proof.
+  unfold CVN_R in |- *; intros.
+  cut ((r:R) <> 0).
+  intro hyp_r; unfold CVN_r in |- *.
+  exists (fun n:nat => / INR (fact (2 * n)) * r ^ (2 * n)).
+  cut
+    { l:R |
+        Un_cv
+        (fun n:nat =>
+          sum_f_R0 (fun k:nat => Rabs (/ INR (fact (2 * k)) * r ^ (2 * k)))
+          n) l }.
+  intro X; elim X; intros.
+  exists x.
+  split.
+  apply p.
+  intros; rewrite H; unfold Rdiv in |- *; do 2 rewrite Rabs_mult.
+  rewrite pow_1_abs; rewrite Rmult_1_l.
+  cut (0 < / INR (fact (2 * n))).
+  intro; rewrite (Rabs_right _ (Rle_ge _ _ (Rlt_le _ _ H1))).
+  apply Rmult_le_compat_l.
+  left; apply H1.
+  rewrite <- RPow_abs; apply pow_maj_Rabs.
+  rewrite Rabs_Rabsolu.
+  unfold Boule in H0; rewrite Rminus_0_r in H0.
+  left; apply H0.
+  apply Rinv_0_lt_compat; apply INR_fact_lt_0.
+  apply Alembert_C2.
+  intro; apply Rabs_no_R0.
+  apply prod_neq_R0.
+  apply Rinv_neq_0_compat.
+  apply INR_fact_neq_0.
+  apply pow_nonzero; assumption.
+  assert (H0 := Alembert_cos).
+  unfold cos_n in H0; unfold Un_cv in H0; unfold Un_cv in |- *; intros.
+  cut (0 < eps / Rsqr r).
+  intro; elim (H0 _ H2); intros N0 H3.
+  exists N0; intros.
+  unfold R_dist in |- *; assert (H5 := H3 _ H4).
+  unfold R_dist in H5;
+    replace
+    (Rabs
+      (Rabs (/ INR (fact (2 * S n)) * r ^ (2 * S n)) /
+        Rabs (/ INR (fact (2 * n)) * r ^ (2 * n)))) with
+    (Rsqr r *
+      Rabs ((-1) ^ S n / INR (fact (2 * S n)) / ((-1) ^ n / INR (fact (2 * n))))).
+  apply Rmult_lt_reg_l with (/ Rsqr r).
+  apply Rinv_0_lt_compat; apply Rsqr_pos_lt; assumption.
+  pattern (/ Rsqr r) at 1 in |- *; replace (/ Rsqr r) with (Rabs (/ Rsqr r)).
+  rewrite <- Rabs_mult; rewrite Rmult_minus_distr_l; rewrite Rmult_0_r;
+    rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_l; rewrite <- (Rmult_comm eps); apply H5.
+  unfold Rsqr in |- *; apply prod_neq_R0; assumption.
+  rewrite Rabs_Rinv.
+  rewrite Rabs_right.
+  reflexivity.
+  apply Rle_ge; apply Rle_0_sqr.
+  unfold Rsqr in |- *; apply prod_neq_R0; assumption.
+  rewrite (Rmult_comm (Rsqr r)); unfold Rdiv in |- *; repeat rewrite Rabs_mult;
+    rewrite Rabs_Rabsolu; rewrite pow_1_abs; rewrite Rmult_1_l;
+      repeat rewrite Rmult_assoc; apply Rmult_eq_compat_l.
+  rewrite Rabs_Rinv.
+  rewrite Rabs_mult; rewrite (pow_1_abs n); rewrite Rmult_1_l;
+    rewrite <- Rabs_Rinv.
+  rewrite Rinv_involutive.
+  rewrite Rinv_mult_distr.
+  rewrite Rabs_Rinv.
+  rewrite Rinv_involutive.
+  rewrite (Rmult_comm (Rabs (Rabs (r ^ (2 * S n))))); rewrite Rabs_mult;
+    rewrite Rabs_Rabsolu; rewrite Rmult_assoc; apply Rmult_eq_compat_l.
+  rewrite Rabs_Rinv.
+  do 2 rewrite Rabs_Rabsolu; repeat rewrite Rabs_right.
+  replace (r ^ (2 * S n)) with (r ^ (2 * n) * r * r).
+  repeat rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
+  unfold Rsqr in |- *; ring.
+  apply pow_nonzero; assumption.
+  replace (2 * S n)%nat with (S (S (2 * n))).
+  simpl in |- *; ring.
+  ring.
+  apply Rle_ge; apply pow_le; left; apply (cond_pos r).
+  apply Rle_ge; apply pow_le; left; apply (cond_pos r).
+  apply Rabs_no_R0; apply pow_nonzero; assumption.
+  apply Rabs_no_R0; apply INR_fact_neq_0.
+  apply INR_fact_neq_0.
+  apply Rabs_no_R0; apply Rinv_neq_0_compat; apply INR_fact_neq_0.
+  apply Rabs_no_R0; apply pow_nonzero; assumption.
+  apply INR_fact_neq_0.
+  apply Rinv_neq_0_compat; apply INR_fact_neq_0.
+  apply prod_neq_R0.
+  apply pow_nonzero; discrR.
+  apply Rinv_neq_0_compat; apply INR_fact_neq_0.
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+  apply H1.
+  apply Rinv_0_lt_compat; apply Rsqr_pos_lt; assumption.
+  assert (H0 := cond_pos r); red in |- *; intro; rewrite H1 in H0;
+    elim (Rlt_irrefl _ H0).
+Qed.
+
+(**********)
+Lemma continuity_cos : continuity cos.
+Proof.
+  set (fn := fun (N:nat) (x:R) => (-1) ^ N / INR (fact (2 * N)) * x ^ (2 * N)).
+  cut (CVN_R fn).
+  intro; cut (forall x:R, { l:R | Un_cv (fun N:nat => SP fn N x) l }).
+  intro cv; cut (forall n:nat, continuity (fn n)).
+  intro; cut (forall x:R, cos x = SFL fn cv x).
+  intro; cut (continuity (SFL fn cv) -> continuity cos).
+  intro; apply H1.
+  apply SFL_continuity; assumption.
+  unfold continuity in |- *; unfold continuity_pt in |- *;
+    unfold continue_in in |- *; unfold limit1_in in |- *;
+      unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *;
+        intros.
+  elim (H1 x _ H2); intros.
+  exists x0; intros.
+  elim H3; intros.
+  split.
+  apply H4.
+  intros; rewrite (H0 x); rewrite (H0 x1); apply H5; apply H6.
+  intro; unfold cos, SFL in |- *.
+  case (cv x); case (exist_cos (Rsqr x)); intros.
+  symmetry  in |- *; eapply UL_sequence.
+  apply u.
+  unfold cos_in in c; unfold infinite_sum in c; unfold Un_cv in |- *; intros.
+  elim (c _ H0); intros N0 H1.
+  exists N0; intros.
+  unfold R_dist in H1; unfold R_dist, SP in |- *.
+  replace (sum_f_R0 (fun k:nat => fn k x) n) with
+  (sum_f_R0 (fun i:nat => cos_n i * Rsqr x ^ i) n).
+  apply H1; assumption.
+  apply sum_eq; intros.
+  unfold cos_n, fn in |- *; apply Rmult_eq_compat_l.
+  unfold Rsqr in |- *; rewrite pow_sqr; reflexivity.
+  intro; unfold fn in |- *;
+    replace (fun x:R => (-1) ^ n / INR (fact (2 * n)) * x ^ (2 * n)) with
+    (fct_cte ((-1) ^ n / INR (fact (2 * n))) * pow_fct (2 * n))%F;
+    [ idtac | reflexivity ].
+  apply continuity_mult.
+  apply derivable_continuous; apply derivable_const.
+  apply derivable_continuous; apply (derivable_pow (2 * n)).
+  apply CVN_R_CVS; apply X.
+  apply CVN_R_cos; unfold fn in |- *; reflexivity.
+Qed.
+
+Lemma sin_gt_cos_7_8 : sin (7 / 8) > cos (7 / 8).
+Proof. 
+assert (lo1 : 0 <= 7/8) by fourier.
+assert (up1 : 7/8 <= 4) by fourier.
+assert (lo : -2 <= 7/8) by fourier.
+assert (up : 7/8 <= 2) by fourier.
+destruct (pre_sin_bound _ 0 lo1 up1) as [lower _ ].
+destruct (pre_cos_bound _ 0 lo up) as [_ upper].
+apply Rle_lt_trans with (1 := upper).
+apply Rlt_le_trans with (2 := lower).
+unfold cos_approx, sin_approx.
+simpl sum_f_R0; replace 7 with (IZR 7) by (simpl; field).
+replace 8 with (IZR 8) by (simpl; field).
+unfold cos_term, sin_term; simpl fact; rewrite !INR_IZR_INZ.
+simpl plus; simpl mult.
+field_simplify;
+  try (repeat apply conj; apply not_eq_sym, Rlt_not_eq, (IZR_lt 0); reflexivity).
+unfold Rminus; rewrite !pow_IZR, <- !mult_IZR, <- !opp_IZR, <- ?plus_IZR.
+match goal with 
+  |- IZR ?a / ?b < ?c / ?d =>
+  apply Rmult_lt_reg_r with d;[apply (IZR_lt 0); reflexivity |
+    unfold Rdiv at 2; rewrite Rmult_assoc, Rinv_l, Rmult_1_r, Rmult_comm;
+     [ |apply not_eq_sym, Rlt_not_eq, (IZR_lt 0); reflexivity ]];
+  apply Rmult_lt_reg_r with b;[apply (IZR_lt 0); reflexivity | ]
+end.
+unfold Rdiv; rewrite !Rmult_assoc, Rinv_l, Rmult_1_r;
+ [ | apply not_eq_sym, Rlt_not_eq, (IZR_lt 0); reflexivity].
+repeat (rewrite <- !plus_IZR || rewrite <- !mult_IZR).
+apply IZR_lt; reflexivity.
+Qed.
+
+Definition PI_2_aux : {z | 7/8 <= z <= 7/4 /\ -cos z = 0}.
+assert (cc : continuity (fun r =>- cos r)).
+ apply continuity_opp, continuity_cos.
+assert (cvp : 0 < cos (7/8)).
+ assert (int78 : -2 <= 7/8 <= 2) by (split; fourier).
+ destruct int78 as [lower upper].
+ case (pre_cos_bound _ 0 lower upper).
+ unfold cos_approx; simpl sum_f_R0; unfold cos_term.
+ intros cl _; apply Rlt_le_trans with (2 := cl); simpl.
+ fourier.
+assert (cun : cos (7/4) < 0).
+ replace (7/4) with (7/8 + 7/8) by field.
+ rewrite cos_plus.
+ apply Rlt_minus; apply Rsqr_incrst_1.
+   exact sin_gt_cos_7_8.
+  apply Rlt_le; assumption.
+ apply Rlt_le; apply Rlt_trans with (1 := cvp); exact sin_gt_cos_7_8.
+apply IVT; auto; fourier.
+Qed.
+
+Definition PI2 := proj1_sig PI_2_aux.
+
+Definition PI := 2 * PI2.
+
+Lemma cos_pi2 : cos PI2 = 0.
+unfold PI2; case PI_2_aux; simpl.
+intros x [_ q]; rewrite <- (Ropp_involutive (cos x)), q; apply Ropp_0.
+Qed.
+
+Lemma pi2_int : 7/8 <= PI2 <= 7/4.
+unfold PI2; case PI_2_aux; simpl; tauto.
+Qed.
+
+(**********)
+Lemma cos_minus : forall x y:R, cos (x - y) = cos x * cos y + sin x * sin y.
+Proof.
+  intros; unfold Rminus in |- *; rewrite cos_plus.
+  rewrite <- cos_sym; rewrite sin_antisym; ring.
+Qed.
+
+(**********)
+Lemma sin2_cos2 : forall x:R, Rsqr (sin x) + Rsqr (cos x) = 1.
+Proof.
+  intro; unfold Rsqr in |- *; rewrite Rplus_comm; rewrite <- (cos_minus x x);
+    unfold Rminus in |- *; rewrite Rplus_opp_r; apply cos_0.
+Qed.
+
+Lemma cos2 : forall x:R, Rsqr (cos x) = 1 - Rsqr (sin x).
+Proof.
+  intros x; rewrite <- (sin2_cos2 x); ring.
+Qed.
+
+Lemma sin2 : forall x:R, Rsqr (sin x) = 1 - Rsqr (cos x).
+Proof.
+  intro x; generalize (cos2 x); intro H1; rewrite H1.
+  unfold Rminus in |- *; rewrite Ropp_plus_distr; rewrite <- Rplus_assoc;
+    rewrite Rplus_opp_r; rewrite Rplus_0_l; symmetry  in |- *;
+      apply Ropp_involutive.
+Qed.
+
+(**********)
+Lemma cos_PI2 : cos (PI / 2) = 0.
+Proof.
+ unfold PI; generalize cos_pi2; replace ((2 * PI2)/2) with PI2 by field; tauto.
+Qed.
+
+Lemma sin_pos_tech : forall x, 0 < x < 2 -> 0 < sin x. 
+intros x [int1 int2].
+assert (lo : 0 <= x) by (apply Rlt_le; assumption).
+assert (up : x <= 4) by (apply Rlt_le, Rlt_trans with (1:=int2); fourier).
+destruct (pre_sin_bound _ 0 lo up) as [t _]; clear lo up.
+apply Rlt_le_trans with (2:= t); clear t.
+unfold sin_approx; simpl sum_f_R0; unfold sin_term; simpl.
+match goal with |- _ < ?a =>
+  replace a with (x * (1 - x^2/6)) by (simpl; field)
+end.
+assert (t' : x ^ 2 <= 4).
+ replace 4 with (2 ^ 2) by field.
+ apply (pow_incr x 2); split; apply Rlt_le; assumption.
+apply Rmult_lt_0_compat;[assumption | fourier ].
+Qed.
+
+Lemma sin_PI2 : sin (PI / 2) = 1.
+replace (PI / 2) with PI2 by (unfold PI; field).
+assert (int' : 0 < PI2 < 2).
+ destruct pi2_int; split; fourier.
+assert (lo2 := sin_pos_tech PI2 int').
+assert (t2 : Rabs (sin PI2) = 1).
+ rewrite <- Rabs_R1; apply Rsqr_eq_abs_0.
+ rewrite Rsqr_1, sin2, cos_pi2, Rsqr_0, Rminus_0_r; reflexivity.
+revert t2; rewrite Rabs_pos_eq;[| apply Rlt_le]; tauto.
+Qed.
+
+Lemma PI_RGT_0 : PI > 0.
+Proof. unfold PI; destruct pi2_int; fourier. Qed.
+
+Lemma PI_4 : PI <= 4.
+Proof. unfold PI; destruct pi2_int; fourier. Qed.
+
+(**********)
+Lemma PI_neq0 : PI <> 0.
+Proof.
+  red in |- *; intro; assert (H0 := PI_RGT_0); rewrite H in H0;
+    elim (Rlt_irrefl _ H0).
+Qed.
+
+
+(**********)
+Lemma cos_PI : cos PI = -1.
+Proof.
+  replace PI with (PI / 2 + PI / 2).
+  rewrite cos_plus.
+  rewrite sin_PI2; rewrite cos_PI2.
+  ring.
+  symmetry  in |- *; apply double_var.
+Qed.
+
+Lemma sin_PI : sin PI = 0.
+Proof.
+  assert (H := sin2_cos2 PI).
+  rewrite cos_PI in H.
+  rewrite <- Rsqr_neg in H.
+  rewrite Rsqr_1 in H.
+  cut (Rsqr (sin PI) = 0).
+  intro; apply (Rsqr_eq_0 _ H0).
+  apply Rplus_eq_reg_l with 1.
+  rewrite Rplus_0_r; rewrite Rplus_comm; exact H.
+Qed.
+
+Lemma sin_bound : forall (a : R) (n : nat), 0 <= a -> a <= PI ->
+       sin_approx a (2 * n + 1) <= sin a <= sin_approx a (2 * (n + 1)).
+Proof.
+intros a n a0 api; apply pre_sin_bound.
+ assumption.
+apply Rle_trans with (1:= api) (2 := PI_4).
+Qed.
+
+Lemma cos_bound : forall (a : R) (n : nat), - PI / 2 <= a -> a <= PI / 2 ->
+       cos_approx a (2 * n + 1) <= cos a <= cos_approx a (2 * (n + 1)).
+Proof.
+intros a n lower upper; apply pre_cos_bound.
+ apply Rle_trans with (2 := lower).
+ apply Rmult_le_reg_r with 2; [fourier |].
+ replace ((-PI/2) * 2) with (-PI) by field.
+ assert (t := PI_4); fourier.
+apply Rle_trans with (1 := upper).
+apply Rmult_le_reg_r with 2; [fourier | ].
+replace ((PI/2) * 2) with PI by field.
+generalize PI_4; intros; fourier.
+Qed.
+(**********)
+Lemma neg_cos : forall x:R, cos (x + PI) = - cos x.
+Proof.
+  intro x; rewrite cos_plus; rewrite sin_PI; rewrite cos_PI; ring.
+Qed.
+
+(**********)
+Lemma sin_cos : forall x:R, sin x = - cos (PI / 2 + x).
+Proof.
+  intro x; rewrite cos_plus; rewrite sin_PI2; rewrite cos_PI2; ring.
+Qed.
+
+(**********)
+Lemma sin_plus : forall x y:R, sin (x + y) = sin x * cos y + cos x * sin y.
+Proof.
+  intros.
+  rewrite (sin_cos (x + y)).
+  replace (PI / 2 + (x + y)) with (PI / 2 + x + y); [ rewrite cos_plus | ring ].
+  rewrite (sin_cos (PI / 2 + x)).
+  replace (PI / 2 + (PI / 2 + x)) with (x + PI).
+  rewrite neg_cos.
+  replace (cos (PI / 2 + x)) with (- sin x).
+  ring.
+  rewrite sin_cos; rewrite Ropp_involutive; reflexivity.
+  pattern PI at 1 in |- *; rewrite (double_var PI); ring.
+Qed.
+
+Lemma sin_minus : forall x y:R, sin (x - y) = sin x * cos y - cos x * sin y.
+Proof.
+  intros; unfold Rminus in |- *; rewrite sin_plus.
+  rewrite <- cos_sym; rewrite sin_antisym; ring.
+Qed.
+
+(**********)
+Definition tan (x:R) : R := sin x / cos x.
+
+Lemma tan_plus :
+  forall x y:R,
+    cos x <> 0 ->
+    cos y <> 0 ->
+    cos (x + y) <> 0 ->
+    1 - tan x * tan y <> 0 ->
+    tan (x + y) = (tan x + tan y) / (1 - tan x * tan y).
+Proof.
+  intros; unfold tan in |- *; rewrite sin_plus; rewrite cos_plus;
+    unfold Rdiv in |- *;
+      replace (cos x * cos y - sin x * sin y) with
+      (cos x * cos y * (1 - sin x * / cos x * (sin y * / cos y))).
+  rewrite Rinv_mult_distr.
+  repeat rewrite <- Rmult_assoc;
+    replace ((sin x * cos y + cos x * sin y) * / (cos x * cos y)) with
+    (sin x * / cos x + sin y * / cos y).
+  reflexivity.
+  rewrite Rmult_plus_distr_r; rewrite Rinv_mult_distr.
+  repeat rewrite Rmult_assoc; repeat rewrite (Rmult_comm (sin x));
+    repeat rewrite <- Rmult_assoc.
+  repeat rewrite Rinv_r_simpl_m; [ reflexivity | assumption | assumption ].
+  assumption.
+  assumption.
+  apply prod_neq_R0; assumption.
+  assumption.
+  unfold Rminus in |- *; rewrite Rmult_plus_distr_l; rewrite Rmult_1_r;
+    apply Rplus_eq_compat_l; repeat rewrite Rmult_assoc;
+      rewrite (Rmult_comm (sin x)); rewrite (Rmult_comm (cos y));
+        rewrite <- Ropp_mult_distr_r_reverse; repeat rewrite <- Rmult_assoc;
+          rewrite <- Rinv_r_sym.
+  rewrite Rmult_1_l; rewrite (Rmult_comm (sin x));
+    rewrite <- Ropp_mult_distr_r_reverse; repeat rewrite Rmult_assoc;
+      apply Rmult_eq_compat_l; rewrite (Rmult_comm (/ cos y));
+        rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
+  apply Rmult_1_r.
+  assumption.
+  assumption.
+Qed.
+
+(*******************************************************)
+(** * Some properties of cos, sin and tan              *)
+(*******************************************************)
+
+Lemma sin_2a : forall x:R, sin (2 * x) = 2 * sin x * cos x.
+Proof.
+  intro x; rewrite double; rewrite sin_plus.
+  rewrite <- (Rmult_comm (sin x)); symmetry  in |- *; rewrite Rmult_assoc;
+    apply double.
+Qed.
+
+Lemma cos_2a : forall x:R, cos (2 * x) = cos x * cos x - sin x * sin x.
+Proof.
+  intro x; rewrite double; apply cos_plus.
+Qed.
+
+Lemma cos_2a_cos : forall x:R, cos (2 * x) = 2 * cos x * cos x - 1.
+Proof.
+  intro x; rewrite double; unfold Rminus in |- *; rewrite Rmult_assoc;
+    rewrite cos_plus; generalize (sin2_cos2 x); rewrite double;
+      intro H1; rewrite <- H1; ring_Rsqr.
+Qed.
+
+Lemma cos_2a_sin : forall x:R, cos (2 * x) = 1 - 2 * sin x * sin x.
+Proof.
+  intro x; rewrite Rmult_assoc; unfold Rminus in |- *; repeat rewrite double.
+  generalize (sin2_cos2 x); intro H1; rewrite <- H1; rewrite cos_plus;
+    ring_Rsqr.
+Qed.
+
+Lemma tan_2a :
+  forall x:R,
+    cos x <> 0 ->
+    cos (2 * x) <> 0 ->
+    1 - tan x * tan x <> 0 -> tan (2 * x) = 2 * tan x / (1 - tan x * tan x).
+Proof.
+  repeat rewrite double; intros; repeat rewrite double; rewrite double in H0;
+    apply tan_plus; assumption.
+Qed.
+
+Lemma sin_neg : forall x:R, sin (- x) = - sin x.
+Proof.
+  apply sin_antisym.
+Qed.
+
+Lemma cos_neg : forall x:R, cos (- x) = cos x.
+Proof.
+  intro; symmetry  in |- *; apply cos_sym.
+Qed.
+
+Lemma tan_0 : tan 0 = 0.
+Proof.
+  unfold tan in |- *; rewrite sin_0; rewrite cos_0.
+  unfold Rdiv in |- *; apply Rmult_0_l.
+Qed.
+
+Lemma tan_neg : forall x:R, tan (- x) = - tan x.
+Proof.
+  intros x; unfold tan in |- *; rewrite sin_neg; rewrite cos_neg;
+    unfold Rdiv in |- *.
+  apply Ropp_mult_distr_l_reverse.
+Qed.
+
+Lemma tan_minus :
+  forall x y:R,
+    cos x <> 0 ->
+    cos y <> 0 ->
+    cos (x - y) <> 0 ->
+    1 + tan x * tan y <> 0 ->
+    tan (x - y) = (tan x - tan y) / (1 + tan x * tan y).
+Proof.
+  intros; unfold Rminus in |- *; rewrite tan_plus.
+  rewrite tan_neg; unfold Rminus in |- *; rewrite <- Ropp_mult_distr_l_reverse;
+    rewrite Rmult_opp_opp; reflexivity.
+  assumption.
+  rewrite cos_neg; assumption.
+  assumption.
+  rewrite tan_neg; unfold Rminus in |- *; rewrite <- Ropp_mult_distr_l_reverse;
+    rewrite Rmult_opp_opp; assumption.
+Qed.
+
+Lemma cos_3PI2 : cos (3 * (PI / 2)) = 0.
+Proof.
+  replace (3 * (PI / 2)) with (PI + PI / 2).
+  rewrite cos_plus; rewrite sin_PI; rewrite cos_PI2; ring.
+  pattern PI at 1 in |- *; rewrite (double_var PI).
+  ring.
+Qed.
+
+Lemma sin_2PI : sin (2 * PI) = 0.
+Proof.
+  rewrite sin_2a; rewrite sin_PI; ring.
+Qed.
+
+Lemma cos_2PI : cos (2 * PI) = 1.
+Proof.
+  rewrite cos_2a; rewrite sin_PI; rewrite cos_PI; ring.
+Qed.
+
+Lemma neg_sin : forall x:R, sin (x + PI) = - sin x.
+Proof.
+  intro x; rewrite sin_plus; rewrite sin_PI; rewrite cos_PI; ring.
+Qed.
+
+Lemma sin_PI_x : forall x:R, sin (PI - x) = sin x.
+Proof.
+  intro x; rewrite sin_minus; rewrite sin_PI; rewrite cos_PI; rewrite Rmult_0_l;
+    unfold Rminus in |- *; rewrite Rplus_0_l; rewrite Ropp_mult_distr_l_reverse;
+      rewrite Ropp_involutive; apply Rmult_1_l.
+Qed.
+
+Lemma sin_period : forall (x:R) (k:nat), sin (x + 2 * INR k * PI) = sin x.
+Proof.
+  intros x k; induction  k as [| k Hreck].
+  simpl in |- *;  ring_simplify (x + 2 * 0 * PI).
+  trivial.
+
+  replace (x + 2 * INR (S k) * PI) with (x + 2 * INR k * PI + 2 * PI).
+  rewrite sin_plus in |- *; rewrite sin_2PI in |- *; rewrite cos_2PI in |- *.
+  ring_simplify; trivial.
+  rewrite S_INR in |- *;  ring.
+Qed.
+
+Lemma cos_period : forall (x:R) (k:nat), cos (x + 2 * INR k * PI) = cos x.
+Proof.
+  intros x k; induction  k as [| k Hreck].
+  simpl in |- *;  ring_simplify (x + 2 * 0 * PI).
+  trivial.
+
+  replace (x + 2 * INR (S k) * PI) with (x + 2 * INR k * PI + 2 * PI).
+  rewrite cos_plus in |- *; rewrite sin_2PI in |- *; rewrite cos_2PI in |- *.
+  ring_simplify; trivial.
+  rewrite S_INR in |- *;  ring.
+Qed.
+
+Lemma sin_shift : forall x:R, sin (PI / 2 - x) = cos x.
+Proof.
+  intro x; rewrite sin_minus; rewrite sin_PI2; rewrite cos_PI2; ring.
+Qed.
+
+Lemma cos_shift : forall x:R, cos (PI / 2 - x) = sin x.
+Proof.
+  intro x; rewrite cos_minus; rewrite sin_PI2; rewrite cos_PI2; ring.
+Qed.
+
+Lemma cos_sin : forall x:R, cos x = sin (PI / 2 + x).
+Proof.
+  intro x; rewrite sin_plus; rewrite sin_PI2; rewrite cos_PI2; ring.
+Qed.
+
+Lemma PI2_RGT_0 : 0 < PI / 2.
+Proof.
+  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+    [ apply PI_RGT_0 | apply Rinv_0_lt_compat; prove_sup ].
+Qed.
+
+Lemma SIN_bound : forall x:R, -1 <= sin x <= 1.
+Proof.
+  intro; case (Rle_dec (-1) (sin x)); intro.
+  case (Rle_dec (sin x) 1); intro.
+  split; assumption.
+  cut (1 < sin x).
+  intro;
+    generalize
+      (Rsqr_incrst_1 1 (sin x) H (Rlt_le 0 1 Rlt_0_1)
+        (Rlt_le 0 (sin x) (Rlt_trans 0 1 (sin x) Rlt_0_1 H)));
+      rewrite Rsqr_1; intro; rewrite sin2 in H0; unfold Rminus in H0;
+        generalize (Rplus_lt_compat_l (-1) 1 (1 + - Rsqr (cos x)) H0);
+          repeat rewrite <- Rplus_assoc; repeat rewrite Rplus_opp_l;
+            rewrite Rplus_0_l; intro; rewrite <- Ropp_0 in H1;
+              generalize (Ropp_lt_gt_contravar (-0) (- Rsqr (cos x)) H1);
+                repeat rewrite Ropp_involutive; intro; generalize (Rle_0_sqr (cos x));
+                  intro; elim (Rlt_irrefl 0 (Rle_lt_trans 0 (Rsqr (cos x)) 0 H3 H2)).
+  auto with real.
+  cut (sin x < -1).
+  intro; generalize (Ropp_lt_gt_contravar (sin x) (-1) H);
+    rewrite Ropp_involutive; clear H; intro;
+      generalize
+        (Rsqr_incrst_1 1 (- sin x) H (Rlt_le 0 1 Rlt_0_1)
+          (Rlt_le 0 (- sin x) (Rlt_trans 0 1 (- sin x) Rlt_0_1 H)));
+        rewrite Rsqr_1; intro; rewrite <- Rsqr_neg in H0;
+          rewrite sin2 in H0; unfold Rminus in H0;
+            generalize (Rplus_lt_compat_l (-1) 1 (1 + - Rsqr (cos x)) H0);
+              repeat rewrite <- Rplus_assoc; repeat rewrite Rplus_opp_l;
+                rewrite Rplus_0_l; intro; rewrite <- Ropp_0 in H1;
+                  generalize (Ropp_lt_gt_contravar (-0) (- Rsqr (cos x)) H1);
+                    repeat rewrite Ropp_involutive; intro; generalize (Rle_0_sqr (cos x));
+                      intro; elim (Rlt_irrefl 0 (Rle_lt_trans 0 (Rsqr (cos x)) 0 H3 H2)).
+  auto with real.
+Qed.
+
+Lemma COS_bound : forall x:R, -1 <= cos x <= 1.
+Proof.
+  intro; rewrite <- sin_shift; apply SIN_bound.
+Qed.
+
+Lemma cos_sin_0 : forall x:R, ~ (cos x = 0 /\ sin x = 0).
+Proof.
+  intro; red in |- *; intro; elim H; intros; generalize (sin2_cos2 x); intro;
+    rewrite H0 in H2; rewrite H1 in H2; repeat rewrite Rsqr_0 in H2;
+      rewrite Rplus_0_r in H2; generalize Rlt_0_1; intro;
+        rewrite <- H2 in H3; elim (Rlt_irrefl 0 H3).
+Qed.
+
+Lemma cos_sin_0_var : forall x:R, cos x <> 0 \/ sin x <> 0.
+Proof.
+  intros x.
+  destruct (Req_dec (cos x) 0). 2: now left.
+  right. intros H'.
+  apply (cos_sin_0 x).
+  now split.
+Qed.
+
+(*****************************************************************)
+(** * Using series definitions of cos and sin                    *)
+(*****************************************************************)
+
+Definition sin_lb (a:R) : R := sin_approx a 3.
+Definition sin_ub (a:R) : R := sin_approx a 4.
+Definition cos_lb (a:R) : R := cos_approx a 3.
+Definition cos_ub (a:R) : R := cos_approx a 4.
+
+Lemma sin_lb_gt_0 : forall a:R, 0 < a -> a <= PI / 2 -> 0 < sin_lb a.
+Proof.
+  intros.
+  unfold sin_lb in |- *; unfold sin_approx in |- *; unfold sin_term in |- *.
+  set (Un := fun i:nat => a ^ (2 * i + 1) / INR (fact (2 * i + 1))).
+  replace
+  (sum_f_R0
+    (fun i:nat => (-1) ^ i * (a ^ (2 * i + 1) / INR (fact (2 * i + 1)))) 3)
+    with (sum_f_R0 (fun i:nat => (-1) ^ i * Un i) 3);
+      [ idtac | apply sum_eq; intros; unfold Un in |- *; reflexivity ].
+  cut (forall n:nat, Un (S n) < Un n).
+  intro; simpl in |- *.
+  repeat rewrite Rmult_1_l; repeat rewrite Rmult_1_r;
+    replace (-1 * Un 1%nat) with (- Un 1%nat); [ idtac | ring ];
+    replace (-1 * -1 * Un 2%nat) with (Un 2%nat); [ idtac | ring ];
+    replace (-1 * (-1 * -1) * Un 3%nat) with (- Un 3%nat);
+    [ idtac | ring ];
+    replace (Un 0%nat + - Un 1%nat + Un 2%nat + - Un 3%nat) with
+    (Un 0%nat - Un 1%nat + (Un 2%nat - Un 3%nat)); [ idtac | ring ].
+  apply Rplus_lt_0_compat.
+  unfold Rminus in |- *; apply Rplus_lt_reg_r with (Un 1%nat);
+    rewrite Rplus_0_r; rewrite (Rplus_comm (Un 1%nat));
+      rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r;
+        apply H1.
+  unfold Rminus in |- *; apply Rplus_lt_reg_r with (Un 3%nat);
+    rewrite Rplus_0_r; rewrite (Rplus_comm (Un 3%nat));
+      rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r;
+        apply H1.
+  intro; unfold Un in |- *.
+  cut ((2 * S n + 1)%nat = (2 * n + 1 + 2)%nat).
+  intro; rewrite H1.
+  rewrite pow_add; unfold Rdiv in |- *; rewrite Rmult_assoc;
+    apply Rmult_lt_compat_l.
+  apply pow_lt; assumption.
+  rewrite <- H1; apply Rmult_lt_reg_l with (INR (fact (2 * n + 1))).
+  apply lt_INR_0; apply neq_O_lt.
+  assert (H2 := fact_neq_0 (2 * n + 1)).
+  red in |- *; intro; elim H2; symmetry  in |- *; assumption.
+  rewrite <- Rinv_r_sym.
+  apply Rmult_lt_reg_l with (INR (fact (2 * S n + 1))).
+  apply lt_INR_0; apply neq_O_lt.
+  assert (H2 := fact_neq_0 (2 * S n + 1)).
+  red in |- *; intro; elim H2; symmetry  in |- *; assumption.
+  rewrite (Rmult_comm (INR (fact (2 * S n + 1)))); repeat rewrite Rmult_assoc;
+    rewrite <- Rinv_l_sym.
+  do 2 rewrite Rmult_1_r; apply Rle_lt_trans with (INR (fact (2 * n + 1)) * 4).
+  apply Rmult_le_compat_l.
+  replace 0 with (INR 0); [ idtac | reflexivity ]; apply le_INR; apply le_O_n.
+  simpl in |- *; rewrite Rmult_1_r; replace 4 with (Rsqr 2);
+    [ idtac | ring_Rsqr ]; replace (a * a) with (Rsqr a);
+    [ idtac | reflexivity ]; apply Rsqr_incr_1.
+  apply Rle_trans with (PI / 2);
+    [ assumption
+      | unfold Rdiv in |- *; apply Rmult_le_reg_l with 2;
+        [ prove_sup0
+          | rewrite <- Rmult_assoc; rewrite Rinv_r_simpl_m;
+            [ replace 4 with 4; [ apply PI_4 | ring ] | discrR ] ] ].
+  left; assumption.
+  left; prove_sup0.
+  rewrite H1; replace (2 * n + 1 + 2)%nat with (S (S (2 * n + 1))).
+  do 2 rewrite fact_simpl; do 2 rewrite mult_INR.
+  repeat rewrite <- Rmult_assoc.
+  rewrite <- (Rmult_comm (INR (fact (2 * n + 1)))).
+  rewrite Rmult_assoc.
+  apply Rmult_lt_compat_l.
+  apply lt_INR_0; apply neq_O_lt.
+  assert (H2 := fact_neq_0 (2 * n + 1)).
+  red in |- *; intro; elim H2; symmetry  in |- *; assumption.
+  do 2 rewrite S_INR; rewrite plus_INR; rewrite mult_INR; set (x := INR n);
+    unfold INR in |- *.
+  replace ((2 * x + 1 + 1 + 1) * (2 * x + 1 + 1)) with (4 * x * x + 10 * x + 6);
+  [ idtac | ring ].
+  apply Rplus_lt_reg_r with (-4); rewrite Rplus_opp_l;
+    replace (-4 + (4 * x * x + 10 * x + 6)) with (4 * x * x + 10 * x + 2);
+    [ idtac | ring ].
+  apply Rplus_le_lt_0_compat.
+  cut (0 <= x).
+  intro; apply Rplus_le_le_0_compat; repeat apply Rmult_le_pos;
+    assumption || left; prove_sup.
+  unfold x in |- *; replace 0 with (INR 0);
+    [ apply le_INR; apply le_O_n | reflexivity ].
+  prove_sup0.
+  ring.
+  apply INR_fact_neq_0.
+  apply INR_fact_neq_0.
+  ring.
+Qed.
+
+Lemma SIN : forall a:R, 0 <= a -> a <= PI -> sin_lb a <= sin a <= sin_ub a.
+  intros; unfold sin_lb, sin_ub in |- *; apply (sin_bound a 1 H H0).
+Qed.
+
+Lemma COS :
+  forall a:R, - PI / 2 <= a -> a <= PI / 2 -> cos_lb a <= cos a <= cos_ub a.
+  intros; unfold cos_lb, cos_ub in |- *; apply (cos_bound a 1 H H0).
+Qed.
+
+(**********)
+Lemma _PI2_RLT_0 : - (PI / 2) < 0.
+Proof.
+  rewrite <- Ropp_0; apply Ropp_lt_contravar; apply PI2_RGT_0.
+Qed.
+
+Lemma PI4_RLT_PI2 : PI / 4 < PI / 2.
+Proof.
+  unfold Rdiv in |- *; apply Rmult_lt_compat_l.
+  apply PI_RGT_0.
+  apply Rinv_lt_contravar.
+  apply Rmult_lt_0_compat; prove_sup0.
+  pattern 2 at 1 in |- *; rewrite <- Rplus_0_r.
+  replace 4 with (2 + 2); [ apply Rplus_lt_compat_l; prove_sup0 | ring ].
+Qed.
+
+Lemma PI2_Rlt_PI : PI / 2 < PI.
+Proof.
+  unfold Rdiv in |- *; pattern PI at 2 in |- *; rewrite <- Rmult_1_r.
+  apply Rmult_lt_compat_l.
+  apply PI_RGT_0.
+  pattern 1 at 3 in |- *; rewrite <- Rinv_1; apply Rinv_lt_contravar.
+  rewrite Rmult_1_l; prove_sup0.
+  pattern 1 at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
+    apply Rlt_0_1.
+Qed.
+
+(***************************************************)
+(** * Increasing and decreasing of [cos] and [sin] *)
+(***************************************************)
+Theorem sin_gt_0 : forall x:R, 0 < x -> x < PI -> 0 < sin x.
+Proof.
+  intros; elim (SIN x (Rlt_le 0 x H) (Rlt_le x PI H0)); intros H1 _;
+    case (Rtotal_order x (PI / 2)); intro H2.
+  apply Rlt_le_trans with (sin_lb x).
+  apply sin_lb_gt_0; [ assumption | left; assumption ].
+  assumption.
+  elim H2; intro H3.
+  rewrite H3; rewrite sin_PI2; apply Rlt_0_1.
+  rewrite <- sin_PI_x; generalize (Ropp_gt_lt_contravar x (PI / 2) H3);
+    intro H4; generalize (Rplus_lt_compat_l PI (- x) (- (PI / 2)) H4).
+  replace (PI + - x) with (PI - x).
+  replace (PI + - (PI / 2)) with (PI / 2).
+  intro H5; generalize (Ropp_lt_gt_contravar x PI H0); intro H6;
+    change (- PI < - x) in H6; generalize (Rplus_lt_compat_l PI (- PI) (- x) H6).
+  rewrite Rplus_opp_r.
+  replace (PI + - x) with (PI - x).
+  intro H7;
+    elim
+      (SIN (PI - x) (Rlt_le 0 (PI - x) H7)
+        (Rlt_le (PI - x) PI (Rlt_trans (PI - x) (PI / 2) PI H5 PI2_Rlt_PI)));
+      intros H8 _;
+        generalize (sin_lb_gt_0 (PI - x) H7 (Rlt_le (PI - x) (PI / 2) H5));
+          intro H9; apply (Rlt_le_trans 0 (sin_lb (PI - x)) (sin (PI - x)) H9 H8).
+  reflexivity.
+  pattern PI at 2 in |- *; rewrite double_var; ring.
+  reflexivity.
+Qed.
+
+Theorem cos_gt_0 : forall x:R, - (PI / 2) < x -> x < PI / 2 -> 0 < cos x.
+Proof.
+  intros; rewrite cos_sin;
+    generalize (Rplus_lt_compat_l (PI / 2) (- (PI / 2)) x H).
+  rewrite Rplus_opp_r; intro H1;
+    generalize (Rplus_lt_compat_l (PI / 2) x (PI / 2) H0);
+      rewrite <- double_var; intro H2; apply (sin_gt_0 (PI / 2 + x) H1 H2).
+Qed.
+
+Lemma sin_ge_0 : forall x:R, 0 <= x -> x <= PI -> 0 <= sin x.
+Proof.
+  intros x H1 H2; elim H1; intro H3;
+    [ elim H2; intro H4;
+      [ left; apply (sin_gt_0 x H3 H4)
+        | rewrite H4; right; symmetry  in |- *; apply sin_PI ]
+      | rewrite <- H3; right; symmetry  in |- *; apply sin_0 ].
+Qed.
+
+Lemma cos_ge_0 : forall x:R, - (PI / 2) <= x -> x <= PI / 2 -> 0 <= cos x.
+Proof.
+  intros x H1 H2; elim H1; intro H3;
+    [ elim H2; intro H4;
+      [ left; apply (cos_gt_0 x H3 H4)
+        | rewrite H4; right; symmetry  in |- *; apply cos_PI2 ]
+      | rewrite <- H3; rewrite cos_neg; right; symmetry  in |- *; apply cos_PI2 ].
+Qed.
+
+Lemma sin_le_0 : forall x:R, PI <= x -> x <= 2 * PI -> sin x <= 0.
+Proof.
+  intros x H1 H2; apply Rge_le; rewrite <- Ropp_0;
+    rewrite <- (Ropp_involutive (sin x)); apply Ropp_le_ge_contravar;
+      rewrite <- neg_sin; replace (x + PI) with (x - PI + 2 * INR 1 * PI);
+        [ rewrite (sin_period (x - PI) 1); apply sin_ge_0;
+          [ replace (x - PI) with (x + - PI);
+            [ rewrite Rplus_comm; replace 0 with (- PI + PI);
+              [ apply Rplus_le_compat_l; assumption | ring ]
+              | ring ]
+            | replace (x - PI) with (x + - PI); rewrite Rplus_comm;
+              [ pattern PI at 2 in |- *; replace PI with (- PI + 2 * PI);
+                [ apply Rplus_le_compat_l; assumption | ring ]
+                | ring ] ]
+          | unfold INR in |- *; ring ].
+Qed.
+
+Lemma cos_le_0 : forall x:R, PI / 2 <= x -> x <= 3 * (PI / 2) -> cos x <= 0.
+Proof.
+  intros x H1 H2; apply Rge_le; rewrite <- Ropp_0;
+    rewrite <- (Ropp_involutive (cos x)); apply Ropp_le_ge_contravar;
+      rewrite <- neg_cos; replace (x + PI) with (x - PI + 2 * INR 1 * PI).
+  rewrite cos_period; apply cos_ge_0.
+  replace (- (PI / 2)) with (- PI + PI / 2).
+  unfold Rminus in |- *; rewrite (Rplus_comm x); apply Rplus_le_compat_l;
+    assumption.
+  pattern PI at 1 in |- *; rewrite (double_var PI); rewrite Ropp_plus_distr;
+    ring.
+  unfold Rminus in |- *; rewrite Rplus_comm;
+    replace (PI / 2) with (- PI + 3 * (PI / 2)).
+  apply Rplus_le_compat_l; assumption.
+  pattern PI at 1 in |- *; rewrite (double_var PI); rewrite Ropp_plus_distr;
+    ring.
+  unfold INR in |- *; ring.
+Qed.
+
+Lemma sin_lt_0 : forall x:R, PI < x -> x < 2 * PI -> sin x < 0.
+Proof.
+  intros x H1 H2; rewrite <- Ropp_0; rewrite <- (Ropp_involutive (sin x));
+    apply Ropp_lt_gt_contravar; rewrite <- neg_sin;
+      replace (x + PI) with (x - PI + 2 * INR 1 * PI);
+      [ rewrite (sin_period (x - PI) 1); apply sin_gt_0;
+        [ replace (x - PI) with (x + - PI);
+          [ rewrite Rplus_comm; replace 0 with (- PI + PI);
+            [ apply Rplus_lt_compat_l; assumption | ring ]
+            | ring ]
+          | replace (x - PI) with (x + - PI); rewrite Rplus_comm;
+            [ pattern PI at 2 in |- *; replace PI with (- PI + 2 * PI);
+              [ apply Rplus_lt_compat_l; assumption | ring ]
+              | ring ] ]
+        | unfold INR in |- *; ring ].
+Qed.
+
+Lemma sin_lt_0_var : forall x:R, - PI < x -> x < 0 -> sin x < 0.
+Proof.
+  intros; generalize (Rplus_lt_compat_l (2 * PI) (- PI) x H);
+    replace (2 * PI + - PI) with PI;
+    [ intro H1; rewrite Rplus_comm in H1;
+      generalize (Rplus_lt_compat_l (2 * PI) x 0 H0);
+        intro H2; rewrite (Rplus_comm (2 * PI)) in H2;
+          rewrite <- (Rplus_comm 0) in H2; rewrite Rplus_0_l in H2;
+            rewrite <- (sin_period x 1); unfold INR in |- *;
+              replace (2 * 1 * PI) with (2 * PI);
+              [ apply (sin_lt_0 (x + 2 * PI) H1 H2) | ring ]
+      | ring ].
+Qed.
+
+Lemma cos_lt_0 : forall x:R, PI / 2 < x -> x < 3 * (PI / 2) -> cos x < 0.
+Proof.
+  intros x H1 H2; rewrite <- Ropp_0; rewrite <- (Ropp_involutive (cos x));
+    apply Ropp_lt_gt_contravar; rewrite <- neg_cos;
+      replace (x + PI) with (x - PI + 2 * INR 1 * PI).
+  rewrite cos_period; apply cos_gt_0.
+  replace (- (PI / 2)) with (- PI + PI / 2).
+  unfold Rminus in |- *; rewrite (Rplus_comm x); apply Rplus_lt_compat_l;
+    assumption.
+  pattern PI at 1 in |- *; rewrite (double_var PI); rewrite Ropp_plus_distr;
+    ring.
+  unfold Rminus in |- *; rewrite Rplus_comm;
+    replace (PI / 2) with (- PI + 3 * (PI / 2)).
+  apply Rplus_lt_compat_l; assumption.
+  pattern PI at 1 in |- *; rewrite (double_var PI); rewrite Ropp_plus_distr;
+    ring.
+  unfold INR in |- *; ring.
+Qed.
+
+Lemma tan_gt_0 : forall x:R, 0 < x -> x < PI / 2 -> 0 < tan x.
+Proof.
+  intros x H1 H2; unfold tan in |- *; generalize _PI2_RLT_0;
+    generalize (Rlt_trans 0 x (PI / 2) H1 H2); intros;
+      generalize (Rlt_trans (- (PI / 2)) 0 x H0 H1); intro H5;
+        generalize (Rlt_trans x (PI / 2) PI H2 PI2_Rlt_PI);
+          intro H7; unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+  apply sin_gt_0; assumption.
+  apply Rinv_0_lt_compat; apply cos_gt_0; assumption.
+Qed.
+
+Lemma tan_lt_0 : forall x:R, - (PI / 2) < x -> x < 0 -> tan x < 0.
+Proof.
+  intros x H1 H2; unfold tan in |- *;
+    generalize (cos_gt_0 x H1 (Rlt_trans x 0 (PI / 2) H2 PI2_RGT_0));
+      intro H3; rewrite <- Ropp_0;
+        replace (sin x / cos x) with (- (- sin x / cos x)).
+  rewrite <- sin_neg; apply Ropp_gt_lt_contravar;
+    change (0 < sin (- x) / cos x) in |- *; unfold Rdiv in |- *;
+      apply Rmult_lt_0_compat.
+  apply sin_gt_0.
+  rewrite <- Ropp_0; apply Ropp_gt_lt_contravar; assumption.
+  apply Rlt_trans with (PI / 2).
+  rewrite <- (Ropp_involutive (PI / 2)); apply Ropp_gt_lt_contravar; assumption.
+  apply PI2_Rlt_PI.
+  apply Rinv_0_lt_compat; assumption.
+  unfold Rdiv in |- *; ring.
+Qed.
+
+Lemma cos_ge_0_3PI2 :
+  forall x:R, 3 * (PI / 2) <= x -> x <= 2 * PI -> 0 <= cos x.
+Proof.
+  intros; rewrite <- cos_neg; rewrite <- (cos_period (- x) 1);
+    unfold INR in |- *; replace (- x + 2 * 1 * PI) with (2 * PI - x).
+  generalize (Ropp_le_ge_contravar x (2 * PI) H0); intro H1;
+    generalize (Rge_le (- x) (- (2 * PI)) H1); clear H1;
+      intro H1; generalize (Rplus_le_compat_l (2 * PI) (- (2 * PI)) (- x) H1).
+  rewrite Rplus_opp_r.
+  intro H2; generalize (Ropp_le_ge_contravar (3 * (PI / 2)) x H); intro H3;
+    generalize (Rge_le (- (3 * (PI / 2))) (- x) H3); clear H3;
+      intro H3;
+        generalize (Rplus_le_compat_l (2 * PI) (- x) (- (3 * (PI / 2))) H3).
+  replace (2 * PI + - (3 * (PI / 2))) with (PI / 2).
+  intro H4;
+    apply
+      (cos_ge_0 (2 * PI - x)
+        (Rlt_le (- (PI / 2)) (2 * PI - x)
+          (Rlt_le_trans (- (PI / 2)) 0 (2 * PI - x) _PI2_RLT_0 H2)) H4).
+  rewrite double; pattern PI at 2 3 in |- *; rewrite double_var; ring.
+  ring.
+Qed.
+
+Lemma form1 :
+  forall p q:R, cos p + cos q = 2 * cos ((p - q) / 2) * cos ((p + q) / 2).
+Proof.
+  intros p q; pattern p at 1 in |- *;
+    replace p with ((p - q) / 2 + (p + q) / 2).
+  rewrite <- (cos_neg q); replace (- q) with ((p - q) / 2 - (p + q) / 2).
+  rewrite cos_plus; rewrite cos_minus; ring.
+  pattern q at 3 in |- *; rewrite double_var; unfold Rdiv in |- *; ring.
+  pattern p at 3 in |- *; rewrite double_var; unfold Rdiv in |- *; ring.
+Qed.
+
+Lemma form2 :
+  forall p q:R, cos p - cos q = -2 * sin ((p - q) / 2) * sin ((p + q) / 2).
+Proof.
+  intros p q; pattern p at 1 in |- *;
+    replace p with ((p - q) / 2 + (p + q) / 2).
+  rewrite <- (cos_neg q); replace (- q) with ((p - q) / 2 - (p + q) / 2).
+  rewrite cos_plus; rewrite cos_minus; ring.
+  pattern q at 3 in |- *; rewrite double_var; unfold Rdiv in |- *; ring.
+  pattern p at 3 in |- *; rewrite double_var; unfold Rdiv in |- *; ring.
+Qed.
+
+Lemma form3 :
+  forall p q:R, sin p + sin q = 2 * cos ((p - q) / 2) * sin ((p + q) / 2).
+Proof.
+  intros p q; pattern p at 1 in |- *;
+    replace p with ((p - q) / 2 + (p + q) / 2).
+  pattern q at 3 in |- *; replace q with ((p + q) / 2 - (p - q) / 2).
+  rewrite sin_plus; rewrite sin_minus; ring.
+  pattern q at 3 in |- *; rewrite double_var; unfold Rdiv in |- *; ring.
+  pattern p at 3 in |- *; rewrite double_var; unfold Rdiv in |- *; ring.
+Qed.
+
+Lemma form4 :
+  forall p q:R, sin p - sin q = 2 * cos ((p + q) / 2) * sin ((p - q) / 2).
+Proof.
+  intros p q; pattern p at 1 in |- *;
+    replace p with ((p - q) / 2 + (p + q) / 2).
+  pattern q at 3 in |- *; replace q with ((p + q) / 2 - (p - q) / 2).
+  rewrite sin_plus; rewrite sin_minus; ring.
+  pattern q at 3 in |- *; rewrite double_var; unfold Rdiv in |- *; ring.
+  pattern p at 3 in |- *; rewrite double_var; unfold Rdiv in |- *; ring.
+
+Qed.
+
+Lemma sin_increasing_0 :
+  forall x y:R,
+    - (PI / 2) <= x ->
+    x <= PI / 2 -> - (PI / 2) <= y -> y <= PI / 2 -> sin x < sin y -> x < y.
+Proof.
+  intros; cut (sin ((x - y) / 2) < 0).
+  intro H4; case (Rtotal_order ((x - y) / 2) 0); intro H5.
+  assert (Hyp : 0 < 2).
+  prove_sup0.
+  generalize (Rmult_lt_compat_l 2 ((x - y) / 2) 0 Hyp H5).
+  unfold Rdiv in |- *.
+  rewrite <- Rmult_assoc.
+  rewrite Rinv_r_simpl_m.
+  rewrite Rmult_0_r.
+  clear H5; intro H5; apply Rminus_lt; assumption.
+  discrR.
+  elim H5; intro H6.
+  rewrite H6 in H4; rewrite sin_0 in H4; elim (Rlt_irrefl 0 H4).
+  change (0 < (x - y) / 2) in H6;
+    generalize (Ropp_le_ge_contravar (- (PI / 2)) y H1).
+  rewrite Ropp_involutive.
+  intro H7; generalize (Rge_le (PI / 2) (- y) H7); clear H7; intro H7;
+    generalize (Rplus_le_compat x (PI / 2) (- y) (PI / 2) H0 H7).
+  rewrite <- double_var.
+  intro H8.
+  assert (Hyp : 0 < 2).
+  prove_sup0.
+  generalize
+    (Rmult_le_compat_l (/ 2) (x - y) PI
+      (Rlt_le 0 (/ 2) (Rinv_0_lt_compat 2 Hyp)) H8).
+  repeat rewrite (Rmult_comm (/ 2)).
+  intro H9;
+    generalize
+      (sin_gt_0 ((x - y) / 2) H6
+        (Rle_lt_trans ((x - y) / 2) (PI / 2) PI H9 PI2_Rlt_PI));
+      intro H10;
+        elim
+          (Rlt_irrefl (sin ((x - y) / 2))
+            (Rlt_trans (sin ((x - y) / 2)) 0 (sin ((x - y) / 2)) H4 H10)).
+  generalize (Rlt_minus (sin x) (sin y) H3); clear H3; intro H3;
+    rewrite form4 in H3;
+      generalize (Rplus_le_compat x (PI / 2) y (PI / 2) H0 H2).
+  rewrite <- double_var.
+  assert (Hyp : 0 < 2).
+  prove_sup0.
+  intro H4;
+    generalize
+      (Rmult_le_compat_l (/ 2) (x + y) PI
+        (Rlt_le 0 (/ 2) (Rinv_0_lt_compat 2 Hyp)) H4).
+  repeat rewrite (Rmult_comm (/ 2)).
+  clear H4; intro H4;
+    generalize (Rplus_le_compat (- (PI / 2)) x (- (PI / 2)) y H H1);
+      replace (- (PI / 2) + - (PI / 2)) with (- PI).
+  intro H5;
+    generalize
+      (Rmult_le_compat_l (/ 2) (- PI) (x + y)
+        (Rlt_le 0 (/ 2) (Rinv_0_lt_compat 2 Hyp)) H5).
+  replace (/ 2 * (x + y)) with ((x + y) / 2).
+  replace (/ 2 * - PI) with (- (PI / 2)).
+  clear H5; intro H5; elim H4; intro H40.
+  elim H5; intro H50.
+  generalize (cos_gt_0 ((x + y) / 2) H50 H40); intro H6;
+    generalize (Rmult_lt_compat_l 2 0 (cos ((x + y) / 2)) Hyp H6).
+  rewrite Rmult_0_r.
+  clear H6; intro H6; case (Rcase_abs (sin ((x - y) / 2))); intro H7.
+  assumption.
+  generalize (Rge_le (sin ((x - y) / 2)) 0 H7); clear H7; intro H7;
+    generalize
+      (Rmult_le_pos (2 * cos ((x + y) / 2)) (sin ((x - y) / 2))
+        (Rlt_le 0 (2 * cos ((x + y) / 2)) H6) H7); intro H8;
+      generalize
+        (Rle_lt_trans 0 (2 * cos ((x + y) / 2) * sin ((x - y) / 2)) 0 H8 H3);
+        intro H9; elim (Rlt_irrefl 0 H9).
+  rewrite <- H50 in H3; rewrite cos_neg in H3; rewrite cos_PI2 in H3;
+    rewrite Rmult_0_r in H3; rewrite Rmult_0_l in H3;
+      elim (Rlt_irrefl 0 H3).
+  unfold Rdiv in H3.
+  rewrite H40 in H3; assert (H50 := cos_PI2); unfold Rdiv in H50;
+    rewrite H50 in H3; rewrite Rmult_0_r in H3; rewrite Rmult_0_l in H3;
+      elim (Rlt_irrefl 0 H3).
+  unfold Rdiv in |- *.
+  rewrite <- Ropp_mult_distr_l_reverse.
+  apply Rmult_comm.
+  unfold Rdiv in |- *; apply Rmult_comm.
+  pattern PI at 1 in |- *; rewrite double_var.
+  rewrite Ropp_plus_distr.
+  reflexivity.
+Qed.
+
+Lemma sin_increasing_1 :
+  forall x y:R,
+    - (PI / 2) <= x ->
+    x <= PI / 2 -> - (PI / 2) <= y -> y <= PI / 2 -> x < y -> sin x < sin y.
+Proof.
+  intros; generalize (Rplus_lt_compat_l x x y H3); intro H4;
+    generalize (Rplus_le_compat (- (PI / 2)) x (- (PI / 2)) x H H);
+      replace (- (PI / 2) + - (PI / 2)) with (- PI).
+  assert (Hyp : 0 < 2).
+  prove_sup0.
+  intro H5; generalize (Rle_lt_trans (- PI) (x + x) (x + y) H5 H4); intro H6;
+    generalize
+      (Rmult_lt_compat_l (/ 2) (- PI) (x + y) (Rinv_0_lt_compat 2 Hyp) H6);
+      replace (/ 2 * - PI) with (- (PI / 2)).
+  replace (/ 2 * (x + y)) with ((x + y) / 2).
+  clear H4 H5 H6; intro H4; generalize (Rplus_lt_compat_l y x y H3); intro H5;
+    rewrite Rplus_comm in H5;
+      generalize (Rplus_le_compat y (PI / 2) y (PI / 2) H2 H2).
+  rewrite <- double_var.
+  intro H6; generalize (Rlt_le_trans (x + y) (y + y) PI H5 H6); intro H7;
+    generalize (Rmult_lt_compat_l (/ 2) (x + y) PI (Rinv_0_lt_compat 2 Hyp) H7);
+      replace (/ 2 * PI) with (PI / 2).
+  replace (/ 2 * (x + y)) with ((x + y) / 2).
+  clear H5 H6 H7; intro H5; generalize (Ropp_le_ge_contravar (- (PI / 2)) y H1);
+    rewrite Ropp_involutive; clear H1; intro H1;
+      generalize (Rge_le (PI / 2) (- y) H1); clear H1; intro H1;
+        generalize (Ropp_le_ge_contravar y (PI / 2) H2); clear H2;
+          intro H2; generalize (Rge_le (- y) (- (PI / 2)) H2);
+            clear H2; intro H2; generalize (Rplus_lt_compat_l (- y) x y H3);
+              replace (- y + x) with (x - y).
+  rewrite Rplus_opp_l.
+  intro H6;
+    generalize (Rmult_lt_compat_l (/ 2) (x - y) 0 (Rinv_0_lt_compat 2 Hyp) H6);
+      rewrite Rmult_0_r; replace (/ 2 * (x - y)) with ((x - y) / 2).
+  clear H6; intro H6;
+    generalize (Rplus_le_compat (- (PI / 2)) x (- (PI / 2)) (- y) H H2);
+      replace (- (PI / 2) + - (PI / 2)) with (- PI).
+  replace (x + - y) with (x - y).
+  intro H7;
+    generalize
+      (Rmult_le_compat_l (/ 2) (- PI) (x - y)
+        (Rlt_le 0 (/ 2) (Rinv_0_lt_compat 2 Hyp)) H7);
+      replace (/ 2 * - PI) with (- (PI / 2)).
+  replace (/ 2 * (x - y)) with ((x - y) / 2).
+  clear H7; intro H7; clear H H0 H1 H2; apply Rminus_lt; rewrite form4;
+    generalize (cos_gt_0 ((x + y) / 2) H4 H5); intro H8;
+      generalize (Rmult_lt_0_compat 2 (cos ((x + y) / 2)) Hyp H8);
+        clear H8; intro H8; cut (- PI < - (PI / 2)).
+  intro H9;
+    generalize
+      (sin_lt_0_var ((x - y) / 2)
+        (Rlt_le_trans (- PI) (- (PI / 2)) ((x - y) / 2) H9 H7) H6);
+      intro H10;
+        generalize
+          (Rmult_lt_gt_compat_neg_l (sin ((x - y) / 2)) 0 (
+            2 * cos ((x + y) / 2)) H10 H8); intro H11; rewrite Rmult_0_r in H11;
+          rewrite Rmult_comm; assumption.
+  apply Ropp_lt_gt_contravar; apply PI2_Rlt_PI.
+  unfold Rdiv in |- *; apply Rmult_comm.
+  unfold Rdiv in |- *; rewrite <- Ropp_mult_distr_l_reverse; apply Rmult_comm.
+  reflexivity.
+  pattern PI at 1 in |- *; rewrite double_var.
+  rewrite Ropp_plus_distr.
+  reflexivity.
+  unfold Rdiv in |- *; apply Rmult_comm.
+  unfold Rminus in |- *; apply Rplus_comm.
+  unfold Rdiv in |- *; apply Rmult_comm.
+  unfold Rdiv in |- *; apply Rmult_comm.
+  unfold Rdiv in |- *; apply Rmult_comm.
+  unfold Rdiv in |- *.
+  rewrite <- Ropp_mult_distr_l_reverse.
+  apply Rmult_comm.
+  pattern PI at 1 in |- *; rewrite double_var.
+  rewrite Ropp_plus_distr.
+  reflexivity.
+Qed.
+
+Lemma sin_decreasing_0 :
+  forall x y:R,
+    x <= 3 * (PI / 2) ->
+    PI / 2 <= x -> y <= 3 * (PI / 2) -> PI / 2 <= y -> sin x < sin y -> y < x.
+Proof.
+  intros; rewrite <- (sin_PI_x x) in H3; rewrite <- (sin_PI_x y) in H3;
+    generalize (Ropp_lt_gt_contravar (sin (PI - x)) (sin (PI - y)) H3);
+      repeat rewrite <- sin_neg;
+        generalize (Rplus_le_compat_l (- PI) x (3 * (PI / 2)) H);
+          generalize (Rplus_le_compat_l (- PI) (PI / 2) x H0);
+            generalize (Rplus_le_compat_l (- PI) y (3 * (PI / 2)) H1);
+              generalize (Rplus_le_compat_l (- PI) (PI / 2) y H2);
+                replace (- PI + x) with (x - PI).
+  replace (- PI + PI / 2) with (- (PI / 2)).
+  replace (- PI + y) with (y - PI).
+  replace (- PI + 3 * (PI / 2)) with (PI / 2).
+  replace (- (PI - x)) with (x - PI).
+  replace (- (PI - y)) with (y - PI).
+  intros; change (sin (y - PI) < sin (x - PI)) in H8;
+    apply Rplus_lt_reg_r with (- PI); rewrite Rplus_comm;
+      replace (y + - PI) with (y - PI).
+  rewrite Rplus_comm; replace (x + - PI) with (x - PI).
+  apply (sin_increasing_0 (y - PI) (x - PI) H4 H5 H6 H7 H8).
+  reflexivity.
+  reflexivity.
+  unfold Rminus in |- *; rewrite Ropp_plus_distr.
+  rewrite Ropp_involutive.
+  apply Rplus_comm.
+  unfold Rminus in |- *; rewrite Ropp_plus_distr.
+  rewrite Ropp_involutive.
+  apply Rplus_comm.
+  pattern PI at 2 in |- *; rewrite double_var.
+  rewrite Ropp_plus_distr.
+  ring.
+  unfold Rminus in |- *; apply Rplus_comm.
+  pattern PI at 2 in |- *; rewrite double_var.
+  rewrite Ropp_plus_distr.
+  ring.
+  unfold Rminus in |- *; apply Rplus_comm.
+Qed.
+
+Lemma sin_decreasing_1 :
+  forall x y:R,
+    x <= 3 * (PI / 2) ->
+    PI / 2 <= x -> y <= 3 * (PI / 2) -> PI / 2 <= y -> x < y -> sin y < sin x.
+Proof.
+  intros; rewrite <- (sin_PI_x x); rewrite <- (sin_PI_x y);
+    generalize (Rplus_le_compat_l (- PI) x (3 * (PI / 2)) H);
+      generalize (Rplus_le_compat_l (- PI) (PI / 2) x H0);
+        generalize (Rplus_le_compat_l (- PI) y (3 * (PI / 2)) H1);
+          generalize (Rplus_le_compat_l (- PI) (PI / 2) y H2);
+            generalize (Rplus_lt_compat_l (- PI) x y H3);
+              replace (- PI + PI / 2) with (- (PI / 2)).
+  replace (- PI + y) with (y - PI).
+  replace (- PI + 3 * (PI / 2)) with (PI / 2).
+  replace (- PI + x) with (x - PI).
+  intros; apply Ropp_lt_cancel; repeat rewrite <- sin_neg;
+    replace (- (PI - x)) with (x - PI).
+  replace (- (PI - y)) with (y - PI).
+  apply (sin_increasing_1 (x - PI) (y - PI) H7 H8 H5 H6 H4).
+  unfold Rminus in |- *; rewrite Ropp_plus_distr.
+  rewrite Ropp_involutive.
+  apply Rplus_comm.
+  unfold Rminus in |- *; rewrite Ropp_plus_distr.
+  rewrite Ropp_involutive.
+  apply Rplus_comm.
+  unfold Rminus in |- *; apply Rplus_comm.
+  pattern PI at 2 in |- *; rewrite double_var; ring.
+  unfold Rminus in |- *; apply Rplus_comm.
+  pattern PI at 2 in |- *; rewrite double_var; ring.
+Qed.
+
+Lemma cos_increasing_0 :
+  forall x y:R,
+    PI <= x -> x <= 2 * PI -> PI <= y -> y <= 2 * PI -> cos x < cos y -> x < y.
+Proof.
+  intros x y H1 H2 H3 H4; rewrite <- (cos_neg x); rewrite <- (cos_neg y);
+    rewrite <- (cos_period (- x) 1); rewrite <- (cos_period (- y) 1);
+      unfold INR in |- *;
+        replace (- x + 2 * 1 * PI) with (PI / 2 - (x - 3 * (PI / 2))).
+  replace (- y + 2 * 1 * PI) with (PI / 2 - (y - 3 * (PI / 2))).
+  repeat rewrite cos_shift; intro H5;
+    generalize (Rplus_le_compat_l (-3 * (PI / 2)) PI x H1);
+      generalize (Rplus_le_compat_l (-3 * (PI / 2)) x (2 * PI) H2);
+        generalize (Rplus_le_compat_l (-3 * (PI / 2)) PI y H3);
+          generalize (Rplus_le_compat_l (-3 * (PI / 2)) y (2 * PI) H4).
+  replace (-3 * (PI / 2) + y) with (y - 3 * (PI / 2)).
+  replace (-3 * (PI / 2) + x) with (x - 3 * (PI / 2)).
+  replace (-3 * (PI / 2) + 2 * PI) with (PI / 2).
+  replace (-3 * (PI / 2) + PI) with (- (PI / 2)).
+  clear H1 H2 H3 H4; intros H1 H2 H3 H4;
+    apply Rplus_lt_reg_r with (-3 * (PI / 2));
+      replace (-3 * (PI / 2) + x) with (x - 3 * (PI / 2)).
+  replace (-3 * (PI / 2) + y) with (y - 3 * (PI / 2)).
+  apply (sin_increasing_0 (x - 3 * (PI / 2)) (y - 3 * (PI / 2)) H4 H3 H2 H1 H5).
+  unfold Rminus in |- *.
+  rewrite Ropp_mult_distr_l_reverse.
+  apply Rplus_comm.
+  unfold Rminus in |- *.
+  rewrite Ropp_mult_distr_l_reverse.
+  apply Rplus_comm.
+  pattern PI at 3 in |- *; rewrite double_var.
+  ring.
+  rewrite double; pattern PI at 3 4 in |- *; rewrite double_var.
+  ring.
+  unfold Rminus in |- *.
+  rewrite Ropp_mult_distr_l_reverse.
+  apply Rplus_comm.
+  unfold Rminus in |- *.
+  rewrite Ropp_mult_distr_l_reverse.
+  apply Rplus_comm.
+  rewrite Rmult_1_r.
+  rewrite (double PI); pattern PI at 3 4 in |- *; rewrite double_var.
+  ring.
+  rewrite Rmult_1_r.
+  rewrite (double PI); pattern PI at 3 4 in |- *; rewrite double_var.
+  ring.
+Qed.
+
+Lemma cos_increasing_1 :
+  forall x y:R,
+    PI <= x -> x <= 2 * PI -> PI <= y -> y <= 2 * PI -> x < y -> cos x < cos y.
+Proof.
+  intros x y H1 H2 H3 H4 H5;
+    generalize (Rplus_le_compat_l (-3 * (PI / 2)) PI x H1);
+      generalize (Rplus_le_compat_l (-3 * (PI / 2)) x (2 * PI) H2);
+        generalize (Rplus_le_compat_l (-3 * (PI / 2)) PI y H3);
+          generalize (Rplus_le_compat_l (-3 * (PI / 2)) y (2 * PI) H4);
+            generalize (Rplus_lt_compat_l (-3 * (PI / 2)) x y H5);
+              rewrite <- (cos_neg x); rewrite <- (cos_neg y);
+                rewrite <- (cos_period (- x) 1); rewrite <- (cos_period (- y) 1);
+                  unfold INR in |- *; replace (-3 * (PI / 2) + x) with (x - 3 * (PI / 2)).
+  replace (-3 * (PI / 2) + y) with (y - 3 * (PI / 2)).
+  replace (-3 * (PI / 2) + PI) with (- (PI / 2)).
+  replace (-3 * (PI / 2) + 2 * PI) with (PI / 2).
+  clear H1 H2 H3 H4 H5; intros H1 H2 H3 H4 H5;
+    replace (- x + 2 * 1 * PI) with (PI / 2 - (x - 3 * (PI / 2))).
+  replace (- y + 2 * 1 * PI) with (PI / 2 - (y - 3 * (PI / 2))).
+  repeat rewrite cos_shift;
+    apply
+      (sin_increasing_1 (x - 3 * (PI / 2)) (y - 3 * (PI / 2)) H5 H4 H3 H2 H1).
+  rewrite Rmult_1_r.
+  rewrite (double PI); pattern PI at 3 4 in |- *; rewrite double_var.
+  ring.
+  rewrite Rmult_1_r.
+  rewrite (double PI); pattern PI at 3 4 in |- *; rewrite double_var.
+  ring.
+  rewrite (double PI); pattern PI at 3 4 in |- *; rewrite double_var.
+  ring.
+  pattern PI at 3 in |- *; rewrite double_var; ring.
+  unfold Rminus in |- *.
+  rewrite <- Ropp_mult_distr_l_reverse.
+  apply Rplus_comm.
+  unfold Rminus in |- *.
+  rewrite <- Ropp_mult_distr_l_reverse.
+  apply Rplus_comm.
+Qed.
+
+Lemma cos_decreasing_0 :
+  forall x y:R,
+    0 <= x -> x <= PI -> 0 <= y -> y <= PI -> cos x < cos y -> y < x.
+Proof.
+  intros; generalize (Ropp_lt_gt_contravar (cos x) (cos y) H3);
+    repeat rewrite <- neg_cos; intro H4;
+      change (cos (y + PI) < cos (x + PI)) in H4; rewrite (Rplus_comm x) in H4;
+        rewrite (Rplus_comm y) in H4; generalize (Rplus_le_compat_l PI 0 x H);
+          generalize (Rplus_le_compat_l PI x PI H0);
+            generalize (Rplus_le_compat_l PI 0 y H1);
+              generalize (Rplus_le_compat_l PI y PI H2); rewrite Rplus_0_r.
+  rewrite <- double.
+  clear H H0 H1 H2 H3; intros; apply Rplus_lt_reg_r with PI;
+    apply (cos_increasing_0 (PI + y) (PI + x) H0 H H2 H1 H4).
+Qed.
+
+Lemma cos_decreasing_1 :
+  forall x y:R,
+    0 <= x -> x <= PI -> 0 <= y -> y <= PI -> x < y -> cos y < cos x.
+Proof.
+  intros; apply Ropp_lt_cancel; repeat rewrite <- neg_cos;
+    rewrite (Rplus_comm x); rewrite (Rplus_comm y);
+      generalize (Rplus_le_compat_l PI 0 x H);
+        generalize (Rplus_le_compat_l PI x PI H0);
+          generalize (Rplus_le_compat_l PI 0 y H1);
+            generalize (Rplus_le_compat_l PI y PI H2); rewrite Rplus_0_r.
+  rewrite <- double.
+  generalize (Rplus_lt_compat_l PI x y H3); clear H H0 H1 H2 H3; intros;
+    apply (cos_increasing_1 (PI + x) (PI + y) H3 H2 H1 H0 H).
+Qed.
+
+Lemma tan_diff :
+  forall x y:R,
+    cos x <> 0 -> cos y <> 0 -> tan x - tan y = sin (x - y) / (cos x * cos y).
+Proof.
+  intros; unfold tan in |- *; rewrite sin_minus.
+  unfold Rdiv in |- *.
+  unfold Rminus in |- *.
+  rewrite Rmult_plus_distr_r.
+  rewrite Rinv_mult_distr.
+  repeat rewrite (Rmult_comm (sin x)).
+  repeat rewrite Rmult_assoc.
+  rewrite (Rmult_comm (cos y)).
+  repeat rewrite Rmult_assoc.
+  rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r.
+  rewrite (Rmult_comm (sin x)).
+  apply Rplus_eq_compat_l.
+  rewrite <- Ropp_mult_distr_l_reverse.
+  rewrite <- Ropp_mult_distr_r_reverse.
+  rewrite (Rmult_comm (/ cos x)).
+  repeat rewrite Rmult_assoc.
+  rewrite (Rmult_comm (cos x)).
+  repeat rewrite Rmult_assoc.
+  rewrite <- Rinv_l_sym.
+  rewrite Rmult_1_r.
+  reflexivity.
+  assumption.
+  assumption.
+  assumption.
+  assumption.
+Qed.
+
+Lemma tan_increasing_0 :
+  forall x y:R,
+    - (PI / 4) <= x ->
+    x <= PI / 4 -> - (PI / 4) <= y -> y <= PI / 4 -> tan x < tan y -> x < y.
+Proof.
+  intros; generalize PI4_RLT_PI2; intro H4;
+    generalize (Ropp_lt_gt_contravar (PI / 4) (PI / 2) H4);
+      intro H5; change (- (PI / 2) < - (PI / 4)) in H5;
+        generalize
+          (cos_gt_0 x (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) x H5 H)
+            (Rle_lt_trans x (PI / 4) (PI / 2) H0 H4)); intro HP1;
+          generalize
+            (cos_gt_0 y (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) y H5 H1)
+              (Rle_lt_trans y (PI / 4) (PI / 2) H2 H4)); intro HP2;
+            generalize
+              (not_eq_sym
+                (Rlt_not_eq 0 (cos x)
+                  (cos_gt_0 x (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) x H5 H)
+                    (Rle_lt_trans x (PI / 4) (PI / 2) H0 H4))));
+              intro H6;
+                generalize
+                  (not_eq_sym
+                    (Rlt_not_eq 0 (cos y)
+                      (cos_gt_0 y (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) y H5 H1)
+                        (Rle_lt_trans y (PI / 4) (PI / 2) H2 H4))));
+                  intro H7; generalize (tan_diff x y H6 H7); intro H8;
+                    generalize (Rlt_minus (tan x) (tan y) H3); clear H3;
+                      intro H3; rewrite H8 in H3; cut (sin (x - y) < 0).
+  intro H9; generalize (Ropp_le_ge_contravar (- (PI / 4)) y H1);
+    rewrite Ropp_involutive; intro H10; generalize (Rge_le (PI / 4) (- y) H10);
+      clear H10; intro H10; generalize (Ropp_le_ge_contravar y (PI / 4) H2);
+        intro H11; generalize (Rge_le (- y) (- (PI / 4)) H11);
+          clear H11; intro H11;
+            generalize (Rplus_le_compat (- (PI / 4)) x (- (PI / 4)) (- y) H H11);
+              generalize (Rplus_le_compat x (PI / 4) (- y) (PI / 4) H0 H10);
+                replace (x + - y) with (x - y).
+  replace (PI / 4 + PI / 4) with (PI / 2).
+  replace (- (PI / 4) + - (PI / 4)) with (- (PI / 2)).
+  intros; case (Rtotal_order 0 (x - y)); intro H14.
+  generalize
+    (sin_gt_0 (x - y) H14 (Rle_lt_trans (x - y) (PI / 2) PI H12 PI2_Rlt_PI));
+    intro H15; elim (Rlt_irrefl 0 (Rlt_trans 0 (sin (x - y)) 0 H15 H9)).
+  elim H14; intro H15.
+  rewrite <- H15 in H9; rewrite sin_0 in H9; elim (Rlt_irrefl 0 H9).
+  apply Rminus_lt; assumption.
+  pattern PI at 1 in |- *; rewrite double_var.
+  unfold Rdiv in |- *.
+  rewrite Rmult_plus_distr_r.
+  repeat rewrite Rmult_assoc.
+  rewrite <- Rinv_mult_distr.
+  rewrite Ropp_plus_distr.
+  replace 4 with 4.
+  reflexivity.
+  ring.
+  discrR.
+  discrR.
+  pattern PI at 1 in |- *; rewrite double_var.
+  unfold Rdiv in |- *.
+  rewrite Rmult_plus_distr_r.
+  repeat rewrite Rmult_assoc.
+  rewrite <- Rinv_mult_distr.
+  replace 4 with 4.
+  reflexivity.
+  ring.
+  discrR.
+  discrR.
+  reflexivity.
+  case (Rcase_abs (sin (x - y))); intro H9.
+  assumption.
+  generalize (Rge_le (sin (x - y)) 0 H9); clear H9; intro H9;
+    generalize (Rinv_0_lt_compat (cos x) HP1); intro H10;
+      generalize (Rinv_0_lt_compat (cos y) HP2); intro H11;
+        generalize (Rmult_lt_0_compat (/ cos x) (/ cos y) H10 H11);
+          replace (/ cos x * / cos y) with (/ (cos x * cos y)).
+  intro H12;
+    generalize
+      (Rmult_le_pos (sin (x - y)) (/ (cos x * cos y)) H9
+        (Rlt_le 0 (/ (cos x * cos y)) H12)); intro H13;
+      elim
+        (Rlt_irrefl 0 (Rle_lt_trans 0 (sin (x - y) * / (cos x * cos y)) 0 H13 H3)).
+  rewrite Rinv_mult_distr.
+  reflexivity.
+  assumption.
+  assumption.
+Qed.
+
+Lemma tan_increasing_1 :
+  forall x y:R,
+    - (PI / 4) <= x ->
+    x <= PI / 4 -> - (PI / 4) <= y -> y <= PI / 4 -> x < y -> tan x < tan y.
+Proof.
+  intros; apply Rminus_lt; generalize PI4_RLT_PI2; intro H4;
+    generalize (Ropp_lt_gt_contravar (PI / 4) (PI / 2) H4);
+      intro H5; change (- (PI / 2) < - (PI / 4)) in H5;
+        generalize
+          (cos_gt_0 x (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) x H5 H)
+            (Rle_lt_trans x (PI / 4) (PI / 2) H0 H4)); intro HP1;
+          generalize
+            (cos_gt_0 y (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) y H5 H1)
+              (Rle_lt_trans y (PI / 4) (PI / 2) H2 H4)); intro HP2;
+            generalize
+              (not_eq_sym
+                (Rlt_not_eq 0 (cos x)
+                  (cos_gt_0 x (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) x H5 H)
+                    (Rle_lt_trans x (PI / 4) (PI / 2) H0 H4))));
+              intro H6;
+                generalize
+                  (not_eq_sym
+                    (Rlt_not_eq 0 (cos y)
+                      (cos_gt_0 y (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) y H5 H1)
+                        (Rle_lt_trans y (PI / 4) (PI / 2) H2 H4))));
+                  intro H7; rewrite (tan_diff x y H6 H7);
+                    generalize (Rinv_0_lt_compat (cos x) HP1); intro H10;
+                      generalize (Rinv_0_lt_compat (cos y) HP2); intro H11;
+                        generalize (Rmult_lt_0_compat (/ cos x) (/ cos y) H10 H11);
+                          replace (/ cos x * / cos y) with (/ (cos x * cos y)).
+  clear H10 H11; intro H8; generalize (Ropp_le_ge_contravar y (PI / 4) H2);
+    intro H11; generalize (Rge_le (- y) (- (PI / 4)) H11);
+      clear H11; intro H11;
+        generalize (Rplus_le_compat (- (PI / 4)) x (- (PI / 4)) (- y) H H11);
+          replace (x + - y) with (x - y).
+  replace (- (PI / 4) + - (PI / 4)) with (- (PI / 2)).
+  clear H11; intro H9; generalize (Rlt_minus x y H3); clear H3; intro H3;
+    clear H H0 H1 H2 H4 H5 HP1 HP2; generalize PI2_Rlt_PI;
+      intro H1; generalize (Ropp_lt_gt_contravar (PI / 2) PI H1);
+        clear H1; intro H1;
+          generalize
+            (sin_lt_0_var (x - y) (Rlt_le_trans (- PI) (- (PI / 2)) (x - y) H1 H9) H3);
+            intro H2;
+              generalize
+                (Rmult_lt_gt_compat_neg_l (sin (x - y)) 0 (/ (cos x * cos y)) H2 H8);
+                rewrite Rmult_0_r; intro H4; assumption.
+  pattern PI at 1 in |- *; rewrite double_var.
+  unfold Rdiv in |- *.
+  rewrite Rmult_plus_distr_r.
+  repeat rewrite Rmult_assoc.
+  rewrite <- Rinv_mult_distr.
+  replace 4 with 4.
+  rewrite Ropp_plus_distr.
+  reflexivity.
+  ring.
+  discrR.
+  discrR.
+  reflexivity.
+  apply Rinv_mult_distr; assumption.
+Qed.
+
+Lemma sin_incr_0 :
+  forall x y:R,
+    - (PI / 2) <= x ->
+    x <= PI / 2 -> - (PI / 2) <= y -> y <= PI / 2 -> sin x <= sin y -> x <= y.
+Proof.
+  intros; case (Rtotal_order (sin x) (sin y)); intro H4;
+    [ left; apply (sin_increasing_0 x y H H0 H1 H2 H4)
+      | elim H4; intro H5;
+        [ case (Rtotal_order x y); intro H6;
+          [ left; assumption
+            | elim H6; intro H7;
+              [ right; assumption
+                | generalize (sin_increasing_1 y x H1 H2 H H0 H7); intro H8;
+                  rewrite H5 in H8; elim (Rlt_irrefl (sin y) H8) ] ]
+          | elim (Rlt_irrefl (sin x) (Rle_lt_trans (sin x) (sin y) (sin x) H3 H5)) ] ].
+Qed.
+
+Lemma sin_incr_1 :
+  forall x y:R,
+    - (PI / 2) <= x ->
+    x <= PI / 2 -> - (PI / 2) <= y -> y <= PI / 2 -> x <= y -> sin x <= sin y.
+Proof.
+  intros; case (Rtotal_order x y); intro H4;
+    [ left; apply (sin_increasing_1 x y H H0 H1 H2 H4)
+      | elim H4; intro H5;
+        [ case (Rtotal_order (sin x) (sin y)); intro H6;
+          [ left; assumption
+            | elim H6; intro H7;
+              [ right; assumption
+                | generalize (sin_increasing_0 y x H1 H2 H H0 H7); intro H8;
+                  rewrite H5 in H8; elim (Rlt_irrefl y H8) ] ]
+          | elim (Rlt_irrefl x (Rle_lt_trans x y x H3 H5)) ] ].
+Qed.
+
+Lemma sin_decr_0 :
+  forall x y:R,
+    x <= 3 * (PI / 2) ->
+    PI / 2 <= x ->
+    y <= 3 * (PI / 2) -> PI / 2 <= y -> sin x <= sin y -> y <= x.
+Proof.
+  intros; case (Rtotal_order (sin x) (sin y)); intro H4;
+    [ left; apply (sin_decreasing_0 x y H H0 H1 H2 H4)
+      | elim H4; intro H5;
+        [ case (Rtotal_order x y); intro H6;
+          [ generalize (sin_decreasing_1 x y H H0 H1 H2 H6); intro H8;
+            rewrite H5 in H8; elim (Rlt_irrefl (sin y) H8)
+            | elim H6; intro H7;
+              [ right; symmetry  in |- *; assumption | left; assumption ] ]
+          | elim (Rlt_irrefl (sin x) (Rle_lt_trans (sin x) (sin y) (sin x) H3 H5)) ] ].
+Qed.
+
+Lemma sin_decr_1 :
+  forall x y:R,
+    x <= 3 * (PI / 2) ->
+    PI / 2 <= x ->
+    y <= 3 * (PI / 2) -> PI / 2 <= y -> x <= y -> sin y <= sin x.
+Proof.
+  intros; case (Rtotal_order x y); intro H4;
+    [ left; apply (sin_decreasing_1 x y H H0 H1 H2 H4)
+      | elim H4; intro H5;
+        [ case (Rtotal_order (sin x) (sin y)); intro H6;
+          [ generalize (sin_decreasing_0 x y H H0 H1 H2 H6); intro H8;
+            rewrite H5 in H8; elim (Rlt_irrefl y H8)
+            | elim H6; intro H7;
+              [ right; symmetry  in |- *; assumption | left; assumption ] ]
+          | elim (Rlt_irrefl x (Rle_lt_trans x y x H3 H5)) ] ].
+Qed.
+
+Lemma cos_incr_0 :
+  forall x y:R,
+    PI <= x ->
+    x <= 2 * PI -> PI <= y -> y <= 2 * PI -> cos x <= cos y -> x <= y.
+Proof.
+  intros; case (Rtotal_order (cos x) (cos y)); intro H4;
+    [ left; apply (cos_increasing_0 x y H H0 H1 H2 H4)
+      | elim H4; intro H5;
+        [ case (Rtotal_order x y); intro H6;
+          [ left; assumption
+            | elim H6; intro H7;
+              [ right; assumption
+                | generalize (cos_increasing_1 y x H1 H2 H H0 H7); intro H8;
+                  rewrite H5 in H8; elim (Rlt_irrefl (cos y) H8) ] ]
+          | elim (Rlt_irrefl (cos x) (Rle_lt_trans (cos x) (cos y) (cos x) H3 H5)) ] ].
+Qed.
+
+Lemma cos_incr_1 :
+  forall x y:R,
+    PI <= x ->
+    x <= 2 * PI -> PI <= y -> y <= 2 * PI -> x <= y -> cos x <= cos y.
+Proof.
+  intros; case (Rtotal_order x y); intro H4;
+    [ left; apply (cos_increasing_1 x y H H0 H1 H2 H4)
+      | elim H4; intro H5;
+        [ case (Rtotal_order (cos x) (cos y)); intro H6;
+          [ left; assumption
+            | elim H6; intro H7;
+              [ right; assumption
+                | generalize (cos_increasing_0 y x H1 H2 H H0 H7); intro H8;
+                  rewrite H5 in H8; elim (Rlt_irrefl y H8) ] ]
+          | elim (Rlt_irrefl x (Rle_lt_trans x y x H3 H5)) ] ].
+Qed.
+
+Lemma cos_decr_0 :
+  forall x y:R,
+    0 <= x -> x <= PI -> 0 <= y -> y <= PI -> cos x <= cos y -> y <= x.
+Proof.
+  intros; case (Rtotal_order (cos x) (cos y)); intro H4;
+    [ left; apply (cos_decreasing_0 x y H H0 H1 H2 H4)
+      | elim H4; intro H5;
+        [ case (Rtotal_order x y); intro H6;
+          [ generalize (cos_decreasing_1 x y H H0 H1 H2 H6); intro H8;
+            rewrite H5 in H8; elim (Rlt_irrefl (cos y) H8)
+            | elim H6; intro H7;
+              [ right; symmetry  in |- *; assumption | left; assumption ] ]
+          | elim (Rlt_irrefl (cos x) (Rle_lt_trans (cos x) (cos y) (cos x) H3 H5)) ] ].
+Qed.
+
+Lemma cos_decr_1 :
+  forall x y:R,
+    0 <= x -> x <= PI -> 0 <= y -> y <= PI -> x <= y -> cos y <= cos x.
+Proof.
+  intros; case (Rtotal_order x y); intro H4;
+    [ left; apply (cos_decreasing_1 x y H H0 H1 H2 H4)
+      | elim H4; intro H5;
+        [ case (Rtotal_order (cos x) (cos y)); intro H6;
+          [ generalize (cos_decreasing_0 x y H H0 H1 H2 H6); intro H8;
+            rewrite H5 in H8; elim (Rlt_irrefl y H8)
+            | elim H6; intro H7;
+              [ right; symmetry  in |- *; assumption | left; assumption ] ]
+          | elim (Rlt_irrefl x (Rle_lt_trans x y x H3 H5)) ] ].
+Qed.
+
+Lemma tan_incr_0 :
+  forall x y:R,
+    - (PI / 4) <= x ->
+    x <= PI / 4 -> - (PI / 4) <= y -> y <= PI / 4 -> tan x <= tan y -> x <= y.
+Proof.
+  intros; case (Rtotal_order (tan x) (tan y)); intro H4;
+    [ left; apply (tan_increasing_0 x y H H0 H1 H2 H4)
+      | elim H4; intro H5;
+        [ case (Rtotal_order x y); intro H6;
+          [ left; assumption
+            | elim H6; intro H7;
+              [ right; assumption
+                | generalize (tan_increasing_1 y x H1 H2 H H0 H7); intro H8;
+                  rewrite H5 in H8; elim (Rlt_irrefl (tan y) H8) ] ]
+          | elim (Rlt_irrefl (tan x) (Rle_lt_trans (tan x) (tan y) (tan x) H3 H5)) ] ].
+Qed.
+
+Lemma tan_incr_1 :
+  forall x y:R,
+    - (PI / 4) <= x ->
+    x <= PI / 4 -> - (PI / 4) <= y -> y <= PI / 4 -> x <= y -> tan x <= tan y.
+Proof.
+  intros; case (Rtotal_order x y); intro H4;
+    [ left; apply (tan_increasing_1 x y H H0 H1 H2 H4)
+      | elim H4; intro H5;
+        [ case (Rtotal_order (tan x) (tan y)); intro H6;
+          [ left; assumption
+            | elim H6; intro H7;
+              [ right; assumption
+                | generalize (tan_increasing_0 y x H1 H2 H H0 H7); intro H8;
+                  rewrite H5 in H8; elim (Rlt_irrefl y H8) ] ]
+          | elim (Rlt_irrefl x (Rle_lt_trans x y x H3 H5)) ] ].
+Qed.
+
+(**********)
+Lemma sin_eq_0_1 : forall x:R, (exists k : Z, x = IZR k * PI) -> sin x = 0.
+Proof.
+  intros.
+  elim H; intros.
+  apply (Zcase_sign x0).
+  intro.
+  rewrite H1 in H0.
+  simpl in H0.
+  rewrite H0; rewrite Rmult_0_l; apply sin_0.
+  intro.
+  cut (0 <= x0)%Z.
+  intro.
+  elim (IZN x0 H2); intros.
+  rewrite H3 in H0.
+  rewrite <- INR_IZR_INZ in H0.
+  rewrite H0.
+  elim (even_odd_cor x1); intros.
+  elim H4; intro.
+  rewrite H5.
+  rewrite mult_INR.
+  simpl in |- *.
+  rewrite <- (Rplus_0_l (2 * INR x2 * PI)).
+  rewrite sin_period.
+  apply sin_0.
+  rewrite H5.
+  rewrite S_INR; rewrite mult_INR.
+  simpl in |- *.
+  rewrite Rmult_plus_distr_r.
+  rewrite Rmult_1_l; rewrite sin_plus.
+  rewrite sin_PI.
+  rewrite Rmult_0_r.
+  rewrite <- (Rplus_0_l (2 * INR x2 * PI)).
+  rewrite sin_period.
+  rewrite sin_0; ring.
+  apply le_IZR.
+  left; apply IZR_lt.
+  assert (H2 := Z.gt_lt_iff).
+  elim (H2 x0 0%Z); intros.
+  apply H3; assumption.
+  intro.
+  rewrite H0.
+  replace (sin (IZR x0 * PI)) with (- sin (- IZR x0 * PI)).
+  cut (0 <= - x0)%Z.
+  intro.
+  rewrite <- Ropp_Ropp_IZR.
+  elim (IZN (- x0) H2); intros.
+  rewrite H3.
+  rewrite <- INR_IZR_INZ.
+  elim (even_odd_cor x1); intros.
+  elim H4; intro.
+  rewrite H5.
+  rewrite mult_INR.
+  simpl in |- *.
+  rewrite <- (Rplus_0_l (2 * INR x2 * PI)).
+  rewrite sin_period.
+  rewrite sin_0; ring.
+  rewrite H5.
+  rewrite S_INR; rewrite mult_INR.
+  simpl in |- *.
+  rewrite Rmult_plus_distr_r.
+  rewrite Rmult_1_l; rewrite sin_plus.
+  rewrite sin_PI.
+  rewrite Rmult_0_r.
+  rewrite <- (Rplus_0_l (2 * INR x2 * PI)).
+  rewrite sin_period.
+  rewrite sin_0; ring.
+  apply le_IZR.
+  apply Rplus_le_reg_l with (IZR x0).
+  rewrite Rplus_0_r.
+  rewrite Ropp_Ropp_IZR.
+  rewrite Rplus_opp_r.
+  left; replace 0 with (IZR 0); [ apply IZR_lt | reflexivity ].
+  assumption.
+  rewrite <- sin_neg.
+  rewrite Ropp_mult_distr_l_reverse.
+  rewrite Ropp_involutive.
+  reflexivity.
+Qed.
+
+Lemma sin_eq_0_0 (x:R) : sin x = 0 ->  exists k : Z, x = IZR k * PI.
+Proof.
+  intros Hx.
+  destruct (euclidian_division x PI PI_neq0) as (q & r & EQ & Hr & Hr').
+  exists q.
+  rewrite <- (Rplus_0_r (_*_)). subst. apply Rplus_eq_compat_l.
+  rewrite sin_plus in Hx.
+  assert (H : sin (IZR q * PI) = 0) by (apply sin_eq_0_1; now exists q).
+  rewrite H, Rmult_0_l, Rplus_0_l in Hx.
+  destruct (Rmult_integral _ _ Hx) as [H'|H'].
+  - exfalso.
+    generalize (sin2_cos2 (IZR q * PI)).
+    rewrite H, H', Rsqr_0, Rplus_0_l.
+    intros; now apply R1_neq_R0.
+  - rewrite Rabs_right in Hr'; [|left; apply PI_RGT_0].
+    destruct Hr as [Hr | ->]; trivial.
+    exfalso.
+    generalize (sin_gt_0 r Hr Hr'). rewrite H'. apply Rlt_irrefl.
+Qed.
+
+Lemma cos_eq_0_0 (x:R) :
+  cos x = 0 ->  exists k : Z, x = IZR k * PI + PI / 2.
+Proof.
+  rewrite cos_sin. intros Hx.
+  destruct (sin_eq_0_0 (PI/2 + x) Hx) as (k,Hk). clear Hx.
+  exists (k-1)%Z. rewrite <- Z_R_minus; simpl.
+  symmetry in Hk. field_simplify [Hk]. field.
+Qed.
+
+Lemma cos_eq_0_1 (x:R) :
+  (exists k : Z, x = IZR k * PI + PI / 2) -> cos x = 0.
+Proof.
+  rewrite cos_sin. intros (k,->).
+  replace (_ + _) with (IZR k * PI + PI) by field.
+  rewrite neg_sin, <- Ropp_0. apply Ropp_eq_compat.
+  apply sin_eq_0_1. now exists k.
+Qed.
+
+Lemma sin_eq_O_2PI_0 (x:R) :
+  0 <= x -> x <= 2 * PI -> sin x = 0 ->
+  x = 0 \/ x = PI \/ x = 2 * PI.
+Proof.
+  intros Lo Hi Hx. destruct (sin_eq_0_0 x Hx) as (k,Hk). clear Hx.
+  destruct (Rtotal_order PI x) as [Hx|[Hx|Hx]].
+  - right; right.
+    clear Lo. subst.
+    f_equal. change 2 with (IZR (- (-2))). f_equal.
+    apply Z.add_move_0_l.
+    apply one_IZR_lt1.
+    rewrite plus_IZR; simpl.
+    split.
+    + replace (-1) with (-2 + 1) by ring.
+      apply Rplus_lt_compat_l.
+      apply Rmult_lt_reg_r with PI; [apply PI_RGT_0|].
+      now rewrite Rmult_1_l.
+    + apply Rle_lt_trans with 0; [|apply Rlt_0_1].
+      replace 0 with (-2 + 2) by ring.
+      apply Rplus_le_compat_l.
+      apply Rmult_le_reg_r with PI; [apply PI_RGT_0|].
+      trivial.
+  - right; left; auto.
+  - left.
+    clear Hi. subst.
+    replace 0 with (IZR 0 * PI) by (simpl; ring). f_equal. f_equal.
+    apply one_IZR_lt1.
+    split.
+    + apply Rlt_le_trans with 0;
+       [rewrite <- Ropp_0; apply Ropp_gt_lt_contravar, Rlt_0_1 | ].
+      apply Rmult_le_reg_r with PI; [apply PI_RGT_0|].
+      now rewrite Rmult_0_l.
+    + apply Rmult_lt_reg_r with PI; [apply PI_RGT_0|].
+      now rewrite Rmult_1_l.
+Qed.
+
+Lemma sin_eq_O_2PI_1 (x:R) :
+  0 <= x -> x <= 2 * PI ->
+  x = 0 \/ x = PI \/ x = 2 * PI -> sin x = 0.
+Proof.
+  intros _ _ [ -> |[ -> | -> ]].
+  - now rewrite sin_0.
+  - now rewrite sin_PI.
+  - now rewrite sin_2PI.
+Qed.
+
+Lemma cos_eq_0_2PI_0 (x:R) :
+  0 <= x -> x <= 2 * PI -> cos x = 0 ->
+  x = PI / 2 \/ x = 3 * (PI / 2).
+Proof.
+  intros Lo Hi Hx.
+  destruct (Rtotal_order x (3 * (PI / 2))) as [LT|[EQ|GT]].
+  - rewrite cos_sin in Hx.
+    assert (Lo' : 0 <= PI / 2 + x).
+    { apply Rplus_le_le_0_compat. apply Rlt_le, PI2_RGT_0. trivial. }
+    assert (Hi' : PI / 2 + x <= 2 * PI).
+    { apply Rlt_le.
+      replace (2 * PI) with (PI / 2 + 3 * (PI / 2)) by field.
+      now apply Rplus_lt_compat_l. }
+    destruct (sin_eq_O_2PI_0 (PI / 2 + x) Lo' Hi' Hx) as [H|[H|H]].
+    + exfalso.
+      apply (Rplus_le_compat_l (PI/2)) in Lo.
+      rewrite Rplus_0_r, H in Lo.
+      apply (Rlt_irrefl 0 (Rlt_le_trans 0 (PI / 2) 0 PI2_RGT_0 Lo)).
+    + left.
+      apply (Rplus_eq_compat_l (-(PI/2))) in H.
+      ring_simplify in H. rewrite H. field.
+    + right.
+      apply (Rplus_eq_compat_l (-(PI/2))) in H.
+      ring_simplify in H. rewrite H. field.
+  - now right.
+  - exfalso.
+    destruct (cos_eq_0_0 x Hx) as (k,Hk). clear Hx Lo.
+    subst.
+    assert (LT : (k < 2)%Z).
+    { apply lt_IZR. simpl.
+      apply (Rmult_lt_reg_r PI); [apply PI_RGT_0|].
+      apply Rlt_le_trans with (IZR k * PI + PI/2); trivial.
+      rewrite <- (Rplus_0_r (IZR k * PI)) at 1.
+      apply Rplus_lt_compat_l. apply PI2_RGT_0. }
+    assert (GT' : (1 < k)%Z).
+    { apply lt_IZR. simpl.
+      apply (Rmult_lt_reg_r PI); [apply PI_RGT_0|rewrite Rmult_1_l].
+      replace (3*(PI/2)) with (PI/2 + PI) in GT by field.
+      rewrite Rplus_comm in GT.
+      now apply Rplus_lt_reg_r in GT. }
+    omega.
+Qed.
+
+Lemma cos_eq_0_2PI_1 (x:R) :
+  0 <= x -> x <= 2 * PI ->
+  x = PI / 2 \/ x = 3 * (PI / 2) -> cos x = 0.
+Proof.
+ intros Lo Hi [ -> | -> ].
+ - now rewrite cos_PI2.
+ - now rewrite cos_3PI2.
+Qed.
diff --git a/theories/Reals/Rtrigo_alt.v b/theories/Reals/Rtrigo_alt.v
index de984415..23b8e847 100644
--- a/theories/Reals/Rtrigo_alt.v
+++ b/theories/Reals/Rtrigo_alt.v
@@ -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-2012     *)
 (*   \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.
 Require Import Rtrigo_def.
-Open Local Scope R_scope.
+Local Open Scope R_scope.
 
 (***************************************************************)
 (** Using series definitions of cos and sin                    *)
@@ -29,7 +27,8 @@ Definition sin_approx (a:R) (n:nat) : R := sum_f_R0 (sin_term a) n.
 Definition cos_approx (a:R) (n:nat) : R := sum_f_R0 (cos_term a) n.
 
 (**********)
-Lemma PI_4 : PI <= 4.
+(*
+Lemma Alt_PI_4 : Alt_PI <= 4.
 Proof.
   assert (H0 := PI_ineq 0).
   elim H0; clear H0; intros _ H0.
@@ -39,20 +38,20 @@ Proof.
   apply Rinv_0_lt_compat; prove_sup0.
   rewrite <- Rinv_l_sym; [ rewrite Rmult_comm; assumption | discrR ].
 Qed.
-
+*)
 (**********)
-Theorem sin_bound :
+Theorem pre_sin_bound :
   forall (a:R) (n:nat),
     0 <= a ->
-    a <= PI -> sin_approx a (2 * n + 1) <= sin a <= sin_approx a (2 * (n + 1)).
+    a <= 4 -> sin_approx a (2 * n + 1) <= sin a <= sin_approx a (2 * (n + 1)).
 Proof.
   intros; case (Req_dec a 0); intro Hyp_a.
-  rewrite Hyp_a; rewrite sin_0; split; right; unfold sin_approx in |- *;
-    apply sum_eq_R0 || (symmetry  in |- *; apply sum_eq_R0);
-      intros; unfold sin_term in |- *; rewrite pow_add;
-        simpl in |- *; unfold Rdiv in |- *; rewrite Rmult_0_l;
+  rewrite Hyp_a; rewrite sin_0; split; right; unfold sin_approx;
+    apply sum_eq_R0 || (symmetry ; apply sum_eq_R0);
+      intros; unfold sin_term; rewrite pow_add;
+        simpl; unfold Rdiv; rewrite Rmult_0_l;
           ring.
-  unfold sin_approx in |- *; cut (0 < a).
+  unfold sin_approx; cut (0 < a).
   intro Hyp_a_pos.
   rewrite (decomp_sum (sin_term a) (2 * n + 1)).
   rewrite (decomp_sum (sin_term a) (2 * (n + 1))).
@@ -77,22 +76,22 @@ Proof.
       - sum_f_R0 (tg_alt Un) (S (2 * n))).
   intro; apply H2.
   apply alternated_series_ineq.
-  unfold Un_decreasing, Un in |- *; intro;
+  unfold Un_decreasing, Un; intro;
     cut ((2 * S (S n0) + 1)%nat = S (S (2 * S n0 + 1))).
   intro; rewrite H3.
   replace (a ^ S (S (2 * S n0 + 1))) with (a ^ (2 * S n0 + 1) * (a * a)).
-  unfold Rdiv in |- *; rewrite Rmult_assoc; apply Rmult_le_compat_l.
+  unfold Rdiv; rewrite Rmult_assoc; apply Rmult_le_compat_l.
   left; apply pow_lt; assumption.
   apply Rmult_le_reg_l with (INR (fact (S (S (2 * S n0 + 1))))).
-  rewrite <- H3; apply lt_INR_0; apply neq_O_lt; red in |- *; intro;
-    assert (H5 := sym_eq H4); elim (fact_neq_0 _ H5).
+  rewrite <- H3; apply lt_INR_0; apply neq_O_lt; red; intro;
+    assert (H5 := eq_sym H4); elim (fact_neq_0 _ H5).
   rewrite <- H3; rewrite (Rmult_comm (INR (fact (2 * S (S n0) + 1))));
     rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
   rewrite Rmult_1_r; rewrite H3; do 2 rewrite fact_simpl; do 2 rewrite mult_INR;
     repeat rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
   rewrite Rmult_1_r.
   do 2 rewrite S_INR; rewrite plus_INR; rewrite mult_INR; repeat rewrite S_INR;
-    simpl in |- *;
+    simpl;
       replace
       (((0 + 1 + 1) * (INR n0 + 1) + (0 + 1) + 1 + 1) *
         ((0 + 1 + 1) * (INR n0 + 1) + (0 + 1) + 1)) with
@@ -102,12 +101,12 @@ Proof.
   replace 16 with (Rsqr 4); [ idtac | ring_Rsqr ].
   replace (a * a) with (Rsqr a); [ idtac | reflexivity ].
   apply Rsqr_incr_1.
-  apply Rle_trans with PI; [ assumption | apply PI_4 ].
+  assumption.
   assumption.
   left; prove_sup0.
   rewrite <- (Rplus_0_r 16); replace 20 with (16 + 4);
     [ apply Rplus_le_compat_l; left; prove_sup0 | ring ].
-  rewrite <- (Rplus_comm 20); pattern 20 at 1 in |- *; rewrite <- Rplus_0_r;
+  rewrite <- (Rplus_comm 20); pattern 20 at 1; rewrite <- Rplus_0_r;
     apply Rplus_le_compat_l.
   apply Rplus_le_le_0_compat.
   repeat apply Rmult_le_pos.
@@ -120,14 +119,14 @@ Proof.
   replace 0 with (INR 0); [ apply le_INR; apply le_O_n | reflexivity ].
   apply INR_fact_neq_0.
   apply INR_fact_neq_0.
-  simpl in |- *; ring.
+  simpl; ring.
   ring.
-  assert (H3 := cv_speed_pow_fact a); unfold Un in |- *; unfold Un_cv in H3;
-    unfold R_dist in H3; unfold Un_cv in |- *; unfold R_dist in |- *;
+  assert (H3 := cv_speed_pow_fact a); unfold Un; unfold Un_cv in H3;
+    unfold R_dist in H3; unfold Un_cv; unfold R_dist;
       intros; elim (H3 eps H4); intros N H5.
   exists N; intros; apply H5.
   replace (2 * S n0 + 1)%nat with (S (2 * S n0)).
-  unfold ge in |- *; apply le_trans with (2 * S n0)%nat.
+  unfold ge; apply le_trans with (2 * S n0)%nat.
   apply le_trans with (2 * S N)%nat.
   apply le_trans with (2 * N)%nat.
   apply le_n_2n.
@@ -138,49 +137,49 @@ Proof.
   assert (X := exist_sin (Rsqr a)); elim X; intros.
   cut (x = sin a / a).
   intro; rewrite H3 in p; unfold sin_in in p; unfold infinite_sum in p;
-    unfold R_dist in p; unfold Un_cv in |- *; unfold R_dist in |- *;
+    unfold R_dist in p; unfold Un_cv; unfold R_dist;
       intros.
   cut (0 < eps / Rabs a).
   intro; elim (p _ H5); intros N H6.
   exists N; intros.
   replace (sum_f_R0 (tg_alt Un) n0) with
   (a * (1 - sum_f_R0 (fun i:nat => sin_n i * Rsqr a ^ i) (S n0))).
-  unfold Rminus in |- *; rewrite Rmult_plus_distr_l; rewrite Rmult_1_r;
+  unfold Rminus; rewrite Rmult_plus_distr_l; rewrite Rmult_1_r;
     rewrite Ropp_plus_distr; rewrite Ropp_involutive;
       repeat rewrite Rplus_assoc; rewrite (Rplus_comm a);
         rewrite (Rplus_comm (- a)); repeat rewrite Rplus_assoc;
           rewrite Rplus_opp_l; rewrite Rplus_0_r; apply Rmult_lt_reg_l with (/ Rabs a).
   apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption.
-  pattern (/ Rabs a) at 1 in |- *; rewrite <- (Rabs_Rinv a Hyp_a).
+  pattern (/ Rabs a) at 1; rewrite <- (Rabs_Rinv a Hyp_a).
   rewrite <- Rabs_mult; rewrite Rmult_plus_distr_l; rewrite <- Rmult_assoc;
     rewrite <- Rinv_l_sym; [ rewrite Rmult_1_l | assumption ];
       rewrite (Rmult_comm (/ a)); rewrite (Rmult_comm (/ Rabs a));
         rewrite <- Rabs_Ropp; rewrite Ropp_plus_distr; rewrite Ropp_involutive;
-          unfold Rminus, Rdiv in H6; apply H6; unfold ge in |- *;
+          unfold Rminus, Rdiv in H6; apply H6; unfold ge;
             apply le_trans with n0; [ exact H7 | apply le_n_Sn ].
   rewrite (decomp_sum (fun i:nat => sin_n i * Rsqr a ^ i) (S n0)).
   replace (sin_n 0) with 1.
-  simpl in |- *; rewrite Rmult_1_r; unfold Rminus in |- *;
+  simpl; rewrite Rmult_1_r; unfold Rminus;
     rewrite Ropp_plus_distr; rewrite <- Rplus_assoc; rewrite Rplus_opp_r;
       rewrite Rplus_0_l; rewrite Ropp_mult_distr_r_reverse;
         rewrite <- Ropp_mult_distr_l_reverse; rewrite scal_sum;
           apply sum_eq.
-  intros; unfold sin_n, Un, tg_alt in |- *;
+  intros; unfold sin_n, Un, tg_alt;
     replace ((-1) ^ S i) with (- (-1) ^ i).
   replace (a ^ (2 * S i + 1)) with (Rsqr a * Rsqr a ^ i * a).
-  unfold Rdiv in |- *; ring.
-  rewrite pow_add; rewrite pow_Rsqr; simpl in |- *; ring.
-  simpl in |- *; ring.
-  unfold sin_n in |- *; unfold Rdiv in |- *; simpl in |- *; rewrite Rinv_1;
+  unfold Rdiv; ring.
+  rewrite pow_add; rewrite pow_Rsqr; simpl; ring.
+  simpl; ring.
+  unfold sin_n; unfold Rdiv; simpl; rewrite Rinv_1;
     rewrite Rmult_1_r; reflexivity.
   apply lt_O_Sn.
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+  unfold Rdiv; apply Rmult_lt_0_compat.
   assumption.
   apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption.
-  unfold sin in |- *; case (exist_sin (Rsqr a)).
+  unfold sin; case (exist_sin (Rsqr a)).
   intros; cut (x = x0).
-  intro; rewrite H3; unfold Rdiv in |- *.
-  symmetry  in |- *; apply Rinv_r_simpl_m; assumption.
+  intro; rewrite H3; unfold Rdiv.
+  symmetry ; apply Rinv_r_simpl_m; assumption.
   unfold sin_in in p; unfold sin_in in s; eapply uniqueness_sum.
   apply p.
   apply s.
@@ -189,16 +188,16 @@ Proof.
   split; apply Ropp_le_contravar; assumption.
   replace (- sum_f_R0 (tg_alt Un) (S (2 * n))) with
   (-1 * sum_f_R0 (tg_alt Un) (S (2 * n))); [ rewrite scal_sum | ring ].
-  apply sum_eq; intros; unfold sin_term, Un, tg_alt in |- *;
+  apply sum_eq; intros; unfold sin_term, Un, tg_alt;
     replace ((-1) ^ S i) with (-1 * (-1) ^ i).
-  unfold Rdiv in |- *; ring.
+  unfold Rdiv; ring.
   reflexivity.
   replace (- sum_f_R0 (tg_alt Un) (2 * n)) with
   (-1 * sum_f_R0 (tg_alt Un) (2 * n)); [ rewrite scal_sum | ring ].
   apply sum_eq; intros.
-  unfold sin_term, Un, tg_alt in |- *;
+  unfold sin_term, Un, tg_alt;
     replace ((-1) ^ S i) with (-1 * (-1) ^ i).
-  unfold Rdiv in |- *; ring.
+  unfold Rdiv; ring.
   reflexivity.
   replace (2 * (n + 1))%nat with (S (S (2 * n))).
   reflexivity.
@@ -214,7 +213,7 @@ Proof.
   apply Rplus_le_reg_l with (- a).
   rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l;
     rewrite (Rplus_comm (- a)); apply H3.
-  unfold sin_term in |- *; simpl in |- *; unfold Rdiv in |- *; rewrite Rinv_1;
+  unfold sin_term; simpl; unfold Rdiv; rewrite Rinv_1;
     ring.
   replace (2 * (n + 1))%nat with (S (S (2 * n))).
   apply lt_O_Sn.
@@ -222,27 +221,26 @@ Proof.
   replace (2 * n + 1)%nat with (S (2 * n)).
   apply lt_O_Sn.
   ring.
-  inversion H; [ assumption | elim Hyp_a; symmetry  in |- *; assumption ].
+  inversion H; [ assumption | elim Hyp_a; symmetry ; assumption ].
 Qed.
 
 (**********)
-Lemma cos_bound :
+Lemma pre_cos_bound :
   forall (a:R) (n:nat),
-    - PI / 2 <= a ->
-    a <= PI / 2 ->
+    - 2 <= a -> a <= 2 ->
     cos_approx a (2 * n + 1) <= cos a <= cos_approx a (2 * (n + 1)).
 Proof.
   cut
     ((forall (a:R) (n:nat),
       0 <= a ->
-      a <= PI / 2 ->
+      a <= 2 ->
       cos_approx a (2 * n + 1) <= cos a <= cos_approx a (2 * (n + 1))) ->
     forall (a:R) (n:nat),
-      - PI / 2 <= a ->
-      a <= PI / 2 ->
+      - 2 <= a ->
+      a <= 2 ->
       cos_approx a (2 * n + 1) <= cos a <= cos_approx a (2 * (n + 1))).
   intros H a n; apply H.
-  intros; unfold cos_approx in |- *.
+  intros; unfold cos_approx.
   rewrite (decomp_sum (cos_term a0) (2 * n0 + 1)).
   rewrite (decomp_sum (cos_term a0) (2 * (n0 + 1))).
   replace (cos_term a0 0) with 1.
@@ -268,21 +266,21 @@ Proof.
       - sum_f_R0 (tg_alt Un) (S (2 * n0))).
   intro; apply H3.
   apply alternated_series_ineq.
-  unfold Un_decreasing in |- *; intro; unfold Un in |- *.
+  unfold Un_decreasing; intro; unfold Un.
   cut ((2 * S (S n1))%nat = S (S (2 * S n1))).
   intro; rewrite H4;
     replace (a0 ^ S (S (2 * S n1))) with (a0 ^ (2 * S n1) * (a0 * a0)).
-  unfold Rdiv in |- *; rewrite Rmult_assoc; apply Rmult_le_compat_l.
+  unfold Rdiv; rewrite Rmult_assoc; apply Rmult_le_compat_l.
   apply pow_le; assumption.
   apply Rmult_le_reg_l with (INR (fact (S (S (2 * S n1))))).
-  rewrite <- H4; apply lt_INR_0; apply neq_O_lt; red in |- *; intro;
-    assert (H6 := sym_eq H5); elim (fact_neq_0 _ H6).
+  rewrite <- H4; apply lt_INR_0; apply neq_O_lt; red; intro;
+    assert (H6 := eq_sym H5); elim (fact_neq_0 _ H6).
   rewrite <- H4; rewrite (Rmult_comm (INR (fact (2 * S (S n1)))));
     rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
   rewrite Rmult_1_r; rewrite H4; do 2 rewrite fact_simpl; do 2 rewrite mult_INR;
     repeat rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
   rewrite Rmult_1_r; do 2 rewrite S_INR; rewrite mult_INR; repeat rewrite S_INR;
-    simpl in |- *;
+    simpl;
       replace
       (((0 + 1 + 1) * (INR n1 + 1) + 1 + 1) * ((0 + 1 + 1) * (INR n1 + 1) + 1))
     with (4 * INR n1 * INR n1 + 14 * INR n1 + 12); [ idtac | ring ].
@@ -291,18 +289,13 @@ Proof.
   replace 4 with (Rsqr 2); [ idtac | ring_Rsqr ].
   replace (a0 * a0) with (Rsqr a0); [ idtac | reflexivity ].
   apply Rsqr_incr_1.
-  apply Rle_trans with (PI / 2).
   assumption.
-  unfold Rdiv in |- *; apply Rmult_le_reg_l with 2.
-  prove_sup0.
-  rewrite <- Rmult_assoc; rewrite Rinv_r_simpl_m.
-  replace 4 with 4; [ apply PI_4 | ring ].
   discrR.
   assumption.
   left; prove_sup0.
-  pattern 4 at 1 in |- *; rewrite <- Rplus_0_r; replace 12 with (4 + 8);
+  pattern 4 at 1; rewrite <- Rplus_0_r; replace 12 with (4 + 8);
     [ apply Rplus_le_compat_l; left; prove_sup0 | ring ].
-  rewrite <- (Rplus_comm 12); pattern 12 at 1 in |- *; rewrite <- Rplus_0_r;
+  rewrite <- (Rplus_comm 12); pattern 12 at 1; rewrite <- Rplus_0_r;
     apply Rplus_le_compat_l.
   apply Rplus_le_le_0_compat.
   repeat apply Rmult_le_pos.
@@ -315,12 +308,12 @@ Proof.
   replace 0 with (INR 0); [ apply le_INR; apply le_O_n | reflexivity ].
   apply INR_fact_neq_0.
   apply INR_fact_neq_0.
-  simpl in |- *; ring.
+  simpl; ring.
   ring.
-  assert (H4 := cv_speed_pow_fact a0); unfold Un in |- *; unfold Un_cv in H4;
-    unfold R_dist in H4; unfold Un_cv in |- *; unfold R_dist in |- *;
+  assert (H4 := cv_speed_pow_fact a0); unfold Un; unfold Un_cv in H4;
+    unfold R_dist in H4; unfold Un_cv; unfold R_dist;
       intros; elim (H4 eps H5); intros N H6; exists N; intros.
-  apply H6; unfold ge in |- *; apply le_trans with (2 * S N)%nat.
+  apply H6; unfold ge; apply le_trans with (2 * S N)%nat.
   apply le_trans with (2 * N)%nat.
   apply le_n_2n.
   apply (fun m n p:nat => mult_le_compat_l p n m); apply le_n_Sn.
@@ -328,40 +321,40 @@ Proof.
   assert (X := exist_cos (Rsqr a0)); elim X; intros.
   cut (x = cos a0).
   intro; rewrite H4 in p; unfold cos_in in p; unfold infinite_sum in p;
-    unfold R_dist in p; unfold Un_cv in |- *; unfold R_dist in |- *;
+    unfold R_dist in p; unfold Un_cv; unfold R_dist;
       intros.
   elim (p _ H5); intros N H6.
   exists N; intros.
   replace (sum_f_R0 (tg_alt Un) n1) with
   (1 - sum_f_R0 (fun i:nat => cos_n i * Rsqr a0 ^ i) (S n1)).
-  unfold Rminus in |- *; rewrite Ropp_plus_distr; rewrite Ropp_involutive;
+  unfold Rminus; rewrite Ropp_plus_distr; rewrite Ropp_involutive;
     repeat rewrite Rplus_assoc; rewrite (Rplus_comm 1);
       rewrite (Rplus_comm (-1)); repeat rewrite Rplus_assoc;
         rewrite Rplus_opp_l; rewrite Rplus_0_r; rewrite <- Rabs_Ropp;
           rewrite Ropp_plus_distr; rewrite Ropp_involutive;
             unfold Rminus in H6; apply H6.
-  unfold ge in |- *; apply le_trans with n1.
+  unfold ge; apply le_trans with n1.
   exact H7.
   apply le_n_Sn.
   rewrite (decomp_sum (fun i:nat => cos_n i * Rsqr a0 ^ i) (S n1)).
   replace (cos_n 0) with 1.
-  simpl in |- *; rewrite Rmult_1_r; unfold Rminus in |- *;
+  simpl; rewrite Rmult_1_r; unfold Rminus;
     rewrite Ropp_plus_distr; rewrite <- Rplus_assoc; rewrite Rplus_opp_r;
       rewrite Rplus_0_l;
         replace (- sum_f_R0 (fun i:nat => cos_n (S i) * (Rsqr a0 * Rsqr a0 ^ i)) n1)
     with
       (-1 * sum_f_R0 (fun i:nat => cos_n (S i) * (Rsqr a0 * Rsqr a0 ^ i)) n1);
       [ idtac | ring ]; rewrite scal_sum; apply sum_eq;
-        intros; unfold cos_n, Un, tg_alt in |- *.
+        intros; unfold cos_n, Un, tg_alt.
   replace ((-1) ^ S i) with (- (-1) ^ i).
   replace (a0 ^ (2 * S i)) with (Rsqr a0 * Rsqr a0 ^ i).
-  unfold Rdiv in |- *; ring.
+  unfold Rdiv; ring.
   rewrite pow_Rsqr; reflexivity.
-  simpl in |- *; ring.
-  unfold cos_n in |- *; unfold Rdiv in |- *; simpl in |- *; rewrite Rinv_1;
+  simpl; ring.
+  unfold cos_n; unfold Rdiv; simpl; rewrite Rinv_1;
     rewrite Rmult_1_r; reflexivity.
   apply lt_O_Sn.
-  unfold cos in |- *; case (exist_cos (Rsqr a0)); intros; unfold cos_in in p;
+  unfold cos; case (exist_cos (Rsqr a0)); intros; unfold cos_in in p;
     unfold cos_in in c; eapply uniqueness_sum.
   apply p.
   apply c.
@@ -370,15 +363,15 @@ Proof.
   split; apply Ropp_le_contravar; assumption.
   replace (- sum_f_R0 (tg_alt Un) (S (2 * n0))) with
   (-1 * sum_f_R0 (tg_alt Un) (S (2 * n0))); [ rewrite scal_sum | ring ].
-  apply sum_eq; intros; unfold cos_term, Un, tg_alt in |- *;
+  apply sum_eq; intros; unfold cos_term, Un, tg_alt;
     replace ((-1) ^ S i) with (-1 * (-1) ^ i).
-  unfold Rdiv in |- *; ring.
+  unfold Rdiv; ring.
   reflexivity.
   replace (- sum_f_R0 (tg_alt Un) (2 * n0)) with
   (-1 * sum_f_R0 (tg_alt Un) (2 * n0)); [ rewrite scal_sum | ring ];
-  apply sum_eq; intros; unfold cos_term, Un, tg_alt in |- *;
+  apply sum_eq; intros; unfold cos_term, Un, tg_alt;
     replace ((-1) ^ S i) with (-1 * (-1) ^ i).
-  unfold Rdiv in |- *; ring.
+  unfold Rdiv; ring.
   reflexivity.
   replace (2 * (n0 + 1))%nat with (S (S (2 * n0))).
   reflexivity.
@@ -393,7 +386,7 @@ Proof.
   apply Rplus_le_reg_l with (-1).
   rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l;
     rewrite (Rplus_comm (-1)); apply H4.
-  unfold cos_term in |- *; simpl in |- *; unfold Rdiv in |- *; rewrite Rinv_1;
+  unfold cos_term; simpl; unfold Rdiv; rewrite Rinv_1;
     ring.
   replace (2 * (n0 + 1))%nat with (S (S (2 * n0))).
   apply lt_O_Sn.
@@ -409,11 +402,9 @@ Proof.
   intro; cut (forall (x:R) (n:nat), cos_approx x n = cos_approx (- x) n).
   intro; rewrite H3; rewrite (H3 a (2 * (n + 1))%nat); rewrite cos_sym; apply H.
   left; assumption.
-  rewrite <- (Ropp_involutive (PI / 2)); apply Ropp_le_contravar;
-    unfold Rdiv in |- *; unfold Rdiv in H0; rewrite <- Ropp_mult_distr_l_reverse;
-      exact H0.
-  intros; unfold cos_approx in |- *; apply sum_eq; intros;
-    unfold cos_term in |- *; do 2 rewrite pow_Rsqr; rewrite Rsqr_neg;
-      unfold Rdiv in |- *; reflexivity.
+  rewrite <- (Ropp_involutive 2); apply Ropp_le_contravar; exact H0.
+  intros; unfold cos_approx; apply sum_eq; intros;
+    unfold cos_term; do 2 rewrite pow_Rsqr; rewrite Rsqr_neg;
+      unfold Rdiv; reflexivity.
   apply Ropp_0_gt_lt_contravar; assumption.
 Qed.
diff --git a/theories/Reals/Rtrigo_calc.v b/theories/Reals/Rtrigo_calc.v
index e5263f9c..a1a3b007 100644
--- a/theories/Reals/Rtrigo_calc.v
+++ b/theories/Reals/Rtrigo_calc.v
@@ -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-2012     *)
 (*   \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.
-Require Import Rtrigo.
+Require Import Rtrigo1.
 Require Import R_sqrt.
-Open Local Scope R_scope.
+Local Open Scope R_scope.
 
 Lemma tan_PI : tan PI = 0.
 Proof.
-  unfold tan in |- *; rewrite sin_PI; rewrite cos_PI; unfold Rdiv in |- *;
+  unfold tan; rewrite sin_PI; rewrite cos_PI; unfold Rdiv;
     apply Rmult_0_l.
 Qed.
 
@@ -25,12 +23,12 @@ Lemma sin_3PI2 : sin (3 * (PI / 2)) = -1.
 Proof.
   replace (3 * (PI / 2)) with (PI + PI / 2).
   rewrite sin_plus; rewrite sin_PI; rewrite cos_PI; rewrite sin_PI2; ring.
-  pattern PI at 1 in |- *; rewrite (double_var PI); ring.
+  pattern PI at 1; rewrite (double_var PI); ring.
 Qed.
 
 Lemma tan_2PI : tan (2 * PI) = 0.
 Proof.
-  unfold tan in |- *; rewrite sin_2PI; unfold Rdiv in |- *; apply Rmult_0_l.
+  unfold tan; rewrite sin_2PI; unfold Rdiv; apply Rmult_0_l.
 Qed.
 
 Lemma sin_cos_PI4 : sin (PI / 4) = cos (PI / 4).
@@ -39,9 +37,9 @@ Proof with trivial.
   replace (PI / 2 + PI / 4) with (- (PI / 4) + PI)...
   rewrite neg_sin; rewrite sin_neg; ring...
   cut (PI = PI / 2 + PI / 2); [ intro | apply double_var ]...
-  pattern PI at 2 3 in |- *; rewrite H; pattern PI at 2 3 in |- *; rewrite H...
+  pattern PI at 2 3; rewrite H; pattern PI at 2 3; rewrite H...
   assert (H0 : 2 <> 0);
-    [ discrR | unfold Rdiv in |- *; rewrite Rinv_mult_distr; try ring ]...
+    [ discrR | unfold Rdiv; rewrite Rinv_mult_distr; try ring ]...
 Qed.
 
 Lemma sin_PI3_cos_PI6 : sin (PI / 3) = cos (PI / 6).
@@ -53,10 +51,10 @@ Proof with trivial.
   assert (H2 : 2 <> 0); [ discrR | idtac ]...
   apply Rmult_eq_reg_l with 6...
   rewrite Rmult_minus_distr_l; repeat rewrite (Rmult_comm 6)...
-  unfold Rdiv in |- *; repeat rewrite Rmult_assoc...
+  unfold Rdiv; 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.
@@ -70,23 +68,23 @@ Proof with trivial.
   assert (H2 : 2 <> 0); [ discrR | idtac ]...
   apply Rmult_eq_reg_l with 6...
   rewrite Rmult_minus_distr_l; repeat rewrite (Rmult_comm 6)...
-  unfold Rdiv in |- *; repeat rewrite Rmult_assoc...
+  unfold Rdiv; 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.
 
 Lemma PI6_RGT_0 : 0 < PI / 6.
 Proof.
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+  unfold Rdiv; apply Rmult_lt_0_compat;
     [ apply PI_RGT_0 | apply Rinv_0_lt_compat; prove_sup0 ].
 Qed.
 
 Lemma PI6_RLT_PI2 : PI / 6 < PI / 2.
 Proof.
-  unfold Rdiv in |- *; apply Rmult_lt_compat_l.
+  unfold Rdiv; apply Rmult_lt_compat_l.
   apply PI_RGT_0.
   apply Rinv_lt_contravar; prove_sup.
 Qed.
@@ -99,11 +97,11 @@ Proof with trivial.
   (2 * sin (PI / 6) * cos (PI / 6))...
   rewrite <- sin_2a; replace (2 * (PI / 6)) with (PI / 3)...
   rewrite sin_PI3_cos_PI6...
-  unfold Rdiv in |- *; rewrite Rmult_1_l; rewrite Rmult_assoc;
-    pattern 2 at 2 in |- *; rewrite (Rmult_comm 2); rewrite Rmult_assoc;
+  unfold Rdiv; rewrite Rmult_1_l; rewrite Rmult_assoc;
+    pattern 2 at 2; rewrite (Rmult_comm 2); rewrite Rmult_assoc;
       rewrite <- Rinv_l_sym...
   rewrite Rmult_1_r...
-  unfold Rdiv in |- *; rewrite Rinv_mult_distr...
+  unfold Rdiv; rewrite Rinv_mult_distr...
   rewrite (Rmult_comm (/ 2)); rewrite (Rmult_comm 2);
     repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym...
   rewrite Rmult_1_r...
@@ -121,7 +119,7 @@ Lemma sqrt2_neq_0 : sqrt 2 <> 0.
 Proof.
   assert (Hyp : 0 < 2);
     [ prove_sup0
-      | generalize (Rlt_le 0 2 Hyp); intro H1; red in |- *; intro H2;
+      | generalize (Rlt_le 0 2 Hyp); intro H1; red; intro H2;
         generalize (sqrt_eq_0 2 H1 H2); intro H; absurd (2 = 0);
           [ discrR | assumption ] ].
 Qed.
@@ -139,7 +137,7 @@ Proof.
     [ discrR
       | assert (Hyp : 0 < 3);
         [ prove_sup0
-          | generalize (Rlt_le 0 3 Hyp); intro H1; red in |- *; intro H2;
+          | generalize (Rlt_le 0 3 Hyp); intro H1; red; intro H2;
             generalize (sqrt_eq_0 3 H1 H2); intro H; absurd (3 = 0);
               [ discrR | assumption ] ] ].
 Qed.
@@ -152,7 +150,7 @@ Proof.
         intro H2;
           [ assumption
             | absurd (0 = sqrt 2);
-              [ apply (sym_not_eq (A:=R)); apply sqrt2_neq_0 | assumption ] ] ].
+              [ apply (not_eq_sym (A:=R)); apply sqrt2_neq_0 | assumption ] ] ].
 Qed.
 
 Lemma Rlt_sqrt3_0 : 0 < sqrt 3.
@@ -164,7 +162,7 @@ Proof.
           [ prove_sup0
             | generalize (Rlt_le 0 3 Hyp2); intro H2;
               generalize (lt_INR_0 1 (neq_O_lt 1 H0));
-                unfold INR in |- *; intro H3;
+                unfold INR; intro H3;
                   generalize (Rplus_lt_compat_l 2 0 1 H3);
                     rewrite Rplus_comm; rewrite Rplus_0_l; replace (2 + 1) with 3;
                       [ intro H4; generalize (sqrt_lt_1 2 3 H1 H2 H4); clear H3; intro H3;
@@ -175,7 +173,7 @@ Qed.
 
 Lemma PI4_RGT_0 : 0 < PI / 4.
 Proof.
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+  unfold Rdiv; apply Rmult_lt_0_compat;
     [ apply PI_RGT_0 | apply Rinv_0_lt_compat; prove_sup0 ].
 Qed.
 
@@ -191,17 +189,17 @@ Proof with trivial.
   rewrite Rsqr_div...
   rewrite Rsqr_1; rewrite Rsqr_sqrt...
   assert (H : 2 <> 0); [ discrR | idtac ]...
-  unfold Rsqr in |- *; pattern (cos (PI / 4)) at 1 in |- *;
+  unfold Rsqr; pattern (cos (PI / 4)) at 1;
     rewrite <- sin_cos_PI4;
       replace (sin (PI / 4) * cos (PI / 4)) with
       (1 / 2 * (2 * sin (PI / 4) * cos (PI / 4)))...
   rewrite <- sin_2a; replace (2 * (PI / 4)) with (PI / 2)...
   rewrite sin_PI2...
   apply Rmult_1_r...
-  unfold Rdiv in |- *; rewrite (Rmult_comm 2); rewrite Rinv_mult_distr...
+  unfold Rdiv; rewrite (Rmult_comm 2); rewrite Rinv_mult_distr...
   repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym...
   rewrite Rmult_1_r...
-  unfold Rdiv in |- *; rewrite Rmult_1_l; repeat rewrite <- Rmult_assoc...
+  unfold Rdiv; rewrite Rmult_1_l; repeat rewrite <- Rmult_assoc...
   rewrite <- Rinv_l_sym...
   rewrite Rmult_1_l...
   left; prove_sup...
@@ -215,18 +213,18 @@ Qed.
 
 Lemma tan_PI4 : tan (PI / 4) = 1.
 Proof.
-  unfold tan in |- *; rewrite sin_cos_PI4.
-  unfold Rdiv in |- *; apply Rinv_r.
-  change (cos (PI / 4) <> 0) in |- *; rewrite cos_PI4; apply R1_sqrt2_neq_0.
+  unfold tan; rewrite sin_cos_PI4.
+  unfold Rdiv; apply Rinv_r.
+  change (cos (PI / 4) <> 0); rewrite cos_PI4; apply R1_sqrt2_neq_0.
 Qed.
 
 Lemma cos3PI4 : cos (3 * (PI / 4)) = -1 / sqrt 2.
 Proof with trivial.
   replace (3 * (PI / 4)) with (PI / 2 - - (PI / 4))...
   rewrite cos_shift; rewrite sin_neg; rewrite sin_PI4...
-  unfold Rdiv in |- *; rewrite Ropp_mult_distr_l_reverse...
-  unfold Rminus in |- *; rewrite Ropp_involutive; pattern PI at 1 in |- *;
-    rewrite double_var; unfold Rdiv in |- *; rewrite Rmult_plus_distr_r;
+  unfold Rdiv; rewrite Ropp_mult_distr_l_reverse...
+  unfold Rminus; rewrite Ropp_involutive; pattern PI at 1;
+    rewrite double_var; unfold Rdiv; rewrite Rmult_plus_distr_r;
       repeat rewrite Rmult_assoc; rewrite <- Rinv_mult_distr;
         [ ring | discrR | discrR ]...
 Qed.
@@ -235,8 +233,8 @@ Lemma sin3PI4 : sin (3 * (PI / 4)) = 1 / sqrt 2.
 Proof with trivial.
   replace (3 * (PI / 4)) with (PI / 2 - - (PI / 4))...
   rewrite sin_shift; rewrite cos_neg; rewrite cos_PI4...
-  unfold Rminus in |- *; rewrite Ropp_involutive; pattern PI at 1 in |- *;
-    rewrite double_var; unfold Rdiv in |- *; rewrite Rmult_plus_distr_r;
+  unfold Rminus; rewrite Ropp_involutive; pattern PI at 1;
+    rewrite double_var; unfold Rdiv; rewrite Rmult_plus_distr_r;
       repeat rewrite Rmult_assoc; rewrite <- Rinv_mult_distr;
         [ ring | discrR | discrR ]...
 Qed.
@@ -253,8 +251,8 @@ Proof with trivial.
   assert (H : 2 <> 0); [ discrR | idtac ]...
   assert (H1 : 4 <> 0); [ apply prod_neq_R0 | idtac ]...
   rewrite Rsqr_div...
-  rewrite cos2; unfold Rsqr in |- *; rewrite sin_PI6; rewrite sqrt_def...
-  unfold Rdiv in |- *; rewrite Rmult_1_l; apply Rmult_eq_reg_l with 4...
+  rewrite cos2; unfold Rsqr; rewrite sin_PI6; rewrite sqrt_def...
+  unfold Rdiv; rewrite Rmult_1_l; apply Rmult_eq_reg_l with 4...
   rewrite Rmult_minus_distr_l; rewrite (Rmult_comm 3);
     repeat rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym...
   rewrite Rmult_1_l; rewrite Rmult_1_r...
@@ -267,14 +265,14 @@ Qed.
 
 Lemma tan_PI6 : tan (PI / 6) = 1 / sqrt 3.
 Proof.
-  unfold tan in |- *; rewrite sin_PI6; rewrite cos_PI6; unfold Rdiv in |- *;
+  unfold tan; rewrite sin_PI6; rewrite cos_PI6; unfold Rdiv;
     repeat rewrite Rmult_1_l; rewrite Rinv_mult_distr.
   rewrite Rinv_involutive.
   rewrite (Rmult_comm (/ 2)); rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
   apply Rmult_1_r.
   discrR.
   discrR.
-  red in |- *; intro; assert (H1 := Rlt_sqrt3_0); rewrite H in H1;
+  red; intro; assert (H1 := Rlt_sqrt3_0); rewrite H in H1;
     elim (Rlt_irrefl 0 H1).
   apply Rinv_neq_0_compat; discrR.
 Qed.
@@ -291,7 +289,7 @@ Qed.
 
 Lemma tan_PI3 : tan (PI / 3) = sqrt 3.
 Proof.
-  unfold tan in |- *; rewrite sin_PI3; rewrite cos_PI3; unfold Rdiv in |- *;
+  unfold tan; rewrite sin_PI3; rewrite cos_PI3; unfold Rdiv;
     rewrite Rmult_1_l; rewrite Rinv_involutive.
   rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
   apply Rmult_1_r.
@@ -302,7 +300,7 @@ Qed.
 Lemma sin_2PI3 : sin (2 * (PI / 3)) = sqrt 3 / 2.
 Proof.
   rewrite double; rewrite sin_plus; rewrite sin_PI3; rewrite cos_PI3;
-    unfold Rdiv in |- *; repeat rewrite Rmult_1_l; rewrite (Rmult_comm (/ 2));
+    unfold Rdiv; repeat rewrite Rmult_1_l; rewrite (Rmult_comm (/ 2));
       repeat rewrite <- Rmult_assoc; rewrite double_var;
         reflexivity.
 Qed.
@@ -312,12 +310,12 @@ Proof with trivial.
   assert (H : 2 <> 0); [ discrR | idtac ]...
   assert (H0 : 4 <> 0); [ apply prod_neq_R0 | idtac ]...
   rewrite double; rewrite cos_plus; rewrite sin_PI3; rewrite cos_PI3;
-    unfold Rdiv in |- *; rewrite Rmult_1_l; apply Rmult_eq_reg_l with 4...
+    unfold Rdiv; rewrite Rmult_1_l; apply Rmult_eq_reg_l with 4...
   rewrite Rmult_minus_distr_l; repeat rewrite Rmult_assoc;
     rewrite (Rmult_comm 2)...
   repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym...
   rewrite Rmult_1_r; rewrite <- Rinv_r_sym...
-  pattern 2 at 4 in |- *; rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc;
+  pattern 2 at 4; rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc;
     rewrite <- Rinv_l_sym...
   rewrite Rmult_1_r; rewrite Ropp_mult_distr_r_reverse; rewrite Rmult_1_r...
   rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym...
@@ -331,7 +329,7 @@ Qed.
 Lemma tan_2PI3 : tan (2 * (PI / 3)) = - sqrt 3.
 Proof with trivial.
   assert (H : 2 <> 0); [ discrR | idtac ]...
-  unfold tan in |- *; rewrite sin_2PI3; rewrite cos_2PI3; unfold Rdiv in |- *;
+  unfold tan; rewrite sin_2PI3; rewrite cos_2PI3; unfold Rdiv;
     rewrite Ropp_mult_distr_l_reverse; rewrite Rmult_1_l;
       rewrite <- Ropp_inv_permute...
   rewrite Rinv_involutive...
@@ -343,21 +341,21 @@ Qed.
 Lemma cos_5PI4 : cos (5 * (PI / 4)) = -1 / sqrt 2.
 Proof with trivial.
   replace (5 * (PI / 4)) with (PI / 4 + PI)...
-  rewrite neg_cos; rewrite cos_PI4; unfold Rdiv in |- *;
+  rewrite neg_cos; rewrite cos_PI4; unfold Rdiv;
     rewrite Ropp_mult_distr_l_reverse...
-  pattern PI at 2 in |- *; rewrite double_var; pattern PI at 2 3 in |- *;
+  pattern PI at 2; rewrite double_var; pattern PI at 2 3;
     rewrite double_var; assert (H : 2 <> 0);
-      [ discrR | unfold Rdiv in |- *; repeat rewrite Rinv_mult_distr; try ring ]...
+      [ discrR | unfold Rdiv; repeat rewrite Rinv_mult_distr; try ring ]...
 Qed.
 
 Lemma sin_5PI4 : sin (5 * (PI / 4)) = -1 / sqrt 2.
 Proof with trivial.
   replace (5 * (PI / 4)) with (PI / 4 + PI)...
-  rewrite neg_sin; rewrite sin_PI4; unfold Rdiv in |- *;
+  rewrite neg_sin; rewrite sin_PI4; unfold Rdiv;
     rewrite Ropp_mult_distr_l_reverse...
-  pattern PI at 2 in |- *; rewrite double_var; pattern PI at 2 3 in |- *;
+  pattern PI at 2; rewrite double_var; pattern PI at 2 3;
     rewrite double_var; assert (H : 2 <> 0);
-      [ discrR | unfold Rdiv in |- *; repeat rewrite Rinv_mult_distr; try ring ]...
+      [ discrR | unfold Rdiv; repeat rewrite Rinv_mult_distr; try ring ]...
 Qed.
 
 Lemma sin_cos5PI4 : cos (5 * (PI / 4)) = sin (5 * (PI / 4)).
@@ -369,7 +367,7 @@ Lemma Rgt_3PI2_0 : 0 < 3 * (PI / 2).
 Proof.
   apply Rmult_lt_0_compat;
     [ prove_sup0
-      | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+      | unfold Rdiv; apply Rmult_lt_0_compat;
         [ apply PI_RGT_0 | apply Rinv_0_lt_compat; prove_sup0 ] ].
 Qed.
 
@@ -384,7 +382,7 @@ Proof.
     generalize (Rplus_lt_compat_l PI 0 (PI / 2) H1);
       replace (PI + PI / 2) with (3 * (PI / 2)).
   rewrite Rplus_0_r; intro H2; assumption.
-  pattern PI at 2 in |- *; rewrite double_var; ring.
+  pattern PI at 2; rewrite double_var; ring.
 Qed.
 
 Lemma Rlt_3PI2_2PI : 3 * (PI / 2) < 2 * PI.
@@ -393,7 +391,7 @@ Proof.
     generalize (Rplus_lt_compat_l (3 * (PI / 2)) 0 (PI / 2) H1);
       replace (3 * (PI / 2) + PI / 2) with (2 * PI).
   rewrite Rplus_0_r; intro H2; assumption.
-  rewrite double; pattern PI at 1 2 in |- *; rewrite double_var; ring.
+  rewrite double; pattern PI at 1 2; rewrite double_var; ring.
 Qed.
 
 (***************************************************************)
@@ -406,13 +404,13 @@ Definition toDeg (x:R) : R := x * plat * / PI.
 
 Lemma rad_deg : forall x:R, toRad (toDeg x) = x.
 Proof.
-  intro; unfold toRad, toDeg in |- *;
+  intro; unfold toRad, toDeg;
     replace (x * plat * / PI * PI * / plat) with
     (x * (plat * / plat) * (PI * / PI)); [ idtac | ring ].
   repeat rewrite <- Rinv_r_sym.
   ring.
   apply PI_neq0.
-  unfold plat in |- *; discrR.
+  unfold plat; discrR.
 Qed.
 
 Lemma toRad_inj : forall x y:R, toRad x = toRad y -> x = y.
@@ -422,7 +420,7 @@ Proof.
   apply Rmult_eq_reg_l with (/ plat).
   rewrite <- (Rmult_comm (x * PI)); rewrite <- (Rmult_comm (y * PI));
     assumption.
-  apply Rinv_neq_0_compat; unfold plat in |- *; discrR.
+  apply Rinv_neq_0_compat; unfold plat; discrR.
   apply PI_neq0.
 Qed.
 
@@ -437,7 +435,7 @@ Definition tand (x:R) : R := tan (toRad x).
 
 Lemma Rsqr_sin_cos_d_one : forall x:R, Rsqr (sind x) + Rsqr (cosd x) = 1.
 Proof.
-  intro x; unfold sind in |- *; unfold cosd in |- *; apply sin2_cos2.
+  intro x; unfold sind; unfold cosd; apply sin2_cos2.
 Qed.
 
 (***************************************************)
@@ -449,10 +447,10 @@ Proof.
   intros; case (Rtotal_order 0 a); intro.
   left; apply sin_lb_gt_0; assumption.
   elim H1; intro.
-  rewrite <- H2; unfold sin_lb in |- *; unfold sin_approx in |- *;
-    unfold sum_f_R0 in |- *; unfold sin_term in |- *;
+  rewrite <- H2; unfold sin_lb; unfold sin_approx;
+    unfold sum_f_R0; unfold sin_term;
       repeat rewrite pow_ne_zero.
-  unfold Rdiv in |- *; repeat rewrite Rmult_0_l; repeat rewrite Rmult_0_r;
+  unfold Rdiv; repeat rewrite Rmult_0_l; repeat rewrite Rmult_0_r;
     repeat rewrite Rplus_0_r; right; reflexivity.
   discriminate.
   discriminate.
diff --git a/theories/Reals/Rtrigo_def.v b/theories/Reals/Rtrigo_def.v
index 417cf13c..f3e69037 100644
--- a/theories/Reals/Rtrigo_def.v
+++ b/theories/Reals/Rtrigo_def.v
@@ -1,19 +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-2012     *)
 (*   \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.
-Open Local Scope R_scope.
+Require Import Rbase Rfunctions SeqSeries Rtrigo_fun Max.
+Local Open Scope R_scope.
 
 (********************************)
 (** * Definition of exponential *)
@@ -33,7 +27,7 @@ Proof.
   intro;
     generalize
       (Alembert_C3 (fun n:nat => / INR (fact n)) x exp_cof_no_R0 Alembert_exp).
-  unfold Pser, exp_in in |- *.
+  unfold Pser, exp_in.
   trivial.
 Defined.
 
@@ -42,24 +36,24 @@ Definition exp (x:R) : R := proj1_sig (exist_exp x).
 Lemma pow_i : forall i:nat, (0 < i)%nat -> 0 ^ i = 0.
 Proof.
   intros; apply pow_ne_zero.
-  red in |- *; intro; rewrite H0 in H; elim (lt_irrefl _ H).
+  red; intro; rewrite H0 in H; elim (lt_irrefl _ H).
 Qed.
 
 Lemma exist_exp0 : { l:R | exp_in 0 l }.
 Proof.
   exists 1.
-  unfold exp_in in |- *; unfold infinite_sum in |- *; intros.
+  unfold exp_in; unfold infinite_sum; intros.
   exists 0%nat.
   intros; replace (sum_f_R0 (fun i:nat => / INR (fact i) * 0 ^ i) n) with 1.
-  unfold R_dist in |- *; replace (1 - 1) with 0;
+  unfold R_dist; replace (1 - 1) with 0;
     [ rewrite Rabs_R0; assumption | ring ].
   induction  n as [| n Hrecn].
-  simpl in |- *; rewrite Rinv_1; ring.
+  simpl; rewrite Rinv_1; ring.
   rewrite tech5.
   rewrite <- Hrecn.
-  simpl in |- *.
+  simpl.
   ring.
-  unfold ge in |- *; apply le_O_n.
+  unfold ge; apply le_O_n.
 Defined.
 
 (* Value of [exp 0] *)
@@ -67,7 +61,7 @@ Lemma exp_0 : exp 0 = 1.
 Proof.
   cut (exp_in 0 (exp 0)).
   cut (exp_in 0 1).
-  unfold exp_in in |- *; intros; eapply uniqueness_sum.
+  unfold exp_in; intros; eapply uniqueness_sum.
   apply H0.
   apply H.
   exact (proj2_sig exist_exp0).
@@ -83,14 +77,14 @@ Definition tanh (x:R) : R := sinh x / cosh x.
 
 Lemma cosh_0 : cosh 0 = 1.
 Proof.
-  unfold cosh in |- *; rewrite Ropp_0; rewrite exp_0.
-  unfold Rdiv in |- *; rewrite <- Rinv_r_sym; [ reflexivity | discrR ].
+  unfold cosh; rewrite Ropp_0; rewrite exp_0.
+  unfold Rdiv; rewrite <- Rinv_r_sym; [ reflexivity | discrR ].
 Qed.
 
 Lemma sinh_0 : sinh 0 = 0.
 Proof.
-  unfold sinh in |- *; rewrite Ropp_0; rewrite exp_0.
-  unfold Rminus, Rdiv in |- *; rewrite Rplus_opp_r; apply Rmult_0_l.
+  unfold sinh; rewrite Ropp_0; rewrite exp_0.
+  unfold Rminus, Rdiv; rewrite Rplus_opp_r; apply Rmult_0_l.
 Qed.
 
 Definition cos_n (n:nat) : R := (-1) ^ n / INR (fact (2 * n)).
@@ -98,8 +92,8 @@ Definition cos_n (n:nat) : R := (-1) ^ n / INR (fact (2 * n)).
 Lemma simpl_cos_n :
   forall n:nat, cos_n (S n) / cos_n n = - / INR (2 * S n * (2 * n + 1)).
 Proof.
-  intro; unfold cos_n in |- *; replace (S n) with (n + 1)%nat; [ idtac | ring ].
-  rewrite pow_add; unfold Rdiv in |- *; rewrite Rinv_mult_distr.
+  intro; unfold cos_n; replace (S n) with (n + 1)%nat; [ idtac | ring ].
+  rewrite pow_add; unfold Rdiv; rewrite Rinv_mult_distr.
   rewrite Rinv_involutive.
   replace
   ((-1) ^ n * (-1) ^ 1 * / INR (fact (2 * (n + 1))) *
@@ -107,7 +101,7 @@ Proof.
   ((-1) ^ n * / (-1) ^ n * / INR (fact (2 * (n + 1))) * INR (fact (2 * n)) *
     (-1) ^ 1); [ idtac | ring ].
   rewrite <- Rinv_r_sym.
-  rewrite Rmult_1_l; unfold pow in |- *; rewrite Rmult_1_r.
+  rewrite Rmult_1_l; unfold pow; rewrite Rmult_1_r.
   replace (2 * (n + 1))%nat with (S (S (2 * n))); [ idtac | ring ].
   do 2 rewrite fact_simpl; do 2 rewrite mult_INR;
     repeat rewrite Rinv_mult_distr; try (apply not_O_INR; discriminate).
@@ -136,29 +130,29 @@ Proof.
   intro; cut (0 <= up (/ eps))%Z.
   intro; assert (H2 := IZN _ H1); elim H2; intros; exists (max x 1).
   split.
-  cut (0 < IZR (Z_of_nat x)).
-  intro; rewrite INR_IZR_INZ; apply Rle_lt_trans with (/ IZR (Z_of_nat x)).
-  apply Rmult_le_reg_l with (IZR (Z_of_nat x)).
+  cut (0 < IZR (Z.of_nat x)).
+  intro; rewrite INR_IZR_INZ; apply Rle_lt_trans with (/ IZR (Z.of_nat x)).
+  apply Rmult_le_reg_l with (IZR (Z.of_nat x)).
   assumption.
   rewrite <- Rinv_r_sym;
-    [ idtac | red in |- *; intro; rewrite H5 in H4; elim (Rlt_irrefl _ H4) ].
-  apply Rmult_le_reg_l with (IZR (Z_of_nat (max x 1))).
-  apply Rlt_le_trans with (IZR (Z_of_nat x)).
+    [ idtac | red; intro; rewrite H5 in H4; elim (Rlt_irrefl _ H4) ].
+  apply Rmult_le_reg_l with (IZR (Z.of_nat (max x 1))).
+  apply Rlt_le_trans with (IZR (Z.of_nat x)).
   assumption.
   repeat rewrite <- INR_IZR_INZ; apply le_INR; apply le_max_l.
-  rewrite Rmult_1_r; rewrite (Rmult_comm (IZR (Z_of_nat (max x 1))));
+  rewrite Rmult_1_r; rewrite (Rmult_comm (IZR (Z.of_nat (max x 1))));
     rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
   rewrite Rmult_1_r; repeat rewrite <- INR_IZR_INZ; apply le_INR;
     apply le_max_l.
   rewrite <- INR_IZR_INZ; apply not_O_INR.
-  red in |- *; intro; assert (H6 := le_max_r x 1); cut (0 < 1)%nat;
+  red; intro; assert (H6 := le_max_r x 1); cut (0 < 1)%nat;
     [ intro | apply lt_O_Sn ]; assert (H8 := lt_le_trans _ _ _ H7 H6);
       rewrite H5 in H8; elim (lt_irrefl _ H8).
-  pattern eps at 1 in |- *; rewrite <- Rinv_involutive.
+  pattern eps at 1; rewrite <- Rinv_involutive.
   apply Rinv_lt_contravar.
   apply Rmult_lt_0_compat; [ apply Rinv_0_lt_compat; assumption | assumption ].
   rewrite H3 in H0; assumption.
-  red in |- *; intro; rewrite H5 in H; elim (Rlt_irrefl _ H).
+  red; intro; rewrite H5 in H; elim (Rlt_irrefl _ H).
   apply Rlt_trans with (/ eps).
   apply Rinv_0_lt_compat; assumption.
   rewrite H3 in H0; assumption.
@@ -172,10 +166,10 @@ Qed.
 
 Lemma Alembert_cos : Un_cv (fun n:nat => Rabs (cos_n (S n) / cos_n n)) 0.
 Proof.
-  unfold Un_cv in |- *; intros.
+  unfold Un_cv; intros.
   assert (H0 := archimed_cor1 eps H).
   elim H0; intros; exists x.
-  intros; rewrite simpl_cos_n; unfold R_dist in |- *; unfold Rminus in |- *;
+  intros; rewrite simpl_cos_n; unfold R_dist; unfold Rminus;
     rewrite Ropp_0; rewrite Rplus_0_r; rewrite Rabs_Rabsolu;
       rewrite Rabs_Ropp; rewrite Rabs_right.
   rewrite mult_INR; rewrite Rinv_mult_distr.
@@ -183,7 +177,7 @@ Proof.
   intro; cut (/ INR (2 * n + 1) < eps).
   intro; rewrite <- (Rmult_1_l eps).
   apply Rmult_gt_0_lt_compat; try assumption.
-  change (0 < / INR (2 * n + 1)) in |- *; apply Rinv_0_lt_compat;
+  change (0 < / INR (2 * n + 1)); apply Rinv_0_lt_compat;
     apply lt_INR_0.
   replace (2 * n + 1)%nat with (S (2 * n)); [ apply lt_O_Sn | ring ].
   apply Rlt_0_1.
@@ -227,7 +221,7 @@ Proof.
 Qed.
 
 Lemma cosn_no_R0 : forall n:nat, cos_n n <> 0.
-  intro; unfold cos_n in |- *; unfold Rdiv in |- *; apply prod_neq_R0.
+  intro; unfold cos_n; unfold Rdiv; apply prod_neq_R0.
   apply pow_nonzero; discrR.
   apply Rinv_neq_0_compat.
   apply INR_fact_neq_0.
@@ -240,7 +234,7 @@ Definition cos_in (x l:R) : Prop :=
 (**********)
 Lemma exist_cos : forall x:R, { l:R | cos_in x l }.
   intro; generalize (Alembert_C3 cos_n x cosn_no_R0 Alembert_cos).
-  unfold Pser, cos_in in |- *; trivial.
+  unfold Pser, cos_in; trivial.
 Qed.
 
 
@@ -252,8 +246,8 @@ Definition sin_n (n:nat) : R := (-1) ^ n / INR (fact (2 * n + 1)).
 Lemma simpl_sin_n :
   forall n:nat, sin_n (S n) / sin_n n = - / INR ((2 * S n + 1) * (2 * S n)).
 Proof.
-  intro; unfold sin_n in |- *; replace (S n) with (n + 1)%nat; [ idtac | ring ].
-  rewrite pow_add; unfold Rdiv in |- *; rewrite Rinv_mult_distr.
+  intro; unfold sin_n; replace (S n) with (n + 1)%nat; [ idtac | ring ].
+  rewrite pow_add; unfold Rdiv; rewrite Rinv_mult_distr.
   rewrite Rinv_involutive.
   replace
   ((-1) ^ n * (-1) ^ 1 * / INR (fact (2 * (n + 1) + 1)) *
@@ -261,7 +255,7 @@ Proof.
   ((-1) ^ n * / (-1) ^ n * / INR (fact (2 * (n + 1) + 1)) *
     INR (fact (2 * n + 1)) * (-1) ^ 1); [ idtac | ring ].
   rewrite <- Rinv_r_sym.
-  rewrite Rmult_1_l; unfold pow in |- *; rewrite Rmult_1_r;
+  rewrite Rmult_1_l; unfold pow; rewrite Rmult_1_r;
     replace (2 * (n + 1) + 1)%nat with (S (S (2 * n + 1))).
   do 2 rewrite fact_simpl; do 2 rewrite mult_INR;
     repeat rewrite Rinv_mult_distr.
@@ -297,9 +291,9 @@ Qed.
 
 Lemma Alembert_sin : Un_cv (fun n:nat => Rabs (sin_n (S n) / sin_n n)) 0.
 Proof.
-  unfold Un_cv in |- *; intros; assert (H0 := archimed_cor1 eps H).
+  unfold Un_cv; intros; assert (H0 := archimed_cor1 eps H).
   elim H0; intros; exists x.
-  intros; rewrite simpl_sin_n; unfold R_dist in |- *; unfold Rminus in |- *;
+  intros; rewrite simpl_sin_n; unfold R_dist; unfold Rminus;
     rewrite Ropp_0; rewrite Rplus_0_r; rewrite Rabs_Rabsolu;
       rewrite Rabs_Ropp; rewrite Rabs_right.
   rewrite mult_INR; rewrite Rinv_mult_distr.
@@ -307,7 +301,7 @@ Proof.
   intro; cut (/ INR (2 * S n + 1) < eps).
   intro; rewrite <- (Rmult_1_l eps); rewrite (Rmult_comm (/ INR (2 * S n + 1)));
     apply Rmult_gt_0_lt_compat; try assumption.
-  change (0 < / INR (2 * S n + 1)) in |- *; apply Rinv_0_lt_compat;
+  change (0 < / INR (2 * S n + 1)); apply Rinv_0_lt_compat;
     apply lt_INR_0; replace (2 * S n + 1)%nat with (S (2 * S n));
       [ apply lt_O_Sn | ring ].
   apply Rlt_0_1.
@@ -335,7 +329,7 @@ Proof.
   apply not_O_INR; discriminate.
   apply not_O_INR; discriminate.
   apply not_O_INR; discriminate.
-  left; change (0 < / INR ((2 * S n + 1) * (2 * S n))) in |- *;
+  left; change (0 < / INR ((2 * S n + 1) * (2 * S n)));
     apply Rinv_0_lt_compat.
   apply lt_INR_0.
   replace ((2 * S n + 1) * (2 * S n))%nat with
@@ -348,7 +342,7 @@ Defined.
 
 Lemma sin_no_R0 : forall n:nat, sin_n n <> 0.
 Proof.
-  intro; unfold sin_n in |- *; unfold Rdiv in |- *; apply prod_neq_R0.
+  intro; unfold sin_n; unfold Rdiv; apply prod_neq_R0.
   apply pow_nonzero; discrR.
   apply Rinv_neq_0_compat; apply INR_fact_neq_0.
 Qed.
@@ -361,7 +355,7 @@ Definition sin_in (x l:R) : Prop :=
 Lemma exist_sin : forall x:R, { l:R | sin_in x l }.
 Proof.
   intro; generalize (Alembert_C3 sin_n x sin_no_R0 Alembert_sin).
-  unfold Pser, sin_n in |- *; trivial.
+  unfold Pser, sin_n; trivial.
 Defined.
 
 (***********************)
@@ -374,40 +368,40 @@ Definition sin (x:R) : R := let (a,_) := exist_sin (Rsqr x) in x * a.
 
 Lemma cos_sym : forall x:R, cos x = cos (- x).
 Proof.
-  intros; unfold cos in |- *; replace (Rsqr (- x)) with (Rsqr x).
+  intros; unfold cos; replace (Rsqr (- x)) with (Rsqr x).
   reflexivity.
   apply Rsqr_neg.
 Qed.
 
 Lemma sin_antisym : forall x:R, sin (- x) = - sin x.
 Proof.
-  intro; unfold sin in |- *; replace (Rsqr (- x)) with (Rsqr x);
+  intro; unfold sin; replace (Rsqr (- x)) with (Rsqr x);
     [ idtac | apply Rsqr_neg ].
   case (exist_sin (Rsqr x)); intros; ring.
 Qed.
 
 Lemma sin_0 : sin 0 = 0.
 Proof.
-  unfold sin in |- *; case (exist_sin (Rsqr 0)).
+  unfold sin; case (exist_sin (Rsqr 0)).
   intros; ring.
 Qed.
 
 Lemma exist_cos0 : { l:R | cos_in 0 l }.
 Proof.
   exists 1.
-  unfold cos_in in |- *; unfold infinite_sum in |- *; intros; exists 0%nat.
+  unfold cos_in; unfold infinite_sum; intros; exists 0%nat.
   intros.
-  unfold R_dist in |- *.
+  unfold R_dist.
   induction  n as [| n Hrecn].
-  unfold cos_n in |- *; simpl in |- *.
-  unfold Rdiv in |- *; rewrite Rinv_1.
+  unfold cos_n; simpl.
+  unfold Rdiv; rewrite Rinv_1.
   do 2 rewrite Rmult_1_r.
-  unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption.
+  unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption.
   rewrite tech5.
   replace (cos_n (S n) * 0 ^ S n) with 0.
   rewrite Rplus_0_r.
-  apply Hrecn; unfold ge in |- *; apply le_O_n.
-  simpl in |- *; ring.
+  apply Hrecn; unfold ge; apply le_O_n.
+  simpl; ring.
 Defined.
 
 (* Value of [cos 0] *)
@@ -415,10 +409,10 @@ Lemma cos_0 : cos 0 = 1.
 Proof.
   cut (cos_in 0 (cos 0)).
   cut (cos_in 0 1).
-  unfold cos_in in |- *; intros; eapply uniqueness_sum.
+  unfold cos_in; intros; eapply uniqueness_sum.
   apply H0.
   apply H.
   exact (proj2_sig exist_cos0).
-  assert (H := proj2_sig (exist_cos (Rsqr 0))); unfold cos in |- *;
-    pattern 0 at 1 in |- *; replace 0 with (Rsqr 0); [ exact H | apply Rsqr_0 ].
+  assert (H := proj2_sig (exist_cos (Rsqr 0))); unfold cos;
+    pattern 0 at 1; replace 0 with (Rsqr 0); [ exact H | apply Rsqr_0 ].
 Qed.
diff --git a/theories/Reals/Rtrigo_fun.v b/theories/Reals/Rtrigo_fun.v
index 2ed86abe..b131b510 100644
--- a/theories/Reals/Rtrigo_fun.v
+++ b/theories/Reals/Rtrigo_fun.v
@@ -1,17 +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-2012     *)
 (*   \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.
-Open Local Scope R_scope.
+Local Open Scope R_scope.
 
 (*****************************************************************)
 (**           To define transcendental functions                 *)
@@ -22,8 +20,8 @@ Open Local Scope R_scope.
 Lemma Alembert_exp :
   Un_cv (fun n:nat => Rabs (/ INR (fact (S n)) * / / INR (fact n))) 0.
 Proof.
-  unfold Un_cv in |- *; intros; elim (Rgt_dec eps 1); intro.
-  split with 0%nat; intros; rewrite (simpl_fact n); unfold R_dist in |- *;
+  unfold Un_cv; intros; elim (Rgt_dec eps 1); intro.
+  split with 0%nat; intros; rewrite (simpl_fact n); unfold R_dist;
     rewrite (Rminus_0_r (Rabs (/ INR (S n))));
       rewrite (Rabs_Rabsolu (/ INR (S n))); cut (/ INR (S n) > 0).
   intro; rewrite (Rabs_pos_eq (/ INR (S n))).
@@ -41,7 +39,7 @@ Proof.
               in H4; rewrite (let (H1, H2) := Rmult_ne (/ INR (S n)) in H1) in H4;
                 rewrite (Rmult_comm (/ INR (S n))) in H4;
                   rewrite (Rmult_assoc eps (/ INR (S n)) (INR (S n))) in H4;
-                    rewrite (Rinv_l (INR (S n)) (not_O_INR (S n) (sym_not_equal (O_S n)))) in H4;
+                    rewrite (Rinv_l (INR (S n)) (not_O_INR (S n) (not_eq_sym (O_S n)))) in H4;
                       rewrite (let (H1, H2) := Rmult_ne eps in H1) in H4;
                         assumption.
   apply Rlt_minus; unfold Rgt in a; rewrite <- Rinv_1;
@@ -49,11 +47,11 @@ Proof.
       rewrite (let (H1, H2) := Rmult_ne eps in H2); unfold Rgt in H;
         assumption.
   unfold Rgt in H1; apply Rlt_le; assumption.
-  unfold Rgt in |- *; apply Rinv_0_lt_compat; apply lt_INR_0; apply lt_O_Sn.
+  unfold Rgt; apply Rinv_0_lt_compat; apply lt_INR_0; apply lt_O_Sn.
 (**)
   cut (0 <= up (/ eps - 1))%Z.
   intro; elim (IZN (up (/ eps - 1)) H0); intros; split with x; intros;
-    rewrite (simpl_fact n); unfold R_dist in |- *;
+    rewrite (simpl_fact n); unfold R_dist;
       rewrite (Rminus_0_r (Rabs (/ INR (S n))));
         rewrite (Rabs_Rabsolu (/ INR (S n))); cut (/ INR (S n) > 0).
   intro; rewrite (Rabs_pos_eq (/ INR (S n))).
@@ -74,28 +72,28 @@ Proof.
               in H6; rewrite (let (H1, H2) := Rmult_ne (/ INR (S n)) in H1) in H6;
                 rewrite (Rmult_comm (/ INR (S n))) in H6;
                   rewrite (Rmult_assoc eps (/ INR (S n)) (INR (S n))) in H6;
-                    rewrite (Rinv_l (INR (S n)) (not_O_INR (S n) (sym_not_equal (O_S n)))) in H6;
+                    rewrite (Rinv_l (INR (S n)) (not_O_INR (S n) (not_eq_sym (O_S n)))) in H6;
                       rewrite (let (H1, H2) := Rmult_ne eps in H1) in H6;
                         assumption.
-  cut (IZR (up (/ eps - 1)) = IZR (Z_of_nat x));
+  cut (IZR (up (/ eps - 1)) = IZR (Z.of_nat x));
     [ intro | rewrite H1; trivial ].
   elim (archimed (/ eps - 1)); intros; clear H6; unfold Rgt in H5;
     rewrite H4 in H5; rewrite INR_IZR_INZ; assumption.
   unfold Rgt in H1; apply Rlt_le; assumption.
-  unfold Rgt in |- *; apply Rinv_0_lt_compat; apply lt_INR_0; apply lt_O_Sn.
+  unfold Rgt; apply Rinv_0_lt_compat; apply lt_INR_0; apply lt_O_Sn.
   apply (le_O_IZR (up (/ eps - 1)));
     apply (Rle_trans 0 (/ eps - 1) (IZR (up (/ eps - 1)))).
-  generalize (Rnot_gt_le eps 1 b); clear b; unfold Rle in |- *; intro; elim H0;
+  generalize (Rnot_gt_le eps 1 b); clear b; unfold Rle; intro; elim H0;
     clear H0; intro.
   left; unfold Rgt in H;
     generalize (Rmult_lt_compat_l (/ eps) eps 1 (Rinv_0_lt_compat eps H) H0);
       rewrite
         (Rinv_l eps
-          (sym_not_eq (Rlt_dichotomy_converse 0 eps (or_introl (0 > eps) H))))
+          (not_eq_sym (Rlt_dichotomy_converse 0 eps (or_introl (0 > eps) H))))
         ; rewrite (let (H1, H2) := Rmult_ne (/ eps) in H1);
-          intro; fold (/ eps - 1 > 0) in |- *; apply Rgt_minus;
-            unfold Rgt in |- *; assumption.
-  right; rewrite H0; rewrite Rinv_1; apply sym_eq; apply Rminus_diag_eq; auto.
+          intro; fold (/ eps - 1 > 0); apply Rgt_minus;
+            unfold Rgt; assumption.
+  right; rewrite H0; rewrite Rinv_1; symmetry; apply Rminus_diag_eq; auto.
   elim (archimed (/ eps - 1)); intros; clear H1; unfold Rgt in H0; apply Rlt_le;
     assumption.
 Qed.
diff --git a/theories/Reals/Rtrigo_reg.v b/theories/Reals/Rtrigo_reg.v
index 59afec88..fff4fec9 100644
--- a/theories/Reals/Rtrigo_reg.v
+++ b/theories/Reals/Rtrigo_reg.v
@@ -1,179 +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-2012     *)
 (*   \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.
-Require Import Rtrigo.
+Require Import Rtrigo1.
 Require Import Ranalysis1.
 Require Import PSeries_reg.
-Open Local Scope nat_scope.
-Open Local Scope R_scope.
-
-Lemma CVN_R_cos :
-  forall fn:nat -> R -> R,
-    fn = (fun (N:nat) (x:R) => (-1) ^ N / INR (fact (2 * N)) * x ^ (2 * N)) ->
-    CVN_R fn.
-Proof.
-  unfold CVN_R in |- *; intros.
-  cut ((r:R) <> 0).
-  intro hyp_r; unfold CVN_r in |- *.
-  exists (fun n:nat => / INR (fact (2 * n)) * r ^ (2 * n)).
-  cut
-    { l:R |
-        Un_cv
-        (fun n:nat =>
-          sum_f_R0 (fun k:nat => Rabs (/ INR (fact (2 * k)) * r ^ (2 * k)))
-          n) l }.
-  intro X; elim X; intros.
-  exists x.
-  split.
-  apply p.
-  intros; rewrite H; unfold Rdiv in |- *; do 2 rewrite Rabs_mult.
-  rewrite pow_1_abs; rewrite Rmult_1_l.
-  cut (0 < / INR (fact (2 * n))).
-  intro; rewrite (Rabs_right _ (Rle_ge _ _ (Rlt_le _ _ H1))).
-  apply Rmult_le_compat_l.
-  left; apply H1.
-  rewrite <- RPow_abs; apply pow_maj_Rabs.
-  rewrite Rabs_Rabsolu.
-  unfold Boule in H0; rewrite Rminus_0_r in H0.
-  left; apply H0.
-  apply Rinv_0_lt_compat; apply INR_fact_lt_0.
-  apply Alembert_C2.
-  intro; apply Rabs_no_R0.
-  apply prod_neq_R0.
-  apply Rinv_neq_0_compat.
-  apply INR_fact_neq_0.
-  apply pow_nonzero; assumption.
-  assert (H0 := Alembert_cos).
-  unfold cos_n in H0; unfold Un_cv in H0; unfold Un_cv in |- *; intros.
-  cut (0 < eps / Rsqr r).
-  intro; elim (H0 _ H2); intros N0 H3.
-  exists N0; intros.
-  unfold R_dist in |- *; assert (H5 := H3 _ H4).
-  unfold R_dist in H5;
-    replace
-    (Rabs
-      (Rabs (/ INR (fact (2 * S n)) * r ^ (2 * S n)) /
-        Rabs (/ INR (fact (2 * n)) * r ^ (2 * n)))) with
-    (Rsqr r *
-      Rabs ((-1) ^ S n / INR (fact (2 * S n)) / ((-1) ^ n / INR (fact (2 * n))))).
-  apply Rmult_lt_reg_l with (/ Rsqr r).
-  apply Rinv_0_lt_compat; apply Rsqr_pos_lt; assumption.
-  pattern (/ Rsqr r) at 1 in |- *; replace (/ Rsqr r) with (Rabs (/ Rsqr r)).
-  rewrite <- Rabs_mult; rewrite Rmult_minus_distr_l; rewrite Rmult_0_r;
-    rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
-  rewrite Rmult_1_l; rewrite <- (Rmult_comm eps); apply H5.
-  unfold Rsqr in |- *; apply prod_neq_R0; assumption.
-  rewrite Rabs_Rinv.
-  rewrite Rabs_right.
-  reflexivity.
-  apply Rle_ge; apply Rle_0_sqr.
-  unfold Rsqr in |- *; apply prod_neq_R0; assumption.
-  rewrite (Rmult_comm (Rsqr r)); unfold Rdiv in |- *; repeat rewrite Rabs_mult;
-    rewrite Rabs_Rabsolu; rewrite pow_1_abs; rewrite Rmult_1_l;
-      repeat rewrite Rmult_assoc; apply Rmult_eq_compat_l.
-  rewrite Rabs_Rinv.
-  rewrite Rabs_mult; rewrite (pow_1_abs n); rewrite Rmult_1_l;
-    rewrite <- Rabs_Rinv.
-  rewrite Rinv_involutive.
-  rewrite Rinv_mult_distr.
-  rewrite Rabs_Rinv.
-  rewrite Rinv_involutive.
-  rewrite (Rmult_comm (Rabs (Rabs (r ^ (2 * S n))))); rewrite Rabs_mult;
-    rewrite Rabs_Rabsolu; rewrite Rmult_assoc; apply Rmult_eq_compat_l.
-  rewrite Rabs_Rinv.
-  do 2 rewrite Rabs_Rabsolu; repeat rewrite Rabs_right.
-  replace (r ^ (2 * S n)) with (r ^ (2 * n) * r * r).
-  repeat rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
-  unfold Rsqr in |- *; ring.
-  apply pow_nonzero; assumption.
-  replace (2 * S n)%nat with (S (S (2 * n))).
-  simpl in |- *; ring.
-  ring.
-  apply Rle_ge; apply pow_le; left; apply (cond_pos r).
-  apply Rle_ge; apply pow_le; left; apply (cond_pos r).
-  apply Rabs_no_R0; apply pow_nonzero; assumption.
-  apply Rabs_no_R0; apply INR_fact_neq_0.
-  apply INR_fact_neq_0.
-  apply Rabs_no_R0; apply Rinv_neq_0_compat; apply INR_fact_neq_0.
-  apply Rabs_no_R0; apply pow_nonzero; assumption.
-  apply INR_fact_neq_0.
-  apply Rinv_neq_0_compat; apply INR_fact_neq_0.
-  apply prod_neq_R0.
-  apply pow_nonzero; discrR.
-  apply Rinv_neq_0_compat; apply INR_fact_neq_0.
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat.
-  apply H1.
-  apply Rinv_0_lt_compat; apply Rsqr_pos_lt; assumption.
-  assert (H0 := cond_pos r); red in |- *; intro; rewrite H1 in H0;
-    elim (Rlt_irrefl _ H0).
-Qed.
+Local Open Scope nat_scope.
+Local Open Scope R_scope.
 
-(**********)
-Lemma continuity_cos : continuity cos.
-Proof.
-  set (fn := fun (N:nat) (x:R) => (-1) ^ N / INR (fact (2 * N)) * x ^ (2 * N)).
-  cut (CVN_R fn).
-  intro; cut (forall x:R, { l:R | Un_cv (fun N:nat => SP fn N x) l }).
-  intro cv; cut (forall n:nat, continuity (fn n)).
-  intro; cut (forall x:R, cos x = SFL fn cv x).
-  intro; cut (continuity (SFL fn cv) -> continuity cos).
-  intro; apply H1.
-  apply SFL_continuity; assumption.
-  unfold continuity in |- *; unfold continuity_pt in |- *;
-    unfold continue_in in |- *; unfold limit1_in in |- *;
-      unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *;
-        intros.
-  elim (H1 x _ H2); intros.
-  exists x0; intros.
-  elim H3; intros.
-  split.
-  apply H4.
-  intros; rewrite (H0 x); rewrite (H0 x1); apply H5; apply H6.
-  intro; unfold cos, SFL in |- *.
-  case (cv x); case (exist_cos (Rsqr x)); intros.
-  symmetry  in |- *; eapply UL_sequence.
-  apply u.
-  unfold cos_in in c; unfold infinite_sum in c; unfold Un_cv in |- *; intros.
-  elim (c _ H0); intros N0 H1.
-  exists N0; intros.
-  unfold R_dist in H1; unfold R_dist, SP in |- *.
-  replace (sum_f_R0 (fun k:nat => fn k x) n) with
-  (sum_f_R0 (fun i:nat => cos_n i * Rsqr x ^ i) n).
-  apply H1; assumption.
-  apply sum_eq; intros.
-  unfold cos_n, fn in |- *; apply Rmult_eq_compat_l.
-  unfold Rsqr in |- *; rewrite pow_sqr; reflexivity.
-  intro; unfold fn in |- *;
-    replace (fun x:R => (-1) ^ n / INR (fact (2 * n)) * x ^ (2 * n)) with
-    (fct_cte ((-1) ^ n / INR (fact (2 * n))) * pow_fct (2 * n))%F;
-    [ idtac | reflexivity ].
-  apply continuity_mult.
-  apply derivable_continuous; apply derivable_const.
-  apply derivable_continuous; apply (derivable_pow (2 * n)).
-  apply CVN_R_CVS; apply X.
-  apply CVN_R_cos; unfold fn in |- *; reflexivity.
-Qed.
 
 (**********)
 Lemma continuity_sin : continuity sin.
 Proof.
-  unfold continuity in |- *; intro.
+  unfold continuity; intro.
   assert (H0 := continuity_cos (PI / 2 - x)).
   unfold continuity_pt in H0; unfold continue_in in H0; unfold limit1_in in H0;
     unfold limit_in in H0; simpl in H0; unfold R_dist in H0;
-      unfold continuity_pt in |- *; unfold continue_in in |- *;
-        unfold limit1_in in |- *; unfold limit_in in |- *;
-          simpl in |- *; unfold R_dist in |- *; intros.
+      unfold continuity_pt; unfold continue_in;
+        unfold limit1_in; unfold limit_in;
+          simpl; unfold R_dist; intros.
   elim (H0 _ H); intros.
   exists x0; intros.
   elim H1; intros.
@@ -182,9 +34,9 @@ Proof.
   intros; rewrite <- (cos_shift x); rewrite <- (cos_shift x1); apply H3.
   elim H4; intros.
   split.
-  unfold D_x, no_cond in |- *; split.
+  unfold D_x, no_cond; split.
   trivial.
-  red in |- *; intro; unfold D_x, no_cond in H5; elim H5; intros _ H8; elim H8;
+  red; intro; unfold D_x, no_cond in H5; elim H5; intros _ H8; elim H8;
     rewrite <- (Ropp_involutive x); rewrite <- (Ropp_involutive x1);
       apply Ropp_eq_compat; apply Rplus_eq_reg_l with (PI / 2);
         apply H7.
@@ -198,7 +50,7 @@ Lemma CVN_R_sin :
     (fun (N:nat) (x:R) => (-1) ^ N / INR (fact (2 * N + 1)) * x ^ (2 * N)) ->
     CVN_R fn.
 Proof.
-  unfold CVN_R in |- *; unfold CVN_r in |- *; intros fn H r.
+  unfold CVN_R; unfold CVN_r; intros fn H r.
   exists (fun n:nat => / INR (fact (2 * n + 1)) * r ^ (2 * n)).
   cut
     { l:R |
@@ -211,7 +63,7 @@ Proof.
   exists x.
   split.
   apply p.
-  intros; rewrite H; unfold Rdiv in |- *; do 2 rewrite Rabs_mult;
+  intros; rewrite H; unfold Rdiv; do 2 rewrite Rabs_mult;
     rewrite pow_1_abs; rewrite Rmult_1_l.
   cut (0 < / INR (fact (2 * n + 1))).
   intro; rewrite (Rabs_right _ (Rle_ge _ _ (Rlt_le _ _ H1))).
@@ -228,11 +80,11 @@ Proof.
   apply Rinv_neq_0_compat; apply INR_fact_neq_0.
   apply pow_nonzero; assumption.
   assert (H1 := Alembert_sin).
-  unfold sin_n in H1; unfold Un_cv in H1; unfold Un_cv in |- *; intros.
+  unfold sin_n in H1; unfold Un_cv in H1; unfold Un_cv; intros.
   cut (0 < eps / Rsqr r).
   intro; elim (H1 _ H3); intros N0 H4.
   exists N0; intros.
-  unfold R_dist in |- *; assert (H6 := H4 _ H5).
+  unfold R_dist; assert (H6 := H4 _ H5).
   unfold R_dist in H5;
     replace
     (Rabs
@@ -244,15 +96,15 @@ Proof.
         ((-1) ^ n / INR (fact (2 * n + 1))))).
   apply Rmult_lt_reg_l with (/ Rsqr r).
   apply Rinv_0_lt_compat; apply Rsqr_pos_lt; assumption.
-  pattern (/ Rsqr r) at 1 in |- *; rewrite <- (Rabs_right (/ Rsqr r)).
+  pattern (/ Rsqr r) at 1; rewrite <- (Rabs_right (/ Rsqr r)).
   rewrite <- Rabs_mult.
   rewrite Rmult_minus_distr_l.
   rewrite Rmult_0_r; rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
   rewrite Rmult_1_l; rewrite <- (Rmult_comm eps).
   apply H6.
-  unfold Rsqr in |- *; apply prod_neq_R0; assumption.
+  unfold Rsqr; apply prod_neq_R0; assumption.
   apply Rle_ge; left; apply Rinv_0_lt_compat; apply Rsqr_pos_lt; assumption.
-  unfold Rdiv in |- *; rewrite (Rmult_comm (Rsqr r)); repeat rewrite Rabs_mult;
+  unfold Rdiv; rewrite (Rmult_comm (Rsqr r)); repeat rewrite Rabs_mult;
     rewrite Rabs_Rabsolu; rewrite pow_1_abs.
   rewrite Rmult_1_l.
   repeat rewrite Rmult_assoc; apply Rmult_eq_compat_l.
@@ -274,10 +126,10 @@ Proof.
   replace (r ^ (2 * S n)) with (r ^ (2 * n) * r * r).
   do 2 rewrite <- Rmult_assoc.
   rewrite <- Rinv_l_sym.
-  unfold Rsqr in |- *; ring.
+  unfold Rsqr; ring.
   apply pow_nonzero; assumption.
   replace (2 * S n)%nat with (S (S (2 * n))).
-  simpl in |- *; ring.
+  simpl; ring.
   ring.
   apply Rle_ge; apply pow_le; left; apply (cond_pos r).
   apply Rle_ge; apply pow_le; left; apply (cond_pos r).
@@ -290,16 +142,16 @@ Proof.
   apply INR_fact_neq_0.
   apply pow_nonzero; discrR.
   apply Rinv_neq_0_compat; apply INR_fact_neq_0.
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+  unfold Rdiv; apply Rmult_lt_0_compat;
     [ assumption | apply Rinv_0_lt_compat; apply Rsqr_pos_lt; assumption ].
-  assert (H0 := cond_pos r); red in |- *; intro; rewrite H1 in H0;
+  assert (H0 := cond_pos r); red; intro; rewrite H1 in H0;
     elim (Rlt_irrefl _ H0).
 Qed.
 
 (** (sin h)/h -> 1 when h -> 0 *)
 Lemma derivable_pt_lim_sin_0 : derivable_pt_lim sin 0 1.
 Proof.
-  unfold derivable_pt_lim in |- *; intros.
+  unfold derivable_pt_lim; intros.
   set
     (fn := fun (N:nat) (x:R) => (-1) ^ N / INR (fact (2 * N + 1)) * x ^ (2 * N)).
   cut (CVN_R fn).
@@ -315,58 +167,58 @@ Proof.
   elim (H2 _ H); intros alp H3.
   elim H3; intros.
   exists (mkposreal _ H4).
-  simpl in |- *; intros.
-  rewrite sin_0; rewrite Rplus_0_l; unfold Rminus in |- *; rewrite Ropp_0;
+  simpl; intros.
+  rewrite sin_0; rewrite Rplus_0_l; unfold Rminus; rewrite Ropp_0;
     rewrite Rplus_0_r.
   cut (Rabs (SFL fn cv h - SFL fn cv 0) < eps).
   intro; cut (SFL fn cv 0 = 1).
   intro; cut (SFL fn cv h = sin h / h).
   intro; rewrite H9 in H8; rewrite H10 in H8.
   apply H8.
-  unfold SFL, sin in |- *.
+  unfold SFL, sin.
   case (cv h); intros.
   case (exist_sin (Rsqr h)); intros.
-  unfold Rdiv in |- *; rewrite (Rinv_r_simpl_m h x0 H6).
+  unfold Rdiv; rewrite (Rinv_r_simpl_m h x0 H6).
   eapply UL_sequence.
   apply u.
   unfold sin_in in s; unfold sin_n, infinite_sum in s;
-    unfold SP, fn, Un_cv in |- *; intros.
+    unfold SP, fn, Un_cv; intros.
   elim (s _ H10); intros N0 H11.
   exists N0; intros.
-  unfold R_dist in |- *; unfold R_dist in H11.
+  unfold R_dist; unfold R_dist in H11.
   replace
   (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * h ^ (2 * k)) n)
     with
       (sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i + 1)) * Rsqr h ^ i) n).
   apply H11; assumption.
-  apply sum_eq; intros; apply Rmult_eq_compat_l; unfold Rsqr in |- *;
+  apply sum_eq; intros; apply Rmult_eq_compat_l; unfold Rsqr;
     rewrite pow_sqr; reflexivity.
-  unfold SFL, sin in |- *.
+  unfold SFL, sin.
   case (cv 0); intros.
   eapply UL_sequence.
   apply u.
-  unfold SP, fn in |- *; unfold Un_cv in |- *; intros; exists 1%nat; intros.
-  unfold R_dist in |- *;
+  unfold SP, fn; unfold Un_cv; intros; exists 1%nat; intros.
+  unfold R_dist;
     replace
     (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * 0 ^ (2 * k)) n)
     with 1.
-  unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption.
+  unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption.
   rewrite decomp_sum.
-  simpl in |- *; rewrite Rmult_1_r; unfold Rdiv in |- *; rewrite Rinv_1;
-    rewrite Rmult_1_r; pattern 1 at 1 in |- *; rewrite <- Rplus_0_r;
+  simpl; rewrite Rmult_1_r; unfold Rdiv; rewrite Rinv_1;
+    rewrite Rmult_1_r; pattern 1 at 1; rewrite <- Rplus_0_r;
       apply Rplus_eq_compat_l.
-  symmetry  in |- *; apply sum_eq_R0; intros.
+  symmetry ; apply sum_eq_R0; intros.
   rewrite Rmult_0_l; rewrite Rmult_0_r; reflexivity.
   unfold ge in H10; apply lt_le_trans with 1%nat; [ apply lt_n_Sn | apply H10 ].
   apply H5.
   split.
-  unfold D_x, no_cond in |- *; split.
+  unfold D_x, no_cond; split.
   trivial.
-  apply (sym_not_eq (A:=R)); apply H6.
-  unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; apply H7.
-  unfold Boule in |- *; unfold Rminus in |- *; rewrite Ropp_0;
+  apply (not_eq_sym (A:=R)); apply H6.
+  unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r; apply H7.
+  unfold Boule; unfold Rminus; rewrite Ropp_0;
     rewrite Rplus_0_r; rewrite Rabs_R0; apply (cond_pos r).
-  intros; unfold fn in |- *;
+  intros; unfold fn;
     replace (fun x:R => (-1) ^ n / INR (fact (2 * n + 1)) * x ^ (2 * n)) with
     (fct_cte ((-1) ^ n / INR (fact (2 * n + 1))) * pow_fct (2 * n))%F;
     [ idtac | reflexivity ].
@@ -377,13 +229,13 @@ Proof.
   apply (derivable_pt_pow (2 * n) y).
   apply (X r).
   apply (CVN_R_CVS _ X).
-  apply CVN_R_sin; unfold fn in |- *; reflexivity.
+  apply CVN_R_sin; unfold fn; reflexivity.
 Qed.
 
 (** ((cos h)-1)/h -> 0 when h -> 0 *)
 Lemma derivable_pt_lim_cos_0 : derivable_pt_lim cos 0 0.
 Proof.
-  unfold derivable_pt_lim in |- *; intros.
+  unfold derivable_pt_lim; intros.
   assert (H0 := derivable_pt_lim_sin_0).
   unfold derivable_pt_lim in H0.
   cut (0 < eps / 2).
@@ -398,8 +250,8 @@ Proof.
   intro; set (delta := mkposreal _ H6).
   exists delta; intros.
   rewrite Rplus_0_l; replace (cos h - cos 0) with (-2 * Rsqr (sin (h / 2))).
-  unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r.
-  unfold Rdiv in |- *; do 2 rewrite Ropp_mult_distr_l_reverse.
+  unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r.
+  unfold Rdiv; do 2 rewrite Ropp_mult_distr_l_reverse.
   rewrite Rabs_Ropp.
   replace (2 * Rsqr (sin (h * / 2)) * / h) with
   (sin (h / 2) * (sin (h / 2) / (h / 2) - 1) + sin (h / 2)).
@@ -409,12 +261,12 @@ Proof.
   rewrite (double_var eps); apply Rplus_lt_compat.
   apply Rle_lt_trans with (Rabs (sin (h / 2) / (h / 2) - 1)).
   rewrite Rabs_mult; rewrite Rmult_comm;
-    pattern (Rabs (sin (h / 2) / (h / 2) - 1)) at 2 in |- *;
+    pattern (Rabs (sin (h / 2) / (h / 2) - 1)) at 2;
       rewrite <- Rmult_1_r; apply Rmult_le_compat_l.
   apply Rabs_pos.
   assert (H9 := SIN_bound (h / 2)).
-  unfold Rabs in |- *; case (Rcase_abs (sin (h / 2))); intro.
-  pattern 1 at 3 in |- *; rewrite <- (Ropp_involutive 1).
+  unfold Rabs; case (Rcase_abs (sin (h / 2))); intro.
+  pattern 1 at 3; rewrite <- (Ropp_involutive 1).
   apply Ropp_le_contravar.
   elim H9; intros; assumption.
   elim H9; intros; assumption.
@@ -423,50 +275,50 @@ Proof.
   intro; assert (H11 := H2 _ H10 H9).
   rewrite Rplus_0_l in H11; rewrite sin_0 in H11.
   rewrite Rminus_0_r in H11; apply H11.
-  unfold Rdiv in |- *; apply prod_neq_R0.
+  unfold Rdiv; apply prod_neq_R0.
   apply H7.
   apply Rinv_neq_0_compat; discrR.
   apply Rlt_trans with (del / 2).
-  unfold Rdiv in |- *; rewrite Rabs_mult.
+  unfold Rdiv; rewrite Rabs_mult.
   rewrite (Rabs_right (/ 2)).
   do 2 rewrite <- (Rmult_comm (/ 2)); apply Rmult_lt_compat_l.
   apply Rinv_0_lt_compat; prove_sup0.
   apply Rlt_le_trans with (pos delta).
   apply H8.
-  unfold delta in |- *; simpl in |- *; apply Rmin_l.
+  unfold delta; simpl; apply Rmin_l.
   apply Rle_ge; left; apply Rinv_0_lt_compat; prove_sup0.
-  rewrite <- (Rplus_0_r (del / 2)); pattern del at 1 in |- *;
+  rewrite <- (Rplus_0_r (del / 2)); pattern del at 1;
     rewrite (double_var del); apply Rplus_lt_compat_l;
-      unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+      unfold Rdiv; apply Rmult_lt_0_compat.
   apply (cond_pos del).
   apply Rinv_0_lt_compat; prove_sup0.
   elim H5; intros; assert (H11 := H10 (h / 2)).
   rewrite sin_0 in H11; do 2 rewrite Rminus_0_r in H11.
   apply H11.
   split.
-  unfold D_x, no_cond in |- *; split.
+  unfold D_x, no_cond; split.
   trivial.
-  apply (sym_not_eq (A:=R)); unfold Rdiv in |- *; apply prod_neq_R0.
+  apply (not_eq_sym (A:=R)); unfold Rdiv; apply prod_neq_R0.
   apply H7.
   apply Rinv_neq_0_compat; discrR.
   apply Rlt_trans with (del_c / 2).
-  unfold Rdiv in |- *; rewrite Rabs_mult.
+  unfold Rdiv; rewrite Rabs_mult.
   rewrite (Rabs_right (/ 2)).
   do 2 rewrite <- (Rmult_comm (/ 2)).
   apply Rmult_lt_compat_l.
   apply Rinv_0_lt_compat; prove_sup0.
   apply Rlt_le_trans with (pos delta).
   apply H8.
-  unfold delta in |- *; simpl in |- *; apply Rmin_r.
+  unfold delta; simpl; apply Rmin_r.
   apply Rle_ge; left; apply Rinv_0_lt_compat; prove_sup0.
-  rewrite <- (Rplus_0_r (del_c / 2)); pattern del_c at 2 in |- *;
+  rewrite <- (Rplus_0_r (del_c / 2)); pattern del_c at 2;
     rewrite (double_var del_c); apply Rplus_lt_compat_l.
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+  unfold Rdiv; apply Rmult_lt_0_compat.
   apply H9.
   apply Rinv_0_lt_compat; prove_sup0.
-  rewrite Rmult_minus_distr_l; rewrite Rmult_1_r; unfold Rminus in |- *;
+  rewrite Rmult_minus_distr_l; rewrite Rmult_1_r; unfold Rminus;
     rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r;
-      rewrite (Rmult_comm 2); unfold Rdiv, Rsqr in |- *.
+      rewrite (Rmult_comm 2); unfold Rdiv, Rsqr.
   repeat rewrite Rmult_assoc.
   repeat apply Rmult_eq_compat_l.
   rewrite Rinv_mult_distr.
@@ -475,16 +327,16 @@ Proof.
   discrR.
   apply H7.
   apply Rinv_neq_0_compat; discrR.
-  pattern h at 2 in |- *; replace h with (2 * (h / 2)).
+  pattern h at 2; replace h with (2 * (h / 2)).
   rewrite (cos_2a_sin (h / 2)).
-  rewrite cos_0; unfold Rsqr in |- *; ring.
-  unfold Rdiv in |- *; rewrite <- Rmult_assoc; apply Rinv_r_simpl_m.
+  rewrite cos_0; unfold Rsqr; ring.
+  unfold Rdiv; rewrite <- Rmult_assoc; apply Rinv_r_simpl_m.
   discrR.
-  unfold Rmin in |- *; case (Rle_dec del del_c); intro.
+  unfold Rmin; case (Rle_dec del del_c); intro.
   apply (cond_pos del).
   elim H5; intros; assumption.
   apply continuity_sin.
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+  unfold Rdiv; apply Rmult_lt_0_compat;
     [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
 Qed.
 
@@ -494,10 +346,10 @@ Proof.
   intro; assert (H0 := derivable_pt_lim_sin_0).
   assert (H := derivable_pt_lim_cos_0).
   unfold derivable_pt_lim in H0, H.
-  unfold derivable_pt_lim in |- *; intros.
+  unfold derivable_pt_lim; intros.
   cut (0 < eps / 2);
     [ intro
-      | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+      | unfold Rdiv; apply Rmult_lt_0_compat;
         [ apply H1 | apply Rinv_0_lt_compat; prove_sup0 ] ].
   elim (H0 _ H2); intros alp1 H3.
   elim (H _ H2); intros alp2 H4.
@@ -512,11 +364,11 @@ Proof.
   rewrite (double_var eps); apply Rplus_lt_compat.
   apply Rle_lt_trans with (Rabs ((cos h - 1) / h)).
   rewrite Rabs_mult; rewrite Rmult_comm;
-    pattern (Rabs ((cos h - 1) / h)) at 2 in |- *; rewrite <- Rmult_1_r;
+    pattern (Rabs ((cos h - 1) / h)) at 2; rewrite <- Rmult_1_r;
       apply Rmult_le_compat_l.
   apply Rabs_pos.
   assert (H8 := SIN_bound x); elim H8; intros.
-  unfold Rabs in |- *; case (Rcase_abs (sin x)); intro.
+  unfold Rabs; case (Rcase_abs (sin x)); intro.
   rewrite <- (Ropp_involutive 1).
   apply Ropp_le_contravar; assumption.
   assumption.
@@ -526,14 +378,14 @@ Proof.
     apply H9.
   apply Rlt_le_trans with alp.
   apply H7.
-  unfold alp in |- *; apply Rmin_r.
+  unfold alp; apply Rmin_r.
   apply Rle_lt_trans with (Rabs (sin h / h - 1)).
   rewrite Rabs_mult; rewrite Rmult_comm;
-    pattern (Rabs (sin h / h - 1)) at 2 in |- *; rewrite <- Rmult_1_r;
+    pattern (Rabs (sin h / h - 1)) at 2; rewrite <- Rmult_1_r;
       apply Rmult_le_compat_l.
   apply Rabs_pos.
   assert (H8 := COS_bound x); elim H8; intros.
-  unfold Rabs in |- *; case (Rcase_abs (cos x)); intro.
+  unfold Rabs; case (Rcase_abs (cos x)); intro.
   rewrite <- (Ropp_involutive 1); apply Ropp_le_contravar; assumption.
   assumption.
   cut (Rabs h < alp1).
@@ -542,8 +394,8 @@ Proof.
     apply H9.
   apply Rlt_le_trans with alp.
   apply H7.
-  unfold alp in |- *; apply Rmin_l.
-  rewrite sin_plus; unfold Rminus, Rdiv in |- *;
+  unfold alp; apply Rmin_l.
+  rewrite sin_plus; unfold Rminus, Rdiv;
     repeat rewrite Rmult_plus_distr_r; repeat rewrite Rmult_plus_distr_l;
       repeat rewrite Rmult_assoc; repeat rewrite Rplus_assoc;
         apply Rplus_eq_compat_l.
@@ -552,7 +404,7 @@ Proof.
   rewrite Ropp_mult_distr_r_reverse; rewrite Ropp_mult_distr_l_reverse;
     rewrite Rmult_1_r; rewrite Rmult_1_l; rewrite Ropp_mult_distr_r_reverse;
       rewrite <- Ropp_mult_distr_l_reverse; apply Rplus_comm.
-  unfold alp in |- *; unfold Rmin in |- *; case (Rle_dec alp1 alp2); intro.
+  unfold alp; unfold Rmin; case (Rle_dec alp1 alp2); intro.
   apply (cond_pos alp1).
   apply (cond_pos alp2).
 Qed.
@@ -567,7 +419,7 @@ Proof.
   intros; generalize (H0 _ _ _ H2 H1);
     replace (comp sin (id + fct_cte (PI / 2))%F) with
     (fun x:R => sin (x + PI / 2)); [ idtac | reflexivity ].
-  unfold derivable_pt_lim in |- *; intros.
+  unfold derivable_pt_lim; intros.
   elim (H3 eps H4); intros.
   exists x0.
   intros; rewrite <- (H (x + h)); rewrite <- (H x); apply H5; assumption.
@@ -581,26 +433,26 @@ Qed.
 
 Lemma derivable_pt_sin : forall x:R, derivable_pt sin x.
 Proof.
-  unfold derivable_pt in |- *; intro.
+  unfold derivable_pt; intro.
   exists (cos x).
   apply derivable_pt_lim_sin.
 Qed.
 
 Lemma derivable_pt_cos : forall x:R, derivable_pt cos x.
 Proof.
-  unfold derivable_pt in |- *; intro.
+  unfold derivable_pt; intro.
   exists (- sin x).
   apply derivable_pt_lim_cos.
 Qed.
 
 Lemma derivable_sin : derivable sin.
 Proof.
-  unfold derivable in |- *; intro; apply derivable_pt_sin.
+  unfold derivable; intro; apply derivable_pt_sin.
 Qed.
 
 Lemma derivable_cos : derivable cos.
 Proof.
-  unfold derivable in |- *; intro; apply derivable_pt_cos.
+  unfold derivable; intro; apply derivable_pt_cos.
 Qed.
 
 Lemma derive_pt_sin :
diff --git a/theories/Reals/SeqProp.v b/theories/Reals/SeqProp.v
index 7a1319ea..41e853cc 100644
--- a/theories/Reals/SeqProp.v
+++ b/theories/Reals/SeqProp.v
@@ -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-2012     *)
 (*   \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.
+Local Open Scope R_scope.
 
 (*****************************************************************)
 (**           Convergence properties of sequences                *)
@@ -29,38 +26,17 @@ 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 :
   forall Un:nat -> R, Un_decreasing Un -> Un_growing (opp_seq Un).
 Proof.
   intro.
-  unfold Un_growing, opp_seq, Un_decreasing in |- *.
+  unfold Un_growing, opp_seq, Un_decreasing.
   intros.
   apply Ropp_le_contravar.
   apply H.
@@ -82,8 +58,8 @@ Proof.
   unfold Un_cv in p.
   unfold R_dist in p.
   unfold opp_seq in p.
-  unfold Un_cv in |- *.
-  unfold R_dist in |- *.
+  unfold Un_cv.
+  unfold R_dist.
   intros.
   elim (p eps H1); intros.
   exists x0; intros.
@@ -101,7 +77,7 @@ Proof.
   apply completeness.
   assumption.
   exists (Un 0%nat).
-  unfold EUn in |- *.
+  unfold EUn.
   exists 0%nat; reflexivity.
 Qed.
 
@@ -138,9 +114,9 @@ Proof.
   unfold bound in H.
   elim H; intros.
   unfold is_upper_bound in H0.
-  unfold has_ub in |- *.
+  unfold has_ub.
   exists x.
-  unfold is_upper_bound in |- *.
+  unfold is_upper_bound.
   intros.
   apply H0.
   elim H1; intros.
@@ -156,9 +132,9 @@ Proof.
   unfold bound in H.
   elim H; intros.
   unfold is_upper_bound in H0.
-  unfold has_lb in |- *.
+  unfold has_lb.
   exists x.
-  unfold is_upper_bound in |- *.
+  unfold is_upper_bound.
   intros.
   apply H0.
   elim H1; intros.
@@ -179,9 +155,9 @@ Lemma Wn_decreasing :
   forall (Un:nat -> R) (pr:has_ub Un), Un_decreasing (sequence_ub Un pr).
 Proof.
   intros.
-  unfold Un_decreasing in |- *.
+  unfold Un_decreasing.
   intro.
-  unfold sequence_ub in |- *.
+  unfold sequence_ub.
   assert (H := ub_to_lub (fun k:nat => Un (S n + k)%nat) (maj_ss Un (S n) pr)).
   assert (H0 := ub_to_lub (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr)).
   elim H; intros.
@@ -195,7 +171,7 @@ Proof.
   elim p; intros.
   apply H2.
   elim p0; intros.
-  unfold is_upper_bound in |- *.
+  unfold is_upper_bound.
   intros.
   unfold is_upper_bound in H3.
   apply H3.
@@ -214,7 +190,7 @@ Proof.
   assert
     (H7 := H3 (lub (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr)) H4).
   apply Rle_antisym; assumption.
-  unfold lub in |- *.
+  unfold lub.
   case (ub_to_lub (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr)).
   trivial.
   cut
@@ -228,7 +204,7 @@ Proof.
     (H7 :=
       H3 (lub (fun k:nat => Un (S n + k)%nat) (maj_ss Un (S n) pr)) H4).
   apply Rle_antisym; assumption.
-  unfold lub in |- *.
+  unfold lub.
   case (ub_to_lub (fun k:nat => Un (S n + k)%nat) (maj_ss Un (S n) pr)).
   trivial.
 Qed.
@@ -237,9 +213,9 @@ Lemma Vn_growing :
   forall (Un:nat -> R) (pr:has_lb Un), Un_growing (sequence_lb Un pr).
 Proof.
   intros.
-  unfold Un_growing in |- *.
+  unfold Un_growing.
   intro.
-  unfold sequence_lb in |- *.
+  unfold sequence_lb.
   assert (H := lb_to_glb (fun k:nat => Un (S n + k)%nat) (min_ss Un (S n) pr)).
   assert (H0 := lb_to_glb (fun k:nat => Un (n + k)%nat) (min_ss Un n pr)).
   elim H; intros.
@@ -254,14 +230,14 @@ Proof.
   apply Ropp_le_contravar.
   apply H2.
   elim p0; intros.
-  unfold is_upper_bound in |- *.
+  unfold is_upper_bound.
   intros.
   unfold is_upper_bound in H3.
   apply H3.
   elim H5; intros.
   exists (1 + x2)%nat.
   unfold opp_seq in H6.
-  unfold opp_seq in |- *.
+  unfold opp_seq.
   replace (n + (1 + x2))%nat with (S n + x2)%nat.
   assumption.
   replace (S n) with (1 + n)%nat; [ ring | ring ].
@@ -278,7 +254,7 @@ Proof.
     (Ropp_involutive (glb (fun k:nat => Un (n + k)%nat) (min_ss Un n pr)))
     .
   apply Ropp_eq_compat; apply Rle_antisym; assumption.
-  unfold glb in |- *.
+  unfold glb.
   case (lb_to_glb (fun k:nat => Un (n + k)%nat) (min_ss Un n pr)); simpl.
   intro; rewrite Ropp_involutive.
   trivial.
@@ -297,7 +273,7 @@ Proof.
       (glb (fun k:nat => Un (S n + k)%nat) (min_ss Un (S n) pr)))
     .
   apply Ropp_eq_compat; apply Rle_antisym; assumption.
-  unfold glb in |- *.
+  unfold glb.
   case (lb_to_glb (fun k:nat => Un (S n + k)%nat) (min_ss Un (S n) pr)); simpl.
   intro; rewrite Ropp_involutive.
   trivial.
@@ -310,7 +286,7 @@ Lemma Vn_Un_Wn_order :
 Proof.
   intros.
   split.
-  unfold sequence_lb in |- *.
+  unfold sequence_lb.
   cut { l:R | is_lub (EUn (opp_seq (fun i:nat => Un (n + i)%nat))) l }.
   intro X.
   elim X; intros.
@@ -322,7 +298,7 @@ Proof.
   apply Ropp_le_contravar.
   apply H.
   exists 0%nat.
-  unfold opp_seq in |- *.
+  unfold opp_seq.
   replace (n + 0)%nat with n; [ reflexivity | ring ].
   cut
     (is_lub (EUn (opp_seq (fun k:nat => Un (n + k)%nat)))
@@ -337,13 +313,13 @@ Proof.
     (Ropp_involutive (glb (fun k:nat => Un (n + k)%nat) (min_ss Un n pr2)))
     .
   apply Ropp_eq_compat; apply Rle_antisym; assumption.
-  unfold glb in |- *.
+  unfold glb.
   case (lb_to_glb (fun k:nat => Un (n + k)%nat) (min_ss Un n pr2)); simpl.
   intro; rewrite Ropp_involutive.
   trivial.
   apply lb_to_glb.
   apply min_ss; assumption.
-  unfold sequence_ub in |- *.
+  unfold sequence_ub.
   cut { l:R | is_lub (EUn (fun i:nat => Un (n + i)%nat)) l }.
   intro X.
   elim X; intros.
@@ -364,7 +340,7 @@ Proof.
   assert
     (H5 := H1 (lub (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr1)) H2).
   apply Rle_antisym; assumption.
-  unfold lub in |- *.
+  unfold lub.
   case (ub_to_lub (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr1)).
   intro; trivial.
   apply ub_to_lub.
@@ -377,13 +353,13 @@ Lemma min_maj :
 Proof.
   intros.
   assert (H := Vn_Un_Wn_order Un pr1 pr2).
-  unfold has_ub in |- *.
-  unfold bound in |- *.
+  unfold has_ub.
+  unfold bound.
   unfold has_ub in pr1.
   unfold bound in pr1.
   elim pr1; intros.
   exists x.
-  unfold is_upper_bound in |- *.
+  unfold is_upper_bound.
   intros.
   unfold is_upper_bound in H0.
   elim H1; intros.
@@ -400,20 +376,20 @@ Lemma maj_min :
 Proof.
   intros.
   assert (H := Vn_Un_Wn_order Un pr1 pr2).
-  unfold has_lb in |- *.
-  unfold bound in |- *.
+  unfold has_lb.
+  unfold bound.
   unfold has_lb in pr2.
   unfold bound in pr2.
   elim pr2; intros.
   exists x.
-  unfold is_upper_bound in |- *.
+  unfold is_upper_bound.
   intros.
   unfold is_upper_bound in H0.
   elim H1; intros.
   rewrite H2.
   apply Rle_trans with (opp_seq Un x1).
   assert (H3 := H x1); elim H3; intros.
-  unfold opp_seq in |- *; apply Ropp_le_contravar.
+  unfold opp_seq; apply Ropp_le_contravar.
   assumption.
   apply H0.
   exists x1; reflexivity.
@@ -423,7 +399,7 @@ Qed.
 Lemma cauchy_maj : forall Un:nat -> R, Cauchy_crit Un -> has_ub Un.
 Proof.
   intros.
-  unfold has_ub in |- *.
+  unfold has_ub.
   apply cauchy_bound.
   assumption.
 Qed.
@@ -433,12 +409,12 @@ Lemma cauchy_opp :
   forall Un:nat -> R, Cauchy_crit Un -> Cauchy_crit (opp_seq Un).
 Proof.
   intro.
-  unfold Cauchy_crit in |- *.
-  unfold R_dist in |- *.
+  unfold Cauchy_crit.
+  unfold R_dist.
   intros.
   elim (H eps H0); intros.
   exists x; intros.
-  unfold opp_seq in |- *.
+  unfold opp_seq.
   rewrite <- Rabs_Ropp.
   replace (- (- Un n - - Un m)) with (Un n - Un m);
   [ apply H1; assumption | ring ].
@@ -448,7 +424,7 @@ Qed.
 Lemma cauchy_min : forall Un:nat -> R, Cauchy_crit Un -> has_lb Un.
 Proof.
   intros.
-  unfold has_lb in |- *.
+  unfold has_lb.
   assert (H0 := cauchy_opp _ H).
   apply cauchy_bound.
   assumption.
@@ -509,7 +485,7 @@ Qed.
 
 Lemma not_Rlt : forall r1 r2:R, ~ r1 < r2 -> r1 >= r2.
 Proof.
-  intros r1 r2; generalize (Rtotal_order r1 r2); unfold Rge in |- *.
+  intros r1 r2; generalize (Rtotal_order r1 r2); unfold Rge.
   tauto.
 Qed.
 
@@ -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,83 +572,34 @@ 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 *)
 Lemma UL_sequence :
   forall (Un:nat -> R) (l1 l2:R), Un_cv Un l1 -> Un_cv Un l2 -> l1 = l2.
 Proof.
-  intros Un l1 l2; unfold Un_cv in |- *; unfold R_dist in |- *; intros.
+  intros Un l1 l2; unfold Un_cv; unfold R_dist; intros.
   apply cond_eq.
   intros; cut (0 < eps / 2);
     [ intro
-      | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+      | unfold Rdiv; apply Rmult_lt_0_compat;
         [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ].
   elim (H (eps / 2) H2); intros.
   elim (H0 (eps / 2) H2); intros.
@@ -673,8 +609,8 @@ Proof.
   [ apply Rabs_triang | ring ].
   rewrite (double_var eps); apply Rplus_lt_compat.
   rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H3;
-    unfold ge, N in |- *; apply le_max_l.
-  apply H4; unfold ge, N in |- *; apply le_max_r.
+    unfold ge, N; apply le_max_l.
+  apply H4; unfold ge, N; apply le_max_r.
 Qed.
 
 (**********)
@@ -682,10 +618,10 @@ Lemma CV_plus :
   forall (An Bn:nat -> R) (l1 l2:R),
     Un_cv An l1 -> Un_cv Bn l2 -> Un_cv (fun i:nat => An i + Bn i) (l1 + l2).
 Proof.
-  unfold Un_cv in |- *; unfold R_dist in |- *; intros.
+  unfold Un_cv; unfold R_dist; intros.
   cut (0 < eps / 2);
     [ intro
-      | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+      | unfold Rdiv; apply Rmult_lt_0_compat;
         [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ].
   elim (H (eps / 2) H2); intros.
   elim (H0 (eps / 2) H2); intros.
@@ -696,10 +632,10 @@ Proof.
   apply Rle_lt_trans with (Rabs (An n - l1) + Rabs (Bn n - l2)).
   apply Rabs_triang.
   rewrite (double_var eps); apply Rplus_lt_compat.
-  apply H3; unfold ge in |- *; apply le_trans with N;
-    [ unfold N in |- *; apply le_max_l | assumption ].
-  apply H4; unfold ge in |- *; apply le_trans with N;
-    [ unfold N in |- *; apply le_max_r | assumption ].
+  apply H3; unfold ge; apply le_trans with N;
+    [ unfold N; apply le_max_l | assumption ].
+  apply H4; unfold ge; apply le_trans with N;
+    [ unfold N; apply le_max_r | assumption ].
 Qed.
 
 (**********)
@@ -707,7 +643,7 @@ Lemma cv_cvabs :
   forall (Un:nat -> R) (l:R),
     Un_cv Un l -> Un_cv (fun i:nat => Rabs (Un i)) (Rabs l).
 Proof.
-  unfold Un_cv in |- *; unfold R_dist in |- *; intros.
+  unfold Un_cv; unfold R_dist; intros.
   elim (H eps H0); intros.
   exists x; intros.
   apply Rle_lt_trans with (Rabs (Un n - l)).
@@ -720,15 +656,15 @@ Lemma CV_Cauchy :
   forall Un:nat -> R, { l:R | Un_cv Un l } -> Cauchy_crit Un.
 Proof.
   intros Un X; elim X; intros.
-  unfold Cauchy_crit in |- *; intros.
+  unfold Cauchy_crit; intros.
   unfold Un_cv in p; unfold R_dist in p.
   cut (0 < eps / 2);
     [ intro
-      | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+      | unfold Rdiv; apply Rmult_lt_0_compat;
         [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ].
   elim (p (eps / 2) H0); intros.
   exists x0; intros.
-  unfold R_dist in |- *;
+  unfold R_dist;
     apply Rle_lt_trans with (Rabs (Un n - x) + Rabs (x - Un m)).
   replace (Un n - Un m) with (Un n - x + (x - Un m));
   [ apply Rabs_triang | ring ].
@@ -759,7 +695,7 @@ Proof.
   unfold is_upper_bound in H1.
   apply H1.
   exists n; reflexivity.
-  pattern x0 at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left;
+  pattern x0 at 1; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left;
     apply Rlt_0_1.
   apply Rle_trans with (Rabs (Un 0%nat)).
   apply Rabs_pos.
@@ -781,7 +717,7 @@ Proof.
   assert (H1 := maj_by_pos An X).
   elim H1; intros M H2.
   elim H2; intros.
-  unfold Un_cv in |- *; unfold R_dist in |- *; intros.
+  unfold Un_cv; unfold R_dist; intros.
   cut (0 < eps / (2 * M)).
   intro.
   case (Req_dec l2 0); intro.
@@ -808,24 +744,24 @@ Proof.
   rewrite Rmult_1_l; rewrite (Rmult_comm (/ M)).
   apply Rlt_trans with (eps / (2 * M)).
   apply H8; assumption.
-  unfold Rdiv in |- *; rewrite Rinv_mult_distr.
+  unfold Rdiv; rewrite Rinv_mult_distr.
   apply Rmult_lt_reg_l with 2.
   prove_sup0.
   replace (2 * (eps * (/ 2 * / M))) with (2 * / 2 * (eps * / M));
   [ idtac | ring ].
   rewrite <- Rinv_r_sym.
   rewrite Rmult_1_l; rewrite double.
-  pattern (eps * / M) at 1 in |- *; rewrite <- Rplus_0_r.
+  pattern (eps * / M) at 1; rewrite <- Rplus_0_r.
   apply Rplus_lt_compat_l; apply Rmult_lt_0_compat;
     [ assumption | apply Rinv_0_lt_compat; assumption ].
   discrR.
   discrR.
-  red in |- *; intro; rewrite H10 in H3; elim (Rlt_irrefl _ H3).
-  red in |- *; intro; rewrite H10 in H3; elim (Rlt_irrefl _ H3).
-  rewrite H7; do 2 rewrite Rmult_0_r; unfold Rminus in |- *;
+  red; intro; rewrite H10 in H3; elim (Rlt_irrefl _ H3).
+  red; intro; rewrite H10 in H3; elim (Rlt_irrefl _ H3).
+  rewrite H7; do 2 rewrite Rmult_0_r; unfold Rminus;
     rewrite Rplus_opp_r; rewrite Rabs_R0; reflexivity.
   replace (An n * Bn n - An n * l2) with (An n * (Bn n - l2)); [ idtac | ring ].
-  symmetry  in |- *; apply Rabs_mult.
+  symmetry ; apply Rabs_mult.
   cut (0 < eps / (2 * Rabs l2)).
   intro.
   unfold Un_cv in H; unfold R_dist in H; unfold Un_cv in H0;
@@ -854,36 +790,36 @@ Proof.
   rewrite Rmult_1_l; rewrite (Rmult_comm (/ M)).
   apply Rlt_le_trans with (eps / (2 * M)).
   apply H10.
-  unfold ge in |- *; apply le_trans with N.
-  unfold N in |- *; apply le_max_r.
+  unfold ge; apply le_trans with N.
+  unfold N; apply le_max_r.
   assumption.
-  unfold Rdiv in |- *; rewrite Rinv_mult_distr.
+  unfold Rdiv; rewrite Rinv_mult_distr.
   right; ring.
   discrR.
-  red in |- *; intro; rewrite H12 in H3; elim (Rlt_irrefl _ H3).
-  red in |- *; intro; rewrite H12 in H3; elim (Rlt_irrefl _ H3).
+  red; intro; rewrite H12 in H3; elim (Rlt_irrefl _ H3).
+  red; intro; rewrite H12 in H3; elim (Rlt_irrefl _ H3).
   apply Rmult_lt_reg_l with (/ Rabs l2).
   apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption.
   rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
   rewrite Rmult_1_l; apply Rlt_le_trans with (eps / (2 * Rabs l2)).
   apply H9.
-  unfold ge in |- *; apply le_trans with N.
-  unfold N in |- *; apply le_max_l.
+  unfold ge; apply le_trans with N.
+  unfold N; apply le_max_l.
   assumption.
-  unfold Rdiv in |- *; right; rewrite Rinv_mult_distr.
+  unfold Rdiv; right; rewrite Rinv_mult_distr.
   ring.
   discrR.
   apply Rabs_no_R0; assumption.
   apply Rabs_no_R0; assumption.
   replace (An n * l2 - l1 * l2) with (l2 * (An n - l1));
-  [ symmetry  in |- *; apply Rabs_mult | ring ].
+  [ symmetry ; apply Rabs_mult | ring ].
   replace (An n * Bn n - An n * l2) with (An n * (Bn n - l2));
-  [ symmetry  in |- *; apply Rabs_mult | ring ].
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+  [ symmetry ; apply Rabs_mult | ring ].
+  unfold Rdiv; apply Rmult_lt_0_compat.
   assumption.
   apply Rinv_0_lt_compat; apply Rmult_lt_0_compat;
     [ prove_sup0 | apply Rabs_pos_lt; assumption ].
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
+  unfold Rdiv; apply Rmult_lt_0_compat;
     [ assumption
       | apply Rinv_0_lt_compat; apply Rmult_lt_0_compat;
         [ prove_sup0 | assumption ] ].
@@ -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 ->
@@ -989,15 +858,15 @@ Proof.
   intros; exists (k + (1 - k) / 2).
   split.
   split.
-  pattern k at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l.
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+  pattern k at 1; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l.
+  unfold Rdiv; apply Rmult_lt_0_compat.
   apply Rplus_lt_reg_r with k; rewrite Rplus_0_r; replace (k + (1 - k)) with 1;
     [ elim H; intros; assumption | ring ].
   apply Rinv_0_lt_compat; prove_sup0.
   apply Rmult_lt_reg_l with 2.
   prove_sup0.
-  unfold Rdiv in |- *; rewrite Rmult_1_r; rewrite Rmult_plus_distr_l;
-    pattern 2 at 1 in |- *; rewrite Rmult_comm; rewrite Rmult_assoc;
+  unfold Rdiv; rewrite Rmult_1_r; rewrite Rmult_plus_distr_l;
+    pattern 2 at 1; rewrite Rmult_comm; rewrite Rmult_assoc;
       rewrite <- Rinv_l_sym; [ idtac | discrR ]; rewrite Rmult_1_r;
         replace (2 * k + (1 - k)) with (1 + k); [ idtac | ring ].
   elim H; intros.
@@ -1016,7 +885,7 @@ Proof.
     repeat rewrite <- Rplus_assoc; rewrite Rplus_opp_l;
       repeat rewrite Rplus_0_l; apply H4.
   apply Rle_ge; elim H; intros; assumption.
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+  unfold Rdiv; apply Rmult_lt_0_compat.
   apply Rplus_lt_reg_r with k; rewrite Rplus_0_r; elim H; intros;
     replace (k + (1 - k)) with 1; [ assumption | ring ].
   apply Rinv_0_lt_compat; prove_sup0.
@@ -1041,12 +910,12 @@ Proof.
   apply Rle_lt_trans with (Rabs (Un N - l)).
   apply RRle_abs.
   apply H2.
-  unfold ge, N in |- *; apply le_max_r.
-  unfold Rminus in |- *; do 2 rewrite <- (Rplus_comm (- l));
+  unfold ge, N; apply le_max_r.
+  unfold Rminus; do 2 rewrite <- (Rplus_comm (- l));
     apply Rplus_le_compat_l.
   apply tech9.
   assumption.
-  unfold N in |- *; apply le_max_l.
+  unfold N; apply le_max_l.
   apply Rplus_lt_reg_r with l.
   rewrite Rplus_0_r.
   replace (l + (Un n - l)) with (Un n); [ assumption | ring ].
@@ -1057,10 +926,10 @@ Lemma CV_opp :
   forall (An:nat -> R) (l:R), Un_cv An l -> Un_cv (opp_seq An) (- l).
 Proof.
   intros An l.
-  unfold Un_cv in |- *; unfold R_dist in |- *; intros.
+  unfold Un_cv; unfold R_dist; intros.
   elim (H eps H0); intros.
   exists x; intros.
-  unfold opp_seq in |- *; replace (- An n - - l) with (- (An n - l));
+  unfold opp_seq; replace (- An n - - l) with (- (An n - l));
     [ rewrite Rabs_Ropp | ring ].
   apply H1; assumption.
 Qed.
@@ -1085,10 +954,10 @@ Lemma CV_minus :
 Proof.
   intros.
   replace (fun i:nat => An i - Bn i) with (fun i:nat => An i + opp_seq Bn i).
-  unfold Rminus in |- *; apply CV_plus.
+  unfold Rminus; apply CV_plus.
   assumption.
   apply CV_opp; assumption.
-  unfold Rminus, opp_seq in |- *; reflexivity.
+  unfold Rminus, opp_seq; reflexivity.
 Qed.
 
 (** Un -> +oo *)
@@ -1100,10 +969,10 @@ Lemma cv_infty_cv_R0 :
   forall Un:nat -> R,
     (forall n:nat, Un n <> 0) -> cv_infty Un -> Un_cv (fun n:nat => / Un n) 0.
 Proof.
-  unfold cv_infty, Un_cv in |- *; unfold R_dist in |- *; intros.
+  unfold cv_infty, Un_cv; unfold R_dist; intros.
   elim (H0 (/ eps)); intros N0 H2.
   exists N0; intros.
-  unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r;
+  unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r;
     rewrite (Rabs_Rinv _ (H n)).
   apply Rmult_lt_reg_l with (Rabs (Un n)).
   apply Rabs_pos_lt; apply H.
@@ -1115,7 +984,7 @@ Proof.
   rewrite Rmult_1_r; apply Rlt_le_trans with (Un n).
   apply H2; assumption.
   apply RRle_abs.
-  red in |- *; intro; rewrite H4 in H1; elim (Rlt_irrefl _ H1).
+  red; intro; rewrite H4 in H1; elim (Rlt_irrefl _ H1).
   apply Rabs_no_R0; apply H.
 Qed.
 
@@ -1124,7 +993,7 @@ Lemma decreasing_prop :
   forall (Un:nat -> R) (m n:nat),
     Un_decreasing Un -> (m <= n)%nat -> Un n <= Un m.
 Proof.
-  unfold Un_decreasing in |- *; intros.
+  unfold Un_decreasing; intros.
   induction  n as [| n Hrecn].
   induction  m as [| m Hrecm].
   right; reflexivity.
@@ -1147,17 +1016,17 @@ Proof.
       (Un_cv (fun n:nat => Rabs x ^ n / INR (fact n)) 0 ->
         Un_cv (fun n:nat => x ^ n / INR (fact n)) 0).
   intro; apply H.
-  unfold Un_cv in |- *; unfold R_dist in |- *; intros; case (Req_dec x 0);
+  unfold Un_cv; unfold R_dist; intros; case (Req_dec x 0);
     intro.
   exists 1%nat; intros.
-  rewrite H1; unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r;
+  rewrite H1; unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r;
     rewrite Rabs_R0; rewrite pow_ne_zero;
-      [ unfold Rdiv in |- *; rewrite Rmult_0_l; rewrite Rabs_R0; assumption
-        | red in |- *; intro; rewrite H3 in H2; elim (le_Sn_n _ H2) ].
+      [ unfold Rdiv; rewrite Rmult_0_l; rewrite Rabs_R0; assumption
+        | red; intro; rewrite H3 in H2; elim (le_Sn_n _ H2) ].
   assert (H2 := Rabs_pos_lt x H1); set (M := up (Rabs x)); cut (0 <= M)%Z.
   intro; elim (IZN M H3); intros M_nat H4.
   set (Un := fun n:nat => Rabs x ^ (M_nat + n) / INR (fact (M_nat + n))).
-  cut (Un_cv Un 0); unfold Un_cv in |- *; unfold R_dist in |- *; intros.
+  cut (Un_cv Un 0); unfold Un_cv; unfold R_dist; intros.
   elim (H5 eps H0); intros N H6.
   exists (M_nat + N)%nat; intros;
     cut (exists p : nat, (p >= N)%nat /\ n = (M_nat + p)%nat).
@@ -1165,7 +1034,7 @@ Proof.
   elim H9; intros; rewrite H11; unfold Un in H6; apply H6; assumption.
   exists (n - M_nat)%nat.
   split.
-  unfold ge in |- *; apply (fun p n m:nat => plus_le_reg_l n m p) with M_nat;
+  unfold ge; apply (fun p n m:nat => plus_le_reg_l n m p) with M_nat;
     rewrite <- le_plus_minus.
   assumption.
   apply le_trans with (M_nat + N)%nat.
@@ -1179,43 +1048,43 @@ Proof.
   intro; cut (Un_decreasing Un).
   intro; cut (forall n:nat, Un (S n) <= Vn n).
   intro; cut (Un_cv Vn 0).
-  unfold Un_cv in |- *; unfold R_dist in |- *; intros.
+  unfold Un_cv; unfold R_dist; intros.
   elim (H10 eps0 H5); intros N1 H11.
   exists (S N1); intros.
   cut (forall n:nat, 0 < Vn n).
   intro; apply Rle_lt_trans with (Rabs (Vn (pred n) - 0)).
   repeat rewrite Rabs_right.
-  unfold Rminus in |- *; rewrite Ropp_0; do 2 rewrite Rplus_0_r;
+  unfold Rminus; rewrite Ropp_0; do 2 rewrite Rplus_0_r;
     replace n with (S (pred n)).
   apply H9.
-  inversion H12; simpl in |- *; reflexivity.
-  apply Rle_ge; unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; left;
+  inversion H12; simpl; reflexivity.
+  apply Rle_ge; unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r; left;
     apply H13.
-  apply Rle_ge; unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; left;
+  apply Rle_ge; unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r; left;
     apply H7.
-  apply H11; unfold ge in |- *; apply le_S_n; replace (S (pred n)) with n;
-    [ unfold ge in H12; exact H12 | inversion H12; simpl in |- *; reflexivity ].
+  apply H11; unfold ge; apply le_S_n; replace (S (pred n)) with n;
+    [ unfold ge in H12; exact H12 | inversion H12; simpl; reflexivity ].
   intro; apply Rlt_le_trans with (Un (S n0)); [ apply H7 | apply H9 ].
   cut (cv_infty (fun n:nat => INR (S n))).
   intro; cut (Un_cv (fun n:nat => / INR (S n)) 0).
-  unfold Un_cv, R_dist in |- *; intros; unfold Vn in |- *.
+  unfold Un_cv, R_dist; intros; unfold Vn.
   cut (0 < eps1 / (Rabs x * Un 0%nat)).
   intro; elim (H11 _ H13); intros N H14.
   exists N; intros;
     replace (Rabs x * (Un 0%nat / INR (S n)) - 0) with
     (Rabs x * Un 0%nat * (/ INR (S n) - 0));
-    [ idtac | unfold Rdiv in |- *; ring ].
+    [ idtac | unfold Rdiv; ring ].
   rewrite Rabs_mult; apply Rmult_lt_reg_l with (/ Rabs (Rabs x * Un 0%nat)).
   apply Rinv_0_lt_compat; apply Rabs_pos_lt.
   apply prod_neq_R0.
   apply Rabs_no_R0; assumption.
-  assert (H16 := H7 0%nat); red in |- *; intro; rewrite H17 in H16;
+  assert (H16 := H7 0%nat); red; intro; rewrite H17 in H16;
     elim (Rlt_irrefl _ H16).
   rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
   rewrite Rmult_1_l.
   replace (/ Rabs (Rabs x * Un 0%nat) * eps1) with (eps1 / (Rabs x * Un 0%nat)).
   apply H14; assumption.
-  unfold Rdiv in |- *; rewrite (Rabs_right (Rabs x * Un 0%nat)).
+  unfold Rdiv; rewrite (Rabs_right (Rabs x * Un 0%nat)).
   apply Rmult_comm.
   apply Rle_ge; apply Rmult_le_pos.
   apply Rabs_pos.
@@ -1223,9 +1092,9 @@ Proof.
   apply Rabs_no_R0.
   apply prod_neq_R0;
     [ apply Rabs_no_R0; assumption
-      | assert (H16 := H7 0%nat); red in |- *; intro; rewrite H17 in H16;
+      | assert (H16 := H7 0%nat); red; intro; rewrite H17 in H16;
         elim (Rlt_irrefl _ H16) ].
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+  unfold Rdiv; apply Rmult_lt_0_compat.
   assumption.
   apply Rinv_0_lt_compat; apply Rmult_lt_0_compat.
   apply Rabs_pos_lt; assumption.
@@ -1233,7 +1102,7 @@ Proof.
   apply (cv_infty_cv_R0 (fun n:nat => INR (S n))).
   intro; apply not_O_INR; discriminate.
   assumption.
-  unfold cv_infty in |- *; intro; case (total_order_T M0 0); intro.
+  unfold cv_infty; intro; case (total_order_T M0 0); intro.
   elim s; intro.
   exists 0%nat; intros.
   apply Rlt_trans with 0; [ assumption | apply lt_INR_0; apply lt_O_Sn ].
@@ -1247,13 +1116,13 @@ Proof.
   elim H10; intros; assumption.
   rewrite H12; rewrite <- INR_IZR_INZ; apply le_INR.
   apply le_trans with n; [ assumption | apply le_n_Sn ].
-  apply le_IZR; left; simpl in |- *; unfold M0_z in |- *;
+  apply le_IZR; left; simpl; unfold M0_z;
     apply Rlt_trans with M0; [ assumption | elim H10; intros; assumption ].
   intro; apply Rle_trans with (Rabs x * Un n * / INR (S n)).
-  unfold Un in |- *; replace (M_nat + S n)%nat with (M_nat + n + 1)%nat.
+  unfold Un; replace (M_nat + S n)%nat with (M_nat + n + 1)%nat.
   rewrite pow_add; replace (Rabs x ^ 1) with (Rabs x);
-    [ idtac | simpl in |- *; ring ].
-  unfold Rdiv in |- *; rewrite <- (Rmult_comm (Rabs x));
+    [ idtac | simpl; ring ].
+  unfold Rdiv; rewrite <- (Rmult_comm (Rabs x));
     repeat rewrite Rmult_assoc; repeat apply Rmult_le_compat_l.
   apply Rabs_pos.
   left; apply pow_lt; assumption.
@@ -1261,33 +1130,33 @@ Proof.
   rewrite fact_simpl; rewrite mult_comm; rewrite mult_INR;
     rewrite Rinv_mult_distr.
   apply Rmult_le_compat_l.
-  left; apply Rinv_0_lt_compat; apply lt_INR_0; apply neq_O_lt; red in |- *;
-    intro; assert (H10 := sym_eq H9); elim (fact_neq_0 _ H10).
+  left; apply Rinv_0_lt_compat; apply lt_INR_0; apply neq_O_lt; red;
+    intro; assert (H10 := eq_sym H9); elim (fact_neq_0 _ H10).
   left; apply Rinv_lt_contravar.
   apply Rmult_lt_0_compat; apply lt_INR_0; apply lt_O_Sn.
   apply lt_INR; apply lt_n_S.
-  pattern n at 1 in |- *; replace n with (0 + n)%nat; [ idtac | reflexivity ].
+  pattern n at 1; replace n with (0 + n)%nat; [ idtac | reflexivity ].
   apply plus_lt_compat_r.
   apply lt_le_trans with 1%nat; [ apply lt_O_Sn | assumption ].
   apply INR_fact_neq_0.
   apply not_O_INR; discriminate.
   ring.
   ring.
-  unfold Vn in |- *; rewrite Rmult_assoc; unfold Rdiv in |- *;
+  unfold Vn; rewrite Rmult_assoc; unfold Rdiv;
     rewrite (Rmult_comm (Un 0%nat)); rewrite (Rmult_comm (Un n)).
   repeat apply Rmult_le_compat_l.
   apply Rabs_pos.
   left; apply Rinv_0_lt_compat; apply lt_INR_0; apply lt_O_Sn.
   apply decreasing_prop; [ assumption | apply le_O_n ].
-  unfold Un_decreasing in |- *; intro; unfold Un in |- *.
+  unfold Un_decreasing; intro; unfold Un.
   replace (M_nat + S n)%nat with (M_nat + n + 1)%nat.
-  rewrite pow_add; unfold Rdiv in |- *; rewrite Rmult_assoc;
+  rewrite pow_add; unfold Rdiv; rewrite Rmult_assoc;
     apply Rmult_le_compat_l.
   left; apply pow_lt; assumption.
-  replace (Rabs x ^ 1) with (Rabs x); [ idtac | simpl in |- *; ring ].
+  replace (Rabs x ^ 1) with (Rabs x); [ idtac | simpl; ring ].
   replace (M_nat + n + 1)%nat with (S (M_nat + n)).
   apply Rmult_le_reg_l with (INR (fact (S (M_nat + n)))).
-  apply lt_INR_0; apply neq_O_lt; red in |- *; intro; assert (H9 := sym_eq H8);
+  apply lt_INR_0; apply neq_O_lt; red; intro; assert (H9 := eq_sym H8);
     elim (fact_neq_0 _ H9).
   rewrite (Rmult_comm (Rabs x)); rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym.
   rewrite Rmult_1_l.
@@ -1301,37 +1170,37 @@ Proof.
   apply INR_fact_neq_0.
   ring.
   ring.
-  intro; unfold Un in |- *; unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+  intro; unfold Un; unfold Rdiv; apply Rmult_lt_0_compat.
   apply pow_lt; assumption.
-  apply Rinv_0_lt_compat; apply lt_INR_0; apply neq_O_lt; red in |- *; intro;
-    assert (H8 := sym_eq H7); elim (fact_neq_0 _ H8).
-  clear Un Vn; apply INR_le; simpl in |- *.
+  apply Rinv_0_lt_compat; apply lt_INR_0; apply neq_O_lt; red; intro;
+    assert (H8 := eq_sym H7); elim (fact_neq_0 _ H8).
+  clear Un Vn; apply INR_le; simpl.
   induction  M_nat as [| M_nat HrecM_nat].
   assert (H6 := archimed (Rabs x)); fold M in H6; elim H6; intros.
   rewrite H4 in H7; rewrite <- INR_IZR_INZ in H7.
   simpl in H7; elim (Rlt_irrefl _ (Rlt_trans _ _ _ H2 H7)).
   replace 1 with (INR 1); [ apply le_INR | reflexivity ]; apply le_n_S;
     apply le_O_n.
-  apply le_IZR; simpl in |- *; left; apply Rlt_trans with (Rabs x).
+  apply le_IZR; simpl; left; apply Rlt_trans with (Rabs x).
   assumption.
   elim (archimed (Rabs x)); intros; assumption.
-  unfold Un_cv in |- *; unfold R_dist in |- *; intros; elim (H eps H0); intros.
+  unfold Un_cv; unfold R_dist; intros; elim (H eps H0); intros.
   exists x0; intros;
     apply Rle_lt_trans with (Rabs (Rabs x ^ n / INR (fact n) - 0)).
-  unfold Rminus in |- *; rewrite Ropp_0; do 2 rewrite Rplus_0_r;
+  unfold Rminus; rewrite Ropp_0; do 2 rewrite Rplus_0_r;
     rewrite (Rabs_right (Rabs x ^ n / INR (fact n))).
-  unfold Rdiv in |- *; rewrite Rabs_mult; rewrite (Rabs_right (/ INR (fact n))).
+  unfold Rdiv; rewrite Rabs_mult; rewrite (Rabs_right (/ INR (fact n))).
   rewrite RPow_abs; right; reflexivity.
   apply Rle_ge; left; apply Rinv_0_lt_compat; apply lt_INR_0; apply neq_O_lt;
-    red in |- *; intro; assert (H4 := sym_eq H3); elim (fact_neq_0 _ H4).
-  apply Rle_ge; unfold Rdiv in |- *; apply Rmult_le_pos.
+    red; intro; assert (H4 := eq_sym H3); elim (fact_neq_0 _ H4).
+  apply Rle_ge; unfold Rdiv; apply Rmult_le_pos.
   case (Req_dec x 0); intro.
   rewrite H3; rewrite Rabs_R0.
   induction  n as [| n Hrecn];
-    [ simpl in |- *; left; apply Rlt_0_1
-      | simpl in |- *; rewrite Rmult_0_l; right; reflexivity ].
+    [ simpl; left; apply Rlt_0_1
+      | simpl; rewrite Rmult_0_l; right; reflexivity ].
   left; apply pow_lt; apply Rabs_pos_lt; assumption.
-  left; apply Rinv_0_lt_compat; apply lt_INR_0; apply neq_O_lt; red in |- *;
-    intro; assert (H4 := sym_eq H3); elim (fact_neq_0 _ H4).
+  left; apply Rinv_0_lt_compat; apply lt_INR_0; apply neq_O_lt; red;
+    intro; assert (H4 := eq_sym H3); elim (fact_neq_0 _ H4).
   apply H1; assumption.
 Qed.
diff --git a/theories/Reals/SeqSeries.v b/theories/Reals/SeqSeries.v
index 4725fe57..5140c29c 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-2012     *)
 (*   \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.
@@ -21,7 +19,7 @@ Require Export Rsigma.
 Require Export Rprod.
 Require Export Cauchy_prod.
 Require Export Alembert.
-Open Local Scope R_scope.
+Local Open Scope R_scope.
 
 (**********)
 Lemma sum_maj1 :
@@ -43,21 +41,21 @@ Proof.
   intro; rewrite H4; rewrite H5.
   apply sum_cv_maj with
     (fun l:nat => An (S N + l)%nat) (fun (l:nat) (x:R) => fn (S N + l)%nat x) x.
-  unfold SP in |- *; apply H2.
+  unfold SP; apply H2.
   apply H3.
   intros; apply H1.
-  symmetry  in |- *; eapply UL_sequence.
+  symmetry ; eapply UL_sequence.
   apply H3.
-  unfold Un_cv in H0; unfold Un_cv in |- *; intros; elim (H0 eps H5);
+  unfold Un_cv in H0; unfold Un_cv; intros; elim (H0 eps H5);
     intros N0 H6.
   unfold R_dist in H6; exists N0; intros.
-  unfold R_dist in |- *;
+  unfold R_dist;
     replace (sum_f_R0 (fun l:nat => An (S N + l)%nat) n - (l2 - sum_f_R0 An N))
     with (sum_f_R0 An N + sum_f_R0 (fun l:nat => An (S N + l)%nat) n - l2);
       [ idtac | ring ].
   replace (sum_f_R0 An N + sum_f_R0 (fun l:nat => An (S N + l)%nat) n) with
   (sum_f_R0 An (S (N + n))).
-  apply H6; unfold ge in |- *; apply le_trans with n.
+  apply H6; unfold ge; apply le_trans with n.
   apply H7.
   apply le_trans with (N + n)%nat.
   apply le_plus_r.
@@ -82,12 +80,12 @@ Proof.
   reflexivity.
   apply le_lt_n_Sm; apply le_plus_l.
   apply le_O_n.
-  symmetry  in |- *; eapply UL_sequence.
+  symmetry ; eapply UL_sequence.
   apply H2.
-  unfold Un_cv in H; unfold Un_cv in |- *; intros.
+  unfold Un_cv in H; unfold Un_cv; intros.
   elim (H eps H4); intros N0 H5.
   unfold R_dist in H5; exists N0; intros.
-  unfold R_dist, SP in |- *;
+  unfold R_dist, SP;
     replace
     (sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n -
       (l1 - sum_f_R0 (fun k:nat => fn k x) N)) with
@@ -98,7 +96,7 @@ Proof.
   (sum_f_R0 (fun k:nat => fn k x) N +
     sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n) with
   (sum_f_R0 (fun k:nat => fn k x) (S (N + n))).
-  unfold SP in H5; apply H5; unfold ge in |- *; apply le_trans with n.
+  unfold SP in H5; apply H5; unfold ge; apply le_trans with n.
   apply H6.
   apply le_trans with (N + n)%nat.
   apply le_plus_r.
@@ -126,16 +124,16 @@ Proof.
   apply le_plus_l.
   apply le_O_n.
   exists (l2 - sum_f_R0 An N).
-  unfold Un_cv in H0; unfold Un_cv in |- *; intros.
+  unfold Un_cv in H0; unfold Un_cv; intros.
   elim (H0 eps H2); intros N0 H3.
   unfold R_dist in H3; exists N0; intros.
-  unfold R_dist in |- *;
+  unfold R_dist;
     replace (sum_f_R0 (fun l:nat => An (S N + l)%nat) n - (l2 - sum_f_R0 An N))
     with (sum_f_R0 An N + sum_f_R0 (fun l:nat => An (S N + l)%nat) n - l2);
       [ idtac | ring ].
   replace (sum_f_R0 An N + sum_f_R0 (fun l:nat => An (S N + l)%nat) n) with
   (sum_f_R0 An (S (N + n))).
-  apply H3; unfold ge in |- *; apply le_trans with n.
+  apply H3; unfold ge; apply le_trans with n.
   apply H4.
   apply le_trans with (N + n)%nat.
   apply le_plus_r.
@@ -162,10 +160,10 @@ Proof.
   apply le_plus_l.
   apply le_O_n.
   exists (l1 - SP fn N x).
-  unfold Un_cv in H; unfold Un_cv in |- *; intros.
+  unfold Un_cv in H; unfold Un_cv; intros.
   elim (H eps H2); intros N0 H3.
   unfold R_dist in H3; exists N0; intros.
-  unfold R_dist, SP in |- *.
+  unfold R_dist, SP.
   replace
   (sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n -
     (l1 - sum_f_R0 (fun k:nat => fn k x) N)) with
@@ -177,7 +175,7 @@ Proof.
     sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n) with
   (sum_f_R0 (fun k:nat => fn k x) (S (N + n))).
   unfold SP in H3; apply H3.
-  unfold ge in |- *; apply le_trans with n.
+  unfold ge; apply le_trans with n.
   apply H4.
   apply le_trans with (N + n)%nat.
   apply le_plus_r.
@@ -215,7 +213,7 @@ Lemma Rseries_CV_comp :
 Proof.
   intros An Bn H X; apply cv_cauchy_2.
   assert (H0 := cv_cauchy_1 _ X).
-  unfold Cauchy_crit_series in |- *; unfold Cauchy_crit in |- *.
+  unfold Cauchy_crit_series; unfold Cauchy_crit.
   intros; elim (H0 eps H1); intros.
   exists x; intros.
   cut
@@ -229,7 +227,7 @@ Proof.
   elim a; intro.
   rewrite (tech2 An n m); [ idtac | assumption ].
   rewrite (tech2 Bn n m); [ idtac | assumption ].
-  unfold R_dist in |- *; unfold Rminus in |- *; do 2 rewrite Ropp_plus_distr;
+  unfold R_dist; unfold Rminus; do 2 rewrite Ropp_plus_distr;
     do 2 rewrite <- Rplus_assoc; do 2 rewrite Rplus_opp_r;
       do 2 rewrite Rplus_0_l; do 2 rewrite Rabs_Ropp; repeat rewrite Rabs_right.
   apply sum_Rle; intros.
@@ -240,12 +238,12 @@ Proof.
   apply Rle_trans with (An (S n + n0)%nat); assumption.
   apply Rle_ge; apply cond_pos_sum; intro.
   elim (H (S n + n0)%nat); intros; assumption.
-  rewrite b; unfold R_dist in |- *; unfold Rminus in |- *;
+  rewrite b; unfold R_dist; unfold Rminus;
     do 2 rewrite Rplus_opp_r; rewrite Rabs_R0; right;
       reflexivity.
   rewrite (tech2 An m n); [ idtac | assumption ].
   rewrite (tech2 Bn m n); [ idtac | assumption ].
-  unfold R_dist in |- *; unfold Rminus in |- *; do 2 rewrite Rplus_assoc;
+  unfold R_dist; unfold Rminus; do 2 rewrite Rplus_assoc;
     rewrite (Rplus_comm (sum_f_R0 An m)); rewrite (Rplus_comm (sum_f_R0 Bn m));
       do 2 rewrite Rplus_assoc; do 2 rewrite Rplus_opp_l;
         do 2 rewrite Rplus_0_r; repeat rewrite Rabs_right.
@@ -268,13 +266,13 @@ Lemma Cesaro :
     Un_cv (fun n:nat => sum_f_R0 (fun k:nat => An k * Bn k) n / sum_f_R0 An n)
     l.
 Proof with trivial.
-  unfold Un_cv in |- *; intros; assert (H3 : forall n:nat, 0 < sum_f_R0 An n)...
+  unfold Un_cv; intros; assert (H3 : forall n:nat, 0 < sum_f_R0 An n)...
   intro; apply tech1...
   assert (H4 : forall n:nat, sum_f_R0 An n <> 0)...
-  intro; red in |- *; intro; assert (H5 := H3 n); rewrite H4 in H5;
+  intro; red; intro; assert (H5 := H3 n); rewrite H4 in H5;
     elim (Rlt_irrefl _ H5)...
   assert (H5 := cv_infty_cv_R0 _ H4 H1); assert (H6 : 0 < eps / 2)...
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat...
+  unfold Rdiv; apply Rmult_lt_0_compat...
   apply Rinv_0_lt_compat; prove_sup...
   elim (H _ H6); clear H; intros N1 H;
     set (C := Rabs (sum_f_R0 (fun k:nat => An k * (Bn k - l)) N1));
@@ -284,10 +282,10 @@ Proof with trivial.
             (forall n:nat, (N <= n)%nat -> C / sum_f_R0 An n < eps / 2))...
   case (Req_dec C 0); intro...
   exists 0%nat; intros...
-  rewrite H7; unfold Rdiv in |- *; rewrite Rmult_0_l; apply Rmult_lt_0_compat...
+  rewrite H7; unfold Rdiv; rewrite Rmult_0_l; apply Rmult_lt_0_compat...
   apply Rinv_0_lt_compat; prove_sup...
   assert (H8 : 0 < eps / (2 * Rabs C))...
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat...
+  unfold Rdiv; apply Rmult_lt_0_compat...
   apply Rinv_0_lt_compat; apply Rmult_lt_0_compat...
   prove_sup...
   apply Rabs_pos_lt...
@@ -296,23 +294,23 @@ Proof with trivial.
       rewrite Rplus_0_r in H11...
   apply Rle_lt_trans with (Rabs (C / sum_f_R0 An n))...
   apply RRle_abs...
-  unfold Rdiv in |- *; rewrite Rabs_mult; apply Rmult_lt_reg_l with (/ Rabs C)...
+  unfold Rdiv; rewrite Rabs_mult; apply Rmult_lt_reg_l with (/ Rabs C)...
   apply Rinv_0_lt_compat; apply Rabs_pos_lt...
   rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym...
   rewrite Rmult_1_l; replace (/ Rabs C * (eps * / 2)) with (eps / (2 * Rabs C))...
-  unfold Rdiv in |- *; rewrite Rinv_mult_distr...
+  unfold Rdiv; rewrite Rinv_mult_distr...
   ring...
   discrR...
   apply Rabs_no_R0...
   apply Rabs_no_R0...
   elim H7; clear H7; intros N2 H7; set (N := max N1 N2); exists (S N); intros;
-    unfold R_dist in |- *;
+    unfold R_dist;
       replace (sum_f_R0 (fun k:nat => An k * Bn k) n / sum_f_R0 An n - l) with
       (sum_f_R0 (fun k:nat => An k * (Bn k - l)) n / sum_f_R0 An n)...
   assert (H9 : (N1 < n)%nat)...
   apply lt_le_trans with (S N)...
-  apply le_lt_n_Sm; unfold N in |- *; apply le_max_l...
-  rewrite (tech2 (fun k:nat => An k * (Bn k - l)) _ _ H9); unfold Rdiv in |- *;
+  apply le_lt_n_Sm; unfold N; apply le_max_l...
+  rewrite (tech2 (fun k:nat => An k * (Bn k - l)) _ _ H9); unfold Rdiv;
     rewrite Rmult_plus_distr_r;
       apply Rle_lt_trans with
         (Rabs (sum_f_R0 (fun k:nat => An k * (Bn k - l)) N1 / sum_f_R0 An n) +
@@ -321,12 +319,12 @@ Proof with trivial.
             (n - S N1) / sum_f_R0 An n))...
   apply Rabs_triang...
   rewrite (double_var eps); apply Rplus_lt_compat...
-  unfold Rdiv in |- *; rewrite Rabs_mult; fold C in |- *; rewrite Rabs_right...
+  unfold Rdiv; rewrite Rabs_mult; fold C; rewrite Rabs_right...
   apply (H7 n); apply le_trans with (S N)...
-  apply le_trans with N; [ unfold N in |- *; apply le_max_r | apply le_n_Sn ]...
+  apply le_trans with N; [ unfold N; apply le_max_r | apply le_n_Sn ]...
   apply Rle_ge; left; apply Rinv_0_lt_compat...
 
-  unfold R_dist in H; unfold Rdiv in |- *; rewrite Rabs_mult;
+  unfold R_dist in H; unfold Rdiv; rewrite Rabs_mult;
     rewrite (Rabs_right (/ sum_f_R0 An n))...
   apply Rle_lt_trans with
     (sum_f_R0 (fun i:nat => Rabs (An (S N1 + i)%nat * (Bn (S N1 + i)%nat - l)))
@@ -342,22 +340,22 @@ Proof with trivial.
   do 2 rewrite <- (Rmult_comm (/ sum_f_R0 An n)); apply Rmult_le_compat_l...
   left; apply Rinv_0_lt_compat...
   apply sum_Rle; intros; rewrite Rabs_mult;
-    pattern (An (S N1 + n0)%nat) at 2 in |- *;
+    pattern (An (S N1 + n0)%nat) at 2;
       rewrite <- (Rabs_right (An (S N1 + n0)%nat))...
   apply Rmult_le_compat_l...
   apply Rabs_pos...
-  left; apply H; unfold ge in |- *; apply le_trans with (S N1);
+  left; apply H; unfold ge; apply le_trans with (S N1);
     [ apply le_n_Sn | apply le_plus_l ]...
   apply Rle_ge; left...
   rewrite <- (scal_sum (fun i:nat => An (S N1 + i)%nat) (n - S N1) (eps / 2));
-    unfold Rdiv in |- *; repeat rewrite Rmult_assoc; apply Rmult_lt_compat_l...
-  pattern (/ 2) at 2 in |- *; rewrite <- Rmult_1_r; apply Rmult_lt_compat_l...
+    unfold Rdiv; repeat rewrite Rmult_assoc; apply Rmult_lt_compat_l...
+  pattern (/ 2) at 2; rewrite <- Rmult_1_r; apply Rmult_lt_compat_l...
   apply Rinv_0_lt_compat; prove_sup...
   rewrite Rmult_comm; apply Rmult_lt_reg_l with (sum_f_R0 An n)...
   rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym...
   rewrite Rmult_1_l; rewrite Rmult_1_r; rewrite (tech2 An N1 n)...
   rewrite Rplus_comm;
-    pattern (sum_f_R0 (fun i:nat => An (S N1 + i)%nat) (n - S N1)) at 1 in |- *;
+    pattern (sum_f_R0 (fun i:nat => An (S N1 + i)%nat) (n - S N1)) at 1;
       rewrite <- Rplus_0_r; apply Rplus_lt_compat_l...
   apply Rle_ge; left; apply Rinv_0_lt_compat...
   replace (sum_f_R0 (fun k:nat => An k * (Bn k - l)) n) with
@@ -373,41 +371,41 @@ Lemma Cesaro_1 :
 Proof with trivial.
   intros Bn l H; set (An := fun _:nat => 1)...
   assert (H0 : forall n:nat, 0 < An n)...
-  intro; unfold An in |- *; apply Rlt_0_1...
+  intro; unfold An; apply Rlt_0_1...
   assert (H1 : forall n:nat, 0 < sum_f_R0 An n)...
   intro; apply tech1...
   assert (H2 : cv_infty (fun n:nat => sum_f_R0 An n))...
-  unfold cv_infty in |- *; intro; case (Rle_dec M 0); intro...
+  unfold cv_infty; intro; case (Rle_dec M 0); intro...
   exists 0%nat; intros; apply Rle_lt_trans with 0...
   assert (H2 : 0 < M)...
   auto with real...
   clear n; set (m := up M); elim (archimed M); intros;
     assert (H5 : (0 <= m)%Z)...
-  apply le_IZR; unfold m in |- *; simpl in |- *; left; apply Rlt_trans with M...
-  elim (IZN _ H5); intros; exists x; intros; unfold An in |- *; rewrite sum_cte;
+  apply le_IZR; unfold m; simpl; left; apply Rlt_trans with M...
+  elim (IZN _ H5); intros; exists x; intros; unfold An; rewrite sum_cte;
     rewrite Rmult_1_l; apply Rlt_trans with (IZR (up M))...
   apply Rle_lt_trans with (INR x)...
-  rewrite INR_IZR_INZ; fold m in |- *; rewrite <- H6; right...
+  rewrite INR_IZR_INZ; fold m; rewrite <- H6; right...
   apply lt_INR; apply le_lt_n_Sm...
   assert (H3 := Cesaro _ _ _ H H0 H2)...
-  unfold Un_cv in |- *; unfold Un_cv in H3; intros; elim (H3 _ H4); intros;
-    exists (S x); intros; unfold R_dist in |- *; unfold R_dist in H5;
+  unfold Un_cv; unfold Un_cv in H3; intros; elim (H3 _ H4); intros;
+    exists (S x); intros; unfold R_dist; unfold R_dist in H5;
       apply Rle_lt_trans with
         (Rabs
           (sum_f_R0 (fun k:nat => An k * Bn k) (pred n) / sum_f_R0 An (pred n) - l))...
   right;
     replace (sum_f_R0 Bn (pred n) / INR n - l) with
     (sum_f_R0 (fun k:nat => An k * Bn k) (pred n) / sum_f_R0 An (pred n) - l)...
-  unfold Rminus in |- *; do 2 rewrite <- (Rplus_comm (- l));
+  unfold Rminus; do 2 rewrite <- (Rplus_comm (- l));
     apply Rplus_eq_compat_l...
-  unfold An in |- *;
+  unfold An;
     replace (sum_f_R0 (fun k:nat => 1 * Bn k) (pred n)) with
     (sum_f_R0 Bn (pred n))...
   rewrite sum_cte; rewrite Rmult_1_l; replace (S (pred n)) with n...
   apply S_pred with 0%nat; apply lt_le_trans with (S x)...
   apply lt_O_Sn...
   apply sum_eq; intros; ring...
-  apply H5; unfold ge in |- *; apply le_S_n; replace (S (pred n)) with n...
+  apply H5; unfold ge; apply le_S_n; replace (S (pred n)) with n...
   apply S_pred with 0%nat; apply lt_le_trans with (S x)...
   apply lt_O_Sn...
 Qed.
diff --git a/theories/Reals/SplitAbsolu.v b/theories/Reals/SplitAbsolu.v
index 67af68d1..d0de58b0 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-2012     *)
 (*   \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 :=
@@ -21,5 +19,5 @@ Ltac split_Rabs :=
   match goal with
     | id:context [(Rabs _)] |- _ => generalize id; clear id; try split_Rabs
     |  |- context [(Rabs ?X1)] =>
-      unfold Rabs in |- *; try split_case_Rabs; intros
+      unfold Rabs; try split_case_Rabs; intros
   end.
diff --git a/theories/Reals/SplitRmult.v b/theories/Reals/SplitRmult.v
index 85a2cdd0..09031fd6 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-2012     *)
 (*   \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..89c17821 100644
--- a/theories/Reals/Sqrt_reg.v
+++ b/theories/Reals/Sqrt_reg.v
@@ -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-2012     *)
 (*   \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.
 Require Import R_sqrt.
-Open Local Scope R_scope.
+Local Open Scope R_scope.
 
 (**********)
 Lemma sqrt_var_maj :
@@ -23,67 +21,67 @@ Proof.
   case (total_order_T h 0); intro.
   elim s; intro.
   repeat rewrite Rabs_left.
-  unfold Rminus in |- *; do 2 rewrite <- (Rplus_comm (-1)).
+  unfold Rminus; do 2 rewrite <- (Rplus_comm (-1)).
   do 2 rewrite Ropp_plus_distr; rewrite Ropp_involutive;
     apply Rplus_le_compat_l.
   apply Ropp_le_contravar; apply sqrt_le_1.
   apply Rle_0_sqr.
   apply H0.
-  pattern (1 + h) at 2 in |- *; rewrite <- Rmult_1_r; unfold Rsqr in |- *;
+  pattern (1 + h) at 2; rewrite <- Rmult_1_r; unfold Rsqr;
     apply Rmult_le_compat_l.
   apply H0.
-  pattern 1 at 2 in |- *; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left;
+  pattern 1 at 2; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left;
     assumption.
   apply Rplus_lt_reg_r with 1; rewrite Rplus_0_r; rewrite Rplus_comm;
-    unfold Rminus in |- *; rewrite Rplus_assoc; rewrite Rplus_opp_l;
+    unfold Rminus; rewrite Rplus_assoc; rewrite Rplus_opp_l;
       rewrite Rplus_0_r.
-  pattern 1 at 2 in |- *; rewrite <- sqrt_1; apply sqrt_lt_1.
+  pattern 1 at 2; rewrite <- sqrt_1; apply sqrt_lt_1.
   apply Rle_0_sqr.
   left; apply Rlt_0_1.
-  pattern 1 at 2 in |- *; rewrite <- Rsqr_1; apply Rsqr_incrst_1.
-  pattern 1 at 2 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
+  pattern 1 at 2; rewrite <- Rsqr_1; apply Rsqr_incrst_1.
+  pattern 1 at 2; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
     assumption.
   apply H0.
   left; apply Rlt_0_1.
   apply Rplus_lt_reg_r with 1; rewrite Rplus_0_r; rewrite Rplus_comm;
-    unfold Rminus in |- *; rewrite Rplus_assoc; rewrite Rplus_opp_l;
+    unfold Rminus; rewrite Rplus_assoc; rewrite Rplus_opp_l;
       rewrite Rplus_0_r.
-  pattern 1 at 2 in |- *; rewrite <- sqrt_1; apply sqrt_lt_1.
+  pattern 1 at 2; rewrite <- sqrt_1; apply sqrt_lt_1.
   apply H0.
   left; apply Rlt_0_1.
-  pattern 1 at 2 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
+  pattern 1 at 2; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
     assumption.
   rewrite b; rewrite Rplus_0_r; rewrite Rsqr_1; rewrite sqrt_1; right;
     reflexivity.
   repeat rewrite Rabs_right.
-  unfold Rminus in |- *; do 2 rewrite <- (Rplus_comm (-1));
+  unfold Rminus; do 2 rewrite <- (Rplus_comm (-1));
     apply Rplus_le_compat_l.
   apply sqrt_le_1.
   apply H0.
   apply Rle_0_sqr.
-  pattern (1 + h) at 1 in |- *; rewrite <- Rmult_1_r; unfold Rsqr in |- *;
+  pattern (1 + h) at 1; rewrite <- Rmult_1_r; unfold Rsqr;
     apply Rmult_le_compat_l.
   apply H0.
-  pattern 1 at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left;
+  pattern 1 at 1; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left;
     assumption.
   apply Rle_ge; apply Rplus_le_reg_l with 1.
-  rewrite Rplus_0_r; rewrite Rplus_comm; unfold Rminus in |- *;
+  rewrite Rplus_0_r; rewrite Rplus_comm; unfold Rminus;
     rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r.
-  pattern 1 at 1 in |- *; rewrite <- sqrt_1; apply sqrt_le_1.
+  pattern 1 at 1; rewrite <- sqrt_1; apply sqrt_le_1.
   left; apply Rlt_0_1.
   apply Rle_0_sqr.
-  pattern 1 at 1 in |- *; rewrite <- Rsqr_1; apply Rsqr_incr_1.
-  pattern 1 at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left;
+  pattern 1 at 1; rewrite <- Rsqr_1; apply Rsqr_incr_1.
+  pattern 1 at 1; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left;
     assumption.
   left; apply Rlt_0_1.
   apply H0.
   apply Rle_ge; left; apply Rplus_lt_reg_r with 1.
-  rewrite Rplus_0_r; rewrite Rplus_comm; unfold Rminus in |- *;
+  rewrite Rplus_0_r; rewrite Rplus_comm; unfold Rminus;
     rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r.
-  pattern 1 at 1 in |- *; rewrite <- sqrt_1; apply sqrt_lt_1.
+  pattern 1 at 1; rewrite <- sqrt_1; apply sqrt_lt_1.
   left; apply Rlt_0_1.
   apply H0.
-  pattern 1 at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
+  pattern 1 at 1; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
     assumption.
   rewrite sqrt_Rsqr.
   replace (1 + h - 1) with h; [ right; reflexivity | ring ].
@@ -103,14 +101,14 @@ Qed.
 (** sqrt is continuous in 1 *)
 Lemma sqrt_continuity_pt_R1 : continuity_pt sqrt 1.
 Proof.
-  unfold continuity_pt in |- *; unfold continue_in in |- *;
-    unfold limit1_in in |- *; unfold limit_in in |- *;
-      unfold dist in |- *; simpl in |- *; unfold R_dist in |- *;
+  unfold continuity_pt; unfold continue_in;
+    unfold limit1_in; unfold limit_in;
+      unfold dist; simpl; unfold R_dist;
         intros.
   set (alpha := Rmin eps 1).
   exists alpha; intros.
   split.
-  unfold alpha in |- *; unfold Rmin in |- *; case (Rle_dec eps 1); intro.
+  unfold alpha; unfold Rmin; case (Rle_dec eps 1); intro.
   assumption.
   apply Rlt_0_1.
   intros; elim H0; intros.
@@ -119,18 +117,18 @@ Proof.
   apply sqrt_var_maj.
   apply Rle_trans with alpha.
   left; apply H2.
-  unfold alpha in |- *; apply Rmin_r.
+  unfold alpha; apply Rmin_r.
   apply Rlt_le_trans with alpha;
-    [ apply H2 | unfold alpha in |- *; apply Rmin_l ].
+    [ apply H2 | unfold alpha; apply Rmin_l ].
 Qed.
 
 (** sqrt is continuous forall x>0 *)
 Lemma sqrt_continuity_pt : forall x:R, 0 < x -> continuity_pt sqrt x.
 Proof.
   intros; generalize sqrt_continuity_pt_R1.
-  unfold continuity_pt in |- *; unfold continue_in in |- *;
-    unfold limit1_in in |- *; unfold limit_in in |- *;
-      unfold dist in |- *; simpl in |- *; unfold R_dist in |- *;
+  unfold continuity_pt; unfold continue_in;
+    unfold limit1_in; unfold limit_in;
+      unfold dist; simpl; unfold R_dist;
         intros.
   cut (0 < eps / sqrt x).
   intro; elim (H0 _ H2); intros alp_1 H3.
@@ -138,9 +136,9 @@ Proof.
   set (alpha := alp_1 * x).
   exists (Rmin alpha x); intros.
   split.
-  change (0 < Rmin alpha x) in |- *; unfold Rmin in |- *;
+  change (0 < Rmin alpha x); unfold Rmin;
     case (Rle_dec alpha x); intro.
-  unfold alpha in |- *; apply Rmult_lt_0_compat; assumption.
+  unfold alpha; apply Rmult_lt_0_compat; assumption.
   apply H.
   intros; replace x0 with (x + (x0 - x)); [ idtac | ring ];
     replace (sqrt (x + (x0 - x)) - sqrt x) with
@@ -152,7 +150,7 @@ Proof.
   rewrite Rmult_1_l; rewrite Rmult_comm.
   unfold Rdiv in H5.
   case (Req_dec x x0); intro.
-  rewrite H7; unfold Rminus, Rdiv in |- *; rewrite Rplus_opp_r;
+  rewrite H7; unfold Rminus, Rdiv; rewrite Rplus_opp_r;
     rewrite Rmult_0_l; rewrite Rplus_0_r; rewrite Rplus_opp_r;
       rewrite Rabs_R0.
   apply Rmult_lt_0_compat.
@@ -160,10 +158,10 @@ Proof.
   apply Rinv_0_lt_compat; rewrite <- H7; apply sqrt_lt_R0; assumption.
   apply H5.
   split.
-  unfold D_x, no_cond in |- *.
+  unfold D_x, no_cond.
   split.
   trivial.
-  red in |- *; intro.
+  red; intro.
   cut ((x0 - x) * / x = 0).
   intro.
   elim (Rmult_integral _ _ H9); intro.
@@ -172,35 +170,35 @@ Proof.
   assert (H11 := Rmult_eq_0_compat_r _ x H10).
   rewrite <- Rinv_l_sym in H11.
   elim R1_neq_R0; exact H11.
-  red in |- *; intro; rewrite H12 in H; elim (Rlt_irrefl _ H).
-  symmetry  in |- *; apply Rplus_eq_reg_l with 1; rewrite Rplus_0_r;
+  red; intro; rewrite H12 in H; elim (Rlt_irrefl _ H).
+  symmetry ; apply Rplus_eq_reg_l with 1; rewrite Rplus_0_r;
     unfold Rdiv in H8; exact H8.
-  unfold Rminus in |- *; rewrite Rplus_comm; rewrite <- Rplus_assoc;
+  unfold Rminus; rewrite Rplus_comm; rewrite <- Rplus_assoc;
     rewrite Rplus_opp_l; rewrite Rplus_0_l; elim H6; intros.
-  unfold Rdiv in |- *; rewrite Rabs_mult.
+  unfold Rdiv; rewrite Rabs_mult.
   rewrite Rabs_Rinv.
   rewrite (Rabs_right x).
   rewrite Rmult_comm; apply Rmult_lt_reg_l with x.
   apply H.
   rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym.
-  rewrite Rmult_1_l; rewrite Rmult_comm; fold alpha in |- *.
+  rewrite Rmult_1_l; rewrite Rmult_comm; fold alpha.
   apply Rlt_le_trans with (Rmin alpha x).
   apply H9.
   apply Rmin_l.
-  red in |- *; intro; rewrite H10 in H; elim (Rlt_irrefl _ H).
+  red; intro; rewrite H10 in H; elim (Rlt_irrefl _ H).
   apply Rle_ge; left; apply H.
-  red in |- *; intro; rewrite H10 in H; elim (Rlt_irrefl _ H).
+  red; intro; rewrite H10 in H; elim (Rlt_irrefl _ H).
   assert (H7 := sqrt_lt_R0 x H).
-  red in |- *; intro; rewrite H8 in H7; elim (Rlt_irrefl _ H7).
+  red; intro; rewrite H8 in H7; elim (Rlt_irrefl _ H7).
   apply Rle_ge; apply sqrt_positivity.
   left; apply H.
-  unfold Rminus in |- *; rewrite Rmult_plus_distr_l;
+  unfold Rminus; rewrite Rmult_plus_distr_l;
     rewrite Ropp_mult_distr_r_reverse; repeat rewrite <- sqrt_mult.
   rewrite Rmult_1_r; rewrite Rmult_plus_distr_l; rewrite Rmult_1_r;
-    unfold Rdiv in |- *; rewrite Rmult_comm; rewrite Rmult_assoc;
+    unfold Rdiv; rewrite Rmult_comm; rewrite Rmult_assoc;
       rewrite <- Rinv_l_sym.
   rewrite Rmult_1_r; reflexivity.
-  red in |- *; intro; rewrite H7 in H; elim (Rlt_irrefl _ H).
+  red; intro; rewrite H7 in H; elim (Rlt_irrefl _ H).
   left; apply H.
   left; apply Rlt_0_1.
   left; apply H.
@@ -210,7 +208,7 @@ Proof.
   rewrite Rplus_comm.
   apply Rplus_le_reg_l with (- ((x0 - x) / x)).
   rewrite Rplus_0_r; rewrite <- Rplus_assoc; rewrite Rplus_opp_l;
-    rewrite Rplus_0_l; unfold Rdiv in |- *; rewrite <- Ropp_mult_distr_l_reverse.
+    rewrite Rplus_0_l; unfold Rdiv; rewrite <- Ropp_mult_distr_l_reverse.
   apply Rmult_le_reg_l with x.
   apply H.
   rewrite Rmult_1_r; rewrite Rmult_comm; rewrite Rmult_assoc;
@@ -218,13 +216,13 @@ Proof.
   rewrite Rmult_1_r; left; apply Rlt_le_trans with (Rmin alpha x).
   apply H8.
   apply Rmin_r.
-  red in |- *; intro; rewrite H9 in H; elim (Rlt_irrefl _ H).
+  red; intro; rewrite H9 in H; elim (Rlt_irrefl _ H).
   apply Rplus_le_le_0_compat.
   left; apply Rlt_0_1.
-  unfold Rdiv in |- *; apply Rmult_le_pos.
+  unfold Rdiv; apply Rmult_le_pos.
   apply Rge_le; exact r.
   left; apply Rinv_0_lt_compat; apply H.
-  unfold Rdiv in |- *; apply Rmult_lt_0_compat.
+  unfold Rdiv; apply Rmult_lt_0_compat.
   apply H1.
   apply Rinv_0_lt_compat; apply sqrt_lt_R0; apply H.
 Qed.
@@ -237,7 +235,7 @@ Proof.
   cut (continuity_pt g 0).
   intro; cut (g 0 <> 0).
   intro; assert (H2 := continuity_pt_inv g 0 H0 H1).
-  unfold derivable_pt_lim in |- *; intros; unfold continuity_pt in H2;
+  unfold derivable_pt_lim; intros; unfold continuity_pt in H2;
     unfold continue_in in H2; unfold limit1_in in H2;
       unfold limit_in in H2; simpl in H2; unfold R_dist in H2.
   elim (H2 eps H3); intros alpha H4.
@@ -249,29 +247,29 @@ Proof.
   unfold inv_fct, g in H6; replace (2 * sqrt x) with (sqrt x + sqrt (x + 0)).
   apply H6.
   split.
-  unfold D_x, no_cond in |- *.
+  unfold D_x, no_cond.
   split.
   trivial.
-  apply (sym_not_eq (A:=R)); exact H8.
-  unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r;
+  apply (not_eq_sym (A:=R)); exact H8.
+  unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r;
     apply Rlt_le_trans with alpha1.
   exact H9.
-  unfold alpha1 in |- *; apply Rmin_l.
+  unfold alpha1; apply Rmin_l.
   rewrite Rplus_0_r; ring.
   cut (0 <= x + h).
   intro; cut (0 < sqrt x + sqrt (x + h)).
   intro; apply Rmult_eq_reg_l with (sqrt x + sqrt (x + h)).
   rewrite <- Rinv_r_sym.
-  rewrite Rplus_comm; unfold Rdiv in |- *; rewrite <- Rmult_assoc;
+  rewrite Rplus_comm; unfold Rdiv; rewrite <- Rmult_assoc;
     rewrite Rsqr_plus_minus; repeat rewrite Rsqr_sqrt.
-  rewrite Rplus_comm; unfold Rminus in |- *; rewrite Rplus_assoc;
+  rewrite Rplus_comm; unfold Rminus; rewrite Rplus_assoc;
     rewrite Rplus_opp_r; rewrite Rplus_0_r; rewrite <- Rinv_r_sym.
   reflexivity.
   apply H8.
   left; apply H.
   assumption.
-  red in |- *; intro; rewrite H12 in H11; elim (Rlt_irrefl _ H11).
-  red in |- *; intro; rewrite H12 in H11; elim (Rlt_irrefl _ H11).
+  red; intro; rewrite H12 in H11; elim (Rlt_irrefl _ H11).
+  red; intro; rewrite H12 in H11; elim (Rlt_irrefl _ H11).
   apply Rplus_lt_le_0_compat.
   apply sqrt_lt_R0; apply H.
   apply sqrt_positivity; apply H10.
@@ -281,35 +279,35 @@ Proof.
   rewrite Rplus_0_r; rewrite Rplus_comm; rewrite Rplus_assoc;
     rewrite Rplus_opp_r; rewrite Rplus_0_r; left; apply Rlt_le_trans with alpha1.
   apply H9.
-  unfold alpha1 in |- *; apply Rmin_r.
+  unfold alpha1; apply Rmin_r.
   apply Rplus_le_le_0_compat.
   left; assumption.
   apply Rge_le; apply r.
-  unfold alpha1 in |- *; unfold Rmin in |- *; case (Rle_dec alpha x); intro.
+  unfold alpha1; unfold Rmin; case (Rle_dec alpha x); intro.
   apply H5.
   apply H.
-  unfold g in |- *; rewrite Rplus_0_r.
+  unfold g; rewrite Rplus_0_r.
   cut (0 < sqrt x + sqrt x).
-  intro; red in |- *; intro; rewrite H2 in H1; elim (Rlt_irrefl _ H1).
+  intro; red; intro; rewrite H2 in H1; elim (Rlt_irrefl _ H1).
   apply Rplus_lt_0_compat; apply sqrt_lt_R0; apply H.
   replace g with (fct_cte (sqrt x) + comp sqrt (fct_cte x + id))%F;
   [ idtac | reflexivity ].
   apply continuity_pt_plus.
-  apply continuity_pt_const; unfold constant, fct_cte in |- *; intro;
+  apply continuity_pt_const; unfold constant, fct_cte; intro;
     reflexivity.
   apply continuity_pt_comp.
   apply continuity_pt_plus.
-  apply continuity_pt_const; unfold constant, fct_cte in |- *; intro;
+  apply continuity_pt_const; unfold constant, fct_cte; intro;
     reflexivity.
   apply derivable_continuous_pt; apply derivable_pt_id.
   apply sqrt_continuity_pt.
-  unfold plus_fct, fct_cte, id in |- *; rewrite Rplus_0_r; apply H.
+  unfold plus_fct, fct_cte, id; rewrite Rplus_0_r; apply H.
 Qed.
 
 (**********)
 Lemma derivable_pt_sqrt : forall x:R, 0 < x -> derivable_pt sqrt x.
 Proof.
-  unfold derivable_pt in |- *; intros.
+  unfold derivable_pt; intros.
   exists (/ (2 * sqrt x)).
   apply derivable_pt_lim_sqrt; assumption.
 Qed.
@@ -332,19 +330,19 @@ Proof.
   intros; case (Rtotal_order 0 x); intro.
   apply (sqrt_continuity_pt x H0).
   elim H0; intro.
-  unfold continuity_pt in |- *; unfold continue_in in |- *;
-    unfold limit1_in in |- *; unfold limit_in in |- *;
-      simpl in |- *; unfold R_dist in |- *; intros.
+  unfold continuity_pt; unfold continue_in;
+    unfold limit1_in; unfold limit_in;
+      simpl; unfold R_dist; intros.
   exists (Rsqr eps); intros.
   split.
-  change (0 < Rsqr eps) in |- *; apply Rsqr_pos_lt.
-  red in |- *; intro; rewrite H3 in H2; elim (Rlt_irrefl _ H2).
+  change (0 < Rsqr eps); apply Rsqr_pos_lt.
+  red; intro; rewrite H3 in H2; elim (Rlt_irrefl _ H2).
   intros; elim H3; intros.
-  rewrite <- H1; rewrite sqrt_0; unfold Rminus in |- *; rewrite Ropp_0;
+  rewrite <- H1; rewrite sqrt_0; unfold Rminus; rewrite Ropp_0;
     rewrite Rplus_0_r; rewrite <- H1 in H5; unfold Rminus in H5;
       rewrite Ropp_0 in H5; rewrite Rplus_0_r in H5.
   case (Rcase_abs x0); intro.
-  unfold sqrt in |- *; case (Rcase_abs x0); intro.
+  unfold sqrt; case (Rcase_abs x0); intro.
   rewrite Rabs_R0; apply H2.
   assert (H6 := Rge_le _ _ r0); elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H6 r)).
   rewrite Rabs_right.
diff --git a/theories/Reals/vo.itarget b/theories/Reals/vo.itarget
index bcd47a0b..36dd0f56 100644
--- a/theories/Reals/vo.itarget
+++ b/theories/Reals/vo.itarget
@@ -9,6 +9,7 @@ DiscrR.vo
 Exp_prop.vo
 Integration.vo
 LegacyRfield.vo
+Machin.vo
 MVT.vo
 NewtonInt.vo
 PartSum.vo
@@ -17,7 +18,10 @@ Ranalysis1.vo
 Ranalysis2.vo
 Ranalysis3.vo
 Ranalysis4.vo
+Ranalysis5.vo
 Ranalysis.vo
+Ranalysis_reg.vo
+Ratan.vo
 Raxioms.vo
 Rbase.vo
 Rbasic_fun.vo
@@ -48,6 +52,7 @@ Rtrigo_calc.vo
 Rtrigo_def.vo
 Rtrigo_fun.vo
 Rtrigo_reg.vo
+Rtrigo1.vo
 Rtrigo.vo
 SeqProp.vo
 SeqSeries.vo
diff --git a/theories/Relations/Operators_Properties.v b/theories/Relations/Operators_Properties.v
index 26c8ef59..779c3d9a 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-2012     *)
 (*   \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.
@@ -52,7 +50,7 @@ Section Properties.
 
     Lemma clos_rt_idempotent : inclusion (R*)* R*.
     Proof.
-      red in |- *.
+      red.
       induction 1; auto with sets.
       intros.
       apply rt_trans with y; auto with sets.
@@ -68,7 +66,7 @@ Section Properties.
     Lemma clos_rt_clos_rst :
       inclusion (clos_refl_trans R) (clos_refl_sym_trans R).
     Proof.
-      red in |- *.
+      red.
       induction 1; auto with sets.
       apply rst_trans with y; auto with sets.
     Qed.
@@ -89,7 +87,7 @@ Section Properties.
       inclusion (clos_refl_sym_trans (clos_refl_sym_trans R))
       (clos_refl_sym_trans R).
     Proof.
-      red in |- *.
+      red.
       induction 1; auto with sets.
       apply rst_trans with y; auto with sets.
     Qed.
diff --git a/theories/Relations/Relation_Definitions.v b/theories/Relations/Relation_Definitions.v
index 0d901445..0e6d034e 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-2012     *)
 (*   \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..b7159578 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-2012     *)
 (*   \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.
@@ -149,13 +149,13 @@ Section Lexicographic_Product.
   Variable leA : A -> A -> Prop.
   Variable leB : forall x:A, B x -> B x -> Prop.
 
-  Inductive lexprod : sigS B -> sigS B -> Prop :=
+  Inductive lexprod : sigT B -> sigT B -> Prop :=
     | left_lex :
       forall (x x':A) (y:B x) (y':B x'),
-        leA x x' -> lexprod (existS B x y) (existS B x' y')
+        leA x x' -> lexprod (existT B x y) (existT B x' y')
     | right_lex :
       forall (x:A) (y y':B x),
-        leB x y y' -> lexprod (existS B x y) (existS B x y').
+        leB x y y' -> lexprod (existT B x y) (existT B x y').
 
 End Lexicographic_Product.
 
diff --git a/theories/Relations/Relations.v b/theories/Relations/Relations.v
index 630b2822..08b7574f 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-2012     *)
 (*   \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.
@@ -16,16 +14,16 @@ Lemma inverse_image_of_equivalence :
   forall (A B:Type) (f:A -> B) (r:relation B),
     equivalence B r -> equivalence A (fun x y:A => r (f x) (f y)).
 Proof.
-  intros; split; elim H; red in |- *; auto.
+  intros; split; elim H; red; auto.
   intros _ equiv_trans _ x y z H0 H1; apply equiv_trans with (f y); assumption.
 Qed.
 
 Lemma inverse_image_of_eq :
   forall (A B:Type) (f:A -> B), equivalence A (fun x y:A => f x = f y).
 Proof.
-  split; red in |- *;
+  split; red;
     [  (* reflexivity *) reflexivity
       |  (* transitivity *) intros; transitivity (f y); assumption
-      |  (* symmetry *) intros; symmetry  in |- *; assumption ].
+      |  (* symmetry *) intros; symmetry ; assumption ].
 Qed.
 
diff --git a/theories/Setoids/Setoid.v b/theories/Setoids/Setoid.v
index 90362da0..eec7aa2d 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-2012     *)
 (*   \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..3129dbb1 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-2012     *)
 (*   \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.
@@ -40,8 +38,8 @@ Section Ensembles_classical.
     elim (not_all_ex_not U (fun x:U => ~ In U A x)).
     intros x H; apply Inhabited_intro with x.
     apply NNPP; auto with sets.
-    red in |- *; intro.
-    apply NI; red in |- *.
+    red; intro.
+    apply NI; red.
     intros x H'; elim (H x); trivial with sets.
   Qed.
 
@@ -49,7 +47,7 @@ Section Ensembles_classical.
     forall A:Ensemble U, A <> Empty_set U -> Inhabited U A.
   Proof.
     intros; apply not_included_empty_Inhabited.
-    red in |- *; auto with sets.
+    red; auto with sets.
   Qed.
 
   Lemma Inhabited_Setminus :
@@ -75,7 +73,7 @@ Section Ensembles_classical.
   Lemma Subtract_intro :
     forall (A:Ensemble U) (x y:U), In U A y -> x <> y -> In U (Subtract U A x) y.
   Proof.
-    unfold Subtract at 1 in |- *; auto with sets.
+    unfold Subtract at 1; auto with sets.
   Qed.
   Hint Resolve Subtract_intro : sets.
 
@@ -105,7 +103,7 @@ Section Ensembles_classical.
   Lemma not_SIncl_empty :
     forall X:Ensemble U, ~ Strict_Included U X (Empty_set U).
   Proof.
-    intro X; red in |- *; intro H'; try exact H'.
+    intro X; red; intro H'; try exact H'.
     lapply (Strict_Included_inv X (Empty_set U)); auto with sets.
     intro H'0; elim H'0; intros H'1 H'2; elim H'2; clear H'0.
     intros x H'0; elim H'0.
@@ -115,10 +113,10 @@ Section Ensembles_classical.
   Lemma Complement_Complement :
     forall A:Ensemble U, Complement U (Complement U A) = A.
   Proof.
-    unfold Complement in |- *; intros; apply Extensionality_Ensembles;
+    unfold Complement; intros; apply Extensionality_Ensembles;
       auto with sets.
-    red in |- *; split; auto with sets.
-    red in |- *; intros; apply NNPP; auto with sets.
+    red; split; auto with sets.
+    red; intros; apply NNPP; auto with sets.
   Qed.
 
 End Ensembles_classical.
diff --git a/theories/Sets/Constructive_sets.v b/theories/Sets/Constructive_sets.v
index d3900446..f559533a 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-2012     *)
 (*   \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.
@@ -38,24 +36,24 @@ Section Ensembles_facts.
 
   Lemma Noone_in_empty : forall x:U, ~ In U (Empty_set U) x.
   Proof.
-    red in |- *; destruct 1.
+    red; destruct 1.
   Qed.
 
   Lemma Included_Empty : forall A:Ensemble U, Included U (Empty_set U) A.
   Proof.
-    intro; red in |- *.
+    intro; red.
     intros x H; elim (Noone_in_empty x); auto with sets.
   Qed.
 
   Lemma Add_intro1 :
     forall (A:Ensemble U) (x y:U), In U A y -> In U (Add U A x) y.
   Proof.
-    unfold Add at 1 in |- *; auto with sets.
+    unfold Add at 1; auto with sets.
   Qed.
 
   Lemma Add_intro2 : forall (A:Ensemble U) (x:U), In U (Add U A x) x.
   Proof.
-    unfold Add at 1 in |- *; auto with sets.
+    unfold Add at 1; auto with sets.
   Qed.
 
   Lemma Inhabited_add : forall (A:Ensemble U) (x:U), Inhabited U (Add U A x).
@@ -68,7 +66,7 @@ Section Ensembles_facts.
     forall X:Ensemble U, Inhabited U X -> X <> Empty_set U.
   Proof.
     intros X H'; elim H'.
-    intros x H'0; red in |- *; intro H'1.
+    intros x H'0; red; intro H'1.
     absurd (In U X x); auto with sets.
     rewrite H'1; auto using Noone_in_empty with sets.
   Qed.
@@ -80,7 +78,7 @@ Section Ensembles_facts.
 
   Lemma not_Empty_Add : forall (A:Ensemble U) (x:U), Empty_set U <> Add U A x.
   Proof.
-    intros; red in |- *; intro H; generalize (Add_not_Empty A x); auto with sets.
+    intros; red; intro H; generalize (Add_not_Empty A x); auto with sets.
   Qed.
 
   Lemma Singleton_inv : forall x y:U, In U (Singleton U x) y -> x = y.
@@ -123,7 +121,7 @@ Section Ensembles_facts.
     forall (A B:Ensemble U) (x:U),
       In U A x -> ~ In U B x -> In U (Setminus U A B) x.
   Proof.
-    unfold Setminus at 1 in |- *; red in |- *; auto with sets.
+    unfold Setminus at 1; red; auto with sets.
   Qed.
 
   Lemma Strict_Included_intro :
@@ -134,7 +132,7 @@ Section Ensembles_facts.
 
   Lemma Strict_Included_strict : forall X:Ensemble U, ~ Strict_Included U X X.
   Proof.
-    intro X; red in |- *; intro H'; elim H'.
+    intro X; red; intro H'; elim H'.
     intros H'0 H'1; elim H'1; auto with sets.
   Qed.
 
diff --git a/theories/Sets/Cpo.v b/theories/Sets/Cpo.v
index c7b496cb..058eec3d 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-2012     *)
 (*   \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..181069d5 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-2012     *)
 (*   \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..fc940e48 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-2012     *)
 (*   \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.
@@ -63,7 +61,7 @@ Section Ensembles_finis_facts.
             (exists x : _, X = Add U A x /\ ~ In U A x /\ cardinal U A n)
       end.
   Proof.
-    induction 1; simpl in |- *; auto.
+    induction 1; simpl; auto.
     exists A; exists x; auto.
   Qed.
 
@@ -75,7 +73,7 @@ Section Ensembles_finis_facts.
 	| S n => Inhabited U X
       end.
   Proof.
-    intros X p C; elim C; simpl in |- *; trivial with sets.
+    intros X p C; elim C; simpl; trivial with sets.
   Qed.
 
 End Ensembles_finis_facts.
diff --git a/theories/Sets/Finite_sets_facts.v b/theories/Sets/Finite_sets_facts.v
index a9fe8ffe..c0613637 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-2012     *)
 (*   \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.
@@ -64,7 +62,7 @@ Section Finite_sets_facts.
   Theorem Singleton_is_finite : forall x:U, Finite U (Singleton U x).
   Proof.
     intro x; rewrite <- (Empty_set_zero U (Singleton U x)).
-    change (Finite U (Add U (Empty_set U) x)) in |- *; auto with sets.
+    change (Finite U (Add U (Empty_set U) x)); auto with sets.
   Qed.
 
   Theorem Union_preserves_Finite :
@@ -136,15 +134,15 @@ Section Finite_sets_facts.
     cut (S (pred n) = pred (S n)).
     intro H'5; rewrite <- H'5.
     apply card_add; auto with sets.
-    red in |- *; intro H'6; elim H'6.
+    red; intro H'6; elim H'6.
     intros H'7 H'8; try assumption.
     elim H'1; auto with sets.
-    unfold pred at 2 in |- *; symmetry  in |- *.
+    unfold pred at 2; symmetry .
     apply S_pred with (m := 0).
-    change (n > 0) in |- *.
+    change (n > 0).
     apply inh_card_gt_O with (X := X); auto with sets.
     apply Inhabited_intro with (x := x0); auto with sets.
-    red in |- *; intro H'3.
+    red; intro H'3.
     apply H'1.
     elim H'3; auto with sets.
     rewrite H'3; auto with sets.
@@ -154,7 +152,7 @@ Section Finite_sets_facts.
     intro H'4; rewrite H'4; auto with sets.
     intros H'3 H'4; try assumption.
     absurd (In U (Add U X x) x0); auto with sets.
-    red in |- *; intro H'5; try exact H'5.
+    red; intro H'5; try exact H'5.
     lapply (Add_inv U X x x0); tauto.
   Qed.
 
@@ -175,21 +173,21 @@ 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.
+    pattern x at 2; rewrite H'6; auto with sets.
     intros H'6 H'7.
     absurd (Add U X x = Add U X0 x0); auto with sets.
     clear H'0 H' H'3 n H'5 H'4 H'2 H'1 c2.
-    red in |- *; intro H'.
+    red; intro H'.
     lapply (Extension U (Add U X x) (Add U X0 x0)); auto with sets.
     clear H'.
     intro H'; red in H'.
@@ -256,7 +254,7 @@ Section Finite_sets_facts.
     apply H'0 with (Y := X0); auto with sets arith.
     apply sincl_add_x with (x := x0).
     rewrite <- H'6; auto with sets arith.
-    pattern x0 at 1 in |- *; rewrite <- H'6; trivial with sets arith.
+    pattern x0 at 1; rewrite <- H'6; trivial with sets arith.
     intros H'6 H'7; red in H'5.
     elim H'5; intros H'8 H'9; try exact H'8; clear H'5.
     red in H'8.
diff --git a/theories/Sets/Image.v b/theories/Sets/Image.v
index e5eae17e..bdb7c077 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-2012     *)
 (*   \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.
@@ -57,7 +55,7 @@ Section Image.
   Proof.
     intros X x f.
     apply Extensionality_Ensembles.
-    split; red in |- *; intros x0 H'.
+    split; red; intros x0 H'.
     elim H'; intros.
     rewrite H0.
     elim Add_inv with U X x x1; auto using Im_def with sets.
@@ -74,7 +72,7 @@ Section Image.
     intro f; try assumption.
     apply Extensionality_Ensembles.
     split; auto with sets.
-    red in |- *.
+    red.
     intros x H'; elim H'.
     intros x0 H'0; elim H'0; auto with sets.
   Qed.
@@ -104,7 +102,7 @@ Section Image.
     forall f:U -> V,
       ~ injective f ->  exists x : _, (exists y : _, f x = f y /\ x <> y).
   Proof.
-    unfold injective in |- *; intros f H.
+    unfold injective; intros f H.
     cut (exists x : _, ~ (forall y:U, f x = f y -> x = y)).
     2: apply not_all_ex_not with (P := fun x:U => forall y:U, f x = f y -> x = y);
       trivial with sets.
@@ -155,7 +153,7 @@ Section Image.
     apply cardinal_unicity with V (Add _ (Im A f) (f x)); trivial with sets.
     apply card_add; auto with sets.
     rewrite <- H1; trivial with sets.
-    red in |- *; intro; apply H'2.
+    red; intro; apply H'2.
     apply In_Image_elim with f; trivial with sets.
   Qed.
 
@@ -182,7 +180,7 @@ Section Image.
       cardinal U A n ->
       forall n':nat, cardinal V (Im A f) n' -> n' < n -> ~ injective f.
   Proof.
-    unfold not in |- *; intros A f n CAn n' CIfn' ltn'n I.
+    unfold not; intros A f n CAn n' CIfn' ltn'n I.
     cut (n' = n).
     intro E; generalize ltn'n; rewrite E; exact (lt_irrefl n).
     apply injective_preserves_cardinal with (A := A) (f := f) (n := n);
@@ -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..897046ab 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-2012     *)
 (*   \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.
@@ -58,7 +56,7 @@ Section Infinite_sets.
     intros A X H' H'0.
     elim H'0; intros H'1 H'2.
     apply Strict_super_set_contains_new_element; auto with sets.
-    red in |- *; intro H'3; apply H'.
+    red; intro H'3; apply H'.
     rewrite <- H'3; auto with sets.
   Qed.
 
@@ -78,7 +76,7 @@ Section Infinite_sets.
     split.
     apply card_add; auto with sets.
     cut (In U A x).
-    intro H'4; red in |- *; auto with sets.
+    intro H'4; red; auto with sets.
     intros x0 H'5; elim H'5; auto with sets.
     intros x1 H'6; elim H'6; auto with sets.
     elim H'3; auto with sets.
@@ -93,7 +91,7 @@ Section Infinite_sets.
     split.
     apply card_add; auto with sets.
     elim H'2; auto with sets.
-    red in |- *.
+    red.
     intros x2 H'9; elim H'9; auto with sets.
     intros x3 H'10; elim H'10; auto with sets.
     elim H'2; auto with sets.
@@ -169,11 +167,11 @@ Section Infinite_sets.
     apply ex_intro with (x := Add U x0 x1).
     split; [ split; [ try assumption | idtac ] | idtac ].
     apply card_add; auto with sets.
-    red in |- *; intro H'9; try exact H'9.
+    red; intro H'9; try exact H'9.
     apply H'1.
     elim H'4; intros H'10 H'11; rewrite <- H'11; clear H'4; auto with sets.
     elim H'4; intros H'9 H'10; try exact H'9; clear H'4; auto with sets.
-    red in |- *; auto with sets.
+    red; auto with sets.
     intros x2 H'4; elim H'4; auto with sets.
     intros x3 H'11; elim H'11; auto with sets.
     elim H'4; intros H'9 H'10; rewrite <- H'10; clear H'4; auto with sets.
@@ -237,7 +235,7 @@ Section Infinite_sets.
   Proof.
     intros A f H' H'0 H'1.
     apply NNPP.
-    red in |- *; intro H'2.
+    red; intro H'2.
     elim (Pigeonhole_bis A f); auto with sets.
   Qed.
 
diff --git a/theories/Sets/Integers.v b/theories/Sets/Integers.v
index 5d073a0c..4ee7496e 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-2012     *)
 (*   \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.
@@ -51,17 +49,17 @@ Section Integers_sect.
 
   Lemma le_reflexive : Reflexive nat le.
   Proof.
-    red in |- *; auto with arith.
+    red; auto with arith.
   Qed.
 
   Lemma le_antisym : Antisymmetric nat le.
   Proof.
-    red in |- *; intros x y H H'; rewrite (le_antisym x y); auto.
+    red; intros x y H H'; rewrite (le_antisym x y); auto.
   Qed.
 
   Lemma le_trans : Transitive nat le.
   Proof.
-    red in |- *; intros; apply le_trans with y; auto.
+    red; intros; apply le_trans with y; auto.
   Qed.
 
   Lemma le_Order : Order nat le.
@@ -85,7 +83,7 @@ Section Integers_sect.
   Lemma le_total_order : Totally_ordered nat nat_po Integers.
   Proof.
     apply Totally_ordered_definition.
-    simpl in |- *.
+    simpl.
     intros H' x y H'0.
     elim le_or_lt with (n := x) (m := y).
     intro H'1; left; auto with sets arith.
@@ -105,7 +103,7 @@ Section Integers_sect.
     intros A H'0 H'1 x H'2; try assumption.
     elim H'1; intros x0 H'3; clear H'1.
     elim le_total_order.
-    simpl in |- *.
+    simpl.
     intro H'1; try assumption.
     lapply H'1; [ intro H'4; idtac | try assumption ]; auto with sets arith.
     generalize (H'4 x0 x).
@@ -116,28 +114,28 @@ Section Integers_sect.
 	[ intro H'5; try exact H'5; clear H'4 H'1 | intro H'5; clear H'4 H'1 ]
 	| clear H'1 ].
     exists x.
-    apply Upper_Bound_definition. simpl in |- *. apply triv_nat.
+    apply Upper_Bound_definition. simpl. apply triv_nat.
     intros y H'1; elim H'1.
     generalize le_trans.
     intro H'4; red in H'4.
     intros x1 H'6; try assumption.
-    apply H'4 with (y := x0). elim H'3; simpl in |- *; auto with sets arith. trivial.
+    apply H'4 with (y := x0). elim H'3; simpl; auto with sets arith. trivial.
     intros x1 H'4; elim H'4. unfold nat_po; simpl; trivial.
     exists x0.
     apply Upper_Bound_definition.
       unfold nat_po. simpl. apply triv_nat.
     intros y H'1; elim H'1.
     intros x1 H'4; try assumption.
-    elim H'3; simpl in |- *; auto with sets arith.
+    elim H'3; simpl; auto with sets arith.
     intros x1 H'4; elim H'4; auto with sets arith.
-    red in |- *.
+    red.
     intros x1 H'1; elim H'1; apply triv_nat.
   Qed.
 
   Lemma Integers_has_no_ub :
     ~ (exists m : nat, Upper_Bound nat nat_po Integers m).
   Proof.
-    red in |- *; intro H'; elim H'.
+    red; intro H'; elim H'.
     intros x H'0.
     elim H'0; intros H'1 H'2.
     cut (In nat Integers (S x)).
@@ -152,7 +150,7 @@ Section Integers_sect.
   Lemma Integers_infinite : ~ Finite nat Integers.
   Proof.
     generalize Integers_has_no_ub.
-    intro H'; red in |- *; intro H'0; try exact H'0.
+    intro H'; red; intro H'0; try exact H'0.
     apply H'.
     apply Finite_subset_has_lub; auto with sets arith.
   Qed.
diff --git a/theories/Sets/Multiset.v b/theories/Sets/Multiset.v
index 6187c08b..1d0abab8 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-2012     *)
 (*   \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.
@@ -44,14 +42,14 @@ Section multiset_defs.
 
   Lemma meq_trans : forall x y z:multiset, meq x y -> meq y z -> meq x z.
   Proof.
-    unfold meq in |- *.
+    unfold meq.
     destruct x; destruct y; destruct z.
     intros; rewrite H; auto.
   Qed.
 
   Lemma meq_sym : forall x y:multiset, meq x y -> meq y x.
   Proof.
-    unfold meq in |- *.
+    unfold meq.
     destruct x; destruct y; auto.
   Qed.
 
@@ -61,12 +59,12 @@ Section multiset_defs.
 
   Lemma munion_empty_left : forall x:multiset, meq x (munion EmptyBag x).
   Proof.
-    unfold meq in |- *; unfold munion in |- *; simpl in |- *; auto.
+    unfold meq; unfold munion; simpl; auto.
   Qed.
 
   Lemma munion_empty_right : forall x:multiset, meq x (munion x EmptyBag).
   Proof.
-    unfold meq in |- *; unfold munion in |- *; simpl in |- *; auto.
+    unfold meq; unfold munion; simpl; auto.
   Qed.
 
 
@@ -74,21 +72,21 @@ Section multiset_defs.
 
   Lemma munion_comm : forall x y:multiset, meq (munion x y) (munion y x).
   Proof.
-    unfold meq in |- *; unfold multiplicity in |- *; unfold munion in |- *.
+    unfold meq; unfold multiplicity; unfold munion.
     destruct x; destruct y; auto with arith.
   Qed.
 
   Lemma munion_ass :
     forall x y z:multiset, meq (munion (munion x y) z) (munion x (munion y z)).
   Proof.
-    unfold meq in |- *; unfold munion in |- *; unfold multiplicity in |- *.
+    unfold meq; unfold munion; unfold multiplicity.
     destruct x; destruct y; destruct z; auto with arith.
   Qed.
 
   Lemma meq_left :
     forall x y z:multiset, meq x y -> meq (munion x z) (munion y z).
   Proof.
-    unfold meq in |- *; unfold munion in |- *; unfold multiplicity in |- *.
+    unfold meq; unfold munion; unfold multiplicity.
     destruct x; destruct y; destruct z.
     intros; elim H; auto with arith.
   Qed.
@@ -96,7 +94,7 @@ Section multiset_defs.
   Lemma meq_right :
     forall x y z:multiset, meq x y -> meq (munion z x) (munion z y).
   Proof.
-    unfold meq in |- *; unfold munion in |- *; unfold multiplicity in |- *.
+    unfold meq; unfold munion; unfold multiplicity.
     destruct x; destruct y; destruct z.
     intros; elim H; auto.
   Qed.
diff --git a/theories/Sets/Partial_Order.v b/theories/Sets/Partial_Order.v
index e819cafa..054164da 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-2012     *)
 (*   \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.
 
@@ -65,13 +63,13 @@ Section Partial_order_facts.
     forall x y z:U,
       Strict_Rel_of U D x y -> Rel_of U D y z -> Strict_Rel_of U D x z.
   Proof.
-    unfold Strict_Rel_of at 1 in |- *.
-    red in |- *.
-    elim D; simpl in |- *.
+    unfold Strict_Rel_of at 1.
+    red.
+    elim D; simpl.
     intros C R H' H'0; elim H'0.
     intros H'1 H'2 H'3 x y z H'4 H'5; split.
     apply H'2 with (y := y); tauto.
-    red in |- *; intro H'6.
+    red; intro H'6.
     elim H'4; intros H'7 H'8; apply H'8; clear H'4.
     apply H'3; auto.
     rewrite H'6; tauto.
@@ -81,22 +79,22 @@ Section Partial_order_facts.
     forall x y z:U,
       Rel_of U D x y -> Strict_Rel_of U D y z -> Strict_Rel_of U D x z.
   Proof.
-    unfold Strict_Rel_of at 1 in |- *.
-    red in |- *.
-    elim D; simpl in |- *.
+    unfold Strict_Rel_of at 1.
+    red.
+    elim D; simpl.
     intros C R H' H'0; elim H'0.
     intros H'1 H'2 H'3 x y z H'4 H'5; split.
     apply H'2 with (y := y); tauto.
-    red in |- *; intro H'6.
+    red; intro H'6.
     elim H'5; intros H'7 H'8; apply H'8; clear H'5.
     apply H'3; auto.
     rewrite <- H'6; auto.
   Qed.
 
   Lemma Strict_Rel_Transitive : Transitive U (Strict_Rel_of U D).
-    red in |- *.
+    red.
     intros x y z H' H'0.
     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..5523f64c 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-2012     *)
 (*   \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..cdbeaf7b 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-2012     *)
 (*   \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.
@@ -41,7 +39,7 @@ Inductive Power_set (A:Ensemble U) : Ensemble (Ensemble U) :=
 Hint Resolve Definition_of_Power_set.
 
 Theorem Empty_set_minimal : forall X:Ensemble U, Included U (Empty_set U) X.
-intro X; red in |- *.
+intro X; red.
 intros x H'; elim H'.
 Qed.
 Hint Resolve Empty_set_minimal.
@@ -81,7 +79,7 @@ Lemma Strict_inclusion_is_transitive_with_inclusion :
    Strict_Included U x y -> Included U y z -> Strict_Included U x z.
 intros x y z H' H'0; try assumption.
 elim Strict_Rel_is_Strict_Included.
-unfold contains in |- *.
+unfold contains.
 intros H'1 H'2; try assumption.
 apply H'1.
 apply Strict_Rel_Transitive_with_Rel with (y := y); auto with sets.
@@ -92,7 +90,7 @@ Lemma Strict_inclusion_is_transitive_with_inclusion_left :
    Included U x y -> Strict_Included U y z -> Strict_Included U x z.
 intros x y z H' H'0; try assumption.
 elim Strict_Rel_is_Strict_Included.
-unfold contains in |- *.
+unfold contains.
 intros H'1 H'2; try assumption.
 apply H'1.
 apply Strict_Rel_Transitive_with_Rel_left with (y := y); auto with sets.
@@ -107,14 +105,14 @@ Qed.
 
 Theorem Empty_set_is_Bottom :
  forall A:Ensemble U, Bottom (Ensemble U) (Power_set_PO A) (Empty_set U).
-intro A; apply Bottom_definition; simpl in |- *; auto with sets.
+intro A; apply Bottom_definition; simpl; auto with sets.
 Qed.
 Hint Resolve Empty_set_is_Bottom.
 
 Theorem Union_minimal :
  forall a b X:Ensemble U,
    Included U a X -> Included U b X -> Included U (Union U a b) X.
-intros a b X H' H'0; red in |- *.
+intros a b X H' H'0; red.
 intros x H'1; elim H'1; auto with sets.
 Qed.
 Hint Resolve Union_minimal.
@@ -135,13 +133,13 @@ Qed.
 
 Theorem Intersection_decreases_l :
  forall a b:Ensemble U, Included U (Intersection U a b) a.
-intros a b; red in |- *.
+intros a b; red.
 intros x H'; elim H'; auto with sets.
 Qed.
 
 Theorem Intersection_decreases_r :
  forall a b:Ensemble U, Included U (Intersection U a b) b.
-intros a b; red in |- *.
+intros a b; red.
 intros x H'; elim H'; auto with sets.
 Qed.
 Hint Resolve Union_increases_l Union_increases_r Intersection_decreases_l
@@ -153,10 +151,10 @@ Theorem Union_is_Lub :
    Included U b A ->
    Lub (Ensemble U) (Power_set_PO A) (Couple (Ensemble U) a b) (Union U a b).
 intros A a b H' H'0.
-apply Lub_definition; simpl in |- *.
-apply Upper_Bound_definition; simpl in |- *; auto with sets.
+apply Lub_definition; simpl.
+apply Upper_Bound_definition; simpl; auto with sets.
 intros y H'1; elim H'1; auto with sets.
-intros y H'1; elim H'1; simpl in |- *; auto with sets.
+intros y H'1; elim H'1; simpl; auto with sets.
 Qed.
 
 Theorem Intersection_is_Glb :
@@ -166,13 +164,13 @@ Theorem Intersection_is_Glb :
    Glb (Ensemble U) (Power_set_PO A) (Couple (Ensemble U) a b)
      (Intersection U a b).
 intros A a b H' H'0.
-apply Glb_definition; simpl in |- *.
-apply Lower_Bound_definition; simpl in |- *; auto with sets.
+apply Glb_definition; simpl.
+apply Lower_Bound_definition; simpl; auto with sets.
 apply Definition_of_Power_set.
 generalize Inclusion_is_transitive; intro IT; red in IT; apply IT with a;
  auto with sets.
 intros y H'1; elim H'1; auto with sets.
-intros y H'1; elim H'1; simpl in |- *; auto with sets.
+intros y H'1; elim H'1; simpl; auto with sets.
 Qed.
 
 End The_power_set_partial_order.
@@ -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..d24e931d 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-2012     *)
 (*   \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.
@@ -46,13 +44,13 @@ Section Sets_as_an_algebra.
       ~ In U A x ->
       Strict_Included U (Add U A x) (Add U B x) -> Strict_Included U A B.
   Proof.
-    intros A B x H' H'0; red in |- *.
+    intros A B x H' H'0; red.
     lapply (Strict_Included_inv U (Add U A x) (Add U B x)); auto with sets.
     clear H'0; intro H'0; split.
     apply incl_add_x with (x := x); tauto.
     elim H'0; intros H'1 H'2; elim H'2; clear H'0 H'2.
     intros x0 H'0.
-    red in |- *; intro H'2.
+    red; intro H'2.
     elim H'0; clear H'0.
     rewrite <- H'2; auto with sets.
   Qed.
@@ -60,7 +58,7 @@ Section Sets_as_an_algebra.
   Lemma incl_soustr_in :
     forall (X:Ensemble U) (x:U), In U X x -> Included U (Subtract U X x) X.
   Proof.
-    intros X x H'; red in |- *.
+    intros X x H'; red.
     intros x0 H'0; elim H'0; auto with sets.
   Qed.
 
@@ -68,7 +66,7 @@ Section Sets_as_an_algebra.
     forall (X Y:Ensemble U) (x:U),
       Included U X Y -> Included U (Subtract U X x) (Subtract U Y x).
   Proof.
-    intros X Y x H'; red in |- *.
+    intros X Y x H'; red.
     intros x0 H'0; elim H'0.
     intros H'1 H'2.
     apply Subtract_intro; auto with sets.
@@ -77,7 +75,7 @@ Section Sets_as_an_algebra.
   Lemma incl_soustr_add_l :
     forall (X:Ensemble U) (x:U), Included U (Subtract U (Add U X x) x) X.
   Proof.
-    intros X x; red in |- *.
+    intros X x; red.
     intros x0 H'; elim H'; auto with sets.
     intro H'0; elim H'0; auto with sets.
     intros t H'1 H'2; elim H'2; auto with sets.
@@ -87,10 +85,10 @@ Section Sets_as_an_algebra.
     forall (X:Ensemble U) (x:U),
       ~ In U X x -> Included U X (Subtract U (Add U X x) x).
   Proof.
-    intros X x H'; red in |- *.
+    intros X x H'; red.
     intros x0 H'0; try assumption.
     apply Subtract_intro; auto with sets.
-    red in |- *; intro H'1; apply H'; rewrite H'1; auto with sets.
+    red; intro H'1; apply H'; rewrite H'1; auto with sets.
   Qed.
   Hint Resolve incl_soustr_add_r: sets v62.
 
@@ -98,7 +96,7 @@ Section Sets_as_an_algebra.
     forall (X:Ensemble U) (x:U),
       In U X x -> Included U X (Add U (Subtract U X x) x).
   Proof.
-    intros X x H'; red in |- *.
+    intros X x H'; red.
     intros x0 H'0; try assumption.
     elim (classic (x = x0)); intro K; auto with sets.
     elim K; auto with sets.
@@ -108,7 +106,7 @@ Section Sets_as_an_algebra.
     forall (X:Ensemble U) (x:U),
       In U X x -> Included U (Add U (Subtract U X x) x) X.
   Proof.
-    intros X x H'; red in |- *.
+    intros X x H'; red.
     intros x0 H'0; elim H'0; auto with sets.
     intros y H'1; elim H'1; auto with sets.
     intros t H'1; try assumption.
@@ -120,7 +118,7 @@ Section Sets_as_an_algebra.
       x <> y -> Subtract U (Add U X x) y = Add U (Subtract U X y) x.
   Proof.
     intros X x y H'; apply Extensionality_Ensembles.
-    split; red in |- *.
+    split; red.
     intros x0 H'0; elim H'0; auto with sets.
     intro H'1; elim H'1.
     intros u H'2 H'3; try assumption.
@@ -148,7 +146,7 @@ Section Sets_as_an_algebra.
     apply H'4 with (y := Y); auto using add_soustr_2 with sets.
     red in H'0.
     elim H'0; intros H'1 H'2; try exact H'1; clear H'0. (* PB *)
-    red in |- *; intro H'0; apply H'2.
+    red; intro H'0; apply H'2.
     rewrite H'0; auto 8 using add_soustr_xy, add_soustr_1, add_soustr_2 with sets.
   Qed.
 
@@ -179,7 +177,7 @@ Section Sets_as_an_algebra.
     exists (Subtract U X x).
     split; auto using incl_soustr_in, add_soustr_xy, add_soustr_1, add_soustr_2 with sets.
     red in H'0.
-    red in |- *.
+    red.
     intros x0 H'2; try assumption.
     lapply (Subtract_inv U X x x0); auto with sets.
     intro H'3; elim H'3; intros K K'; clear H'3.
@@ -191,7 +189,7 @@ Section Sets_as_an_algebra.
     elim K'; auto with sets.
     intro H'1; left; try assumption.
     red in H'0.
-    red in |- *.
+    red.
     intros x0 H'2; try assumption.
     lapply (H'0 x0); auto with sets.
     intro H'3; try assumption.
@@ -209,7 +207,7 @@ Section Sets_as_an_algebra.
       (forall z:Ensemble U, Included U x z -> Included U z y -> x = z \/ z = y).
   Proof.
     intros A x y H'; elim H'.
-    unfold Strict_Rel_of in |- *; simpl in |- *.
+    unfold Strict_Rel_of; simpl.
     intros H'0 H'1; split; [ auto with sets | idtac ].
     intros z H'2 H'3; try assumption.
     elim (classic (x = z)); auto with sets.
@@ -229,11 +227,11 @@ Section Sets_as_an_algebra.
   Proof.
     intros A a H' x H'0 H'1; try assumption.
     apply setcover_intro; auto with sets.
-    red in |- *.
-    split; [ idtac | red in |- *; intro H'2; try exact H'2 ]; auto with sets.
+    red.
+    split; [ idtac | red; intro H'2; try exact H'2 ]; auto with sets.
     apply H'1.
     rewrite H'2; auto with sets.
-    red in |- *; intro H'2; elim H'2; clear H'2.
+    red; intro H'2; elim H'2; clear H'2.
     intros z H'2; elim H'2; intros H'3 H'4; try exact H'3; clear H'2.
     lapply (Strict_Included_inv U a z); auto with sets; clear H'3.
     intro H'2; elim H'2; intros H'3 H'5; elim H'5; clear H'2 H'5.
@@ -251,7 +249,7 @@ Section Sets_as_an_algebra.
     red in K.
     elim K; intros H'11 H'12; apply H'12; clear K; auto with sets.
     rewrite H'15.
-    red in |- *.
+    red.
     intros x1 H'10; elim H'10; auto with sets.
     intros x2 H'11; elim H'11; auto with sets.
   Qed.
@@ -277,11 +275,11 @@ Section Sets_as_an_algebra.
     elim (H'7 (Add U a x)); auto with sets.
     intro H'1.
     absurd (a = Add U a x); auto with sets.
-    red in |- *; intro H'8; try exact H'8.
+    red; intro H'8; try exact H'8.
     apply H'3.
     rewrite H'8; auto with sets.
     auto with sets.
-    red in |- *.
+    red.
     intros x0 H'1; elim H'1; auto with sets.
     intros x1 H'8; elim H'8; auto with sets.
     split; [ idtac | try assumption ].
diff --git a/theories/Sets/Powerset_facts.v b/theories/Sets/Powerset_facts.v
index 09edd08a..58e3f44d 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-2012     *)
 (*   \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.
@@ -44,7 +42,7 @@ Section Sets_as_an_algebra.
 
   Theorem Empty_set_zero' : forall x:U, Add U (Empty_set U) x = Singleton U x.
   Proof.
-    unfold Add at 1 in |- *; auto using Empty_set_zero with sets.
+    unfold Add at 1; auto using Empty_set_zero with sets.
   Qed.
 
   Lemma less_than_empty :
@@ -78,7 +76,7 @@ Section Sets_as_an_algebra.
   Theorem Couple_as_union :
     forall x y:U, Union U (Singleton U x) (Singleton U y) = Couple U x y.
   Proof.
-    intros x y; apply Extensionality_Ensembles; split; red in |- *.
+    intros x y; apply Extensionality_Ensembles; split; red.
     intros x0 H'; elim H'; (intros x1 H'0; elim H'0; auto with sets).
     intros x0 H'; elim H'; auto with sets.
   Qed.
@@ -88,7 +86,7 @@ Section Sets_as_an_algebra.
       Union U (Union U (Singleton U x) (Singleton U y)) (Singleton U z) =
       Triple U x y z.
   Proof.
-    intros x y z; apply Extensionality_Ensembles; split; red in |- *.
+    intros x y z; apply Extensionality_Ensembles; split; red.
     intros x0 H'; elim H'.
     intros x1 H'0; elim H'0; (intros x2 H'1; elim H'1; auto with sets).
     intros x1 H'0; elim H'0; auto with sets.
@@ -116,7 +114,7 @@ Section Sets_as_an_algebra.
   Proof.
     intros A B.
     apply Extensionality_Ensembles.
-    split; red in |- *; intros x H'; elim H'; auto with sets.
+    split; red; intros x H'; elim H'; auto with sets.
   Qed.
 
   Theorem Distributivity :
@@ -126,7 +124,7 @@ Section Sets_as_an_algebra.
   Proof.
     intros A B C.
     apply Extensionality_Ensembles.
-    split; red in |- *; intros x H'.
+    split; red; intros x H'.
     elim H'.
     intros x0 H'0 H'1; generalize H'0.
     elim H'1; auto with sets.
@@ -140,7 +138,7 @@ Section Sets_as_an_algebra.
   Proof.
     intros A B C.
     apply Extensionality_Ensembles.
-    split; red in |- *; intros x H'.
+    split; red; intros x H'.
     elim H'; auto with sets.
     intros x0 H'0; elim H'0; auto with sets.
     elim H'.
@@ -153,15 +151,15 @@ Section Sets_as_an_algebra.
   Theorem Union_add :
     forall (A B:Ensemble U) (x:U), Add U (Union U A B) x = Union U A (Add U B x).
   Proof.
-    unfold Add in |- *; auto using Union_associative with sets.
+    unfold Add; auto using Union_associative with sets.
   Qed.
 
   Theorem Non_disjoint_union :
     forall (X:Ensemble U) (x:U), In U X x -> Add U X x = X.
   Proof.
-    intros X x H'; unfold Add in |- *.
-    apply Extensionality_Ensembles; red in |- *.
-    split; red in |- *; auto with sets.
+    intros X x H'; unfold Add.
+    apply Extensionality_Ensembles; red.
+    split; red; auto with sets.
     intros x0 H'0; elim H'0; auto with sets.
     intros t H'1; elim H'1; auto with sets.
   Qed.
@@ -169,12 +167,12 @@ Section Sets_as_an_algebra.
   Theorem Non_disjoint_union' :
     forall (X:Ensemble U) (x:U), ~ In U X x -> Subtract U X x = X.
   Proof.
-    intros X x H'; unfold Subtract in |- *.
+    intros X x H'; unfold Subtract.
     apply Extensionality_Ensembles.
-    split; red in |- *; auto with sets.
+    split; red; auto with sets.
     intros x0 H'0; elim H'0; auto with sets.
     intros x0 H'0; apply Setminus_intro; auto with sets.
-    red in |- *; intro H'1; elim H'1.
+    red; intro H'1; elim H'1.
     lapply (Singleton_inv U x x0); auto with sets.
     intro H'4; apply H'; rewrite H'4; auto with sets.
   Qed.
@@ -188,7 +186,7 @@ Section Sets_as_an_algebra.
     forall (A B:Ensemble U) (x:U),
       Included U A B -> Included U (Add U A x) (Add U B x).
   Proof.
-    intros A B x H'; red in |- *; auto with sets.
+    intros A B x H'; red; auto with sets.
     intros x0 H'0.
     lapply (Add_inv U A x x0); auto with sets.
     intro H'1; elim H'1;
@@ -200,7 +198,7 @@ Section Sets_as_an_algebra.
     forall (A B:Ensemble U) (x:U),
       ~ In U A x -> Included U (Add U A x) (Add U B x) -> Included U A B.
   Proof.
-    unfold Included in |- *.
+    unfold Included.
     intros A B x H' H'0 x0 H'1.
     lapply (H'0 x0); auto with sets.
     intro H'2; lapply (Add_inv U B x x0); auto with sets.
@@ -214,7 +212,7 @@ Section Sets_as_an_algebra.
     forall (A:Ensemble U) (x y:U), Add U (Add U A x) y = Add U (Add U A y) x.
   Proof.
     intros A x y.
-    unfold Add in |- *.
+    unfold Add.
     rewrite (Union_associative A (Singleton U x) (Singleton U y)).
     rewrite (Union_commutative (Singleton U x) (Singleton U y)).
     rewrite <- (Union_associative A (Singleton U y) (Singleton U x));
@@ -236,7 +234,7 @@ Section Sets_as_an_algebra.
   Proof.
     intros A B x y H'; try assumption.
     rewrite <- (Union_add (Add U A x) B y).
-    unfold Add at 4 in |- *.
+    unfold Add at 4.
     rewrite (Union_commutative A (Singleton U x)).
     rewrite Union_associative.
     rewrite (Union_absorbs A B H').
diff --git a/theories/Sets/Relations_1.v b/theories/Sets/Relations_1.v
index 2818b370..229ef592 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-2012     *)
 (*   \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..c4ede814 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-2012     *)
 (*   \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 :=
@@ -35,8 +33,8 @@ Theorem Rsym_imp_notRsym :
  forall (U:Type) (R:Relation U),
    Symmetric U R -> Symmetric U (Complement U R).
 Proof.
-unfold Symmetric, Complement in |- *.
-intros U R H' x y H'0; red in |- *; intro H'1; apply H'0; auto with sets.
+unfold Symmetric, Complement.
+intros U R H' x y H'0; red; intro H'1; apply H'0; auto with sets.
 Qed.
 
 Theorem Equiv_from_preorder :
@@ -46,8 +44,8 @@ Proof.
 intros U R H'; elim H'; intros H'0 H'1.
 apply Definition_of_equivalence.
 red in H'0; auto 10 with sets.
-2: red in |- *; intros x y h; elim h; intros H'3 H'4; auto 10 with sets.
-red in H'1; red in |- *; auto 10 with sets.
+2: red; intros x y h; elim h; intros H'3 H'4; auto 10 with sets.
+red in H'1; red; auto 10 with sets.
 intros x y z h; elim h; intros H'3 H'4; clear h.
 intro h; elim h; intros H'5 H'6; clear h.
 split; apply H'1 with y; auto 10 with sets.
@@ -72,7 +70,7 @@ Hint Resolve contains_is_preorder.
 Theorem same_relation_is_equivalence :
  forall U:Type, Equivalence (Relation U) (same_relation U).
 Proof.
-unfold same_relation at 1 in |- *; auto 10 with sets.
+unfold same_relation at 1; auto 10 with sets.
 Qed.
 Hint Resolve same_relation_is_equivalence.
 
@@ -80,14 +78,14 @@ Theorem cong_reflexive_same_relation :
  forall (U:Type) (R R':Relation U),
    same_relation U R R' -> Reflexive U R -> Reflexive U R'.
 Proof.
-unfold same_relation in |- *; intuition.
+unfold same_relation; intuition.
 Qed.
 
 Theorem cong_symmetric_same_relation :
  forall (U:Type) (R R':Relation U),
    same_relation U R R' -> Symmetric U R -> Symmetric U R'.
 Proof.
-  compute in |- *; intros; elim H; intros; clear H;
+  compute; intros; elim H; intros; clear H;
    apply (H3 y x (H0 x y (H2 x y H1))).
 (*Intuition.*)
 Qed.
@@ -96,7 +94,7 @@ Theorem cong_antisymmetric_same_relation :
  forall (U:Type) (R R':Relation U),
    same_relation U R R' -> Antisymmetric U R -> Antisymmetric U R'.
 Proof.
-  compute in |- *; intros; elim H; intros; clear H;
+  compute; intros; elim H; intros; clear H;
    apply (H0 x y (H3 x y H1) (H3 y x H2)).
 (*Intuition.*)
 Qed.
@@ -105,8 +103,8 @@ Theorem cong_transitive_same_relation :
  forall (U:Type) (R R':Relation U),
    same_relation U R R' -> Transitive U R -> Transitive U R'.
 Proof.
-intros U R R' H' H'0; red in |- *.
+intros U R R' H' H'0; red.
 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..a371f316 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-2012     *)
 (*   \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..676fd719 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-2012     *)
 (*   \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.
@@ -45,13 +43,13 @@ Qed.
 Theorem Rstar_contains_R :
  forall (U:Type) (R:Relation U), contains U (Rstar U R) R.
 Proof.
-intros U R; red in |- *; intros x y H'; apply Rstar_n with y; auto with sets.
+intros U R; red; intros x y H'; apply Rstar_n with y; auto with sets.
 Qed.
 
 Theorem Rstar_contains_Rplus :
  forall (U:Type) (R:Relation U), contains U (Rstar U R) (Rplus U R).
 Proof.
-intros U R; red in |- *.
+intros U R; red.
 intros x y H'; elim H'.
 generalize Rstar_contains_R; intro T; red in T; auto with sets.
 intros x0 y0 z H'0 H'1 H'2; apply Rstar_n with y0; auto with sets.
@@ -60,7 +58,7 @@ Qed.
 Theorem Rstar_transitive :
  forall (U:Type) (R:Relation U), Transitive U (Rstar U R).
 Proof.
-intros U R; red in |- *.
+intros U R; red.
 intros x y z H'; elim H'; auto with sets.
 intros x0 y0 z0 H'0 H'1 H'2 H'3; apply Rstar_n with y0; auto with sets.
 Qed.
@@ -77,7 +75,7 @@ Theorem Rstar_equiv_Rstar1 :
  forall (U:Type) (R:Relation U), same_relation U (Rstar U R) (Rstar1 U R).
 Proof.
 generalize Rstar_contains_R; intro T; red in T.
-intros U R; unfold same_relation, contains in |- *.
+intros U R; unfold same_relation, contains.
 split; intros x y H'; elim H'; auto with sets.
 generalize Rstar_transitive; intro T1; red in T1.
 intros x0 y0 z H'0 H'1 H'2 H'3; apply T1 with y0; auto with sets.
@@ -87,7 +85,7 @@ Qed.
 Theorem Rsym_imp_Rstarsym :
  forall (U:Type) (R:Relation U), Symmetric U R -> Symmetric U (Rstar U R).
 Proof.
-intros U R H'; red in |- *.
+intros U R H'; red.
 intros x y H'0; elim H'0; auto with sets.
 intros x0 y0 z H'1 H'2 H'3.
 generalize Rstar_transitive; intro T1; red in T1.
@@ -99,7 +97,7 @@ Theorem Sstar_contains_Rstar :
  forall (U:Type) (R S:Relation U),
    contains U (Rstar U S) R -> contains U (Rstar U S) (Rstar U R).
 Proof.
-unfold contains in |- *.
+unfold contains.
 intros U R S H' x y H'0; elim H'0; auto with sets.
 generalize Rstar_transitive; intro T1; red in T1.
 intros x0 y0 z H'1 H'2 H'3; apply T1 with y0; auto with sets.
@@ -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..6d1853e2 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-2012     *)
 (*   \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..a63f7c80 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-2012     *)
 (*   \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.
@@ -35,7 +33,7 @@ Require Export Relations_3.
 Theorem Rstar_imp_coherent :
  forall (U:Type) (R:Relation U) (x y:U), Rstar U R x y -> coherent U R x y.
 Proof.
-intros U R x y H'; red in |- *.
+intros U R x y H'; red.
 exists y; auto with sets.
 Qed.
 Hint Resolve Rstar_imp_coherent.
@@ -43,8 +41,8 @@ Hint Resolve Rstar_imp_coherent.
 Theorem coherent_symmetric :
  forall (U:Type) (R:Relation U), Symmetric U (coherent U R).
 Proof.
-unfold coherent at 1 in |- *.
-intros U R; red in |- *.
+unfold coherent at 1.
+intros U R; red.
 intros x y H'; elim H'.
 intros z H'0; exists z; tauto.
 Qed.
@@ -52,9 +50,9 @@ Qed.
 Theorem Strong_confluence :
  forall (U:Type) (R:Relation U), Strongly_confluent U R -> Confluent U R.
 Proof.
-intros U R H'; red in |- *.
-intro x; red in |- *; intros a b H'0.
-unfold coherent at 1 in |- *.
+intros U R H'; red.
+intro x; red; intros a b H'0.
+unfold coherent at 1.
 generalize b; clear b.
 elim H'0; clear H'0.
 intros x0 b H'1; exists b; auto with sets.
@@ -77,9 +75,9 @@ Qed.
 Theorem Strong_confluence_direct :
  forall (U:Type) (R:Relation U), Strongly_confluent U R -> Confluent U R.
 Proof.
-intros U R H'; red in |- *.
-intro x; red in |- *; intros a b H'0.
-unfold coherent at 1 in |- *.
+intros U R H'; red.
+intro x; red; intros a b H'0.
+unfold coherent at 1.
 generalize b; clear b.
 elim H'0; clear H'0.
 intros x0 b H'1; exists b; auto with sets.
@@ -113,7 +111,7 @@ Theorem Noetherian_contains_Noetherian :
  forall (U:Type) (R R':Relation U),
    Noetherian U R -> contains U R R' -> Noetherian U R'.
 Proof.
-unfold Noetherian at 2 in |- *.
+unfold Noetherian at 2.
 intros U R R' H' H'0 x.
 elim (H' x); auto with sets.
 Qed.
@@ -122,8 +120,8 @@ Theorem Newman :
  forall (U:Type) (R:Relation U),
    Noetherian U R -> Locally_confluent U R -> Confluent U R.
 Proof.
-intros U R H' H'0; red in |- *; intro x.
-elim (H' x); unfold confluent in |- *.
+intros U R H' H'0; red; intro x.
+elim (H' x); unfold confluent.
 intros x0 H'1 H'2 y z H'3 H'4.
 generalize (Rstar_cases U R x0 y); intro h; lapply h;
  [ intro h0; elim h0;
@@ -165,7 +163,7 @@ generalize (H'2 v); intro h; lapply h;
        | clear h h0 ]
     | clear h h0 ]
  | clear h ]; auto with sets.
-red in |- *; (exists z1; split); auto with sets.
+red; (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..6e38b5e5 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-2012     *)
 (*   \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 *)
@@ -53,37 +51,37 @@ Hint Unfold seq.
 
 Lemma leb_refl : forall b:bool, leb b b.
 Proof.
-destruct b; simpl in |- *; auto.
+destruct b; simpl; auto.
 Qed.
 Hint Resolve leb_refl.
 
 Lemma incl_left : forall s1 s2:uniset, seq s1 s2 -> incl s1 s2.
 Proof.
-unfold incl in |- *; intros s1 s2 E a; elim (E a); auto.
+unfold incl; intros s1 s2 E a; elim (E a); auto.
 Qed.
 
 Lemma incl_right : forall s1 s2:uniset, seq s1 s2 -> incl s2 s1.
 Proof.
-unfold incl in |- *; intros s1 s2 E a; elim (E a); auto.
+unfold incl; intros s1 s2 E a; elim (E a); auto.
 Qed.
 
 Lemma seq_refl : forall x:uniset, seq x x.
 Proof.
-destruct x; unfold seq in |- *; auto.
+destruct x; unfold seq; auto.
 Qed.
 Hint Resolve seq_refl.
 
 Lemma seq_trans : forall x y z:uniset, seq x y -> seq y z -> seq x z.
 Proof.
-unfold seq in |- *.
-destruct x; destruct y; destruct z; simpl in |- *; intros.
+unfold seq.
+destruct x; destruct y; destruct z; simpl; intros.
 rewrite H; auto.
 Qed.
 
 Lemma seq_sym : forall x y:uniset, seq x y -> seq y x.
 Proof.
-unfold seq in |- *.
-destruct x; destruct y; simpl in |- *; auto.
+unfold seq.
+destruct x; destruct y; simpl; auto.
 Qed.
 
 (** uniset union *)
@@ -92,20 +90,20 @@ Definition union (m1 m2:uniset) :=
 
 Lemma union_empty_left : forall x:uniset, seq x (union Emptyset x).
 Proof.
-unfold seq in |- *; unfold union in |- *; simpl in |- *; auto.
+unfold seq; unfold union; simpl; auto.
 Qed.
 Hint Resolve union_empty_left.
 
 Lemma union_empty_right : forall x:uniset, seq x (union x Emptyset).
 Proof.
-unfold seq in |- *; unfold union in |- *; simpl in |- *.
+unfold seq; unfold union; simpl.
 intros x a; rewrite (orb_b_false (charac x a)); auto.
 Qed.
 Hint Resolve union_empty_right.
 
 Lemma union_comm : forall x y:uniset, seq (union x y) (union y x).
 Proof.
-unfold seq in |- *; unfold charac in |- *; unfold union in |- *.
+unfold seq; unfold charac; unfold union.
 destruct x; destruct y; auto with bool.
 Qed.
 Hint Resolve union_comm.
@@ -113,14 +111,14 @@ Hint Resolve union_comm.
 Lemma union_ass :
  forall x y z:uniset, seq (union (union x y) z) (union x (union y z)).
 Proof.
-unfold seq in |- *; unfold union in |- *; unfold charac in |- *.
+unfold seq; unfold union; unfold charac.
 destruct x; destruct y; destruct z; auto with bool.
 Qed.
 Hint Resolve union_ass.
 
 Lemma seq_left : forall x y z:uniset, seq x y -> seq (union x z) (union y z).
 Proof.
-unfold seq in |- *; unfold union in |- *; unfold charac in |- *.
+unfold seq; unfold union; unfold charac.
 destruct x; destruct y; destruct z.
 intros; elim H; auto.
 Qed.
@@ -128,7 +126,7 @@ Hint Resolve seq_left.
 
 Lemma seq_right : forall x y z:uniset, seq x y -> seq (union z x) (union z y).
 Proof.
-unfold seq in |- *; unfold union in |- *; unfold charac in |- *.
+unfold seq; unfold union; unfold charac.
 destruct x; destruct y; destruct z.
 intros; elim H; auto.
 Qed.
@@ -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..8b1bdbd4 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-2012     *)
 (*   \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
@@ -57,13 +55,13 @@ Section defs.
 
   Lemma leA_Tree_Leaf : forall a:A, leA_Tree a Tree_Leaf.
   Proof.
-    simpl in |- *; auto with datatypes.
+    simpl; auto with datatypes.
   Qed.
 
   Lemma leA_Tree_Node :
     forall (a b:A) (G D:Tree), leA a b -> leA_Tree a (Tree_Node b G D).
   Proof.
-    simpl in |- *; auto with datatypes.
+    simpl; auto with datatypes.
   Qed.
 
 
@@ -123,7 +121,7 @@ Section defs.
     forall (T:Tree) (a b:A), leA a b -> leA_Tree b T -> leA_Tree a T.
   Proof.
     simple induction T; auto with datatypes.
-    intros; simpl in |- *; apply leA_trans with b; auto with datatypes.
+    intros; simpl; apply leA_trans with b; auto with datatypes.
   Qed.
 
   (** ** Merging two sorted lists *)
@@ -215,12 +213,12 @@ Section defs.
     simple induction 1; intros.
     apply insert_exist with (Tree_Node a Tree_Leaf Tree_Leaf);
       auto using node_is_heap, nil_is_heap, leA_Tree_Leaf with datatypes.
-    simpl in |- *; unfold meq, munion in |- *; auto using node_is_heap with datatypes.
+    simpl; unfold meq, munion; auto using node_is_heap with datatypes.
     elim (leA_dec a a0); intros.
     elim (X a0); intros.
     apply insert_exist with (Tree_Node a T2 T0);
       auto using node_is_heap, nil_is_heap, leA_Tree_Leaf with datatypes.
-    simpl in |- *; apply treesort_twist1; trivial with datatypes.
+    simpl; apply treesort_twist1; trivial with datatypes.
     elim (X a); intros T3 HeapT3 ConT3 LeA.
     apply insert_exist with (Tree_Node a0 T2 T3);
       auto using node_is_heap, nil_is_heap, leA_Tree_Leaf with datatypes.
@@ -228,7 +226,7 @@ Section defs.
     apply low_trans with a; auto with datatypes.
     apply LeA; auto with datatypes.
     apply low_trans with a; auto with datatypes.
-    simpl in |- *; apply treesort_twist2; trivial with datatypes.
+    simpl; apply treesort_twist2; trivial with datatypes.
   Qed.
 
 
@@ -244,10 +242,10 @@ Section defs.
   Proof.
     simple induction l.
     apply (heap_exist nil Tree_Leaf); auto with datatypes.
-    simpl in |- *; unfold meq in |- *; exact nil_is_heap.
+    simpl; unfold meq; exact nil_is_heap.
     simple induction 1.
     intros T i m; elim (insert T i a).
-    intros; apply heap_exist with T1; simpl in |- *; auto with datatypes.
+    intros; apply heap_exist with T1; simpl; auto with datatypes.
     apply meq_trans with (munion (contents T) (singletonBag a)).
     apply meq_trans with (munion (singletonBag a) (contents T)).
     apply meq_right; trivial with datatypes.
@@ -271,7 +269,7 @@ Section defs.
     apply flat_exist with (nil (A:=A)); auto with datatypes.
     elim X; intros l1 s1 i1 m1; elim X0; intros l2 s2 i2 m2.
     elim (merge _ s1 _ s2); intros.
-    apply flat_exist with (a :: l); simpl in |- *; auto with datatypes.
+    apply flat_exist with (a :: l); simpl; auto with datatypes.
     apply meq_trans with
       (munion (list_contents _ eqA_dec l1)
 	(munion (list_contents _ eqA_dec l2) (singletonBag a))).
@@ -290,7 +288,7 @@ Section defs.
     forall l:list A,
     {m : list A | Sorted leA m & permutation _ eqA_dec l m}.
   Proof.
-    intro l; unfold permutation in |- *.
+    intro l; unfold permutation.
     elim (list_to_heap l).
     intros.
     elim (heap_to_list T); auto with datatypes.
diff --git a/theories/Sorting/Mergesort.v b/theories/Sorting/Mergesort.v
index cded23ea..301a2142 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-2012     *)
 (*   \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) *)
 
@@ -133,7 +131,7 @@ Theorem Sorted_merge : forall l1 l2,
   Sorted l1 -> Sorted l2 -> Sorted (merge l1 l2).
 Proof.
 induction l1; induction l2; intros; simpl; auto.
-  destruct (a <=? a0) as ()_eqn:Heq1.
+  destruct (a <=? a0) eqn:Heq1.
     invert H.
       simpl. constructor; trivial; rewrite Heq1; constructor.
       assert (Sorted (merge (b::l) (a0::l2))) by (apply IHl1; auto).
diff --git a/theories/Sorting/PermutEq.v b/theories/Sorting/PermutEq.v
index 00d6e7ce..cc47b500 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-2012     *)
 (*   \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..2cd4f5f7 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-2012     *)
 (*   \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.
@@ -54,7 +52,7 @@ Lemma list_contents_app :
   forall l m:list A,
     meq (list_contents (l ++ m)) (munion (list_contents l) (list_contents m)).
 Proof.
-  simple induction l; simpl in |- *; auto with datatypes.
+  simple induction l; simpl; auto with datatypes.
   intros.
   apply meq_trans with
     (munion (singletonBag a) (munion (list_contents l0) (list_contents m)));
@@ -67,19 +65,19 @@ Definition permutation (l m:list A) := meq (list_contents l) (list_contents m).
 
 Lemma permut_refl : forall l:list A, permutation l l.
 Proof.
-  unfold permutation in |- *; auto with datatypes.
+  unfold permutation; auto with datatypes.
 Qed.
 
 Lemma permut_sym :
   forall l1 l2 : list A, permutation l1 l2 -> permutation l2 l1.
 Proof.
-  unfold permutation, meq; intros; apply sym_eq; trivial.
+  unfold permutation, meq; intros; symmetry; trivial.
 Qed.
 
 Lemma permut_trans :
   forall l m n:list A, permutation l m -> permutation m n -> permutation l n.
 Proof.
-  unfold permutation in |- *; intros.
+  unfold permutation; intros.
   apply meq_trans with (list_contents m); auto with datatypes.
 Qed.
 
@@ -104,7 +102,7 @@ Lemma permut_app :
   forall l l' m m':list A,
     permutation l l' -> permutation m m' -> permutation (l ++ m) (l' ++ m').
 Proof.
-  unfold permutation in |- *; intros.
+  unfold permutation; intros.
   apply meq_trans with (munion (list_contents l) (list_contents m));
     auto using permut_cons, list_contents_app with datatypes.
   apply meq_trans with (munion (list_contents l') (list_contents m'));
@@ -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..a69c4aa7 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-2012     *)
 (*   \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..03952c95 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-2012     *)
 (*   \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..ab03cb5e 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-2012     *)
 (*   \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..a89b888e 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-2012     *)
 (*   \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 *)
 
@@ -67,7 +65,7 @@ Definition ascii_of_N (n : N) :=
 
 (** Same for [nat] *)
 
-Definition ascii_of_nat (a : nat) := ascii_of_N (N_of_nat a).
+Definition ascii_of_nat (a : nat) := ascii_of_N (N.of_nat a).
 
 (** The opposite functions *)
 
@@ -83,7 +81,7 @@ Definition N_of_ascii (a : ascii) : N :=
  let (a0,a1,a2,a3,a4,a5,a6,a7) := a in
  N_of_digits (a0::a1::a2::a3::a4::a5::a6::a7::nil).
 
-Definition nat_of_ascii (a : ascii) : nat := nat_of_N (N_of_ascii a).
+Definition nat_of_ascii (a : ascii) : nat := N.to_nat (N_of_ascii a).
 
 (** Proofs that we have indeed opposite function (below 256) *)
 
@@ -113,10 +111,10 @@ Theorem nat_ascii_embedding :
 Proof.
  intros. unfold nat_of_ascii, ascii_of_nat.
  rewrite N_ascii_embedding.
- apply nat_of_N_of_nat.
- unfold Nlt.
- change 256%N with (N_of_nat 256).
- rewrite <- N_of_nat_compare.
+ apply Nat2N.id.
+ unfold N.lt.
+ change 256%N with (N.of_nat 256).
+ rewrite <- Nat2N.inj_compare.
  rewrite <- Compare_dec.nat_compare_lt. auto.
 Qed.
 
@@ -139,7 +137,7 @@ Qed.
   which is typically not the case in coqide).
 *)
 
-Open Local Scope char_scope.
+Local Open Scope char_scope.
 
 Example Space := " ".
 Example DoubleQuote := """".
diff --git a/theories/Strings/String.v b/theories/Strings/String.v
index c26b8818..6294d156 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-2012     *)
 (*   \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 *)
 
@@ -26,7 +24,7 @@ Inductive string : Set :=
 
 Delimit Scope string_scope with string.
 Bind Scope string_scope with string.
-Open Local Scope string_scope.
+Local Open Scope string_scope.
 
 (** Equality is decidable *)
 
@@ -74,14 +72,14 @@ Fixpoint get (n : nat) (s : string) {struct s} : option ascii :=
 Theorem get_correct :
   forall s1 s2 : string, (forall n : nat, get n s1 = get n s2) <-> s1 = s2.
 Proof.
-intros s1; elim s1; simpl in |- *.
-intros s2; case s2; simpl in |- *; split; auto.
+intros s1; elim s1; simpl.
+intros s2; case s2; simpl; split; auto.
 intros H; generalize (H 0); intros H1; inversion H1.
 intros; discriminate.
-intros a s1' Rec s2; case s2; simpl in |- *; split; auto.
+intros a s1' Rec s2; case s2; simpl; split; auto.
 intros H; generalize (H 0); intros H1; inversion H1.
 intros; discriminate.
-intros H; generalize (H 0); simpl in |- *; intros H1; inversion H1.
+intros H; generalize (H 0); simpl; intros H1; inversion H1.
 case (Rec s).
 intros H0; rewrite H0; auto.
 intros n; exact (H (S n)).
@@ -96,9 +94,9 @@ Theorem append_correct1 :
  forall (s1 s2 : string) (n : nat),
  n < length s1 -> get n s1 = get n (s1 ++ s2).
 Proof.
-intros s1; elim s1; simpl in |- *; auto.
+intros s1; elim s1; simpl; auto.
 intros s2 n H; inversion H.
-intros a s1' Rec s2 n; case n; simpl in |- *; auto.
+intros a s1' Rec s2 n; case n; simpl; auto.
 intros n0 H; apply Rec; auto.
 apply lt_S_n; auto.
 Qed.
@@ -109,10 +107,10 @@ Theorem append_correct2 :
  forall (s1 s2 : string) (n : nat),
  get n s2 = get (n + length s1) (s1 ++ s2).
 Proof.
-intros s1; elim s1; simpl in |- *; auto.
-intros s2 n; rewrite plus_comm; simpl in |- *; auto.
-intros a s1' Rec s2 n; case n; simpl in |- *; auto.
-generalize (Rec s2 0); simpl in |- *; auto. intros.
+intros s1; elim s1; simpl; auto.
+intros s2 n; rewrite plus_comm; simpl; auto.
+intros a s1' Rec s2 n; case n; simpl; auto.
+generalize (Rec s2 0); simpl; auto. intros.
 rewrite <- Plus.plus_Snm_nSm; auto.
 Qed.
 
@@ -137,16 +135,16 @@ Theorem substring_correct1 :
  forall (s : string) (n m p : nat),
  p < m -> get p (substring n m s) = get (p + n) s.
 Proof.
-intros s; elim s; simpl in |- *; auto.
-intros n; case n; simpl in |- *; auto.
-intros m; case m; simpl in |- *; auto.
-intros a s' Rec; intros n; case n; simpl in |- *; auto.
-intros m; case m; simpl in |- *; auto.
+intros s; elim s; simpl; auto.
+intros n; case n; simpl; auto.
+intros m; case m; simpl; auto.
+intros a s' Rec; intros n; case n; simpl; auto.
+intros m; case m; simpl; auto.
 intros p H; inversion H.
-intros m' p; case p; simpl in |- *; auto.
-intros n0 H; apply Rec; simpl in |- *; auto.
+intros m' p; case p; simpl; auto.
+intros n0 H; apply Rec; simpl; auto.
 apply Lt.lt_S_n; auto.
-intros n' m p H; rewrite <- Plus.plus_Snm_nSm; simpl in |- *; auto.
+intros n' m p H; rewrite <- Plus.plus_Snm_nSm; simpl; auto.
 Qed.
 
 (** The substring has at most [m] elements *)
@@ -154,14 +152,14 @@ Qed.
 Theorem substring_correct2 :
  forall (s : string) (n m p : nat), m <= p -> get p (substring n m s) = None.
 Proof.
-intros s; elim s; simpl in |- *; auto.
-intros n; case n; simpl in |- *; auto.
-intros m; case m; simpl in |- *; auto.
-intros a s' Rec; intros n; case n; simpl in |- *; auto.
-intros m; case m; simpl in |- *; auto.
-intros m' p; case p; simpl in |- *; auto.
+intros s; elim s; simpl; auto.
+intros n; case n; simpl; auto.
+intros m; case m; simpl; auto.
+intros a s' Rec; intros n; case n; simpl; auto.
+intros m; case m; simpl; auto.
+intros m' p; case p; simpl; auto.
 intros H; inversion H.
-intros n0 H; apply Rec; simpl in |- *; auto.
+intros n0 H; apply Rec; simpl; auto.
 apply Le.le_S_n; auto.
 Qed.
 
@@ -190,11 +188,11 @@ Theorem prefix_correct :
  forall s1 s2 : string,
  prefix s1 s2 = true <-> substring 0 (length s1) s2 = s1.
 Proof.
-intros s1; elim s1; simpl in |- *; auto.
-intros s2; case s2; simpl in |- *; split; auto.
-intros a s1' Rec s2; case s2; simpl in |- *; auto.
+intros s1; elim s1; simpl; auto.
+intros s2; case s2; simpl; split; auto.
+intros a s1' Rec s2; case s2; simpl; auto.
 split; intros; discriminate.
-intros b s2'; case (ascii_dec a b); simpl in |- *; auto.
+intros b s2'; case (ascii_dec a b); simpl; auto.
 intros e; case (Rec s2'); intros H1 H2; split; intros H3; auto.
 rewrite e; rewrite H1; auto.
 apply H2; injection H3; auto.
@@ -236,28 +234,28 @@ Theorem index_correct1 :
  forall (n m : nat) (s1 s2 : string),
  index n s1 s2 = Some m -> substring m (length s1) s2 = s1.
 Proof.
-intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl in |- *;
+intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl;
  auto.
-intros n; case n; simpl in |- *; auto.
-intros m s1; case s1; simpl in |- *; auto.
+intros n; case n; simpl; auto.
+intros m s1; case s1; simpl; auto.
 intros H; injection H; intros H1; rewrite <- H1; auto.
 intros; discriminate.
 intros; discriminate.
 intros b s2' Rec n m s1.
-case n; simpl in |- *; auto.
+case n; simpl; auto.
 generalize (prefix_correct s1 (String b s2'));
  case (prefix s1 (String b s2')).
 intros H0 H; injection H; intros H1; rewrite <- H1; auto.
-case H0; simpl in |- *; auto.
-case m; simpl in |- *; auto.
+case H0; simpl; auto.
+case m; simpl; 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.
+intros n'; case m; simpl; 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.
 
@@ -269,38 +267,38 @@ Theorem index_correct2 :
  index n s1 s2 = Some m ->
  forall p : nat, n <= p -> p < m -> substring p (length s1) s2 <> s1.
 Proof.
-intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl in |- *;
+intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl;
  auto.
-intros n; case n; simpl in |- *; auto.
-intros m s1; case s1; simpl in |- *; auto.
+intros n; case n; simpl; auto.
+intros m s1; case s1; simpl; auto.
 intros H; injection H; intros H1; rewrite <- H1.
 intros p H0 H2; inversion H2.
 intros; discriminate.
 intros; discriminate.
 intros b s2' Rec n m s1.
-case n; simpl in |- *; auto.
+case n; simpl; auto.
 generalize (prefix_correct s1 (String b s2'));
  case (prefix s1 (String b s2')).
 intros H0 H; injection H; intros H1; rewrite <- H1; auto.
 intros p H2 H3; inversion H3.
-case m; simpl in |- *; auto.
+case m; simpl; 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 p; try case p; simpl in |- *; auto.
-intros H2 H3; red in |- *; intros H4; case H0.
+intros x H H0 H1 p; try case p; simpl; auto.
+intros H2 H3; red; 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.
-intros n'; case m; simpl in |- *; auto.
+intros n'; case m; simpl; auto.
 case (index n' s1 s2'); intros; discriminate.
 intros m'; generalize (Rec n' m' s1); case (index n' s1 s2'); auto.
-intros x H H0 p; case p; simpl in |- *; auto.
+intros x H H0 p; case p; simpl; 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.
@@ -314,33 +312,33 @@ Theorem index_correct3 :
  index n s1 s2 = None ->
  s1 <> EmptyString -> n <= m -> substring m (length s1) s2 <> s1.
 Proof.
-intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl in |- *;
+intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl;
  auto.
-intros n; case n; simpl in |- *; auto.
-intros m s1; case s1; simpl in |- *; auto.
-case m; intros; red in |- *; intros; discriminate.
+intros n; case n; simpl; auto.
+intros m s1; case s1; simpl; auto.
+case m; intros; red; intros; discriminate.
 intros n' m; case m; auto.
-intros s1; case s1; simpl in |- *; auto.
+intros s1; case s1; simpl; auto.
 intros b s2' Rec n m s1.
-case n; simpl in |- *; auto.
+case n; simpl; auto.
 generalize (prefix_correct s1 (String b s2'));
  case (prefix s1 (String b s2')).
 intros; discriminate.
-case m; simpl in |- *; auto with bool.
-case s1; simpl in |- *; auto.
-intros a s H H0 H1 H2; red in |- *; intros H3; case H.
+case m; simpl; auto with bool.
+case s1; simpl; auto.
+intros a s H H0 H1 H2; red; intros H3; case H.
 intros H4 H5; absurd (false = true); auto with bool.
-case s1; simpl in |- *; auto.
+case s1; simpl; auto.
 intros a s n0 H H0 H1 H2;
- change (substring n0 (length (String a s)) s2' <> String a s) in |- *;
+ change (substring n0 (length (String a s)) s2' <> String a s);
  apply (Rec 0); auto.
-generalize H0; case (index 0 (String a s) s2'); simpl in |- *; auto; intros;
+generalize H0; case (index 0 (String a s) s2'); simpl; auto; intros;
  discriminate.
 apply Le.le_O_n.
-intros n'; case m; simpl in |- *; auto.
+intros n'; case m; simpl; auto.
 intros H H0 H1; inversion H1.
 intros n0 H H0 H1; apply (Rec n'); auto.
-generalize H; case (index n' s1 s2'); simpl in |- *; auto; intros;
+generalize H; case (index n' s1 s2'); simpl; auto; intros;
  discriminate.
 apply Le.le_S_n; auto.
 Qed.
@@ -355,13 +353,13 @@ Theorem index_correct4 :
  forall (n : nat) (s : string),
  index n EmptyString s = None -> length s < n.
 Proof.
-intros n s; generalize n; clear n; elim s; simpl in |- *; auto.
-intros n; case n; simpl in |- *; auto.
+intros n s; generalize n; clear n; elim s; simpl; auto.
+intros n; case n; simpl; auto.
 intros; discriminate.
 intros; apply Lt.lt_O_Sn.
-intros a s' H n; case n; simpl in |- *; auto.
+intros a s' H n; case n; simpl; auto.
 intros; discriminate.
-intros n'; generalize (H n'); case (index n' EmptyString s'); simpl in |- *;
+intros n'; generalize (H n'); case (index n' EmptyString s'); simpl;
  auto.
 intros; discriminate.
 intros H0 H1; apply Lt.lt_n_S; auto.
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..971fcd7f 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.
@@ -81,9 +79,9 @@ End PairDecidableType.
 Module PairUsualDecidableType(D1 D2:UsualDecidableType) <: UsualDecidableType.
  Definition t := prod D1.t D2.t.
  Definition eq := @eq t.
- Definition eq_refl := @refl_equal t.
- Definition eq_sym := @sym_eq t.
- Definition eq_trans := @trans_eq t.
+ Definition eq_refl := @eq_refl t.
+ Definition eq_sym := @eq_sym t.
+ Definition eq_trans := @eq_trans t.
  Definition eq_dec : forall x y, { eq x y }+{ ~eq x y }.
  Proof.
  intros (x1,x2) (y1,y2);
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..ffd0649a 100644
--- a/theories/Structures/GenericMinMax.v
+++ b/theories/Structures/GenericMinMax.v
@@ -40,34 +40,34 @@ Module GenericMinMax (Import O:OrderedTypeFull') <: HasMinMax O.
  Definition max := gmax O.compare.
  Definition min := gmin O.compare.
 
- Lemma ge_not_lt : forall x y, y<=x -> x<y -> False.
+ Lemma ge_not_lt x y : y<=x -> x<y -> False.
  Proof.
- intros x y H H'.
+ intros H H'.
  apply (StrictOrder_Irreflexive x).
  rewrite le_lteq in *; destruct H as [H|H].
  transitivity y; auto.
  rewrite H in H'; auto.
  Qed.
 
- Lemma max_l : forall x y, y<=x -> max x y == x.
+ Lemma max_l x y : y<=x -> max x y == x.
  Proof.
  intros. unfold max, gmax. case compare_spec; auto with relations.
  intros; elim (ge_not_lt x y); auto.
  Qed.
 
- Lemma max_r : forall x y, x<=y -> max x y == y.
+ Lemma max_r x y : x<=y -> max x y == y.
  Proof.
  intros. unfold max, gmax. case compare_spec; auto with relations.
  intros; elim (ge_not_lt y x); auto.
  Qed.
 
- Lemma min_l : forall x y, x<=y -> min x y == x.
+ Lemma min_l x y : x<=y -> min x y == x.
  Proof.
  intros. unfold min, gmin. case compare_spec; auto with relations.
  intros; elim (ge_not_lt y x); auto.
  Qed.
 
- Lemma min_r : forall x y, y<=x -> min x y == y.
+ Lemma min_r x y : y<=x -> min x y == y.
  Proof.
  intros. unfold min, gmin. case compare_spec; auto with relations.
  intros; elim (ge_not_lt x y); auto.
@@ -76,31 +76,30 @@ Module GenericMinMax (Import O:OrderedTypeFull') <: HasMinMax O.
 End GenericMinMax.
 
 
-(** ** Consequences of the minimalist interface: facts about [max]. *)
+(** ** Consequences of the minimalist interface: facts about [max] and [min]. *)
 
-Module MaxLogicalProperties (Import O:TotalOrder')(Import M:HasMax O).
- Module Import T := !MakeOrderTac O.
+Module MinMaxLogicalProperties (Import O:TotalOrder')(Import M:HasMinMax O).
+ Module Import Private_Tac := !MakeOrderTac O O.
 
 (** An alternative caracterisation of [max], equivalent to
     [max_l /\ max_r] *)
 
-Lemma max_spec : forall n m,
-  (n < m /\ max n m == m)  \/ (m <= n /\ max n m == n).
+Lemma max_spec n m :
+  (n < m /\ max n m == m) \/ (m <= n /\ max n m == n).
 Proof.
- intros n m.
  destruct (lt_total n m); [left|right].
- split; auto. apply max_r. rewrite le_lteq; auto.
- assert (m <= n) by (rewrite le_lteq; intuition).
- split; auto. apply max_l; auto.
+ - split; auto. apply max_r. rewrite le_lteq; auto.
+ - assert (m <= n) by (rewrite le_lteq; intuition).
+   split; auto. now apply max_l.
 Qed.
 
 (** A more symmetric version of [max_spec], based only on [le].
     Beware that left and right alternatives overlap. *)
 
-Lemma max_spec_le : forall n m,
+Lemma max_spec_le n m :
  (n <= m /\ max n m == m) \/ (m <= n /\ max n m == n).
 Proof.
- intros. destruct (max_spec n m); [left|right]; intuition; order.
+ destruct (max_spec n m); [left|right]; intuition; order.
 Qed.
 
 Instance : Proper (eq==>eq==>iff) le.
@@ -108,25 +107,24 @@ Proof. repeat red. intuition order. Qed.
 
 Instance max_compat : Proper (eq==>eq==>eq) max.
 Proof.
-intros x x' Hx y y' Hy.
-assert (H1 := max_spec x y). assert (H2 := max_spec x' y').
-set (m := max x y) in *; set (m' := max x' y') in *; clearbody m m'.
-rewrite <- Hx, <- Hy in *.
-destruct (lt_total x y); intuition order.
+ intros x x' Hx y y' Hy.
+ assert (H1 := max_spec x y). assert (H2 := max_spec x' y').
+ set (m := max x y) in *; set (m' := max x' y') in *; clearbody m m'.
+ rewrite <- Hx, <- Hy in *.
+ destruct (lt_total x y); intuition order.
 Qed.
 
-
 (** A function satisfying the same specification is equal to [max]. *)
 
-Lemma max_unicity : forall n m p,
- ((n < m /\ p == m)  \/ (m <= n /\ p == n)) ->  p == max n m.
+Lemma max_unicity n m p :
+ ((n < m /\ p == m) \/ (m <= n /\ p == n)) -> p == max n m.
 Proof.
- intros. assert (Hm := max_spec n m).
+ assert (Hm := max_spec n m).
  destruct (lt_total n m); intuition; order.
 Qed.
 
-Lemma max_unicity_ext : forall f,
- (forall n m, (n < m /\ f n m == m)  \/ (m <= n /\ f n m == n)) ->
+Lemma max_unicity_ext f :
+ (forall n m, (n < m /\ f n m == m) \/ (m <= n /\ f n m == n)) ->
  (forall n m, f n m == max n m).
 Proof.
  intros. apply max_unicity; auto.
@@ -134,12 +132,12 @@ Qed.
 
 (** [max] commutes with monotone functions. *)
 
-Lemma max_mono: forall f,
+Lemma max_mono f :
  (Proper (eq ==> eq) f) ->
  (Proper (le ==> le) f) ->
  forall x y, max (f x) (f y) == f (max x y).
 Proof.
- intros f Eqf Lef x y.
+ intros Eqf Lef x y.
  destruct (max_spec x y) as [(H,E)|(H,E)]; rewrite E;
   destruct (max_spec (f x) (f y)) as [(H',E')|(H',E')]; auto.
  assert (f x <= f y) by (apply Lef; order). order.
@@ -148,237 +146,232 @@ Qed.
 
 (** *** Semi-lattice algebraic properties of [max] *)
 
-Lemma max_id : forall n, max n n == n.
+Lemma max_id n : max n n == n.
 Proof.
- intros. destruct (max_spec n n); intuition.
+ apply max_l; order.
 Qed.
 
 Notation max_idempotent := max_id (only parsing).
 
-Lemma max_assoc : forall m n p, max m (max n p) == max (max m n) p.
+Lemma max_assoc m n p : max m (max n p) == max (max m n) p.
 Proof.
- intros.
- destruct (max_spec n p) as [(H,Eq)|(H,Eq)]; rewrite Eq.
- destruct (max_spec m n) as [(H',Eq')|(H',Eq')]; rewrite Eq'.
- destruct (max_spec m p); intuition; order. order.
- destruct (max_spec m n) as [(H',Eq')|(H',Eq')]; rewrite Eq'. order.
- destruct (max_spec m p); intuition; order.
+ destruct (max_spec n p) as [(H,E)|(H,E)]; rewrite E;
+ destruct (max_spec m n) as [(H',E')|(H',E')]; rewrite E', ?E; try easy.
+ - apply max_r; order.
+ - symmetry. apply max_l; order.
 Qed.
 
-Lemma max_comm : forall n m, max n m == max m n.
+Lemma max_comm n m : max n m == max m n.
 Proof.
- intros.
- destruct (max_spec n m) as [(H,Eq)|(H,Eq)]; rewrite Eq.
- destruct (max_spec m n) as [(H',Eq')|(H',Eq')]; rewrite Eq'; order.
- destruct (max_spec m n) as [(H',Eq')|(H',Eq')]; rewrite Eq'; order.
+ destruct (max_spec m n) as [(H,E)|(H,E)]; rewrite E;
+  (apply max_r || apply max_l); order.
 Qed.
 
+Ltac solve_max :=
+ match goal with |- context [max ?n ?m] =>
+  destruct (max_spec n m); intuition; order
+ end.
+
 (** *** Least-upper bound properties of [max] *)
 
-Lemma le_max_l : forall n m, n <= max n m.
-Proof.
- intros; destruct (max_spec n m); intuition; order.
-Qed.
+Lemma le_max_l n m : n <= max n m.
+Proof. solve_max. Qed.
 
-Lemma le_max_r : forall n m, m <= max n m.
-Proof.
- intros; destruct (max_spec n m); intuition; order.
-Qed.
+Lemma le_max_r n m : m <= max n m.
+Proof. solve_max. Qed.
 
-Lemma max_l_iff : forall n m, max n m == n <-> m <= n.
-Proof.
- split. intro H; rewrite <- H. apply le_max_r. apply max_l.
-Qed.
+Lemma max_l_iff n m : max n m == n <-> m <= n.
+Proof. solve_max. Qed.
 
-Lemma max_r_iff : forall n m, max n m == m <-> n <= m.
-Proof.
- split. intro H; rewrite <- H. apply le_max_l. apply max_r.
-Qed.
+Lemma max_r_iff n m : max n m == m <-> n <= m.
+Proof. solve_max. Qed.
 
-Lemma max_le : forall n m p, p <= max n m -> p <= n \/ p <= m.
+Lemma max_le n m p : p <= max n m -> p <= n \/ p <= m.
 Proof.
- intros n m p H; destruct (max_spec n m);
-  [right|left]; intuition; order.
+ destruct (max_spec n m); [right|left]; intuition; order.
 Qed.
 
-Lemma max_le_iff : forall n m p, p <= max n m <-> p <= n \/ p <= m.
-Proof.
- intros. split. apply max_le.
- destruct (max_spec n m); intuition; order.
-Qed.
+Lemma max_le_iff n m p : p <= max n m <-> p <= n \/ p <= m.
+Proof. split. apply max_le. solve_max. Qed.
 
-Lemma max_lt_iff : forall n m p, p < max n m <-> p < n \/ p < m.
+Lemma max_lt_iff n m p : p < max n m <-> p < n \/ p < m.
 Proof.
- intros. destruct (max_spec n m); intuition;
+ destruct (max_spec n m); intuition;
   order || (right; order) || (left; order).
 Qed.
 
-Lemma max_lub_l : forall n m p, max n m <= p -> n <= p.
-Proof.
- intros; destruct (max_spec n m); intuition; order.
-Qed.
+Lemma max_lub_l n m p : max n m <= p -> n <= p.
+Proof. solve_max. Qed.
 
-Lemma max_lub_r : forall n m p, max n m <= p -> m <= p.
-Proof.
- intros; destruct (max_spec n m); intuition; order.
-Qed.
+Lemma max_lub_r n m p : max n m <= p -> m <= p.
+Proof. solve_max. Qed.
 
-Lemma max_lub : forall n m p, n <= p -> m <= p -> max n m <= p.
-Proof.
- intros; destruct (max_spec n m); intuition; order.
-Qed.
+Lemma max_lub n m p : n <= p -> m <= p -> max n m <= p.
+Proof. solve_max. Qed.
 
-Lemma max_lub_iff : forall n m p, max n m <= p <-> n <= p /\ m <= p.
-Proof.
- intros; destruct (max_spec n m); intuition; order.
-Qed.
+Lemma max_lub_iff n m p : max n m <= p <-> n <= p /\ m <= p.
+Proof. solve_max. Qed.
 
-Lemma max_lub_lt : forall n m p, n < p -> m < p -> max n m < p.
-Proof.
- intros; destruct (max_spec n m); intuition; order.
-Qed.
+Lemma max_lub_lt n m p : n < p -> m < p -> max n m < p.
+Proof. solve_max. Qed.
 
-Lemma max_lub_lt_iff : forall n m p, max n m < p <-> n < p /\ m < p.
-Proof.
- intros; destruct (max_spec n m); intuition; order.
-Qed.
+Lemma max_lub_lt_iff n m p : max n m < p <-> n < p /\ m < p.
+Proof. solve_max. Qed.
 
-Lemma max_le_compat_l : forall n m p, n <= m -> max p n <= max p m.
-Proof.
- intros.
- destruct (max_spec p n) as [(LT,E)|(LE,E)]; rewrite E.
- assert (LE' := le_max_r p m). order.
- apply le_max_l.
-Qed.
+Lemma max_le_compat_l n m p : n <= m -> max p n <= max p m.
+Proof. intros. apply max_lub_iff. solve_max. Qed.
 
-Lemma max_le_compat_r : forall n m p, n <= m -> max n p <= max m p.
-Proof.
- intros. rewrite (max_comm n p), (max_comm m p).
- auto using max_le_compat_l.
-Qed.
+Lemma max_le_compat_r n m p : n <= m -> max n p <= max m p.
+Proof. intros. apply max_lub_iff. solve_max. Qed.
 
-Lemma max_le_compat : forall n m p q, n <= m -> p <= q ->
- max n p <= max m q.
+Lemma max_le_compat n m p q : n <= m -> p <= q -> max n p <= max m q.
 Proof.
- intros  n m p q Hnm Hpq.
+ intros Hnm Hpq.
  assert (LE := max_le_compat_l _ _ m Hpq).
  assert (LE' := max_le_compat_r _ _ p Hnm).
  order.
 Qed.
 
-End MaxLogicalProperties.
-
-
-(** ** Properties concernant [min], then both [min] and [max].
+(** Properties of [min] *)
 
-   To avoid too much code duplication, we exploit that [min] can be
-   seen as a [max] of the reversed order.
-*)
-
-Module MinMaxLogicalProperties (Import O:TotalOrder')(Import M:HasMinMax O).
- Include MaxLogicalProperties O M.
- Import T.
+Lemma min_spec n m :
+ (n < m /\ min n m == n) \/ (m <= n /\ min n m == m).
+Proof.
+ destruct (lt_total n m); [left|right].
+ - split; auto. apply min_l. rewrite le_lteq; auto.
+ - assert (m <= n) by (rewrite le_lteq; intuition).
+   split; auto. now apply min_r.
+Qed.
 
- Module ORev := TotalOrderRev O.
- Module MRev <: HasMax ORev.
-  Definition max x y := M.min y x.
-  Definition max_l x y := M.min_r y x.
-  Definition max_r x y := M.min_l y x.
- End MRev.
- Module MPRev := MaxLogicalProperties ORev MRev.
+Lemma min_spec_le n m :
+ (n <= m /\ min n m == n) \/ (m <= n /\ min n m == m).
+Proof.
+ destruct (min_spec n m); [left|right]; intuition; order.
+Qed.
 
 Instance min_compat : Proper (eq==>eq==>eq) min.
-Proof. intros x x' Hx y y' Hy. apply MPRev.max_compat; assumption. Qed.
+Proof.
+intros x x' Hx y y' Hy.
+assert (H1 := min_spec x y). assert (H2 := min_spec x' y').
+set (m := min x y) in *; set (m' := min x' y') in *; clearbody m m'.
+rewrite <- Hx, <- Hy in *.
+destruct (lt_total x y); intuition order.
+Qed.
 
-Lemma min_spec : forall n m,
- (n < m /\ min n m == n) \/ (m <= n /\ min n m == m).
-Proof. intros. exact (MPRev.max_spec m n). Qed.
+Lemma min_unicity n m p :
+ ((n < m /\ p == n) \/ (m <= n /\ p == m)) ->  p == min n m.
+Proof.
+ assert (Hm := min_spec n m).
+ destruct (lt_total n m); intuition; order.
+Qed.
 
-Lemma min_spec_le : forall n m,
- (n <= m /\ min n m == n) \/ (m <= n /\ min n m == m).
-Proof. intros. exact (MPRev.max_spec_le m n). Qed.
+Lemma min_unicity_ext f :
+ (forall n m, (n < m /\ f n m == n)  \/ (m <= n /\ f n m == m)) ->
+ (forall n m, f n m == min n m).
+Proof.
+ intros. apply min_unicity; auto.
+Qed.
 
-Lemma min_mono: forall f,
+Lemma min_mono f :
  (Proper (eq ==> eq) f) ->
  (Proper (le ==> le) f) ->
  forall x y, min (f x) (f y) == f (min x y).
 Proof.
- intros. apply MPRev.max_mono; auto. compute in *; eauto.
+ intros Eqf Lef x y.
+ destruct (min_spec x y) as [(H,E)|(H,E)]; rewrite E;
+  destruct (min_spec (f x) (f y)) as [(H',E')|(H',E')]; auto.
+ assert (f x <= f y) by (apply Lef; order). order.
+ assert (f y <= f x) by (apply Lef; order). order.
 Qed.
 
-Lemma min_unicity : forall n m p,
- ((n < m /\ p == n)  \/ (m <= n /\ p == m)) ->  p == min n m.
-Proof. intros n m p. apply MPRev.max_unicity. Qed.
-
-Lemma min_unicity_ext : forall f,
- (forall n m, (n < m /\ f n m == n)  \/ (m <= n /\ f n m == m)) ->
- (forall n m, f n m == min n m).
-Proof. intros f H n m. apply MPRev.max_unicity, H; auto. Qed.
-
-Lemma min_id : forall n, min n n == n.
-Proof. intros. exact (MPRev.max_id n). Qed.
+Lemma min_id n : min n n == n.
+Proof.
+ apply min_l; order.
+Qed.
 
 Notation min_idempotent := min_id (only parsing).
 
-Lemma min_assoc : forall m n p, min m (min n p) == min (min m n) p.
-Proof. intros. symmetry; apply MPRev.max_assoc. Qed.
+Lemma min_assoc m n p : min m (min n p) == min (min m n) p.
+Proof.
+ destruct (min_spec n p) as [(H,E)|(H,E)]; rewrite E;
+ destruct (min_spec m n) as [(H',E')|(H',E')]; rewrite E', ?E; try easy.
+ - symmetry. apply min_l; order.
+ - apply min_r; order.
+Qed.
 
-Lemma min_comm : forall n m, min n m == min m n.
-Proof. intros. exact (MPRev.max_comm m n). Qed.
+Lemma min_comm n m : min n m == min m n.
+Proof.
+ destruct (min_spec m n) as [(H,E)|(H,E)]; rewrite E;
+  (apply min_r || apply min_l); order.
+Qed.
 
-Lemma le_min_r : forall n m, min n m <= m.
-Proof. intros. exact (MPRev.le_max_l m n). Qed.
+Ltac solve_min :=
+ match goal with |- context [min ?n ?m] =>
+  destruct (min_spec n m); intuition; order
+ end.
 
-Lemma le_min_l : forall n m, min n m <= n.
-Proof. intros. exact (MPRev.le_max_r m n). Qed.
+Lemma le_min_r n m : min n m <= m.
+Proof. solve_min. Qed.
 
-Lemma min_l_iff : forall n m, min n m == n <-> n <= m.
-Proof. intros n m. exact (MPRev.max_r_iff m n). Qed.
+Lemma le_min_l n m : min n m <= n.
+Proof. solve_min. Qed.
 
-Lemma min_r_iff : forall n m, min n m == m <-> m <= n.
-Proof. intros n m. exact (MPRev.max_l_iff m n). Qed.
+Lemma min_l_iff n m : min n m == n <-> n <= m.
+Proof. solve_min. Qed.
 
-Lemma min_le : forall n m p, min n m <= p -> n <= p \/ m <= p.
-Proof. intros n m p H. destruct (MPRev.max_le _ _ _ H); auto. Qed.
+Lemma min_r_iff n m : min n m == m <-> m <= n.
+Proof. solve_min. Qed.
 
-Lemma min_le_iff : forall n m p, min n m <= p <-> n <= p \/ m <= p.
-Proof. intros n m p. rewrite (MPRev.max_le_iff m n p); intuition. Qed.
+Lemma min_le n m p : min n m <= p -> n <= p \/ m <= p.
+Proof.
+ destruct (min_spec n m); [left|right]; intuition; order.
+Qed.
+
+Lemma min_le_iff n m p : min n m <= p <-> n <= p \/ m <= p.
+Proof. split. apply min_le. solve_min. Qed.
 
-Lemma min_lt_iff : forall n m p, min n m < p <-> n < p \/ m < p.
-Proof. intros n m p. rewrite (MPRev.max_lt_iff m n p); intuition. Qed.
+Lemma min_lt_iff n m p : min n m < p <-> n < p \/ m < p.
+Proof.
+ destruct (min_spec n m); intuition;
+  order || (right; order) || (left; order).
+Qed.
 
-Lemma min_glb_l : forall n m p, p <= min n m -> p <= n.
-Proof. intros n m. exact (MPRev.max_lub_r m n). Qed.
+Lemma min_glb_l n m p : p <= min n m -> p <= n.
+Proof. solve_min. Qed.
 
-Lemma min_glb_r : forall n m p, p <= min n m -> p <= m.
-Proof. intros n m. exact (MPRev.max_lub_l m n). Qed.
+Lemma min_glb_r n m p : p <= min n m -> p <= m.
+Proof. solve_min. Qed.
 
-Lemma min_glb : forall n m p, p <= n -> p <= m -> p <= min n m.
-Proof. intros. apply MPRev.max_lub; auto. Qed.
+Lemma min_glb n m p : p <= n -> p <= m -> p <= min n m.
+Proof. solve_min. Qed.
 
-Lemma min_glb_iff : forall n m p, p <= min n m <-> p <= n /\ p <= m.
-Proof. intros. rewrite (MPRev.max_lub_iff m n p); intuition. Qed.
+Lemma min_glb_iff n m p : p <= min n m <-> p <= n /\ p <= m.
+Proof. solve_min. Qed.
 
-Lemma min_glb_lt : forall n m p, p < n -> p < m -> p < min n m.
-Proof. intros. apply MPRev.max_lub_lt; auto. Qed.
+Lemma min_glb_lt n m p : p < n -> p < m -> p < min n m.
+Proof. solve_min. Qed.
 
-Lemma min_glb_lt_iff : forall n m p, p < min n m <-> p < n /\ p < m.
-Proof. intros. rewrite (MPRev.max_lub_lt_iff m n p); intuition. Qed.
+Lemma min_glb_lt_iff n m p : p < min n m <-> p < n /\ p < m.
+Proof. solve_min. Qed.
 
-Lemma min_le_compat_l : forall n m p, n <= m -> min p n <= min p m.
-Proof. intros n m. exact (MPRev.max_le_compat_r m n). Qed.
+Lemma min_le_compat_l n m p : n <= m -> min p n <= min p m.
+Proof. intros. apply min_glb_iff. solve_min. Qed.
 
-Lemma min_le_compat_r : forall n m p, n <= m -> min n p <= min m p.
-Proof. intros n m. exact (MPRev.max_le_compat_l m n). Qed.
+Lemma min_le_compat_r n m p : n <= m -> min n p <= min m p.
+Proof. intros. apply min_glb_iff. solve_min. Qed.
 
-Lemma min_le_compat : forall n m p q, n <= m -> p <= q ->
+Lemma min_le_compat n m p q : n <= m -> p <= q ->
  min n p <= min m q.
-Proof. intros. apply MPRev.max_le_compat; auto. Qed.
-
+Proof.
+ intros Hnm Hpq.
+ assert (LE := min_le_compat_l _ _ m Hpq).
+ assert (LE' := min_le_compat_r _ _ p Hnm).
+ order.
+Qed.
 
 (** *** Combined properties of min and max *)
 
-Lemma min_max_absorption : forall n m, max n (min n m) == n.
+Lemma min_max_absorption n m : max n (min n m) == n.
 Proof.
  intros.
  destruct (min_spec n m) as [(C,E)|(C,E)]; rewrite E.
@@ -386,7 +379,7 @@ Proof.
  destruct (max_spec n m); intuition; order.
 Qed.
 
-Lemma max_min_absorption : forall n m, min n (max n m) == n.
+Lemma max_min_absorption n m : min n (max n m) == n.
 Proof.
  intros.
  destruct (max_spec n m) as [(C,E)|(C,E)]; rewrite E.
@@ -396,35 +389,35 @@ Qed.
 
 (** Distributivity *)
 
-Lemma max_min_distr : forall n m p,
+Lemma max_min_distr n m p :
  max n (min m p) == min (max n m) (max n p).
 Proof.
- intros. symmetry. apply min_mono.
+ symmetry. apply min_mono.
  eauto with *.
  repeat red; intros. apply max_le_compat_l; auto.
 Qed.
 
-Lemma min_max_distr : forall n m p,
+Lemma min_max_distr n m p :
  min n (max m p) == max (min n m) (min n p).
 Proof.
- intros. symmetry. apply max_mono.
+ symmetry. apply max_mono.
  eauto with *.
  repeat red; intros. apply min_le_compat_l; auto.
 Qed.
 
 (** Modularity *)
 
-Lemma max_min_modular : forall n m p,
+Lemma max_min_modular n m p :
  max n (min m (max n p)) == min (max n m) (max n p).
 Proof.
- intros. rewrite <- max_min_distr.
+ rewrite <- max_min_distr.
  destruct (max_spec n p) as [(C,E)|(C,E)]; rewrite E; auto with *.
  destruct (min_spec m n) as [(C',E')|(C',E')]; rewrite E'.
  rewrite 2 max_l; try order. rewrite min_le_iff; auto.
  rewrite 2 max_l; try order. rewrite min_le_iff; auto.
 Qed.
 
-Lemma min_max_modular : forall n m p,
+Lemma min_max_modular n m p :
  min n (max m (min n p)) == max (min n m) (min n p).
 Proof.
  intros. rewrite <- min_max_distr.
@@ -436,7 +429,7 @@ Qed.
 
 (** Disassociativity *)
 
-Lemma max_min_disassoc : forall n m p,
+Lemma max_min_disassoc n m p :
  min n (max m p) <= max (min n m) p.
 Proof.
  intros. rewrite min_max_distr.
@@ -445,24 +438,24 @@ Qed.
 
 (** Anti-monotonicity swaps the role of [min] and [max] *)
 
-Lemma max_min_antimono : forall f,
+Lemma max_min_antimono f :
  Proper (eq==>eq) f ->
  Proper (le==>inverse le) f ->
  forall x y, max (f x) (f y) == f (min x y).
 Proof.
- intros f Eqf Lef x y.
+ intros Eqf Lef x y.
  destruct (min_spec x y) as [(H,E)|(H,E)]; rewrite E;
   destruct (max_spec (f x) (f y)) as [(H',E')|(H',E')]; auto.
  assert (f y <= f x) by (apply Lef; order). order.
  assert (f x <= f y) by (apply Lef; order). order.
 Qed.
 
-Lemma min_max_antimono : forall f,
+Lemma min_max_antimono f :
  Proper (eq==>eq) f ->
  Proper (le==>inverse le) f ->
  forall x y, min (f x) (f y) == f (max x y).
 Proof.
- intros f Eqf Lef x y.
+ intros Eqf Lef x y.
  destruct (max_spec x y) as [(H,E)|(H,E)]; rewrite E;
   destruct (min_spec (f x) (f y)) as [(H',E')|(H',E')]; auto.
  assert (f y <= f x) by (apply Lef; order). order.
@@ -478,11 +471,11 @@ Module MinMaxDecProperties (Import O:OrderedTypeFull')(Import M:HasMinMax O).
 
 (** Induction principles for [max]. *)
 
-Lemma max_case_strong : forall n m (P:t -> Type),
+Lemma max_case_strong n m (P:t -> Type) :
   (forall x y, x==y -> P x -> P y) ->
   (m<=n -> P n) -> (n<=m -> P m) -> P (max n m).
 Proof.
-intros n m P Compat Hl Hr.
+intros Compat Hl Hr.
 destruct (CompSpec2Type (compare_spec n m)) as [EQ|LT|GT].
 assert (n<=m) by (rewrite le_lteq; auto).
 apply (Compat m), Hr; auto. symmetry; apply max_r; auto.
@@ -492,26 +485,26 @@ assert (m<=n) by (rewrite le_lteq; auto).
 apply (Compat n), Hl; auto. symmetry; apply max_l; auto.
 Defined.
 
-Lemma max_case : forall n m (P:t -> Type),
+Lemma max_case n m (P:t -> Type) :
   (forall x y, x == y -> P x -> P y) ->
   P n -> P m -> P (max n m).
 Proof. intros. apply max_case_strong; auto. Defined.
 
 (** [max] returns one of its arguments. *)
 
-Lemma max_dec : forall n m, {max n m == n} + {max n m == m}.
+Lemma max_dec n m : {max n m == n} + {max n m == m}.
 Proof.
- intros n m. apply max_case; auto with relations.
+ apply max_case; auto with relations.
  intros x y H [E|E]; [left|right]; rewrite <-H; auto.
 Defined.
 
 (** Idem for [min] *)
 
-Lemma min_case_strong : forall n m (P:O.t -> Type),
+Lemma min_case_strong n m (P:O.t -> Type) :
  (forall x y, x == y -> P x -> P y) ->
  (n<=m -> P n) -> (m<=n -> P m) -> P (min n m).
 Proof.
-intros n m P Compat Hl Hr.
+intros Compat Hl Hr.
 destruct (CompSpec2Type (compare_spec n m)) as [EQ|LT|GT].
 assert (n<=m) by (rewrite le_lteq; auto).
 apply (Compat n), Hl; auto. symmetry; apply min_l; auto.
@@ -521,12 +514,12 @@ assert (m<=n) by (rewrite le_lteq; auto).
 apply (Compat m), Hr; auto. symmetry; apply min_r; auto.
 Defined.
 
-Lemma min_case : forall n m (P:O.t -> Type),
+Lemma min_case n m (P:O.t -> Type) :
   (forall x y, x == y -> P x -> P y) ->
   P n -> P m -> P (min n m).
 Proof. intros. apply min_case_strong; auto. Defined.
 
-Lemma min_dec : forall n m, {min n m == n} + {min n m == m}.
+Lemma min_dec n m : {min n m == n} + {min n m == m}.
 Proof.
  intros. apply min_case; auto with relations.
  intros x y H [E|E]; [left|right]; rewrite <- E; auto with relations.
@@ -556,19 +549,19 @@ Module UsualMinMaxLogicalProperties
 
  Include MinMaxLogicalProperties O M.
 
- Lemma max_monotone : forall f, Proper (le ==> le) f ->
+ Lemma max_monotone f : Proper (le ==> le) f ->
   forall x y, max (f x) (f y) = f (max x y).
  Proof. intros; apply max_mono; auto. congruence. Qed.
 
- Lemma min_monotone : forall f, Proper (le ==> le) f ->
+ Lemma min_monotone f : Proper (le ==> le) f ->
   forall x y, min (f x) (f y) = f (min x y).
  Proof. intros; apply min_mono; auto. congruence. Qed.
 
- Lemma min_max_antimonotone : forall f, Proper (le ==> inverse le) f ->
+ Lemma min_max_antimonotone f : Proper (le ==> inverse le) f ->
   forall x y, min (f x) (f y) = f (max x y).
  Proof. intros; apply min_max_antimono; auto. congruence. Qed.
 
- Lemma max_min_antimonotone : forall f, Proper (le ==> inverse le) f ->
+ Lemma max_min_antimonotone f : Proper (le ==> inverse le) f ->
   forall x y, max (f x) (f y) = f (min x y).
  Proof. intros; apply max_min_antimono; auto. congruence. Qed.
 
@@ -578,29 +571,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..75578195 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.
@@ -106,19 +108,21 @@ Module OrderedTypeFacts (Import O: OrderedType).
   Lemma lt_total : forall x y, lt x y \/ eq x y \/ lt y x.
   Proof. intros; destruct (compare x y); auto. Qed.
 
-  Module OrderElts <: Orders.TotalOrder.
-  Definition t := t.
-  Definition eq := eq.
-  Definition lt := lt.
-  Definition le x y := lt x y \/ eq x y.
-  Definition eq_equiv := eq_equiv.
-  Definition lt_strorder := lt_strorder.
-  Definition lt_compat := lt_compat.
-  Definition lt_total := lt_total.
-  Lemma le_lteq : forall x y, le x y <-> lt x y \/ eq x y.
-  Proof. unfold le; intuition. Qed.
-  End OrderElts.
-  Module OrderTac := !MakeOrderTac OrderElts.
+  Module TO.
+   Definition t := t.
+   Definition eq := eq.
+   Definition lt := lt.
+   Definition le x y := lt x y \/ eq x y.
+  End TO.
+  Module IsTO.
+   Definition eq_equiv := eq_equiv.
+   Definition lt_strorder := lt_strorder.
+   Definition lt_compat := lt_compat.
+   Definition lt_total := lt_total.
+   Lemma le_lteq x y : TO.le x y <-> lt x y \/ eq x y.
+   Proof. reflexivity. Qed.
+  End IsTO.
+  Module OrderTac := !MakeOrderTac TO IsTO.
   Ltac order := OrderTac.order.
 
   Lemma le_eq x y z : ~lt x y -> eq y z -> ~lt x z. Proof. order. Qed.
@@ -143,7 +147,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 +155,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 +163,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 +322,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..83130deb 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.
@@ -23,9 +21,9 @@ Module Type UsualOrderedType.
  Parameter Inline t : Type.
  Definition eq := @eq t.
  Parameter Inline lt : t -> t -> Prop.
- Definition eq_refl := @refl_equal t.
- Definition eq_sym := @sym_eq t.
- Definition eq_trans := @trans_eq t.
+ Definition eq_refl := @eq_refl t.
+ Definition eq_sym := @eq_sym t.
+ Definition eq_trans := @eq_trans t.
  Axiom lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
  Axiom lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
  Parameter compare : forall x y : t, Compare lt eq x y.
@@ -43,9 +41,9 @@ Module Nat_as_OT <: UsualOrderedType.
   Definition t := nat.
 
   Definition eq := @eq nat.
-  Definition eq_refl := @refl_equal t.
-  Definition eq_sym := @sym_eq t.
-  Definition eq_trans := @trans_eq t.
+  Definition eq_refl := @eq_refl t.
+  Definition eq_sym := @eq_sym t.
+  Definition eq_trans := @eq_trans t.
 
   Definition lt := lt.
 
@@ -55,12 +53,12 @@ Module Nat_as_OT <: UsualOrderedType.
   Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
   Proof. unfold lt, eq; intros; omega. Qed.
 
-  Definition compare : forall x y : t, Compare lt eq x y.
+  Definition compare x y : Compare lt eq x y.
   Proof.
-    intros x y; destruct (nat_compare x y) as [ | | ]_eqn.
-    apply EQ. apply nat_compare_eq; assumption.
-    apply LT. apply nat_compare_Lt_lt; assumption.
-    apply GT. apply nat_compare_Gt_gt; assumption.
+    case_eq (nat_compare x y); intro.
+    - apply EQ. now apply nat_compare_eq.
+    - apply LT. now apply nat_compare_Lt_lt.
+    - apply GT. now apply nat_compare_Gt_gt.
   Defined.
 
   Definition eq_dec := eq_nat_dec.
@@ -70,15 +68,15 @@ End Nat_as_OT.
 
 (** [Z] is an ordered type with respect to the usual order on integers. *)
 
-Open Local Scope Z_scope.
+Local Open Scope Z_scope.
 
 Module Z_as_OT <: UsualOrderedType.
 
   Definition t := Z.
   Definition eq := @eq Z.
-  Definition eq_refl := @refl_equal t.
-  Definition eq_sym := @sym_eq t.
-  Definition eq_trans := @trans_eq t.
+  Definition eq_refl := @eq_refl t.
+  Definition eq_sym := @eq_sym t.
+  Definition eq_trans := @eq_trans t.
 
   Definition lt (x y:Z) := (x<y).
 
@@ -88,89 +86,73 @@ Module Z_as_OT <: UsualOrderedType.
   Lemma lt_not_eq : forall x y, x<y -> ~ x=y.
   Proof. intros; omega. Qed.
 
-  Definition compare : forall x y, Compare lt eq x y.
+  Definition compare x y : Compare lt eq x y.
   Proof.
-    intros x y; destruct (x ?= y) as [ | | ]_eqn.
-    apply EQ; apply Zcompare_Eq_eq; assumption.
-    apply LT; assumption.
-    apply GT; apply Zgt_lt; assumption.
+    case_eq (x ?= y); intro.
+    - apply EQ. now apply Z.compare_eq.
+    - apply LT. assumption.
+    - apply GT. now apply Z.gt_lt.
   Defined.
 
-  Definition eq_dec := Z_eq_dec.
+  Definition eq_dec := Z.eq_dec.
 
 End Z_as_OT.
 
 (** [positive] is an ordered type with respect to the usual order on natural numbers. *)
 
-Open Local Scope positive_scope.
+Local Open Scope positive_scope.
 
 Module Positive_as_OT <: UsualOrderedType.
   Definition t:=positive.
   Definition eq:=@eq positive.
-  Definition eq_refl := @refl_equal t.
-  Definition eq_sym := @sym_eq t.
-  Definition eq_trans := @trans_eq t.
+  Definition eq_refl := @eq_refl t.
+  Definition eq_sym := @eq_sym t.
+  Definition eq_trans := @eq_trans t.
 
-  Definition lt p q:= (p ?= q) Eq = Lt.
+  Definition lt := Pos.lt.
 
-  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 := Pos.lt_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 Pos.lt_irrefl.
   Qed.
 
-  Definition compare : forall x y : t, Compare lt eq x y.
+  Definition compare x y : Compare lt eq x y.
   Proof.
-  intros x y. destruct ((x ?= y) Eq) as [ | | ]_eqn.
-  apply EQ; apply Pcompare_Eq_eq; assumption.
-  apply LT; assumption.
-  apply GT; apply ZC1; assumption.
+  case_eq (x ?= y); intros H.
+  - apply EQ. now apply Pos.compare_eq.
+  - apply LT; assumption.
+  - apply GT. now apply Pos.gt_lt.
   Defined.
 
-  Definition eq_dec : forall x y, { eq x y } + { ~ eq x y }.
-  Proof.
-   intros; unfold eq; decide equality.
-  Defined.
+  Definition eq_dec := Pos.eq_dec.
 
 End Positive_as_OT.
 
 
 (** [N] is an ordered type with respect to the usual order on natural numbers. *)
 
-Open Local Scope positive_scope.
-
 Module N_as_OT <: UsualOrderedType.
   Definition t:=N.
   Definition eq:=@eq N.
-  Definition eq_refl := @refl_equal t.
-  Definition eq_sym := @sym_eq t.
-  Definition eq_trans := @trans_eq t.
+  Definition eq_refl := @eq_refl t.
+  Definition eq_sym := @eq_sym t.
+  Definition eq_trans := @eq_trans t.
 
-  Definition lt:=Nlt.
-  Definition lt_trans := Nlt_trans.
-  Definition lt_not_eq := Nlt_not_eq.
+  Definition lt := N.lt.
+  Definition lt_trans := N.lt_trans.
+  Definition lt_not_eq := N.lt_neq.
 
-  Definition compare : forall x y : t, Compare lt eq x y.
+  Definition compare x y : Compare lt eq x y.
   Proof.
-  intros x y. destruct (x ?= y)%N as [ | | ]_eqn.
-  apply EQ; apply Ncompare_Eq_eq; assumption.
-  apply LT; assumption.
-  apply GT. apply Ngt_Nlt; assumption.
+  case_eq (x ?= y)%N; intro.
+  - apply EQ. now apply N.compare_eq.
+  - apply LT. assumption.
+  - apply GT. now apply N.gt_lt.
   Defined.
 
-  Definition eq_dec : forall x y, { eq x y } + { ~ eq x y }.
-  Proof.
-   intros. unfold eq. decide equality. apply Positive_as_OT.eq_dec.
-  Defined.
+  Definition eq_dec := N.eq_dec.
 
 End N_as_OT.
 
@@ -250,9 +232,9 @@ End PairOrderedType.
 Module PositiveOrderedTypeBits <: UsualOrderedType.
   Definition t:=positive.
   Definition eq:=@eq positive.
-  Definition eq_refl := @refl_equal t.
-  Definition eq_sym := @sym_eq t.
-  Definition eq_trans := @trans_eq t.
+  Definition eq_refl := @eq_refl t.
+  Definition eq_sym := @eq_sym t.
+  Definition eq_trans := @eq_trans t.
 
   Fixpoint bits_lt (p q:positive) : Prop :=
    match p, q with
@@ -296,38 +278,38 @@ Module PositiveOrderedTypeBits <: UsualOrderedType.
   Definition compare : forall x y : t, Compare lt eq x y.
   Proof.
   induction x; destruct y.
-  (* I I *)
-  destruct (IHx y).
-  apply LT; auto.
-  apply EQ; rewrite e; red; auto.
-  apply GT; auto.
-  (* I O *)
-  apply GT; simpl; auto.
-  (* I H *)
-  apply GT; simpl; auto.
-  (* O I *)
-  apply LT; simpl; auto.
-  (* O O *)
-  destruct (IHx y).
-  apply LT; auto.
-  apply EQ; rewrite e; red; auto.
-  apply GT; auto.
-  (* O H *)
-  apply LT; simpl; auto.
-  (* H I *)
-  apply LT; simpl; auto.
-  (* H O *)
-  apply GT; simpl; auto.
-  (* H H *)
-  apply EQ; red; auto.
+  - (* I I *)
+    destruct (IHx y).
+    apply LT; auto.
+    apply EQ; rewrite e; red; auto.
+    apply GT; auto.
+  - (* I O *)
+    apply GT; simpl; auto.
+  - (* I H *)
+    apply GT; simpl; auto.
+  - (* O I *)
+    apply LT; simpl; auto.
+  - (* O O *)
+    destruct (IHx y).
+    apply LT; auto.
+    apply EQ; rewrite e; red; auto.
+    apply GT; auto.
+  - (* O H *)
+    apply LT; simpl; auto.
+  - (* H I *)
+    apply LT; simpl; auto.
+  - (* H O *)
+    apply GT; simpl; auto.
+  - (* H H *)
+    apply EQ; red; auto.
   Qed.
 
   Lemma eq_dec (x y: positive): {x = y} + {x <> y}.
   Proof.
-  intros. case_eq ((x ?= y) Eq); intros.
-  left. apply Pcompare_Eq_eq; auto.
-  right. red. intro. subst y. rewrite (Pcompare_refl x) in H. discriminate.
-  right. red. intro. subst y. rewrite (Pcompare_refl x) in H. discriminate.
+  intros. case_eq (x ?= y); intros.
+  - left. now apply Pos.compare_eq.
+  - right. intro. subst y. now rewrite (Pos.compare_refl x) in *.
+  - right. intro. subst y. now rewrite (Pos.compare_refl x) in *.
   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..5dd917a7 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.
 
@@ -142,7 +140,7 @@ Module OT_from_Alt (Import O:OrderedTypeAlt) <: OrderedType.
  Lemma lt_eq : forall x y z, lt x y -> eq y z -> lt x z.
  Proof.
   unfold lt, eq; intros x y z Hxy Hyz.
-  destruct (compare x z) as [ ]_eqn:Hxz; auto.
+  destruct (compare x z) eqn:Hxz; auto.
   rewrite compare_sym, CompOpp_iff in Hyz. simpl in Hyz.
   rewrite (compare_trans Hxz Hyz) in Hxy; discriminate.
   rewrite compare_sym, CompOpp_iff in Hxy. simpl in Hxy.
@@ -152,7 +150,7 @@ Module OT_from_Alt (Import O:OrderedTypeAlt) <: OrderedType.
  Lemma eq_lt : forall x y z, eq x y -> lt y z -> lt x z.
  Proof.
   unfold lt, eq; intros x y z Hxy Hyz.
-  destruct (compare x z) as [ ]_eqn:Hxz; auto.
+  destruct (compare x z) eqn:Hxz; auto.
   rewrite compare_sym, CompOpp_iff in Hxy. simpl in Hxy.
   rewrite (compare_trans Hxy Hxz) in Hyz; discriminate.
   rewrite compare_sym, CompOpp_iff in Hyz. simpl in Hyz.
@@ -171,7 +169,7 @@ Module OT_from_Alt (Import O:OrderedTypeAlt) <: OrderedType.
  Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y).
  Proof.
   unfold eq, lt, compare; intros.
-  destruct (O.compare x y) as [ ]_eqn:H; auto.
+  destruct (O.compare x y) eqn:H; auto.
   apply CompGt.
   rewrite compare_sym, H; auto.
  Qed.
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/Structures/OrdersTac.v b/theories/Structures/OrdersTac.v
index 66a672c9..68ffc379 100644
--- a/theories/Structures/OrdersTac.v
+++ b/theories/Structures/OrdersTac.v
@@ -40,16 +40,26 @@ Definition trans_ord o o' :=
 Local Infix "+" := trans_ord.
 
 
-(** ** The requirements of the tactic : [TotalOrder].
+(** ** The tactic requirements : a total order
 
-   [TotalOrder] contains an equivalence [eq],
-   a strict order [lt] total and compatible with [eq], and
-   a larger order [le] synonym for [lt\/eq].
+   We need :
+   - an equivalence [eq],
+   - a strict order [lt] total and compatible with [eq],
+   - a larger order [le] synonym for [lt\/eq].
+
+   This used to be provided here via a [TotalOrder], but
+   for technical reasons related to extraction, we now ask
+   for two sperate parts: relations in a [EqLtLe] + properties in
+   [IsTotalOrder]. Note that [TotalOrder = EqLtLe <+ IsTotalOrder]
 *)
 
+Module Type IsTotalOrder (O:EqLtLe) :=
+ IsEq O <+ IsStrOrder O <+ LeIsLtEq O <+ LtIsTotal O.
+
 (** ** Properties that will be used by the [order] tactic *)
 
-Module OrderFacts(Import O:TotalOrder').
+Module OrderFacts (Import O:EqLtLe)(P:IsTotalOrder O).
+Include EqLtLeNotation O.
 
 (** Reflexivity rules *)
 
@@ -57,7 +67,7 @@ Lemma eq_refl : forall x, x==x.
 Proof. reflexivity. Qed.
 
 Lemma le_refl : forall x, x<=x.
-Proof. intros; rewrite le_lteq; right; reflexivity. Qed.
+Proof. intros; rewrite P.le_lteq; right; reflexivity. Qed.
 
 Lemma lt_irrefl : forall x, ~ x<x.
 Proof. intros; apply StrictOrder_Irreflexive. Qed.
@@ -69,7 +79,7 @@ Proof. auto with *. Qed.
 
 Lemma le_antisym : forall x y, x<=y -> y<=x -> x==y.
 Proof.
- intros x y; rewrite 2 le_lteq. intuition.
+ intros x y; rewrite 2 P.le_lteq. intuition.
  elim (StrictOrder_Irreflexive x); transitivity y; auto.
 Qed.
 
@@ -90,7 +100,7 @@ Local Notation "#" := interp_ord.
 
 Lemma trans : forall o o' x y z, #o x y -> #o' y z -> #(o+o') x z.
 Proof.
-destruct o, o'; simpl; intros x y z; rewrite ?le_lteq; intuition;
+destruct o, o'; simpl; intros x y z; rewrite ?P.le_lteq; intuition;
  subst_eqns; eauto using (StrictOrder_Transitive x y z) with *.
 Qed.
 
@@ -114,19 +124,19 @@ Proof. eauto using eq_trans, eq_sym. Qed.
 
 Lemma not_neq_eq : forall x y, ~~x==y -> x==y.
 Proof.
-intros x y H. destruct (lt_total x y) as [H'|[H'|H']]; auto;
+intros x y H. destruct (P.lt_total x y) as [H'|[H'|H']]; auto;
  destruct H; intro H; rewrite H in H'; eapply lt_irrefl; eauto.
 Qed.
 
 Lemma not_ge_lt : forall x y, ~y<=x -> x<y.
 Proof.
-intros x y H. destruct (lt_total x y); auto.
-destruct H. rewrite le_lteq. intuition.
+intros x y H. destruct (P.lt_total x y); auto.
+destruct H. rewrite P.le_lteq. intuition.
 Qed.
 
 Lemma not_gt_le : forall x y, ~y<x -> x<=y.
 Proof.
-intros x y H. rewrite le_lteq. generalize (lt_total x y); intuition.
+intros x y H. rewrite P.le_lteq. generalize (P.lt_total x y); intuition.
 Qed.
 
 Lemma le_neq_lt : forall x y, x<=y -> ~x==y -> x<y.
@@ -138,9 +148,9 @@ End OrderFacts.
 
 (** ** [MakeOrderTac] : The functor providing the order tactic. *)
 
-Module MakeOrderTac (Import O:TotalOrder').
-
-Include OrderFacts O.
+Module MakeOrderTac (Import O:EqLtLe)(P:IsTotalOrder O).
+Include OrderFacts O P.
+Include EqLtLeNotation O.
 
 (** order_eq : replace x by y in all (in)equations hyps thanks
    to equality EQ (where eq has been hidden in order to avoid
@@ -257,37 +267,10 @@ End MakeOrderTac.
 
 Module OTF_to_OrderTac (OTF:OrderedTypeFull).
  Module TO := OTF_to_TotalOrder OTF.
- Include !MakeOrderTac TO.
+ Include !MakeOrderTac OTF TO.
 End OTF_to_OrderTac.
 
 Module OT_to_OrderTac (OT:OrderedType).
  Module OTF := OT_to_Full OT.
  Include !OTF_to_OrderTac OTF.
 End OT_to_OrderTac.
-
-Module TotalOrderRev (O:TotalOrder) <: TotalOrder.
-
-Definition t := O.t.
-Definition eq := O.eq.
-Definition lt := flip O.lt.
-Definition le := flip O.le.
-Include EqLtLeNotation.
-
-(* No Instance syntax to avoid saturating the Equivalence tables *)
-Definition eq_equiv := O.eq_equiv.
-
-Instance lt_strorder: StrictOrder lt.
-Proof. unfold lt; auto with *. Qed.
-Instance lt_compat : Proper (eq==>eq==>iff) lt.
-Proof. unfold lt; auto with *. Qed.
-
-Lemma le_lteq : forall x y, x<=y <-> x<y \/ x==y.
-Proof. intros; unfold le, lt, flip. rewrite O.le_lteq; intuition. Qed.
-
-Lemma lt_total : forall x y, x<y \/ x==y \/ y<x.
-Proof.
- intros x y; unfold lt, eq, flip.
- generalize (O.lt_total x y); intuition.
-Qed.
-
-End TotalOrderRev.
diff --git a/theories/Unicode/Utf8.v b/theories/Unicode/Utf8.v
index 41a98ef2..6d2da154 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-2012     *)
 (*   \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" := (Z.le x y) (at level 70, no associativity).
 *)
diff --git a/theories/Unicode/Utf8_core.v b/theories/Unicode/Utf8_core.v
index ce637413..f9670d17 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-2012     *)
 (*   \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.
@@ -15,7 +17,9 @@ Notation "∃  x .. y , P" := (exists x, .. (exists y, P) ..)
 
 Notation "x ∨ y" := (x \/ y) (at level 85, right associativity) : type_scope.
 Notation "x ∧ y" := (x /\ y) (at level 80, right associativity) : type_scope.
-Notation "x → y" := (x -> y) (at level 90, right associativity): type_scope.
+Notation "x → y" := (x -> y)
+  (at level 90, y at level 200, right associativity): type_scope.
+
 Notation "x ↔ y" := (x <-> y) (at level 95, no associativity): type_scope.
 Notation "¬ x" := (~x) (at level 75, right associativity) : type_scope.
 Notation "x ≠ y" := (x <> y) (at level 70) : type_scope.
diff --git a/theories/Vectors/Fin.v b/theories/Vectors/Fin.v
new file mode 100644
index 00000000..a5e37f34
--- /dev/null
+++ b/theories/Vectors/Fin.v
@@ -0,0 +1,184 @@
+(************************************************************************)
+(*  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-01/2012
+*)
+
+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.
+
+Definition FS_inj {n} (x y: t n) (eq: FS x = FS y): x = y :=
+match eq in _ = a return
+  match a as a' in t m return match m with |0 => Prop |S n' => t n' -> Prop end
+  with @F1 _ =>  fun _ => True |@FS _ y => fun x' => x' = y end x with
+  eq_refl => eq_refl
+end.
+
+(** [to_nat f] = p iff [f] is the p{^ th} element of [fin m]. *)
+Fixpoint to_nat {m} (n : t m) : {i | i < m} :=
+  match n in t k return {i | i< k} with
+    |F1 j => exist (fun i => i< S j) 0 (Lt.lt_0_Sn j)
+    |FS _ p => match to_nat p with |exist i P => exist _ (S i) (Lt.lt_n_S _ _ P) end
+  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)).
+Proof.
+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..32ffcb3d
--- /dev/null
+++ b/theories/Vectors/VectorDef.v
@@ -0,0 +1,318 @@
+(************************************************************************)
+(*  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.
+Local Open 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 => fun devil => False_rect (@ID) devil
+ |cons a 0 v =>
+   match v as vnn in t _ nn
+       return
+         match nn,vnn with
+         |0,vm =>  P (a :: vm)
+         |S _,_ => _
+         end
+     with
+     |nil => bas a
+     |_ :: _ => fun devil => False_rect (@ID) devil
+     end
+ |cons a (S nn') v => rect a v (rectS_fix v)
+ end.
+
+(** An induction scheme for 2 vectors of same length *)
+Definition rect2 {A B} (P:forall {n}, t A n -> t B n -> Type)
+  (bas : P [] []) (rect : forall {n v1 v2}, P v1 v2 ->
+    forall a b, P (a :: v1) (b :: v2)) :=
+fix rect2_fix {n} (v1:t A n):
+  forall v2 : t B n, P v1 v2 :=
+match v1 as v1' in t _ n1
+  return forall v2 : t B n1, P v1' v2 with
+  |[] => fun v2 =>
+     match v2 with
+       |[] => bas
+       |_ :: _ => fun devil => False_rect (@ID) devil
+     end
+  |h1 :: t1 => fun v2 =>
+    match v2 with
+      |[] => fun devil => False_rect (@ID) devil
+      |h2 :: t2 => fun t1' =>
+        rect (rect2_fix t1' t2) h1 h2
+    end t1
+end.
+
+(** A vector of length [0] is [nil] *)
+Definition case0 {A} (P:t A 0 -> Type) (H:P (nil A)) v:P v :=
+match v with
+  |[] => H
+end.
+
+(** A vector of length [S _] is [cons] *)
+Definition caseS {A} (P : forall {n}, t A (S n) -> Type)
+  (H : forall h {n} t, @P n (h :: t)) {n} (v: t A (S n)) : P v :=
+match v as v' in t _ m return match m, v' with |0, _ => False -> True |S _, v0 => P v' end with
+  |[] => fun devil => False_rect _ devil (* subterm !!! *)
+  |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. *)
+Definition nth {A} := 
+fix nth_fix {m} (v' : t A m) (p : Fin.t m) {struct v'} : A :=
+match p in Fin.t m' return t A m' -> A with
+ |Fin.F1 q => fun v => caseS (fun n v' => A) (fun h n t => h) v
+ |Fin.FS q p' => fun v => (caseS (fun n v' => Fin.t n -> A)
+   (fun h n t p0 => nth_fix 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..2f4086e5
--- /dev/null
+++ b/theories/Vectors/VectorSpec.v
@@ -0,0 +1,119 @@
+(************************************************************************)
+(*  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.
+
+Definition cons_inj A a1 a2 n (v1 v2 : t A n)
+ (eq : a1 :: v1 = a2 :: v2) : a1 = a2 /\ v1 = v2 :=
+   match eq in _ = x return caseS _ (fun a2' _ v2' => fun v1' => a1 = a2' /\ v1' = v2') x v1
+   with | eq_refl => conj eq_refl eq_refl
+   end.
+
+(** 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..8f5c0957 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-2012     *)
 (*   \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 *)
@@ -43,7 +41,7 @@ Section Wf_Disjoint_Union.
     well_founded leA -> well_founded leB -> well_founded Le_AsB.
   Proof.
     intros.
-    unfold well_founded in |- *.
+    unfold well_founded.
     destruct a as [a| b].
     apply (acc_A_sum a).
     apply (H a).
diff --git a/theories/Wellfounded/Inclusion.v b/theories/Wellfounded/Inclusion.v
index fad1978e..c7cc29b5 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-2012     *)
 (*   \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.
@@ -26,7 +24,7 @@ Section WfInclusion.
 
   Theorem wf_incl : inclusion A R1 R2 -> well_founded R2 -> well_founded R1.
   Proof.
-    unfold well_founded in |- *; auto with sets.
+    unfold well_founded; auto with sets.
   Qed.
 
 End WfInclusion.
diff --git a/theories/Wellfounded/Inverse_Image.v b/theories/Wellfounded/Inverse_Image.v
index 204cff19..e38b2157 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-2012     *)
 (*   \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.
@@ -33,7 +31,7 @@ Section Inverse_Image.
 
   Theorem wf_inverse_image : well_founded R -> well_founded Rof.
   Proof.
-    red in |- *; intros; apply Acc_inverse_image; auto.
+    red; intros; apply Acc_inverse_image; auto.
   Qed.
 
   Variable F : A -> B -> Prop.
@@ -51,7 +49,7 @@ Section Inverse_Image.
 
   Theorem wf_inverse_rel : well_founded R -> well_founded RoF.
   Proof.
-    red in |- *; constructor; intros.
+    red; constructor; intros.
     case H0; intros.
     apply (Acc_inverse_rel x); auto.
   Qed.
diff --git a/theories/Wellfounded/Lexicographic_Exponentiation.v b/theories/Wellfounded/Lexicographic_Exponentiation.v
index bc8803ad..13db01a3 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-2012     *)
 (*   \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
@@ -38,11 +36,11 @@ Section Wf_Lexicographic_Exponentiation.
   Proof.
     simple induction x.
     simple induction z.
-    simpl in |- *; intros H.
+    simpl; intros H.
     inversion_clear H.
-    simpl in |- *; intros; apply (Lt_nil A leA).
+    simpl; intros; apply (Lt_nil A leA).
     intros a l HInd.
-    simpl in |- *.
+    simpl.
     intros.
     inversion_clear H.
     apply (Lt_hd A leA); auto with sets.
@@ -56,7 +54,7 @@ Section Wf_Lexicographic_Exponentiation.
       ltl x (y ++ z) -> ltl x y \/ (exists y' : List, x = y ++ y' /\ ltl y' z).
   Proof.
     intros x y; generalize x.
-    elim y; simpl in |- *.
+    elim y; simpl.
     right.
     exists x0; auto with sets.
     intros.
@@ -198,7 +196,7 @@ Section Wf_Lexicographic_Exponentiation.
           Descl x0 /\ Descl (l0 ++ Cons x1 Nil)).
 
 
-    simpl in |- *.
+    simpl.
     split.
     generalize (app_inj_tail _ _ _ _ H2); simple induction 1.
     simple induction 1; auto with sets.
@@ -241,7 +239,7 @@ Section Wf_Lexicographic_Exponentiation.
   Proof.
     intros a b x.
     case x.
-    simpl in |- *.
+    simpl.
     simple induction 1.
     intros.
     inversion H1; auto with sets.
@@ -269,7 +267,7 @@ Section Wf_Lexicographic_Exponentiation.
     case x.
     intros; apply (Lt_nil A leA).
 
-    simpl in |- *; intros.
+    simpl; intros.
     inversion_clear H0.
     apply (Lt_hd A leA a b); auto with sets.
 
@@ -286,17 +284,17 @@ Section Wf_Lexicographic_Exponentiation.
     apply (Acc_inv (R:=Lex_Exp) (x:=<< x1 ++ x2, y1 >>)).
     auto with sets.
 
-    unfold lex_exp in |- *; simpl in |- *; auto with sets.
+    unfold lex_exp; simpl; auto with sets.
   Qed.
 
 
   Theorem wf_lex_exp : well_founded leA -> well_founded Lex_Exp.
   Proof.
-    unfold well_founded at 2 in |- *.
+    unfold well_founded at 2.
     simple induction a; intros x y.
     apply Acc_intro.
     simple induction y0.
-    unfold lex_exp at 1 in |- *; simpl in |- *.
+    unfold lex_exp at 1; simpl.
     apply rev_ind with
       (A := A)
       (P := fun x:List =>
@@ -337,8 +335,8 @@ Section Wf_Lexicographic_Exponentiation.
     intro.
     apply Acc_intro.
     simple induction y2.
-    unfold lex_exp at 1 in |- *.
-    simpl in |- *; intros x4 y3. intros.
+    unfold lex_exp at 1.
+    simpl; intros x4 y3. intros.
     apply (H0 x4 y3); auto with sets.
 
     intros.
@@ -359,7 +357,7 @@ Section Wf_Lexicographic_Exponentiation.
     generalize (HInd2 f); intro.
     apply Acc_intro.
     simple induction y3.
-    unfold lex_exp at 1 in |- *; simpl in |- *; intros.
+    unfold lex_exp at 1; simpl; intros.
     apply H15; auto with sets.
   Qed.
 
diff --git a/theories/Wellfounded/Lexicographic_Product.v b/theories/Wellfounded/Lexicographic_Product.v
index e0f0cc8f..c3e8c92c 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-2012     *)
 (*   \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.
@@ -29,7 +27,7 @@ Section WfLexicographic_Product.
     forall x:A,
       Acc leA x ->
       (forall x0:A, clos_trans A leA x0 x -> well_founded (leB x0)) ->
-      forall y:B x, Acc (leB x) y -> Acc LexProd (existS B x y).
+      forall y:B x, Acc (leB x) y -> Acc LexProd (existT B x y).
   Proof.
     induction 1 as [x _ IHAcc]; intros H2 y.
     induction 1 as [x0 H IHAcc0]; intros.
@@ -56,18 +54,18 @@ Section WfLexicographic_Product.
     subst x1.
     apply IHAcc0.
     elim inj_pair2 with A B x y' x0; assumption.
-  Qed.
+  Defined.
 
   Theorem wf_lexprod :
     well_founded leA ->
     (forall x:A, well_founded (leB x)) -> well_founded LexProd.
   Proof.
-    intros wfA wfB; unfold well_founded in |- *.
+    intros wfA wfB; unfold well_founded.
     destruct a.
     apply acc_A_B_lexprod; auto with sets; intros.
     red in wfB.
     auto with sets.
-  Qed.
+  Defined.
 
 
 End WfLexicographic_Product.
@@ -90,16 +88,16 @@ Section Wf_Symmetric_Product.
     inversion_clear H5; auto with sets.
     apply IHAcc; auto.
     apply Acc_intro; trivial.
-  Qed.
+  Defined.
 
 
   Lemma wf_symprod :
     well_founded leA -> well_founded leB -> well_founded Symprod.
   Proof.
-    red in |- *.
+    red.
     destruct a.
     apply Acc_symprod; auto with sets.
-  Qed.
+  Defined.
 
 End Wf_Symmetric_Product.
 
@@ -130,7 +128,7 @@ Section Swap.
 
     apply sp_noswap.
     apply left_sym; auto with sets.
-  Qed.
+  Defined.
 
 
   Lemma Acc_swapprod :
@@ -158,14 +156,14 @@ Section Swap.
     apply right_sym; auto with sets.
 
     auto with sets.
-  Qed.
+  Defined.
 
 
   Lemma wf_swapprod : well_founded R -> well_founded SwapProd.
   Proof.
-    red in |- *.
+    red.
     destruct a; intros.
     apply Acc_swapprod; auto with sets.
-  Qed.
+  Defined.
 
 End Swap.
diff --git a/theories/Wellfounded/Transitive_Closure.v b/theories/Wellfounded/Transitive_Closure.v
index 59832b1b..943840cd 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-2012     *)
 (*   \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.
@@ -20,7 +18,7 @@ Section Wf_Transitive_Closure.
   Notation trans_clos := (clos_trans A R).
 
   Lemma incl_clos_trans : inclusion A R trans_clos.
-    red in |- *; auto with sets.
+    red; auto with sets.
   Qed.
 
   Lemma Acc_clos_trans : forall x:A, Acc R x -> Acc trans_clos x.
@@ -41,7 +39,7 @@ Section Wf_Transitive_Closure.
 
   Theorem wf_clos_trans : well_founded R -> well_founded trans_clos.
   Proof.
-    unfold well_founded in |- *; auto with sets.
+    unfold well_founded; auto with sets.
   Defined.
 
 End Wf_Transitive_Closure.
diff --git a/theories/Wellfounded/Union.v b/theories/Wellfounded/Union.v
index 84d75754..5e4fec65 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-2012     *)
 (*   \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.
@@ -53,7 +51,7 @@ Section WfUnion.
 
     elim strip_commut with x x0 y0; auto with sets; intros.
     apply Acc_inv_trans with x1; auto with sets.
-    unfold union in |- *.
+    unfold union.
     elim H11; auto with sets; intros.
     apply t_trans with y1; auto with sets.
 
@@ -67,7 +65,7 @@ Section WfUnion.
   Theorem wf_union :
     commut A R1 R2 -> well_founded R1 -> well_founded R2 -> well_founded Union.
   Proof.
-    unfold well_founded in |- *.
+    unfold well_founded.
     intros.
     apply Acc_union; auto with sets.
   Qed.
diff --git a/theories/Wellfounded/Well_Ordering.v b/theories/Wellfounded/Well_Ordering.v
index cec21555..df6d9ed6 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-2012     *)
 (*   \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 *)
@@ -27,7 +25,7 @@ Section WellOrdering.
 
   Theorem wf_WO : well_founded le_WO.
   Proof.
-    unfold well_founded in |- *; intro.
+    unfold well_founded; intro.
     apply Acc_intro.
     elim a.
     intros.
@@ -39,7 +37,7 @@ Section WellOrdering.
     apply (H v0 y0).
     cut (f = f1).
     intros E; rewrite E; auto.
-    symmetry  in |- *.
+    symmetry .
     apply (inj_pair2 A (fun a0:A => B a0 -> WO) a0 f1 f H5).
   Qed.
 
@@ -63,7 +61,7 @@ Section Characterisation_wf_relations.
     apply (well_founded_induction_type H (fun a:A => WO A B)); auto.
     intros x H1.
     apply (sup A B x).
-    unfold B at 1 in |- *.
+    unfold B at 1.
     destruct 1 as [x0].
     apply (H1 x0); auto.
 Qed.
diff --git a/theories/Wellfounded/Wellfounded.v b/theories/Wellfounded/Wellfounded.v
index 03b7b210..b8c6653b 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-2012     *)
 (*   \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..eeec9042 100644
--- a/theories/ZArith/BinInt.v
+++ b/theories/ZArith/BinInt.v
@@ -1,1158 +1,1759 @@
 (* -*- 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-2012     *)
 (*   \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.
-
-Unset Boxed Definitions.
-
-(*****************************)
-(** * Binary integer numbers *)
-
-Inductive Z : Set :=
-  | Z0 : Z
-  | Zpos : positive -> Z
-  | Zneg : positive -> Z.
-
-
-(** 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.
+(** Initial author: Pierre Crégut, CNET, Lannion, France *)
 
-Ltac elim_compare com1 com2 :=
-  case (Dcompare (com1 ?= com2)%Z);
-    [ idtac | let x := fresh "H" in
-      (intro x; case x; clear x) ].
+(** The type [Z] and its constructors [Z0] and [Zpos] and [Zneg]
+    are now defined in [BinNums.v] *)
 
-(** ** Sign function *)
+Local Open Scope Z_scope.
 
-Definition Zsgn (z:Z) : Z :=
-  match z with
-    | Z0 => Z0
-    | Zpos p => Zpos 1
-    | Zneg p => Zneg 1
-  end.
+(** Every definitions and early properties about binary integers
+    are placed in a module [Z] for qualification purpose. *)
 
-(** ** Direct, easier to handle variants of successor and addition *)
+Module Z
+ <: ZAxiomsSig
+ <: UsualOrderedTypeFull
+ <: UsualDecidableTypeFull
+ <: TotalOrder.
 
-Definition Zsucc' (x:Z) :=
-  match x with
-    | Z0 => Zpos 1
-    | Zpos x' => Zpos (Psucc x')
-    | Zneg x' => ZPminus 1 x'
-  end.
+(** * Definitions of operations, now in a separate file *)
 
-Definition Zpred' (x:Z) :=
-  match x with
-    | Z0 => Zneg 1
-    | Zpos x' => ZPminus x' 1
-    | Zneg x' => Zneg (Psucc x')
-  end.
+Include BinIntDef.Z.
 
-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.
+(** When including property functors, only inline t eq zero one two *)
 
-Open Local Scope Z_scope.
+Set Inline Level 30.
 
-(**********************************************************************)
-(** ** Inductive specification of Z *)
+(** * Logic Predicates *)
 
-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.
-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)).
-Qed.
+Definition eq := @Logic.eq Z.
+Definition eq_equiv := @eq_equivalence Z.
 
-(**********************************************************************)
-(** * Misc properties about binary integer operations *)
+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.
 
-(**********************************************************************)
-(** ** Properties of opposite on binary integer numbers *)
+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.
+
+Definition divide x y := exists z, y = z*x.
+Notation "( x | y )" := (divide x y) (at level 0).
+
+Definition Even a := exists b, a = 2*b.
+Definition Odd a := exists b, a = 2*b+1.
 
-Theorem Zopp_0 : Zopp Z0 = Z0.
+(** * Decidability of equality. *)
+
+Definition eq_dec (x y : Z) : {x = y} + {x <> y}.
 Proof.
-  reflexivity.
+ decide equality; apply Pos.eq_dec.
+Defined.
+
+(** * Properties of [pos_sub] *)
+
+(** [pos_sub] can be written in term of positive comparison
+    and subtraction (cf. earlier definition of addition of Z) *)
+
+Lemma pos_sub_spec p q :
+ pos_sub p q =
+ match (p ?= q)%positive with
+   | Eq => 0
+   | Lt => neg (q - p)
+   | Gt => pos (p - q)
+ end.
+Proof.
+ 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.
 
-Theorem Zopp_neg : forall p:positive, - Zneg p = Zpos p.
+Lemma pos_sub_discr p q :
+  match pos_sub p q with
+  | Z0 => p = q
+  | pos k => p = q + k
+  | neg k => q = p + k
+  end%positive.
 Proof.
-  reflexivity.
+ rewrite pos_sub_spec.
+ case Pos.compare_spec; auto; intros;
+  now rewrite Pos.add_comm, Pos.sub_add.
 Qed.
 
-(** [opp] is involutive *)
+(** Particular cases of the previous result *)
 
-Theorem Zopp_involutive : forall n:Z, - - n = n.
+Lemma pos_sub_diag p : pos_sub p p = 0.
 Proof.
-  intro x; destruct x; reflexivity.
+ now rewrite pos_sub_spec, Pos.compare_refl.
 Qed.
 
-(** Injectivity of the opposite *)
+Lemma pos_sub_lt p q : (p < q)%positive -> pos_sub p q = neg (q - p).
+Proof.
+ intros H. now rewrite pos_sub_spec, H.
+Qed.
 
-Theorem Zopp_inj : forall n m:Z, - n = - m -> n = m.
+Lemma pos_sub_gt p q : (q < p)%positive -> pos_sub p q = pos (p - q).
 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 ].
+ intros H. now rewrite pos_sub_spec, Pos.compare_antisym, H.
 Qed.
 
-(**********************************************************************)
-(** ** Other properties of binary integer numbers *)
+(** The opposite of [pos_sub] is [pos_sub] with reversed arguments *)
 
-Lemma ZL0 : 2%nat = (1 + 1)%nat.
+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.
 
-(**********************************************************************)
-(** * Properties of the addition on integers *)
+(** 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. *)
 
-(** ** Zero is left neutral for addition *)
+Module Import Private_BootStrap.
 
-Theorem Zplus_0_l : forall n:Z, Z0 + n = n.
-Proof.
-  intro x; destruct x; reflexivity.
-Qed.
+(** * Properties of addition *)
 
-(** ** Zero is right neutral for addition *)
+(** ** Zero is neutral for addition *)
 
-Theorem Zplus_0_r : forall n:Z, n + Z0 = n.
+Lemma add_0_r n : n + 0 = n.
 Proof.
-  intro x; destruct x; reflexivity.
+ now destruct n.
 Qed.
 
 (** ** Addition is commutative *)
 
-Theorem Zplus_comm : forall n m:Z, n + m = m + n.
+Lemma add_comm n m : n + m = m + n.
 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.
+ destruct n, m; simpl; trivial; now rewrite Pos.add_comm.
 Qed.
 
 (** ** Opposite distributes over addition *)
 
-Theorem Zopp_plus_distr : forall n m:Z, - (n + m) = - n + - m.
+Lemma opp_add_distr n m : - (n + m) = - n + - m.
 Proof.
-  intro x; destruct x as [| p| p]; intro y; destruct y as [| q| q];
-    simpl in |- *; reflexivity || destruct ((p ?= q)%positive Eq);
-      reflexivity.
+ destruct n, m; simpl; trivial using pos_sub_opp.
 Qed.
 
-Theorem Zopp_succ : forall n:Z, Zopp (Zsucc n) = Zpred (Zopp n).
+(** ** Opposite is injective *)
+
+Lemma opp_inj n m : -n = -m -> n = m.
 Proof.
-intro; unfold Zsucc; now rewrite Zopp_plus_distr.
+ destruct n, m; simpl; intros H; destr_eq H; now f_equal.
+Qed.
+
+(** ** Addition is associative *)
+
+Lemma pos_sub_add p q r :
+  pos_sub (p + q) r = pos 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, pos x + (y + z) = pos x + y + z).
+ { intros x [|y|y] [|z|z]; rewrite ?add_0_r; trivial.
+   - simpl. now rewrite Pos.add_assoc.
+   - simpl (_ + neg _). symmetry. apply pos_sub_add.
+   - simpl (neg _ + _); simpl (_ + neg _).
+     now rewrite (add_comm _ (pos _)), <- 2 pos_sub_add, Pos.add_comm.
+   - apply opp_inj. rewrite !opp_add_distr. simpl opp.
+     simpl (neg _ + _); simpl (_ + neg _).
+     rewrite add_comm, Pos.add_comm. apply pos_sub_add. }
+ destruct n.
+ - trivial.
+ - apply AUX.
+ - apply opp_inj. rewrite !opp_add_distr. simpl opp. apply AUX.
+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.
 
 (** ** Opposite is inverse for addition *)
 
-Theorem Zplus_opp_r : forall n:Z, n + - n = Z0.
+Lemma add_opp_diag_r n : n + - n = 0.
 Proof.
-  intro x; destruct x as [| p| p]; simpl in |- *;
-    [ reflexivity
-      | rewrite (Pcompare_refl p); reflexivity
-      | rewrite (Pcompare_refl p); reflexivity ].
+ destruct n; simpl; trivial; now rewrite pos_sub_diag.
 Qed.
 
-Theorem Zplus_opp_l : forall n:Z, - n + n = Z0.
+Lemma add_opp_diag_l n : - n + n = 0.
 Proof.
-  intro; rewrite Zplus_comm; apply Zplus_opp_r.
+ rewrite add_comm. apply add_opp_diag_r.
 Qed.
 
-Hint Local Resolve Zplus_0_l Zplus_0_r.
+(** ** Commutativity of multiplication *)
 
-(** ** Addition is associative *)
+Lemma mul_comm n m : n * m = m * n.
+Proof.
+ destruct n, m; simpl; trivial; f_equal; apply Pos.mul_comm.
+Qed.
 
-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.
+(** ** Associativity of multiplication *)
+
+Lemma mul_assoc n m p : n * (m * p) = n * m * p.
+Proof.
+ destruct n, m, p; simpl; trivial; f_equal; apply Pos.mul_assoc.
 Qed.
 
-Notation Zplus_succ_r := Zplus_succ_r_reverse (only parsing).
+(** Multiplication and constants *)
 
-Lemma Zplus_succ_comm : forall n m:Z, Zsucc n + m = n + Zsucc m.
+Lemma mul_1_l n : 1 * n = n.
 Proof.
-  unfold Zsucc in |- *; intros n m; rewrite <- Zplus_assoc;
-    rewrite (Zplus_comm (Zpos 1)); trivial with arith.
+ now destruct n.
 Qed.
 
-(** ** Misc properties, usually redundant or non natural *)
+Lemma mul_1_r n : n * 1 = n.
+Proof.
+ destruct n; simpl; now rewrite ?Pos.mul_1_r.
+Qed.
+
+(** ** Multiplication and Opposite *)
 
-Lemma Zplus_0_r_reverse : forall n:Z, n = n + Z0.
+Lemma mul_opp_l n m : - n * m = - (n * m).
 Proof.
-  symmetry  in |- *; apply Zplus_0_r.
+ now destruct n, m.
 Qed.
 
-Lemma Zplus_0_simpl_l : forall n m:Z, n + Z0 = m -> n = m.
+Lemma mul_opp_r n m : n * - m = - (n * m).
 Proof.
-  intros n m; rewrite Zplus_0_r; intro; assumption.
+ now destruct n, m.
 Qed.
 
-Lemma Zplus_0_simpl_l_reverse : forall n m:Z, n = m + Z0 -> n = m.
+Lemma mul_opp_opp n m : - n * - m = n * m.
 Proof.
-  intros n m; rewrite Zplus_0_r; intro; assumption.
+ now destruct n, m.
 Qed.
 
-Lemma Zplus_eq_compat : forall n m p q:Z, n = m -> p = q -> n + p = m + q.
+Lemma mul_opp_comm n m : - n * m = n * - m.
 Proof.
-  intros; rewrite H; rewrite H0; reflexivity.
+ now destruct n, m.
 Qed.
 
-Lemma Zplus_opp_expand : forall n m p:Z, n + - m = n + - p + (p + - m).
+(** ** Distributivity of multiplication over addition *)
+
+Lemma mul_add_distr_pos (p:positive) n m :
+ pos p * (n + m) = pos p * n + pos p * m.
 Proof.
-  intros x y z.
-  rewrite <- (Zplus_assoc x).
-  rewrite (Zplus_assoc (- z)).
-  rewrite Zplus_opp_l.
-  reflexivity.
+ 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.
 
-(************************************************************************)
-(** * Properties of successor and predecessor on binary integer numbers *)
+Lemma mul_add_distr_l n m p : n * (m + p) = n * m + n * p.
+Proof.
+ destruct n as [|n|n]. trivial.
+ apply mul_add_distr_pos.
+ change (neg n) with (- pos n).
+ rewrite !mul_opp_l, <- opp_add_distr. f_equal.
+ apply mul_add_distr_pos.
+Qed.
 
-Theorem Zsucc_discr : forall n:Z, n <> Zsucc n.
+Lemma mul_add_distr_r n m p : (n + m) * p = n * p + m * p.
 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 ].
+ rewrite !(mul_comm _ p). apply mul_add_distr_l.
 Qed.
 
-Theorem Zpos_succ_morphism :
-  forall p:positive, Zpos (Psucc p) = Zsucc (Zpos p).
+(** ** Basic properties of divisibility *)
+
+Lemma divide_Zpos p q : (pos p|pos q) <-> (p|q)%positive.
 Proof.
-  intro; rewrite Pplus_one_succ_r; unfold Zsucc in |- *; simpl in |- *;
-    trivial with arith.
+ split.
+ intros ([ |r|r],H); simpl in *; destr_eq H. exists r; auto.
+ intros (r,H). exists (pos r); simpl; now f_equal.
 Qed.
 
-(** ** Successor and predecessor are inverse functions *)
+Lemma divide_Zpos_Zneg_r n p : (n|pos p) <-> (n|neg p).
+Proof.
+ split; intros (m,H); exists (-m); now rewrite mul_opp_l, <- H.
+Qed.
 
-Theorem Zsucc_pred : forall n:Z, n = Zsucc (Zpred n).
+Lemma divide_Zpos_Zneg_l n p : (pos p|n) <-> (neg p|n).
 Proof.
-  intros n; unfold Zsucc, Zpred in |- *; rewrite <- Zplus_assoc; simpl in |- *;
-    rewrite Zplus_0_r; trivial with arith.
+ split; intros (m,H); exists (-m); now rewrite mul_opp_l, <- mul_opp_r.
 Qed.
 
-Hint Immediate Zsucc_pred: zarith.
+(** ** Conversions between [Z.testbit] and [N.testbit] *)
 
-Theorem Zpred_succ : forall n:Z, n = Zpred (Zsucc n).
+Lemma testbit_of_N a n :
+ testbit (of_N a) (of_N n) = N.testbit a n.
 Proof.
-  intros m; unfold Zpred, Zsucc in |- *; rewrite <- Zplus_assoc; simpl in |- *;
-    rewrite Zplus_comm; auto with arith.
+ destruct a as [|a], n; simpl; trivial. now destruct a.
 Qed.
 
-Theorem Zsucc_inj : forall n m:Z, Zsucc n = Zsucc m -> n = m.
+Lemma testbit_of_N' a n : 0<=n ->
+ testbit (of_N a) n = N.testbit a (to_N n).
 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.
+ intro Hn. rewrite <- testbit_of_N. f_equal.
+ destruct n; trivial; now destruct Hn.
 Qed.
 
-(*************************************************************************)
-(** ** Properties of the direct definition of successor and predecessor  *)
+Lemma testbit_Zpos a n : 0<=n ->
+ testbit (pos a) n = N.testbit (N.pos a) (to_N n).
+Proof.
+ intro Hn. now rewrite <- testbit_of_N'.
+Qed.
 
-Theorem Zsucc_succ' : forall n:Z, Zsucc n = Zsucc' n.
+Lemma testbit_Zneg a n : 0<=n ->
+ testbit (neg a) n = negb (N.testbit (Pos.pred_N a) (to_N n)).
 Proof.
-destruct n as [| p | p]; simpl.
-reflexivity.
-now rewrite Pplus_one_succ_r.
-now destruct p as [q | q |].
+ intro Hn.
+ rewrite <- testbit_of_N' by trivial.
+ destruct n as [ |n|n];
+  [ | simpl; now destruct (Pos.pred_N a) | now destruct Hn].
+ unfold testbit.
+ now destruct a as [|[ | | ]| ].
 Qed.
 
-Theorem Zpred_pred' : forall n:Z, Zpred n = Zpred' n.
+End Private_BootStrap.
+
+(** * Proofs of specifications *)
+
+(** ** Specification of constants *)
+
+Lemma one_succ : 1 = succ 0.
 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.
+Lemma two_succ : 2 = succ 1.
 Proof.
-intros n m; do 2 rewrite <- Zsucc_succ'; now apply Zsucc_inj.
+reflexivity.
 Qed.
 
-Theorem Zsucc'_pred' : forall n:Z, Zsucc' (Zpred' n) = n.
+(** ** Specification of addition *)
+
+Lemma add_0_l n : 0 + n = n.
 Proof.
-intro; rewrite <- Zsucc_succ'; rewrite <- Zpred_pred';
-symmetry; apply Zsucc_pred.
+ now destruct n.
 Qed.
 
-Theorem Zpred'_succ' : forall n:Z, Zpred' (Zsucc' n) = n.
+Lemma add_succ_l n m : succ n + m = succ (n + m).
 Proof.
-intro; apply Zsucc'_inj; now rewrite Zsucc'_pred'.
+ unfold succ. now rewrite 2 (add_comm _ 1), add_assoc.
 Qed.
 
-Theorem Zpred'_inj : forall n m:Z, Zpred' n = Zpred' m -> n = m.
+(** ** Specification of opposite *)
+
+Lemma opp_0 : -0 = 0.
 Proof.
-intros n m H.
-rewrite <- (Zsucc'_pred' n); rewrite <- (Zsucc'_pred' m); now rewrite H.
+ reflexivity.
 Qed.
 
-Theorem Zsucc'_discr : forall n:Z, n <> Zsucc' n.
+Lemma opp_succ n : -(succ n) = pred (-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. apply opp_add_distr.
 Qed.
 
-(** Misc properties, usually redundant or non natural *)
+(** ** Specification of successor and predecessor *)
 
-Lemma Zsucc_eq_compat : forall n m:Z, n = m -> Zsucc n = Zsucc m.
+Lemma succ_pred n : succ (pred n) = n.
 Proof.
-  intros n m H; rewrite H; reflexivity.
+ unfold succ, pred. now rewrite <- add_assoc, add_opp_diag_r, add_0_r.
 Qed.
 
-Lemma Zsucc_inj_contrapositive : forall n m:Z, n <> m -> Zsucc n <> Zsucc m.
+Lemma pred_succ n : pred (succ n) = n.
 Proof.
-  unfold not in |- *; intros n m H1 H2; apply H1; apply Zsucc_inj; assumption.
+ unfold succ, pred. now rewrite <- add_assoc, add_opp_diag_r, add_0_r.
 Qed.
 
-(**********************************************************************)
-(** * Properties of subtraction on binary integer numbers *)
+(** ** Specification of subtraction *)
 
-(** ** [minus] and [Z0] *)
-
-Lemma Zminus_0_r : forall n:Z, n - Z0 = n.
+Lemma sub_0_r n : n - 0 = n.
 Proof.
-  intro; unfold Zminus in |- *; simpl in |- *; rewrite Zplus_0_r;
-    trivial with arith.
+ apply add_0_r.
 Qed.
 
-Lemma Zminus_0_l_reverse : forall n:Z, n = n - Z0.
+Lemma sub_succ_r n m : n - succ m = pred (n - m).
 Proof.
-  intro; symmetry  in |- *; apply Zminus_0_r.
+ unfold sub, succ, pred. now rewrite opp_add_distr, add_assoc.
 Qed.
 
-Lemma Zminus_diag : forall n:Z, n - n = Z0.
+(** ** Specification of multiplication *)
+
+Lemma mul_0_l n : 0 * n = 0.
 Proof.
-  intro; unfold Zminus in |- *; rewrite Zplus_opp_r; trivial with arith.
+ reflexivity.
 Qed.
 
-Lemma Zminus_diag_reverse : forall n:Z, Z0 = n - n.
+Lemma mul_succ_l n m : succ n * m = n * m + m.
 Proof.
-  intro; symmetry  in |- *; apply Zminus_diag.
+ unfold succ. now rewrite mul_add_distr_r, mul_1_l.
 Qed.
 
+(** ** Specification of comparisons and order *)
 
-(** ** Relating [minus] with [plus] and [Zsucc] *)
+Lemma eqb_eq n m : (n =? m) = true <-> n = m.
+Proof.
+ destruct n, m; simpl; try (now split); rewrite Pos.eqb_eq;
+ split; (now injection 1) || (intros; now f_equal).
+Qed.
 
-Lemma Zminus_plus_distr : forall n m p:Z, n - (m + p) = n - m - p.
+Lemma ltb_lt n m : (n <? m) = true <-> n < m.
 Proof.
-intros; unfold Zminus; rewrite Zopp_plus_distr; apply Zplus_assoc.
+ unfold ltb, lt. destruct compare; easy'.
 Qed.
 
-Lemma Zminus_succ_l : forall n m:Z, Zsucc (n - m) = Zsucc n - m.
+Lemma leb_le n m : (n <=? m) = true <-> n <= m.
 Proof.
-  intros n m; unfold Zminus, Zsucc in |- *; rewrite (Zplus_comm n (- m));
-    rewrite <- Zplus_assoc; apply Zplus_comm.
+ unfold leb, le. destruct compare; easy'.
 Qed.
 
-Lemma Zminus_succ_r : forall n m:Z, n - (Zsucc m) = Zpred (n - m).
+Lemma compare_eq_iff n m : (n ?= m) = Eq <-> n = m.
 Proof.
-intros; unfold Zsucc; now rewrite Zminus_plus_distr.
+destruct n, m; simpl; rewrite ?CompOpp_iff, ?Pos.compare_eq_iff;
+ split; congruence.
 Qed.
 
-Lemma Zplus_minus_eq : forall n m p:Z, n = m + p -> p = n - m.
+Lemma compare_sub n m : (n ?= m) = (n - m ?= 0).
 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.
+ 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_plus : forall n m:Z, n + m - n = m.
+Lemma compare_antisym n m : (m ?= n) = CompOpp (n ?= m).
 Proof.
-  intros n m; unfold Zminus in |- *; rewrite (Zplus_comm n m);
-    rewrite <- Zplus_assoc; rewrite Zplus_opp_r; apply Zplus_0_r.
+destruct n, m; simpl; trivial; now rewrite <- ?Pos.compare_antisym.
 Qed.
 
-Lemma Zplus_minus : forall n m:Z, n + (m - n) = m.
+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]. *)
+
+Include BoolOrderFacts.
+
+(** Remaining specification of [lt] and [le] *)
+
+Lemma lt_succ_r n m : n < succ m <-> n<=m.
 Proof.
-  unfold Zminus in |- *; intros n m; rewrite Zplus_permute; rewrite Zplus_opp_r;
-    apply Zplus_0_r.
+ unfold lt, le. rewrite compare_sub, sub_succ_r.
+ rewrite (compare_sub n m).
+ destruct (n-m) as [|[ | | ]|]; easy'.
 Qed.
 
-Lemma Zminus_plus_simpl_l : forall n m p:Z, p + n - (p + m) = n - m.
+(** ** Specification of minimum and maximum *)
+
+Lemma max_l n m : m<=n -> max n m = 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.
+ unfold le, max. rewrite (compare_antisym n m).
+ case compare; intuition.
 Qed.
 
-Lemma Zminus_plus_simpl_l_reverse : forall n m p:Z, n - m = p + n - (p + m).
+Lemma max_r n m :  n<=m -> max n m = m.
 Proof.
-  intros; symmetry  in |- *; apply Zminus_plus_simpl_l.
+ unfold le, max. case compare_spec; intuition.
 Qed.
 
-Lemma Zminus_plus_simpl_r : forall n m p:Z, n + p - (m + p) = n - m.
+Lemma min_l n m : n<=m -> min n m = n.
 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.
+ unfold le, min. case compare_spec; intuition.
 Qed.
 
-Lemma Zpos_minus_morphism : forall a b:positive, Pcompare a b Eq = Lt ->
-  Zpos (b-a) = Zpos b - Zpos a.
+Lemma min_r n m : m<=n -> min n m = m.
 Proof.
-  intros.
-  simpl.
-  change Eq with (CompOpp Eq).
-  rewrite <- Pcompare_antisym.
-  rewrite H; simpl; auto.
+ unfold le, min.
+ rewrite (compare_antisym n m). case compare_spec; intuition.
 Qed.
 
-(** ** Misc redundant properties *)
+(** ** Specification of absolute value *)
 
-Lemma Zeq_minus : forall n m:Z, n = m -> n - m = Z0.
+Lemma abs_eq n : 0 <= n -> abs n = n.
 Proof.
-  intros x y H; rewrite H; symmetry  in |- *; apply Zminus_diag_reverse.
+ destruct n; trivial. now destruct 1.
 Qed.
 
-Lemma Zminus_eq : forall n m:Z, n - m = Z0 -> n = m.
+Lemma abs_neq n : n <= 0 -> abs n = - n.
 Proof.
-  intros x y H; rewrite <- (Zplus_minus y x); rewrite H; apply Zplus_0_r.
+ destruct n; trivial. now destruct 1.
 Qed.
 
+(** ** Specification of sign *)
 
-(**********************************************************************)
-(** * Properties of multiplication on binary integer numbers *)
-
-Theorem Zpos_mult_morphism :
-  forall p q:positive, Zpos (p*q) = Zpos p * Zpos q.
+Lemma sgn_null n : n = 0 -> sgn n = 0.
 Proof.
-  auto.
+ intros. now subst.
 Qed.
 
-(** ** One is neutral for multiplication *)
-
-Theorem Zmult_1_l : forall n:Z, Zpos 1 * n = n.
+Lemma sgn_pos n : 0 < n -> sgn n = 1.
 Proof.
-  intro x; destruct x; reflexivity.
+ now destruct n.
 Qed.
 
-Theorem Zmult_1_r : forall n:Z, n * Zpos 1 = n.
+Lemma sgn_neg n : n < 0 -> sgn n = -1.
 Proof.
-  intro x; destruct x; simpl in |- *; try rewrite Pmult_1_r; reflexivity.
+ now destruct n.
 Qed.
 
-(** ** Zero property of multiplication *)
+(** ** Specification of power *)
 
-Theorem Zmult_0_l : forall n:Z, Z0 * n = Z0.
+Lemma pow_0_r n : n^0 = 1.
 Proof.
-  intro x; destruct x; reflexivity.
+ reflexivity.
 Qed.
 
-Theorem Zmult_0_r : forall n:Z, n * Z0 = Z0.
+Lemma pow_succ_r n m : 0<=m -> n^(succ m) = n * n^m.
 Proof.
-  intro x; destruct x; reflexivity.
+ destruct m as [|m|m]; (now destruct 1) || (intros _); simpl; trivial.
+ unfold pow_pos. now rewrite Pos.add_comm, Pos.iter_add.
 Qed.
 
-Hint Local Resolve Zmult_0_l Zmult_0_r.
+Lemma pow_neg_r n m : m<0 -> n^m = 0.
+Proof.
+ now destruct m.
+Qed.
 
-Lemma Zmult_0_r_reverse : forall n:Z, Z0 = n * Z0.
+(** For folding back a [pow_pos] into a [pow] *)
+
+Lemma pow_pos_fold n p : pow_pos n p = n ^ (pos p).
 Proof.
-  intro x; destruct x; reflexivity.
+ reflexivity.
 Qed.
 
-(** ** Commutativity of multiplication *)
+(** ** Specification of square *)
 
-Theorem Zmult_comm : forall n m:Z, n * m = m * n.
+Lemma square_spec n : square n = n * n.
 Proof.
-  intros x y; destruct x as [| p| p]; destruct y as [| q| q]; simpl in |- *;
-    try rewrite (Pmult_comm p q); reflexivity.
+ destruct n; trivial; simpl; f_equal; apply Pos.square_spec.
 Qed.
 
-(** ** Associativity of multiplication *)
+(** ** Specification of square root *)
 
-Theorem Zmult_assoc : forall n m p:Z, n * (m * p) = n * m * p.
+Lemma sqrtrem_spec n : 0<=n ->
+ let (s,r) := sqrtrem n in n = s*s + r /\ 0 <= r <= 2*s.
 Proof.
-  intros x y z; destruct x; destruct y; destruct z; simpl in |- *;
-    try rewrite Pmult_assoc; reflexivity.
+ destruct n. now repeat split.
+ generalize (Pos.sqrtrem_spec p). simpl.
+ destruct 1; simpl; subst; now repeat split.
+ now destruct 1.
 Qed.
 
-Lemma Zmult_assoc_reverse : forall n m p:Z, n * m * p = n * (m * p).
+Lemma sqrt_spec n : 0<=n ->
+ let s := sqrt n in s*s <= n < (succ s)*(succ s).
 Proof.
-  intros n m p; rewrite Zmult_assoc; trivial with arith.
+ destruct n. now repeat split. unfold sqrt.
+ intros _. simpl succ. rewrite Pos.add_1_r. apply (Pos.sqrt_spec p).
+ now destruct 1.
 Qed.
 
-(** ** Associativity mixed with commutativity *)
+Lemma sqrt_neg n : n<0 -> sqrt n = 0.
+Proof.
+ now destruct n.
+Qed.
 
-Theorem Zmult_permute : forall n m p:Z, n * (m * p) = m * (n * p).
+Lemma sqrtrem_sqrt n : fst (sqrtrem n) = sqrt n.
 Proof.
-  intros x y z; rewrite (Zmult_assoc y x z); rewrite (Zmult_comm y x).
-  apply Zmult_assoc.
+ destruct n; try reflexivity.
+ unfold sqrtrem, sqrt, Pos.sqrt.
+ destruct (Pos.sqrtrem p) as (s,r). now destruct r.
 Qed.
 
-(** ** Z is integral *)
+(** ** Specification of logarithm *)
 
-Theorem Zmult_integral_l : forall n m:Z, n <> Z0 -> m * n = Z0 -> m = Z0.
+Lemma log2_spec n : 0 < n -> 2^(log2 n) <= n < 2^(succ (log2 n)).
 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.
+ assert (Pow : forall p q, pos (p^q) = (pos p)^(pos q)).
+ { intros. now apply Pos.iter_swap_gen. }
+ destruct n as [|[p|p|]|]; intros Hn; split; try easy; unfold log2;
+  simpl succ; rewrite ?Pos.add_1_r, <- Pow.
+ 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.
 
-
-Theorem Zmult_integral : forall n m:Z, n * m = Z0 -> n = Z0 \/ m = Z0.
+Lemma log2_nonpos n : n<=0 -> log2 n = 0.
 Proof.
-  intros x y; destruct x; destruct y; auto; simpl in |- *; intro H;
-    discriminate H.
+ destruct n as [|p|p]; trivial; now destruct 1.
 Qed.
 
+(** Specification of parity functions *)
+
+Lemma even_spec n : even n = true <-> Even n.
+Proof.
+ split.
+ exists (div2 n). now destruct n as [|[ | | ]|[ | | ]].
+ intros (m,->). now destruct m.
+Qed.
 
-Lemma Zmult_1_inversion_l :
-  forall n m:Z, n * m = Zpos 1 -> n = Zpos 1 \/ n = Zneg 1.
+Lemma odd_spec n : odd n = true <-> Odd n.
 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.
+ 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 Zdouble_mult : forall z, Zdouble z = (Zpos 2) * z.
+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 pos 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).
+   change (pos a~1) with (2*(pos a)+1).
+   rewrite 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).
+   change (pos a~0) with (2*pos a).
+   rewrite 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 (pos b) (eq_refl _));
+  destruct pos_div_eucl as (q,r); rewrite mul_comm.
+ - (* pos pos *)
+   trivial.
+ - (* pos neg *)
+   intros ->.
+   destruct r as [ |r|r]; rewrite <- !mul_opp_comm; trivial;
+    rewrite mul_add_distr_l, mul_1_r, <- add_assoc; f_equal;
+   now rewrite add_assoc, add_opp_diag_r.
+ - (* neg pos *)
+   change (neg a) with (- pos a). intros ->.
+   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.
+ - (* neg neg *)
+   change (neg a) with (- pos a). intros ->.
+   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 < pos (p~0) -> m - pos p < pos p).
+  intros m p. unfold lt.
+  rewrite (compare_sub m), (compare_sub _ (pos _)). unfold sub.
+  rewrite <- add_assoc. simpl opp; simpl (neg _ + _).
+  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.
+
+Lemma mod_pos_bound a b : 0 < b -> 0 <= a mod b < b.
+Proof.
+ 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 (pos 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.
+
+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.
+ destruct b as [|b|b]; try easy; intros _.
+ destruct a as [|a|a]; unfold modulo, div_eucl.
+ now split.
+ generalize (pos_div_eucl_bound a (pos b) (eq_refl _)).
+ 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 (neg b - neg r <= 0). unfold le, lt in *.
+  rewrite <- compare_sub. simpl in *.
+  now rewrite <- Pos.compare_antisym, Hr'.
+ generalize (pos_div_eucl_bound a (pos b) (eq_refl _)).
+ 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.
+
+(** ** Correctness proofs for Floor division *)
+
+Theorem quotrem_eq a b : let (q,r) := quotrem a b in a = q * b + r.
 Proof.
-  reflexivity.
+ destruct a as [|a|a], b as [|b|b]; simpl; trivial;
+ generalize (N.pos_div_eucl_spec a (N.pos b)); case N.pos_div_eucl; trivial;
+  intros q r;
+  try change (neg a) with (-pos a);
+  change (pos a) with (of_N (N.pos a)); intros ->; now destruct q, r.
 Qed.
 
-Lemma Zdouble_plus_one_mult : forall z,
-  Zdouble_plus_one z = (Zpos 2) * z + (Zpos 1).
+Lemma quot_rem' a b : a = b*(a÷b) + rem a b.
 Proof.
-  destruct z; simpl; auto with zarith.
+ rewrite mul_comm. generalize (quotrem_eq a b).
+ unfold quot, rem. now destruct quotrem.
 Qed.
 
-(** ** Multiplication and Opposite *)
+Lemma quot_rem a b : b<>0 -> a = b*(a÷b) + rem a b.
+Proof. intros _. apply quot_rem'. Qed.
 
-Theorem Zopp_mult_distr_l : forall n m:Z, - (n * m) = - n * m.
+Lemma rem_bound_pos a b : 0<=a -> 0<b -> 0 <= rem a b < b.
 Proof.
-  intros x y; destruct x; destruct y; reflexivity.
+ 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 (N.pos b)).
+ destruct N.pos_div_eucl as (q,[|r]); simpl; split; try easy.
+ now apply H.
 Qed.
 
-Theorem Zopp_mult_distr_r : forall n m:Z, - (n * m) = n * - m.
+Lemma rem_opp_l' a b : rem (-a) b = - (rem a b).
 Proof.
-  intros x y; rewrite (Zmult_comm x y); rewrite Zopp_mult_distr_l;
-    apply Zmult_comm.
+ destruct a, b; trivial; unfold rem; simpl;
+  now destruct N.pos_div_eucl as (q,[|r]).
 Qed.
 
-Lemma Zopp_mult_distr_l_reverse : forall n m:Z, - n * m = - (n * m).
+Lemma rem_opp_r' a b : rem a (-b) = rem a b.
 Proof.
-  intros x y; symmetry  in |- *; apply Zopp_mult_distr_l.
+ destruct a, b; trivial; unfold rem; simpl;
+  now destruct N.pos_div_eucl as (q,[|r]).
 Qed.
 
-Theorem Zmult_opp_comm : forall n m:Z, - n * m = n * - m.
+Lemma rem_opp_l a b : b<>0 -> rem (-a) b = - (rem a b).
+Proof. intros _. apply rem_opp_l'. Qed.
+
+Lemma rem_opp_r a b : b<>0 -> rem a (-b) = rem a b.
+Proof. intros _. apply rem_opp_r'. Qed.
+
+(** ** Correctness proofs for gcd *)
+
+Lemma ggcd_gcd a b : fst (ggcd a b) = gcd a b.
 Proof.
-  intros x y; rewrite Zopp_mult_distr_l_reverse; rewrite Zopp_mult_distr_r;
-    trivial with arith.
+ 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.
 
-Theorem Zmult_opp_opp : forall n m:Z, - n * - m = n * m.
+Lemma ggcd_correct_divisors a b :
+  let '(g,(aa,bb)) := ggcd a b in
+  a = g*aa /\ b = g*bb.
 Proof.
-  intros x y; destruct x; destruct y; reflexivity.
+ 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_eq_mult_neg_1 : forall n:Z, - n = n * Zneg 1.
+Lemma gcd_divide_l a b : (gcd a b | a).
 Proof.
-  intro x; induction x; intros; rewrite Zmult_comm; auto with arith.
+ 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.
 
-(** ** Distributivity of multiplication over addition *)
+Lemma gcd_divide_r a b : (gcd a b | b).
+Proof.
+ 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 weak_Zmult_plus_distr_r :
-  forall (p:positive) (n m:Z), Zpos p * (n + m) = Zpos p * n + Zpos p * m.
+Lemma gcd_greatest a b c : (c|a) -> (c|b) -> (c | gcd a b).
 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) ] ]).
+ assert (H : forall p q r, (r|pos p) -> (r|pos q) -> (r|pos (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_plus_distr_r : forall n m p:Z, n * (m + p) = n * m + n * p.
+Lemma gcd_nonneg a b : 0 <= gcd a b.
 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 ].
+ now destruct a, b.
 Qed.
 
-Theorem Zmult_plus_distr_l : forall n m p:Z, (n + m) * p = n * p + m * p.
+(** 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 n m p; rewrite Zmult_comm; rewrite Zmult_plus_distr_r;
-    do 2 rewrite (Zmult_comm p); trivial with arith.
+ destruct a as [|a|a], b as [|b|b]; unfold ggcd, opp; auto;
+  destruct (Pos.ggcd a b) as (g,(aa,bb)); auto.
 Qed.
 
-(** ** Distributivity of multiplication over subtraction *)
+(** ** Proofs of specifications for bitwise operations *)
 
-Lemma Zmult_minus_distr_r : forall n m p:Z, (n - m) * p = n * p - m * p.
+Lemma div2_spec a : div2 a = shiftr a 1.
 Proof.
-  intros x y z; unfold Zminus in |- *.
-  rewrite <- Zopp_mult_distr_l_reverse.
-  apply Zmult_plus_distr_l.
+ reflexivity.
 Qed.
 
+Lemma testbit_0_l n : testbit 0 n = false.
+Proof.
+ now destruct n.
+Qed.
 
-Lemma Zmult_minus_distr_l : forall n m p:Z, p * (n - m) = p * n - p * m.
+Lemma testbit_neg_r a n : n<0 -> testbit a n = 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 n.
 Qed.
 
-(** ** Simplification of multiplication for non-zero integers *)
+Lemma testbit_odd_0 a : testbit (2*a+1) 0 = true.
+Proof.
+ now destruct a as [|a|[a|a|]].
+Qed.
 
-Lemma Zmult_reg_l : forall n m p:Z, p <> Z0 -> p * n = p * m -> n = m.
+Lemma testbit_even_0 a : testbit (2*a) 0 = false.
 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.
+ now destruct a.
 Qed.
 
-Lemma Zmult_reg_r : forall n m p:Z, p <> Z0 -> n * p = m * p -> n = m.
+Lemma testbit_odd_succ a n : 0<=n ->
+ testbit (2*a+1) (succ n) = testbit a 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.
+ destruct n as [|n|n]; (now destruct 1) || intros _.
+ destruct a as [|[a|a|]|[a|a|]]; simpl; trivial. now destruct a.
+ unfold testbit; simpl.
+ destruct a as [|a|[a|a|]]; simpl; trivial;
+  rewrite ?Pos.add_1_r, ?Pos.pred_N_succ; now destruct n.
 Qed.
 
-(** ** Addition and multiplication by 2 *)
+Lemma testbit_even_succ a n : 0<=n ->
+ testbit (2*a) (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; simpl.
+ destruct a as [|a|[a|a|]]; simpl; trivial;
+  rewrite ?Pos.add_1_r, ?Pos.pred_N_succ; now destruct n.
+Qed.
 
-Lemma Zplus_diag_eq_mult_2 : forall n:Z, n + n = n * Zpos 2.
+(** 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; pattern x at 1 2 in |- *; rewrite <- (Zmult_1_r x);
-    rewrite <- Zmult_plus_distr_r; reflexivity.
+ 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 + pos p) = (to_N m + N.pos p)%N).
+  destruct m; trivial; now destruct Hm.
+ assert (forall p, 0 <= m + pos 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 (pos a) with (of_N (N.pos a)) at 1.
+ rewrite <- (Pos.iter_swap_gen _ _ _ N.div2) by now intros [|[ | | ]].
+ rewrite testbit_Zpos, testbit_of_N', H; trivial.
+ exact (N.shiftr_spec' (N.pos a) (N.pos n) (to_N m)).
+ (* a < 0 *)
+ rewrite <- (Pos.iter_swap_gen _ _ _ Pos.div2_up) by trivial.
+ rewrite 2 testbit_Zneg, H; trivial. f_equal.
+ rewrite (Pos.iter_swap_gen _ _ _ _ N.div2) by exact N.pred_div2_up.
+ exact (N.shiftr_spec' (Pos.pred_N a) (N.pos n) (to_N m)).
 Qed.
 
-(** ** Multiplication and successor *)
+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 (N.pos a) (N.pos n) (N.pos 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 (N.pos 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 <= pos m - pos n).
+  red. now rewrite compare_antisym, <- compare_sub, <- compare_antisym.
+ assert (EQ : to_N (pos m - pos n) = (N.pos m - N.pos 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' (N.pos p) (N.pos n) (N.pos 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 (N.pos n)).
+ (* n < 0 *)
+ unfold sub. simpl.
+ now apply (shiftr_spec_aux a (pos 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.
 
-Lemma Zmult_succ_r : forall n m:Z, n * Zsucc m = n * m + n.
+(** ** 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 n m; unfold Zsucc in |- *; rewrite Zmult_plus_distr_r;
-    rewrite (Zmult_comm n (Zpos 1)); rewrite Zmult_1_l;
-      trivial with arith.
+ intros H0 Hs Hp z; destruct z.
+ assumption.
+ induction p using Pos.peano_ind.
+  now apply (Hs 0).
+  rewrite <- Pos.add_1_r.
+  now apply (Hs (pos p)).
+ induction p using Pos.peano_ind.
+  now apply (Hp 0).
+  rewrite <- Pos.add_1_r.
+  now apply (Hp (neg p)).
 Qed.
 
-Lemma Zmult_succ_r_reverse : forall n m:Z, n * m + n = n * Zsucc m.
+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; symmetry  in |- *; apply Zmult_succ_r.
+ intros _ H0 Hs. induction z using peano_ind.
+ assumption.
+ now apply -> Hs.
+ apply Hs. now rewrite succ_pred.
 Qed.
 
-Lemma Zmult_succ_l : forall n m:Z, Zsucc n * m = n * m + m.
+
+(** * Proofs of morphisms, obvious since eq is Leibniz *)
+
+Local Obligation Tactic := simpl_relation.
+Program Definition succ_wd : Proper (eq==>eq) succ := _.
+Program Definition pred_wd : Proper (eq==>eq) pred := _.
+Program Definition opp_wd : Proper (eq==>eq) opp := _.
+Program Definition add_wd : Proper (eq==>eq==>eq) add := _.
+Program Definition sub_wd : Proper (eq==>eq==>eq) sub := _.
+Program Definition mul_wd : Proper (eq==>eq==>eq) mul := _.
+Program Definition lt_wd : Proper (eq==>eq==>iff) lt := _.
+Program Definition div_wd : Proper (eq==>eq==>eq) div := _.
+Program Definition mod_wd : Proper (eq==>eq==>eq) modulo := _.
+Program Definition quot_wd : Proper (eq==>eq==>eq) quot := _.
+Program Definition rem_wd : Proper (eq==>eq==>eq) rem := _.
+Program Definition pow_wd : Proper (eq==>eq==>eq) pow := _.
+Program Definition testbit_wd : Proper (eq==>eq==>Logic.eq) testbit := _.
+
+(** The Bind Scope prevents Z to stay associated with abstract_scope.
+    (TODO FIX) *)
+
+Include ZProp. Bind Scope Z_scope with Z.
+Include UsualMinMaxLogicalProperties <+ UsualMinMaxDecProperties.
+
+(** 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.
-  intros n m; unfold Zsucc in |- *; rewrite Zmult_plus_distr_l;
-    rewrite Zmult_1_l; trivial with arith.
+ unfold lt, gt. now rewrite compare_antisym, CompOpp_iff.
 Qed.
 
-Lemma Zmult_succ_l_reverse : forall n m:Z, n * m + m = Zsucc n * m.
+Lemma gt_lt n m : n > m -> m < n.
 Proof.
-  intros; symmetry  in |- *; apply Zmult_succ_l.
+ 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.
 
-(** ** Misc redundant properties *)
+Lemma ge_le n m : n >= m -> m <= n.
+Proof.
+ apply ge_le_iff.
+Qed.
 
-Lemma Z_eq_mult : forall n m:Z, m = Z0 -> m * n = Z0.
+Lemma le_ge n m : n <= m -> m >= n.
 Proof.
-  intros x y H; rewrite H; auto with arith.
+ 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 *.
 
-(**********************************************************************)
-(** * Relating binary positive numbers and binary integers *)
+(** 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 Zpos_eq : forall p q:positive, p = q -> Zpos p = Zpos q.
+Lemma gtb_ltb n m : (n >? m) = (m <? n).
 Proof.
-  intros; f_equal; auto.
+ unfold gtb, ltb. rewrite compare_antisym. now case compare.
 Qed.
 
-Lemma Zpos_eq_rev : forall p q:positive, Zpos p = Zpos q -> p = q.
+Lemma geb_leb n m : (n >=? m) = (m <=? n).
 Proof.
-  inversion 1; auto.
+ unfold geb, leb. rewrite compare_antisym. now case compare.
 Qed.
 
-Lemma Zpos_eq_iff : forall p q:positive, p = q <-> Zpos p = Zpos q.
+Lemma gtb_lt n m : (n >? m) = true <-> m < n.
 Proof.
-  split; [apply Zpos_eq|apply Zpos_eq_rev].
+ rewrite gtb_ltb. apply ltb_lt.
 Qed.
 
-Lemma Zpos_xI : forall p:positive, Zpos p~1 = Zpos 2 * Zpos p + Zpos 1.
+Lemma geb_le n m : (n >=? m) = true <-> m <= n.
 Proof.
-  intro; apply refl_equal.
+ rewrite geb_leb. apply leb_le.
 Qed.
 
-Lemma Zpos_xO : forall p:positive, Zpos p~0 = Zpos 2 * Zpos p.
+Lemma gtb_spec n m : BoolSpec (m<n) (n<=m) (n >? m).
 Proof.
-  intro; apply refl_equal.
+ rewrite gtb_ltb. apply ltb_spec.
 Qed.
 
-Lemma Zneg_xI : forall p:positive, Zneg p~1 = Zpos 2 * Zneg p - Zpos 1.
+Lemma geb_spec n m : BoolSpec (m<=n) (n<m) (n >=? m).
 Proof.
-  intro; apply refl_equal.
+ rewrite geb_leb. apply leb_spec.
 Qed.
 
-Lemma Zneg_xO : forall p:positive, Zneg p~0 = Zpos 2 * Zneg p.
+(** TODO : to add in Numbers ? *)
+
+Lemma add_reg_l n m p : n + m = n + p -> m = p.
 Proof.
-  reflexivity.
+ exact (proj1 (add_cancel_l m p n)).
 Qed.
 
-Lemma Zpos_plus_distr : forall p q:positive, Zpos (p + q) = Zpos p + Zpos q.
+Lemma mul_reg_l n m p : p <> 0 -> p * n = p * m -> n = m.
 Proof.
-  intros p p'; destruct p;
-    [ destruct p' as [p0| p0| ]
-      | destruct p' as [p0| p0| ]
-      | destruct p' as [p| p| ] ]; reflexivity.
+ exact (fun Hp => proj1 (mul_cancel_l n m p Hp)).
 Qed.
 
-Lemma Zneg_plus_distr : forall p q:positive, Zneg (p + q) = Zneg p + Zneg q.
+Lemma mul_reg_r n m p : p <> 0 -> n * p = m * p -> n = m.
 Proof.
-  intros p p'; destruct p;
-    [ destruct p' as [p0| p0| ]
-      | destruct p' as [p0| p0| ]
-      | destruct p' as [p| p| ] ]; reflexivity.
+ exact (fun Hp => proj1 (mul_cancel_r n m p Hp)).
 Qed.
 
-(**********************************************************************)
-(** * Order relations *)
+Lemma opp_eq_mul_m1 n : - n = n * -1.
+Proof.
+ rewrite mul_comm. now destruct n.
+Qed.
 
-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.
+Lemma add_diag n : n + n = 2 * n.
+Proof.
+ change 2 with (1+1). now rewrite mul_add_distr_r, !mul_1_l.
+Qed.
+
+(** * Comparison and opposite *)
 
-Infix "<=" := Zle : Z_scope.
-Infix "<" := Zlt : Z_scope.
-Infix ">=" := Zge : Z_scope.
-Infix ">" := Zgt : Z_scope.
+Lemma compare_opp n m : (- n ?= - m) = (m ?= n).
+Proof.
+ destruct n, m; simpl; trivial; intros; now rewrite <- Pos.compare_antisym.
+Qed.
 
+(** * Comparison and addition *)
+
+Lemma add_compare_mono_l n m p : (n + m ?= n + p) = (m ?= p).
+Proof.
+ 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.
+
+End Z.
+
+(** Re-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.
+Infix "?=" := Z.compare (at level 70, no associativity) : Z_scope.
+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.
+Notation "( x | y )" := (Z.divide x y) (at level 0) : 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.
+(** Conversions from / to positive numbers *)
+
+Module Pos2Z.
+
+Lemma id p : Z.to_pos (Z.pos p) = p.
+Proof. reflexivity. Qed.
+
+Lemma inj p q : Z.pos p = Z.pos q -> p = q.
+Proof. now injection 1. Qed.
+
+Lemma inj_iff p q : Z.pos p = Z.pos q <-> p = q.
+Proof. split. apply inj. intros; now f_equal. Qed.
+
+Lemma is_pos p : 0 < Z.pos p.
+Proof. reflexivity. Qed.
+
+Lemma is_nonneg p : 0 <= Z.pos p.
+Proof. easy. Qed.
+
+Lemma inj_1 : Z.pos 1 = 1.
+Proof. reflexivity. Qed.
+
+Lemma inj_xO p : Z.pos p~0 = 2 * Z.pos p.
+Proof. reflexivity. Qed.
+
+Lemma inj_xI p : Z.pos p~1 = 2 * Z.pos p + 1.
+Proof. reflexivity. Qed.
+
+Lemma inj_succ p : Z.pos (Pos.succ p) = Z.succ (Z.pos p).
+Proof. simpl. now rewrite Pos.add_1_r. Qed.
+
+Lemma inj_add p q : Z.pos (p+q) = Z.pos p + Z.pos q.
+Proof. reflexivity. Qed.
+
+Lemma inj_sub p q : (p < q)%positive ->
+ Z.pos (q-p) = Z.pos q - Z.pos p.
+Proof. intros. simpl. now rewrite Z.pos_sub_gt. Qed.
+
+Lemma inj_sub_max p q : Z.pos (p - q) = Z.max 1 (Z.pos p - Z.pos q).
+Proof.
+  simpl. rewrite Z.pos_sub_spec. case Pos.compare_spec; intros.
+  - subst; now rewrite Pos.sub_diag.
+  - now rewrite Pos.sub_lt.
+  - now destruct (p-q)%positive.
+Qed.
+
+Lemma inj_pred p : p <> 1%positive ->
+ Z.pos (Pos.pred p) = Z.pred (Z.pos p).
+Proof. destruct p; easy || now destruct 1. Qed.
+
+Lemma inj_mul p q : Z.pos (p*q) = Z.pos p * Z.pos q.
+Proof. reflexivity. Qed.
+
+Lemma inj_pow_pos p q : Z.pos (p^q) = Z.pow_pos (Z.pos p) q.
+Proof. now apply Pos.iter_swap_gen. Qed.
+
+Lemma inj_pow p q : Z.pos (p^q) = (Z.pos p)^(Z.pos q).
+Proof. apply inj_pow_pos. Qed.
+
+Lemma inj_square p : Z.pos (Pos.square p) = Z.square (Z.pos p).
+Proof. reflexivity. Qed.
+
+Lemma inj_compare p q : (p ?= q)%positive = (Z.pos p ?= Z.pos q).
+Proof. reflexivity. Qed.
+
+Lemma inj_leb p q : (p <=? q)%positive = (Z.pos p <=? Z.pos q).
+Proof. reflexivity. Qed.
+
+Lemma inj_ltb p q : (p <? q)%positive = (Z.pos p <? Z.pos q).
+Proof. reflexivity. Qed.
+
+Lemma inj_eqb p q : (p =? q)%positive = (Z.pos p =? Z.pos q).
+Proof. reflexivity. Qed.
+
+Lemma inj_max p q : Z.pos (Pos.max p q) = Z.max (Z.pos p) (Z.pos q).
+Proof.
+ unfold Z.max, Pos.max. rewrite inj_compare. now case Z.compare_spec.
+Qed.
+
+Lemma inj_min p q : Z.pos (Pos.min p q) = Z.min (Z.pos p) (Z.pos q).
+Proof.
+ unfold Z.min, Pos.min. rewrite inj_compare. now case Z.compare_spec.
+Qed.
+
+Lemma inj_sqrt p : Z.pos (Pos.sqrt p) = Z.sqrt (Z.pos p).
+Proof. reflexivity. Qed.
+
+Lemma inj_gcd p q : Z.pos (Pos.gcd p q) = Z.gcd (Z.pos p) (Z.pos q).
+Proof. reflexivity. Qed.
+
+Definition inj_divide p q : (Z.pos p|Z.pos q) <-> (p|q)%positive.
+Proof. apply Z.Private_BootStrap.divide_Zpos. Qed.
+
+Lemma inj_testbit a n : 0<=n ->
+ Z.testbit (Z.pos a) n = N.testbit (N.pos a) (Z.to_N n).
+Proof. apply Z.Private_BootStrap.testbit_Zpos. Qed.
+
+(** Some results concerning Z.neg *)
+
+Lemma inj_neg p q : Z.neg p = Z.neg q -> p = q.
+Proof. now injection 1. Qed.
+
+Lemma inj_neg_iff p q : Z.neg p = Z.neg q <-> p = q.
+Proof. split. apply inj_neg. intros; now f_equal. Qed.
+
+Lemma neg_is_neg p : Z.neg p < 0.
+Proof. reflexivity. Qed.
+
+Lemma neg_is_nonpos p : Z.neg p <= 0.
+Proof. easy. Qed.
+
+Lemma neg_xO p : Z.neg p~0 = 2 * Z.neg p.
+Proof. reflexivity. Qed.
+
+Lemma neg_xI p : Z.neg p~1 = 2 * Z.neg p - 1.
+Proof. reflexivity. Qed.
+
+Lemma opp_neg p : - Z.neg p = Z.pos p.
+Proof. reflexivity. Qed.
+
+Lemma opp_pos p : - Z.pos p = Z.neg p.
+Proof. reflexivity. Qed.
+
+Lemma add_neg_neg p q : Z.neg p + Z.neg q = Z.neg (p+q).
+Proof. reflexivity. Qed.
+
+Lemma add_pos_neg p q : Z.pos p + Z.neg q = Z.pos_sub p q.
+Proof. reflexivity. Qed.
+
+Lemma add_neg_pos p q : Z.neg p + Z.pos q = Z.pos_sub q p.
+Proof. reflexivity. Qed.
+
+Lemma divide_pos_neg_r n p : (n|Z.pos p) <-> (n|Z.neg p).
+Proof. apply Z.Private_BootStrap.divide_Zpos_Zneg_r. Qed.
+
+Lemma divide_pos_neg_l n p : (Z.pos p|n) <-> (Z.neg p|n).
+Proof. apply Z.Private_BootStrap.divide_Zpos_Zneg_l. Qed.
+
+Lemma testbit_neg a n : 0<=n ->
+ Z.testbit (Z.neg a) n = negb (N.testbit (Pos.pred_N a) (Z.to_N n)).
+Proof. apply Z.Private_BootStrap.testbit_Zneg. Qed.
+
+End Pos2Z.
+
+Module Z2Pos.
+
+Lemma id x : 0 < x -> Z.pos (Z.to_pos x) = x.
+Proof. now destruct x. Qed.
+
+Lemma inj x y : 0 < x -> 0 < y -> Z.to_pos x = Z.to_pos y -> x = y.
+Proof.
+ destruct x; simpl; try easy. intros _ H ->. now apply id.
+Qed.
+
+Lemma inj_iff x y : 0 < x -> 0 < y -> (Z.to_pos x = Z.to_pos y <-> x = y).
+Proof. split. now apply inj. intros; now f_equal. Qed.
+
+Lemma to_pos_nonpos x : x <= 0 -> Z.to_pos x = 1%positive.
+Proof. destruct x; trivial. now destruct 1. Qed.
+
+Lemma inj_1 : Z.to_pos 1 = 1%positive.
+Proof. reflexivity. Qed.
+
+Lemma inj_double x : 0 < x ->
+ Z.to_pos (Z.double x) = (Z.to_pos x)~0%positive.
+Proof. now destruct x. Qed.
+
+Lemma inj_succ_double x : 0 < x ->
+ Z.to_pos (Z.succ_double x) = (Z.to_pos x)~1%positive.
+Proof. now destruct x. Qed.
+
+Lemma inj_succ x : 0 < x -> Z.to_pos (Z.succ x) = Pos.succ (Z.to_pos x).
+Proof.
+ destruct x; try easy. simpl. now rewrite Pos.add_1_r.
+Qed.
+
+Lemma inj_add x y : 0 < x -> 0 < y ->
+ Z.to_pos (x+y) = (Z.to_pos x + Z.to_pos y)%positive.
+Proof. destruct x; easy || now destruct y. Qed.
+
+Lemma inj_sub x y : 0 < x < y ->
+ Z.to_pos (y-x) = (Z.to_pos y - Z.to_pos x)%positive.
+Proof.
+ destruct x; try easy. destruct y; try easy. simpl.
+ intros. now rewrite Z.pos_sub_gt.
+Qed.
+
+Lemma inj_pred x : 1 < x -> Z.to_pos (Z.pred x) = Pos.pred (Z.to_pos x).
+Proof. now destruct x as [|[x|x|]|]. Qed.
+
+Lemma inj_mul x y : 0 < x -> 0 < y ->
+ Z.to_pos (x*y) = (Z.to_pos x * Z.to_pos y)%positive.
+Proof. destruct x; easy || now destruct y. Qed.
+
+Lemma inj_pow x y : 0 < x -> 0 < y ->
+ Z.to_pos (x^y) = (Z.to_pos x ^ Z.to_pos y)%positive.
+Proof.
+ intros. apply Pos2Z.inj. rewrite Pos2Z.inj_pow, !id; trivial.
+ apply Z.pow_pos_nonneg. trivial. now apply Z.lt_le_incl.
+Qed.
+
+Lemma inj_pow_pos x p : 0 < x ->
+ Z.to_pos (Z.pow_pos x p) = ((Z.to_pos x)^p)%positive.
+Proof. intros. now apply (inj_pow x (Z.pos p)). Qed.
+
+Lemma inj_compare x y : 0 < x -> 0 < y ->
+ (x ?= y) = (Z.to_pos x ?= Z.to_pos y)%positive.
+Proof. destruct x; easy || now destruct y. Qed.
+
+Lemma inj_leb x y : 0 < x -> 0 < y ->
+ (x <=? y) = (Z.to_pos x <=? Z.to_pos y)%positive.
+Proof. destruct x; easy || now destruct y. Qed.
+
+Lemma inj_ltb x y : 0 < x -> 0 < y ->
+ (x <? y) = (Z.to_pos x <? Z.to_pos y)%positive.
+Proof. destruct x; easy || now destruct y. Qed.
+
+Lemma inj_eqb x y : 0 < x -> 0 < y ->
+ (x =? y) = (Z.to_pos x =? Z.to_pos y)%positive.
+Proof. destruct x; easy || now destruct y. Qed.
+
+Lemma inj_max x y :
+ Z.to_pos (Z.max x y) = Pos.max (Z.to_pos x) (Z.to_pos y).
+Proof.
+ destruct x; simpl; try rewrite Pos.max_1_l.
+ - now destruct y.
+ - destruct y; simpl; now rewrite ?Pos.max_1_r, <- ?Pos2Z.inj_max.
+ - destruct y; simpl; rewrite ?Pos.max_1_r; trivial.
+   apply to_pos_nonpos. now apply Z.max_lub.
+Qed.
+
+Lemma inj_min x y :
+ Z.to_pos (Z.min x y) = Pos.min (Z.to_pos x) (Z.to_pos y).
+Proof.
+ destruct x; simpl; try rewrite Pos.min_1_l.
+ - now destruct y.
+ - destruct y; simpl; now rewrite ?Pos.min_1_r, <- ?Pos2Z.inj_min.
+ - destruct y; simpl; rewrite ?Pos.min_1_r; trivial.
+   apply to_pos_nonpos. apply Z.min_le_iff. now left.
+Qed.
+
+Lemma inj_sqrt x : Z.to_pos (Z.sqrt x) = Pos.sqrt (Z.to_pos x).
+Proof. now destruct x. Qed.
+
+Lemma inj_gcd x y : 0 < x -> 0 < y ->
+ Z.to_pos (Z.gcd x y) = Pos.gcd (Z.to_pos x) (Z.to_pos y).
+Proof. destruct x; easy || now destruct y. Qed.
+
+End Z2Pos.
+
+(** Compatibility Notations *)
+
+Notation Zdouble_plus_one := Z.succ_double (compat "8.3").
+Notation Zdouble_minus_one := Z.pred_double (compat "8.3").
+Notation Zdouble := Z.double (compat "8.3").
+Notation ZPminus := Z.pos_sub (compat "8.3").
+Notation Zsucc' := Z.succ (compat "8.3").
+Notation Zpred' := Z.pred (compat "8.3").
+Notation Zplus' := Z.add (compat "8.3").
+Notation Zplus := Z.add (compat "8.3"). (* Slightly incompatible *)
+Notation Zopp := Z.opp (compat "8.3").
+Notation Zsucc := Z.succ (compat "8.3").
+Notation Zpred := Z.pred (compat "8.3").
+Notation Zminus := Z.sub (compat "8.3").
+Notation Zmult := Z.mul (compat "8.3").
+Notation Zcompare := Z.compare (compat "8.3").
+Notation Zsgn := Z.sgn (compat "8.3").
+Notation Zle := Z.le (compat "8.3").
+Notation Zge := Z.ge (compat "8.3").
+Notation Zlt := Z.lt (compat "8.3").
+Notation Zgt := Z.gt (compat "8.3").
+Notation Zmax := Z.max (compat "8.3").
+Notation Zmin := Z.min (compat "8.3").
+Notation Zabs := Z.abs (compat "8.3").
+Notation Zabs_nat := Z.abs_nat (compat "8.3").
+Notation Zabs_N := Z.abs_N (compat "8.3").
+Notation Z_of_nat := Z.of_nat (compat "8.3").
+Notation Z_of_N := Z.of_N (compat "8.3").
+
+Notation Zind := Z.peano_ind (compat "8.3").
+Notation Zopp_0 := Z.opp_0 (compat "8.3").
+Notation Zopp_involutive := Z.opp_involutive (compat "8.3").
+Notation Zopp_inj := Z.opp_inj (compat "8.3").
+Notation Zplus_0_l := Z.add_0_l (compat "8.3").
+Notation Zplus_0_r := Z.add_0_r (compat "8.3").
+Notation Zplus_comm := Z.add_comm (compat "8.3").
+Notation Zopp_plus_distr := Z.opp_add_distr (compat "8.3").
+Notation Zopp_succ := Z.opp_succ (compat "8.3").
+Notation Zplus_opp_r := Z.add_opp_diag_r (compat "8.3").
+Notation Zplus_opp_l := Z.add_opp_diag_l (compat "8.3").
+Notation Zplus_assoc := Z.add_assoc (compat "8.3").
+Notation Zplus_permute := Z.add_shuffle3 (compat "8.3").
+Notation Zplus_reg_l := Z.add_reg_l (compat "8.3").
+Notation Zplus_succ_l := Z.add_succ_l (compat "8.3").
+Notation Zplus_succ_comm := Z.add_succ_comm (compat "8.3").
+Notation Zsucc_discr := Z.neq_succ_diag_r (compat "8.3").
+Notation Zsucc_inj := Z.succ_inj (compat "8.3").
+Notation Zsucc'_inj := Z.succ_inj (compat "8.3").
+Notation Zsucc'_pred' := Z.succ_pred (compat "8.3").
+Notation Zpred'_succ' := Z.pred_succ (compat "8.3").
+Notation Zpred'_inj := Z.pred_inj (compat "8.3").
+Notation Zsucc'_discr := Z.neq_succ_diag_r (compat "8.3").
+Notation Zminus_0_r := Z.sub_0_r (compat "8.3").
+Notation Zminus_diag := Z.sub_diag (compat "8.3").
+Notation Zminus_plus_distr := Z.sub_add_distr (compat "8.3").
+Notation Zminus_succ_r := Z.sub_succ_r (compat "8.3").
+Notation Zminus_plus := Z.add_simpl_l (compat "8.3").
+Notation Zmult_0_l := Z.mul_0_l (compat "8.3").
+Notation Zmult_0_r := Z.mul_0_r (compat "8.3").
+Notation Zmult_1_l := Z.mul_1_l (compat "8.3").
+Notation Zmult_1_r := Z.mul_1_r (compat "8.3").
+Notation Zmult_comm := Z.mul_comm (compat "8.3").
+Notation Zmult_assoc := Z.mul_assoc (compat "8.3").
+Notation Zmult_permute := Z.mul_shuffle3 (compat "8.3").
+Notation Zmult_1_inversion_l := Z.mul_eq_1 (compat "8.3").
+Notation Zdouble_mult := Z.double_spec (compat "8.3").
+Notation Zdouble_plus_one_mult := Z.succ_double_spec (compat "8.3").
+Notation Zopp_mult_distr_l_reverse := Z.mul_opp_l (compat "8.3").
+Notation Zmult_opp_opp := Z.mul_opp_opp (compat "8.3").
+Notation Zmult_opp_comm := Z.mul_opp_comm (compat "8.3").
+Notation Zopp_eq_mult_neg_1 := Z.opp_eq_mul_m1 (compat "8.3").
+Notation Zmult_plus_distr_r := Z.mul_add_distr_l (compat "8.3").
+Notation Zmult_plus_distr_l := Z.mul_add_distr_r (compat "8.3").
+Notation Zmult_minus_distr_r := Z.mul_sub_distr_r (compat "8.3").
+Notation Zmult_reg_l := Z.mul_reg_l (compat "8.3").
+Notation Zmult_reg_r := Z.mul_reg_r (compat "8.3").
+Notation Zmult_succ_l := Z.mul_succ_l (compat "8.3").
+Notation Zmult_succ_r := Z.mul_succ_r (compat "8.3").
+
+Notation Zpos_xI := Pos2Z.inj_xI (compat "8.3").
+Notation Zpos_xO := Pos2Z.inj_xO (compat "8.3").
+Notation Zneg_xI := Pos2Z.neg_xI (compat "8.3").
+Notation Zneg_xO := Pos2Z.neg_xO (compat "8.3").
+Notation Zopp_neg := Pos2Z.opp_neg (compat "8.3").
+Notation Zpos_succ_morphism := Pos2Z.inj_succ (compat "8.3").
+Notation Zpos_mult_morphism := Pos2Z.inj_mul (compat "8.3").
+Notation Zpos_minus_morphism := Pos2Z.inj_sub (compat "8.3").
+Notation Zpos_eq_rev := Pos2Z.inj (compat "8.3").
+Notation Zpos_plus_distr := Pos2Z.inj_add (compat "8.3").
+Notation Zneg_plus_distr := Pos2Z.add_neg_neg (compat "8.3").
+
+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 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 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 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 * Z.succ m.
+Proof (SYM2 Z.mul_succ_r).
+Lemma Zmult_succ_l_reverse : forall n m, n * m + m = Z.succ n * m.
+Proof (SYM2 Z.mul_succ_l).
+Lemma Zpos_eq : forall p q, p = q -> Z.pos p = Z.pos q.
+Proof. congruence. Qed.
+Lemma Zpos_eq_iff : forall p q, p = q <-> Z.pos p = Z.pos q.
+Proof (fun p q => iff_sym (Pos2Z.inj_iff p q)).
+
+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..958ce2ef
--- /dev/null
+++ b/theories/ZArith/BinIntDef.v
@@ -0,0 +1,619 @@
+(* -*- coding: utf-8 -*- *)
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+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.
+
+(** ** Nicer names [Z.pos] and [Z.neg] for contructors *)
+
+Notation pos := Zpos.
+Notation neg := Zneg.
+
+(** ** Constants *)
+
+Definition zero := 0.
+Definition one := 1.
+Definition two := 2.
+
+(** ** Doubling and variants *)
+
+Definition double x :=
+  match x with
+    | 0 => 0
+    | pos p => pos p~0
+    | neg p => neg p~0
+  end.
+
+Definition succ_double x :=
+  match x with
+    | 0 => 1
+    | pos p => pos p~1
+    | neg p => neg (Pos.pred_double p)
+  end.
+
+Definition pred_double x :=
+  match x with
+    | 0 => -1
+    | neg p => neg p~1
+    | pos p => pos (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 => pos p~0
+    | p~0, q~1 => pred_double (pos_sub p q)
+    | p~0, q~0 => double (pos_sub p q)
+    | p~0, 1 => pos (Pos.pred_double p)
+    | 1, q~1 => neg q~0
+    | 1, q~0 => neg (Pos.pred_double q)
+    | 1, 1 => Z0
+  end%positive.
+
+(** ** Addition *)
+
+Definition add x y :=
+  match x, y with
+    | 0, y => y
+    | x, 0 => x
+    | pos x', pos y' => pos (x' + y')
+    | pos x', neg y' => pos_sub x' y'
+    | neg x', pos y' => pos_sub y' x'
+    | neg x', neg y' => neg (x' + y')
+  end.
+
+Infix "+" := add : Z_scope.
+
+(** ** Opposite *)
+
+Definition opp x :=
+  match x with
+    | 0 => 0
+    | pos x => neg x
+    | neg x => pos 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
+    | pos x', pos y' => pos (x' * y')
+    | pos x', neg y' => neg (x' * y')
+    | neg x', pos y' => neg (x' * y')
+    | neg x', neg y' => pos (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
+    | pos p => pow_pos x p
+    | 0 => 1
+    | neg _ => 0
+  end.
+
+Infix "^" := pow : Z_scope.
+
+(** ** Square *)
+
+Definition square x :=
+  match x with
+    | 0 => 0
+    | pos p => pos (Pos.square p)
+    | neg p => pos (Pos.square p)
+  end.
+
+(** ** Comparison *)
+
+Definition compare x y :=
+  match x, y with
+    | 0, 0 => Eq
+    | 0, pos y' => Lt
+    | 0, neg y' => Gt
+    | pos x', 0 => Gt
+    | pos x', pos y' => (x' ?= y')%positive
+    | pos x', neg y' => Gt
+    | neg x', 0 => Lt
+    | neg x', pos y' => Lt
+    | neg x', neg 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
+    | pos p => 1
+    | neg 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 will 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.
+
+Fixpoint eqb x y :=
+  match x, y with
+    | 0, 0 => true
+    | pos p, pos q => Pos.eqb p q
+    | neg p, neg 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
+    | pos p => pos p
+    | neg p => pos p
+  end.
+
+(** ** Conversions *)
+
+(** From [Z] to [nat] via absolute value *)
+
+Definition abs_nat (z:Z) : nat :=
+  match z with
+    | 0 => 0%nat
+    | pos p => Pos.to_nat p
+    | neg p => Pos.to_nat p
+  end.
+
+(** From [Z] to [N] via absolute value *)
+
+Definition abs_N (z:Z) : N :=
+  match z with
+    | 0 => 0%N
+    | pos p => N.pos p
+    | neg p => N.pos p
+  end.
+
+(** From [Z] to [nat] by rounding negative numbers to 0 *)
+
+Definition to_nat (z:Z) : nat :=
+  match z with
+    | pos 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
+    | pos p => N.pos p
+    | _ => 0%N
+  end.
+
+(** From [nat] to [Z] *)
+
+Definition of_nat (n:nat) : Z :=
+  match n with
+   | O => 0
+   | S n => pos (Pos.of_succ_nat n)
+  end.
+
+(** From [N] to [Z] *)
+
+Definition of_N (n:N) : Z :=
+  match n with
+    | 0%N => 0
+    | N.pos p => pos p
+  end.
+
+(** From [Z] to [positive] by rounding nonpositive numbers to 1 *)
+
+Definition to_pos (z:Z) : positive :=
+  match z with
+    | pos p => p
+    | _ => 1%positive
+  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
+    | pos 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)
+    | pos a', pos _ => pos_div_eucl a' b
+    | neg a', pos _ =>
+      let (q, r) := pos_div_eucl a' b in
+	match r with
+	  | 0 => (- q, 0)
+	  | _ => (- (q + 1), b - r)
+	end
+    | neg a', neg b' =>
+      let (q, r) := pos_div_eucl a' (pos b') in (q, - r)
+    | pos a', neg b' =>
+      let (q, r) := pos_div_eucl a' (pos 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)
+   | pos a, pos b =>
+     let (q, r) := N.pos_div_eucl a (N.pos b) in (of_N q, of_N r)
+   | neg a, pos b =>
+     let (q, r) := N.pos_div_eucl a (N.pos b) in (-of_N q, - of_N r)
+   | pos a, neg b =>
+     let (q, r) := N.pos_div_eucl a (N.pos b) in (-of_N q, of_N r)
+   | neg a, neg b =>
+     let (q, r) := N.pos_div_eucl a (N.pos 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
+    | pos (xO _) => true
+    | neg (xO _) => true
+    | _ => false
+  end.
+
+Definition odd z :=
+  match z with
+    | 0 => false
+    | pos (xO _) => false
+    | neg (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
+   | pos 1 => 0
+   | pos p => pos (Pos.div2 p)
+   | neg p => neg (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
+    | pos 1 => 0
+    | pos p => pos (Pos.div2 p)
+    | neg 1 => 0
+    | neg p => neg (Pos.div2 p)
+  end.
+
+(** NB: [Z.quot2] used to be named [Z.div2] in Coq <= 8.3 *)
+
+
+(** * Base-2 logarithm *)
+
+Definition log2 z :=
+  match z with
+    | pos (p~1) => pos (Pos.size p)
+    | pos (p~0) => pos (Pos.size p)
+    | _ => 0
+  end.
+
+
+(** ** Square root *)
+
+Definition sqrtrem n :=
+ match n with
+  | 0 => (0, 0)
+  | pos p =>
+    match Pos.sqrtrem p with
+     | (s, IsPos r) => (pos s, pos r)
+     | (s, _) => (pos s, 0)
+    end
+  | neg _ => (0,0)
+ end.
+
+Definition sqrt n :=
+ match n with
+  | pos p => pos (Pos.sqrt p)
+  | _ => 0
+ end.
+
+
+(** ** Greatest Common Divisor *)
+
+Definition gcd a b :=
+  match a,b with
+    | 0, _ => abs b
+    | _, 0 => abs a
+    | pos a, pos b => pos (Pos.gcd a b)
+    | pos a, neg b => pos (Pos.gcd a b)
+    | neg a, pos b => pos (Pos.gcd a b)
+    | neg a, neg b => pos (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))
+    | pos a, pos b =>
+       let '(g,(aa,bb)) := Pos.ggcd a b in (pos g, (pos aa, pos bb))
+    | pos a, neg b =>
+       let '(g,(aa,bb)) := Pos.ggcd a b in (pos g, (pos aa, neg bb))
+    | neg a, pos b =>
+       let '(g,(aa,bb)) := Pos.ggcd a b in (pos g, (neg aa, pos bb))
+    | neg a, neg b =>
+       let '(g,(aa,bb)) := Pos.ggcd a b in (pos g, (neg aa, neg 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
+   | pos p =>
+     match a with
+       | 0 => false
+       | pos a => Pos.testbit a (N.pos p)
+       | neg a => negb (N.testbit (Pos.pred_N a) (N.pos p))
+     end
+   | neg _ => 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
+   | pos p => Pos.iter p (mul 2) a
+   | neg 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
+   | pos a, pos b => pos (Pos.lor a b)
+   | neg a, pos b => neg (N.succ_pos (N.ldiff (Pos.pred_N a) (N.pos b)))
+   | pos a, neg b => neg (N.succ_pos (N.ldiff (Pos.pred_N b) (N.pos a)))
+   | neg a, neg b => neg (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
+   | pos a, pos b => of_N (Pos.land a b)
+   | neg a, pos b => of_N (N.ldiff (N.pos b) (Pos.pred_N a))
+   | pos a, neg b => of_N (N.ldiff (N.pos a) (Pos.pred_N b))
+   | neg a, neg b => neg (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
+   | pos a, pos b => of_N (Pos.ldiff a b)
+   | neg a, pos b => neg (N.succ_pos (N.lor (Pos.pred_N a) (N.pos b)))
+   | pos a, neg b => of_N (N.land (N.pos a) (Pos.pred_N b))
+   | neg a, neg 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
+   | pos a, pos b => of_N (Pos.lxor a b)
+   | neg a, pos b => neg (N.succ_pos (N.lxor (Pos.pred_N a) (N.pos b)))
+   | pos a, neg b => neg (N.succ_pos (N.lxor (N.pos a) (Pos.pred_N b)))
+   | neg a, neg 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..99ecd150 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].
@@ -18,28 +16,26 @@
 
 Require Import ZArith.
 Delimit Scope Int_scope with I.
-
+Local Open Scope Int_scope.
 
 (** * a specification of integers *)
 
 Module Type Int.
 
-  Open Scope Int_scope.
-
-  Parameter int : Set.
+  Parameter t : Set.
+  Bind Scope Int_scope with t.
 
-  Parameter i2z : int -> Z.
-  Arguments Scope i2z [ Int_scope ].
+  Parameter i2z : t -> Z.
 
-  Parameter _0 : int.
-  Parameter _1 : int.
-  Parameter _2 : int.
-  Parameter _3 : int.
-  Parameter plus : int -> int -> int.
-  Parameter opp : int -> int.
-  Parameter minus : int -> int -> int.
-  Parameter mult : int -> int -> int.
-  Parameter max : int -> int -> int.
+  Parameter _0 : t.
+  Parameter _1 : t.
+  Parameter _2 : t.
+  Parameter _3 : t.
+  Parameter plus : t -> t -> t.
+  Parameter opp : t -> t.
+  Parameter minus : t -> t -> t.
+  Parameter mult : t -> t -> t.
+  Parameter max : t -> t -> t.
 
   Notation "0" := _0 : Int_scope.
   Notation "1" := _1 : Int_scope.
@@ -56,10 +52,10 @@ Module Type Int.
 
   Notation "x == y" := (i2z x = i2z y)
     (at level 70, y at next level, no associativity) : Int_scope.
-  Notation "x <= y" := (Zle (i2z x) (i2z y)): Int_scope.
-  Notation "x < y" := (Zlt (i2z x) (i2z y)) : Int_scope.
-  Notation "x >= y" := (Zge (i2z x) (i2z y)) : Int_scope.
-  Notation "x > y" := (Zgt (i2z x) (i2z y)): Int_scope.
+  Notation "x <= y" := (i2z x <= i2z y)%Z : Int_scope.
+  Notation "x < y" := (i2z x < i2z y)%Z : Int_scope.
+  Notation "x >= y" := (i2z x >= i2z y)%Z : Int_scope.
+  Notation "x > y" := (i2z x > i2z y)%Z : Int_scope.
   Notation "x <= y <= z" := (x <= y /\ y <= z) : Int_scope.
   Notation "x <= y < z" := (x <= y /\ y < z) : Int_scope.
   Notation "x < y < z" := (x < y /\ y < z) : Int_scope.
@@ -67,41 +63,39 @@ Module Type Int.
 
   (** Some decidability fonctions (informative). *)
 
-  Axiom gt_le_dec : forall x y: int, {x > y} + {x <= y}.
-  Axiom ge_lt_dec :  forall x y : int, {x >= y} + {x < y}.
-  Axiom eq_dec : forall x y : int, { x == y } + {~ x==y }.
+  Axiom gt_le_dec : forall x y : t, {x > y} + {x <= y}.
+  Axiom ge_lt_dec :  forall x y : t, {x >= y} + {x < y}.
+  Axiom eq_dec : forall x y : t, { x == y } + {~ x==y }.
 
   (** Specifications *)
 
   (** First, we ask [i2z] to be injective. Said otherwise, our ad-hoc equality
       [==] and the generic [=] are in fact equivalent. We define [==]
-      nonetheless since the translation to [Z] for using automatic tactic is easier. *)
+      nonetheless since the translation to [Z] for using automatic tactic
+      is easier. *)
 
-  Axiom i2z_eq : forall n p : int, n == p -> n = p.
+  Axiom i2z_eq : forall n p : t, n == p -> n = p.
 
    (** Then, we express the specifications of the above parameters using their
        Z counterparts. *)
 
-  Open Scope Z_scope.
-  Axiom i2z_0 : i2z _0 = 0.
-  Axiom i2z_1 : i2z _1 = 1.
-  Axiom i2z_2 : i2z _2 = 2.
-  Axiom i2z_3 : i2z _3 = 3.
-  Axiom i2z_plus : forall n p, i2z (n + p) = i2z n + i2z p.
-  Axiom i2z_opp : forall n, i2z (-n) = -i2z n.
-  Axiom i2z_minus : forall n p, i2z (n - p) = i2z n - i2z p.
-  Axiom i2z_mult : forall n p, i2z (n * p) = i2z n * i2z p.
-  Axiom i2z_max : forall n p, i2z (max n p) = Zmax (i2z n) (i2z p).
+  Axiom i2z_0 : i2z _0 = 0%Z.
+  Axiom i2z_1 : i2z _1 = 1%Z.
+  Axiom i2z_2 : i2z _2 = 2%Z.
+  Axiom i2z_3 : i2z _3 = 3%Z.
+  Axiom i2z_plus : forall n p, i2z (n + p) = (i2z n + i2z p)%Z.
+  Axiom i2z_opp : forall n, i2z (-n) = (-i2z n)%Z.
+  Axiom i2z_minus : forall n p, i2z (n - p) = (i2z n - i2z p)%Z.
+  Axiom i2z_mult : forall n p, i2z (n * p) = (i2z n * i2z p)%Z.
+  Axiom i2z_max : forall n p, i2z (max n p) = Z.max (i2z n) (i2z p).
 
 End Int.
 
 
 (** * Facts and  tactics using [Int] *)
 
-Module MoreInt (I:Int).
-  Import I.
-
-  Open Scope Int_scope.
+Module MoreInt (Import I:Int).
+  Local Notation int := I.t.
 
   (** A magic (but costly) tactic that goes from [int] back to the [Z]
       friendly world ... *)
@@ -110,13 +104,14 @@ Module MoreInt (I:Int).
     i2z_0 i2z_1 i2z_2 i2z_3 i2z_plus i2z_opp i2z_minus i2z_mult i2z_max : i2z.
 
   Ltac i2z := match goal with
-		| H : (eq (A:=int) ?a ?b) |- _ =>
-		  generalize (f_equal i2z H);
-		    try autorewrite with i2z; clear H; intro H; i2z
-		| |- (eq (A:=int) ?a ?b) => apply (i2z_eq a b); try autorewrite with i2z; i2z
-		| H : _ |- _ => progress autorewrite with i2z in H; i2z
-		| _ => try autorewrite with i2z
-	      end.
+    | H : ?a = ?b |- _ =>
+      generalize (f_equal i2z H);
+	try autorewrite with i2z; clear H; intro H; i2z
+    | |- ?a = ?b =>
+      apply (i2z_eq a b); try autorewrite with i2z; i2z
+    | H : _ |- _ => progress autorewrite with i2z in H; i2z
+    | _ => try autorewrite with i2z
+  end.
 
   (** A reflexive version of the [i2z] tactic *)
 
@@ -126,14 +121,14 @@ Module MoreInt (I:Int).
       Anyhow, [i2z_refl] is enough for applying [romega]. *)
 
   Ltac i2z_gen := match goal with
-    | |- (eq (A:=int) ?a ?b) => apply (i2z_eq a b); i2z_gen
-    | H : (eq (A:=int) ?a ?b) |- _ =>
+    | |- ?a = ?b => apply (i2z_eq a b); i2z_gen
+    | H : ?a = ?b |- _ =>
        generalize (f_equal i2z H); clear H; i2z_gen
-    | H : (eq (A:=Z) ?a ?b) |- _ => revert H; i2z_gen
-    | H : (Zlt ?a ?b) |- _ => revert H; i2z_gen
-    | H : (Zle ?a ?b) |- _ => revert H; i2z_gen
-    | H : (Zgt ?a ?b) |- _ => revert H; i2z_gen
-    | H : (Zge ?a ?b) |- _ => revert H; i2z_gen
+    | H : eq (A:=Z) ?a ?b |- _ => revert H; i2z_gen
+    | H : Z.lt ?a ?b |- _ => revert H; i2z_gen
+    | H : Z.le ?a ?b |- _ => revert H; i2z_gen
+    | H : Z.gt ?a ?b |- _ => revert H; i2z_gen
+    | H : Z.ge ?a ?b |- _ => revert H; i2z_gen
     | H : _ -> ?X |- _ =>
       (* A [Set] or [Type] part cannot be dealt with easily
          using the [ExprP] datatype. So we forget it, leaving
@@ -203,11 +198,11 @@ Module MoreInt (I:Int).
 
     with z2ez trm :=
     match constr:trm with
-      | (?x+?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZplus ex ey)
-      | (?x-?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZminus ex ey)
-      | (?x*?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZmult ex ey)
-      | (Zmax ?x ?y) => let ex := z2ez x with ey := z2ez y in constr:(EZmax ex ey)
-      | (-?x)%Z =>  let ex := z2ez x in constr:(EZopp ex)
+      | (?x + ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZplus ex ey)
+      | (?x - ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZminus ex ey)
+      | (?x * ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZmult ex ey)
+      | (Z.max ?x ?y) => let ex := z2ez x with ey := z2ez y in constr:(EZmax ex ey)
+      | (- ?x)%Z =>  let ex := z2ez x in constr:(EZopp ex)
       | i2z ?x => let ex := i2ei x in constr:(EZofI ex)
       | ?x => constr:(EZraw x)
     end.
@@ -222,10 +217,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.
 
@@ -252,7 +247,7 @@ Module MoreInt (I:Int).
       | EZplus e1 e2 => ((ez2z e1)+(ez2z e2))%Z
       | EZminus e1 e2 => ((ez2z e1)-(ez2z e2))%Z
       | EZmult e1 e2 => ((ez2z e1)*(ez2z e2))%Z
-      | EZmax e1 e2 => Zmax (ez2z e1) (ez2z e2)
+      | EZmax e1 e2 => Z.max (ez2z e1) (ez2z e2)
       | EZopp e => (-(ez2z e))%Z
       | EZofI e => i2z (ei2i e)
       | EZraw z => z
@@ -362,30 +357,29 @@ End MoreInt.
 (** It's always nice to know that our [Int] interface is realizable :-) *)
 
 Module Z_as_Int <: Int.
-  Open Scope Z_scope.
-  Definition int := Z.
+  Local Open Scope Z_scope.
+  Definition t := Z.
   Definition _0 := 0.
   Definition _1 := 1.
   Definition _2 := 2.
   Definition _3 := 3.
-  Definition plus := Zplus.
-  Definition opp := Zopp.
-  Definition minus := Zminus.
-  Definition mult := Zmult.
-  Definition max := Zmax.
+  Definition plus := Z.add.
+  Definition opp := Z.opp.
+  Definition minus := Z.sub.
+  Definition mult := Z.mul.
+  Definition max := Z.max.
   Definition gt_le_dec := Z_gt_le_dec.
   Definition ge_lt_dec := Z_ge_lt_dec.
-  Definition eq_dec := Z_eq_dec.
-  Definition i2z : int -> Z := fun n => n.
+  Definition eq_dec := Z.eq_dec.
+  Definition i2z : t -> Z := fun n => n.
   Lemma i2z_eq : forall n p, i2z n=i2z p -> n = p. Proof. auto. Qed.
   Lemma i2z_0 : i2z _0 = 0.  Proof. auto. Qed.
   Lemma i2z_1 : i2z _1 = 1.  Proof. auto. Qed.
   Lemma i2z_2 : i2z _2 = 2.  Proof. auto. Qed.
   Lemma i2z_3 : i2z _3 = 3.  Proof. auto. Qed.
-  Lemma i2z_plus : forall n p, i2z (n + p) = i2z n + i2z p.  Proof. auto. Qed.
-  Lemma i2z_opp : forall n, i2z (- n)  = - i2z n.  Proof. auto. Qed.
-  Lemma i2z_minus : forall n p, i2z (n - p)  = i2z n - i2z p.  Proof. auto. Qed.
-  Lemma i2z_mult : forall n p, i2z (n * p)  = i2z n * i2z p.  Proof. auto. Qed.
-  Lemma i2z_max : forall n p, i2z (max n p) = Zmax (i2z n) (i2z p). Proof. auto. Qed.
+  Lemma i2z_plus n p : i2z (n + p) = i2z n + i2z p.  Proof. auto. Qed.
+  Lemma i2z_opp n : i2z (- n) = - i2z n.  Proof. auto. Qed.
+  Lemma i2z_minus n p : i2z (n - p) = i2z n - i2z p.  Proof. auto. Qed.
+  Lemma i2z_mult n p : i2z (n * p) = i2z n * i2z p.  Proof. auto. Qed.
+  Lemma i2z_max n p : i2z (max n p) = Z.max (i2z n) (i2z p). Proof. auto. Qed.
 End Z_as_Int.
-
diff --git a/theories/ZArith/Wf_Z.v b/theories/ZArith/Wf_Z.v
index 0fe6d623..3935e124 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-2012     *)
 (*   \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.
+   (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,76 +89,62 @@ 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]. *)
+  (** A more general induction principle on non-negative numbers using [Z.lt]. *)
 
   Lemma Zlt_0_rec :
     forall P:Z -> Type,
       (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 :
@@ -209,7 +155,7 @@ Section Efficient_Rec.
     exact Zlt_0_rec.
   Qed.
 
-  (** Obsolete version of [Zlt] induction principle on non-negative numbers *)
+  (** Obsolete version of [Z.lt] induction principle on non-negative numbers *)
 
   Lemma Z_lt_rec :
     forall P:Z -> Type,
@@ -227,29 +173,22 @@ Section Efficient_Rec.
     exact Z_lt_rec.
   Qed.
 
-  (** An even more general induction principle using [Zlt]. *)
+  (** An even more general induction principle using [Z.lt]. *)
 
   Lemma Zlt_lower_bound_rec :
     forall P:Z -> Type, forall z:Z,
       (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..033dc11f 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-2012     *)
 (*   \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..38b6c44d 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-2012     *)
 (*   \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..ff4f5e7b 100644
--- a/theories/ZArith/ZArith_dec.v
+++ b/theories/ZArith/ZArith_dec.v
@@ -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-2012     *)
 (*   \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.
 Require Import Zorder.
 Require Import Zcompare.
-Open Local Scope Z_scope.
+Local Open Scope Z_scope.
 
 (* begin hide *)
 (* Trivial, to deprecate? *)
@@ -23,68 +21,43 @@ Proof.
 Defined.
 (* end hide *)
 
-Lemma Zcompare_rect :
-  forall (P:Type) (n m:Z),
-    ((n ?= m) = Eq -> P) -> ((n ?= m) = Lt -> P) -> ((n ?= m) = Gt -> P) -> P.
+Lemma Zcompare_rect (P:Type) (n m:Z) :
+  ((n ?= m) = Eq -> P) -> ((n ?= m) = Lt -> P) -> ((n ?= m) = Gt -> P) -> P.
 Proof.
-  intros * H1 H2 H3.
+  intros H1 H2 H3.
   destruct (n ?= m); auto.
 Defined.
 
-Lemma Zcompare_rec :
-  forall (P:Set) (n m:Z),
-    ((n ?= m) = Eq -> P) -> ((n ?= m) = Lt -> P) -> ((n ?= m) = Gt -> P) -> P.
-Proof.
-  intro; apply Zcompare_rect.
-Defined.
+Lemma Zcompare_rec (P:Set) (n m:Z) :
+  ((n ?= m) = Eq -> P) -> ((n ?= m) = Lt -> P) -> ((n ?= m) = Gt -> P) -> P.
+Proof. apply Zcompare_rect. Defined.
+
+Notation Z_eq_dec := Z.eq_dec (compat "8.3").
 
 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}.
   Proof.
-    unfold Zlt in |- *.
-    apply Zcompare_rec with (n := x) (m := y); intro H.
-    right. rewrite H. discriminate.
-    left; assumption.
-    right. rewrite H. discriminate.
+    unfold Z.lt; case Z.compare; (now left) || (now right).
   Defined.
 
   Definition Z_le_dec : {x <= y} + {~ x <= y}.
   Proof.
-    unfold Zle in |- *.
-    apply Zcompare_rec with (n := x) (m := y); intro H.
-    left. rewrite H. discriminate.
-    left. rewrite H. discriminate.
-    right. tauto.
+    unfold Z.le; case Z.compare; (now left) || (right; tauto).
   Defined.
 
   Definition Z_gt_dec : {x > y} + {~ x > y}.
   Proof.
-    unfold Zgt in |- *.
-    apply Zcompare_rec with (n := x) (m := y); intro H.
-    right. rewrite H. discriminate.
-    right. rewrite H. discriminate.
-    left; assumption.
+    unfold Z.gt; case Z.compare; (now left) || (now right).
   Defined.
 
   Definition Z_ge_dec : {x >= y} + {~ x >= y}.
   Proof.
-    unfold Zge in |- *.
-    apply Zcompare_rec with (n := x) (m := y); intro H.
-    left. rewrite H. discriminate.
-    right. tauto.
-    left. rewrite H. discriminate.
+    unfold Z.ge; case Z.compare; (now left) || (right; tauto).
   Defined.
 
   Definition Z_lt_ge_dec : {x < y} + {x >= y}.
@@ -94,16 +67,15 @@ Section decidability.
 
   Lemma Z_lt_le_dec : {x < y} + {y <= x}.
   Proof.
-    intros.
     elim Z_lt_ge_dec.
-    intros; left; assumption.
-    intros; right; apply Zge_le; assumption.
+    * now left.
+    * right; now apply Z.ge_le.
   Defined.
 
   Definition Z_le_gt_dec : {x <= y} + {x > y}.
   Proof.
     elim Z_le_dec; auto with arith.
-    intro. right. apply Znot_le_gt; auto with arith.
+    intro. right. Z.swap_greater. now apply Z.nle_gt.
   Defined.
 
   Definition Z_gt_le_dec : {x > y} + {x <= y}.
@@ -114,15 +86,15 @@ Section decidability.
   Definition Z_ge_lt_dec : {x >= y} + {x < y}.
   Proof.
     elim Z_ge_dec; auto with arith.
-    intro. right. apply Znot_ge_lt; auto with arith.
+    intro. right. Z.swap_greater. now apply Z.lt_nge.
   Defined.
 
   Definition Z_le_lt_eq_dec : x <= y -> {x < y} + {x = y}.
   Proof.
     intro H.
     apply Zcompare_rec with (n := x) (m := y).
-    intro. right. elim (Zcompare_Eq_iff_eq x y); auto with arith.
-    intro. left. elim (Zcompare_Eq_iff_eq x y); auto with arith.
+    intro. right. elim (Z.compare_eq_iff x y); auto with arith.
+    intro. left. elim (Z.compare_eq_iff x y); auto with arith.
     intro H1. absurd (x > y); auto with arith.
   Defined.
 
@@ -139,8 +111,8 @@ Proof.
   assumption.
   intro.
   right.
-  apply Zle_lt_trans with (m := x).
-  apply Zge_le.
+  apply Z.le_lt_trans with (m := x).
+  apply Z.ge_le.
   assumption.
   assumption.
 Defined.
@@ -149,20 +121,16 @@ Lemma Zlt_cotrans_pos : forall n m:Z, 0 < n + m -> {0 < n} + {0 < m}.
 Proof.
   intros x y H.
   case (Zlt_cotrans 0 (x + y) H x).
-  intro.
-  left.
-  assumption.
-  intro.
-  right.
-  apply Zplus_lt_reg_l with (p := x).
-  rewrite Zplus_0_r.
-  assumption.
+  - now left.
+  - right.
+    apply Z.add_lt_mono_l with (p := x).
+    now rewrite Z.add_0_r.
 Defined.
 
 Lemma Zlt_cotrans_neg : forall n m:Z, n + m < 0 -> {n < 0} + {m < 0}.
 Proof.
   intros x y H; case (Zlt_cotrans (x + y) 0 H x); intro Hxy;
-    [ right; apply Zplus_lt_reg_l with (p := x); rewrite Zplus_0_r | left ];
+    [ right; apply Z.add_lt_mono_l with (p := x); rewrite Z.add_0_r | left ];
     assumption.
 Defined.
 
@@ -174,7 +142,7 @@ Proof.
   left.
   assumption.
   intro H0.
-  generalize (Zge_le _ _ H0).
+  generalize (Z.ge_le _ _ H0).
   intro.
   case (Z_le_lt_eq_dec _ _ H1).
   intro.
@@ -183,7 +151,7 @@ Proof.
   intro.
   apply False_rec.
   apply H.
-  symmetry  in |- *.
+  symmetry .
   assumption.
 Defined.
 
@@ -196,17 +164,17 @@ Proof.
   left.
   assumption.
   intro H.
-  generalize (Zge_le _ _ H).
+  generalize (Z.ge_le _ _ H).
   intro H0.
   case (Z_le_lt_eq_dec y x H0).
   intro H1.
   left.
   right.
-  apply Zlt_gt.
+  apply Z.lt_gt.
   assumption.
   intro.
   right.
-  symmetry  in |- *.
+  symmetry .
   assumption.
 Defined.
 
@@ -214,7 +182,7 @@ Defined.
 Lemma Z_dec' : forall n m:Z, {n < m} + {m < n} + {n = m}.
 Proof.
   intros x y.
-  case (Z_eq_dec x y); intro H;
+  case (Z.eq_dec x y); intro H;
     [ right; assumption | left; apply (not_Zeq_inf _ _ H) ].
 Defined.
 
@@ -222,12 +190,12 @@ Defined.
 (* To deprecate ? *)
 Corollary Z_zerop : forall x:Z, {x = 0} + {x <> 0}.
 Proof.
-  exact (fun x:Z => Z_eq_dec x 0).
+  exact (fun x:Z => Z.eq_dec x 0).
 Defined.
 
 Corollary Z_notzerop : forall (x:Z), {x <> 0} + {x = 0}.
 Proof (fun x => sumbool_not _ _ (Z_zerop x)).
 
 Corollary Z_noteq_dec : forall (x y:Z), {x <> y} + {x = y}.
-Proof (fun x y => sumbool_not _ _ (Z_eq_dec x y)).
+Proof (fun x y => sumbool_not _ _ (Z.eq_dec x y)).
 (* end hide *)
diff --git a/theories/ZArith/ZOdiv.v b/theories/ZArith/ZOdiv.v
index 70f6866e..17c5bae3 100644
--- a/theories/ZArith/ZOdiv.v
+++ b/theories/ZArith/ZOdiv.v
@@ -1,947 +1,88 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-
-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.
+Require Import BinInt Zquot.
+
+Notation ZO_div_mod_eq := Z.quot_rem' (only parsing).
+Notation ZOmod_lt := Zrem_lt (only parsing).
+Notation ZOmod_sgn := Zrem_sgn (only parsing).
+Notation ZOmod_sgn2 := Zrem_sgn2 (only parsing).
+Notation ZOmod_lt_pos := Zrem_lt_pos (only parsing).
+Notation ZOmod_lt_neg := Zrem_lt_neg (only parsing).
+Notation ZOmod_lt_pos_pos := Zrem_lt_pos_pos (only parsing).
+Notation ZOmod_lt_pos_neg := Zrem_lt_pos_neg (only parsing).
+Notation ZOmod_lt_neg_pos := Zrem_lt_neg_pos (only parsing).
+Notation ZOmod_lt_neg_neg := Zrem_lt_neg_neg (only parsing).
+
+Notation ZOdiv_opp_l := Zquot_opp_l (only parsing).
+Notation ZOdiv_opp_r := Zquot_opp_r (only parsing).
+Notation ZOmod_opp_l := Zrem_opp_l (only parsing).
+Notation ZOmod_opp_r := Zrem_opp_r (only parsing).
+Notation ZOdiv_opp_opp := Zquot_opp_opp (only parsing).
+Notation ZOmod_opp_opp := Zrem_opp_opp (only parsing).
+
+Notation Remainder := Remainder (only parsing).
+Notation Remainder_alt := Remainder_alt (only parsing).
+Notation Remainder_equiv := Remainder_equiv (only parsing).
+Notation ZOdiv_mod_unique_full := Zquot_mod_unique_full (only parsing).
+Notation ZOdiv_unique_full := Zquot_unique_full (only parsing).
+Notation ZOdiv_unique := Zquot_unique (only parsing).
+Notation ZOmod_unique_full := Zrem_unique_full (only parsing).
+Notation ZOmod_unique := Zrem_unique (only parsing).
+
+Notation ZOmod_0_l := Zrem_0_l (only parsing).
+Notation ZOmod_0_r := Zrem_0_r (only parsing).
+Notation ZOdiv_0_l := Zquot_0_l (only parsing).
+Notation ZOdiv_0_r := Zquot_0_r (only parsing).
+Notation ZOmod_1_r := Zrem_1_r (only parsing).
+Notation ZOdiv_1_r := Zquot_1_r (only parsing).
+Notation ZOdiv_1_l := Zquot_1_l (only parsing).
+Notation ZOmod_1_l := Zrem_1_l (only parsing).
+Notation ZO_div_same := Z_quot_same (only parsing).
+Notation ZO_mod_same := Z_rem_same (only parsing).
+Notation ZO_mod_mult := Z_rem_mult (only parsing).
+Notation ZO_div_mult := Z_quot_mult (only parsing).
+
+Notation ZO_div_pos := Z_quot_pos (only parsing).
+Notation ZO_div_lt := Z_quot_lt (only parsing).
+Notation ZOdiv_small := Zquot_small (only parsing).
+Notation ZOmod_small := Zrem_small (only parsing).
+Notation ZO_div_monotone := Z_quot_monotone (only parsing).
+Notation ZO_mult_div_le := Z_mult_quot_le (only parsing).
+Notation ZO_mult_div_ge := Z_mult_quot_ge (only parsing).
+Definition ZO_div_exact_full_1 a b := proj1 (Z_quot_exact_full a b).
+Definition ZO_div_exact_full_2 a b := proj2 (Z_quot_exact_full a b).
+Notation ZOmod_le := Zrem_le (only parsing).
+Notation ZOdiv_le_upper_bound := Zquot_le_upper_bound (only parsing).
+Notation ZOdiv_lt_upper_bound := Zquot_lt_upper_bound (only parsing).
+Notation ZOdiv_le_lower_bound := Zquot_le_lower_bound (only parsing).
+Notation ZOdiv_sgn := Zquot_sgn (only parsing).
+
+Notation ZO_mod_plus := Z_rem_plus (only parsing).
+Notation ZO_div_plus := Z_quot_plus (only parsing).
+Notation ZO_div_plus_l := Z_quot_plus_l (only parsing).
+Notation ZOdiv_mult_cancel_r := Zquot_mult_cancel_r (only parsing).
+Notation ZOdiv_mult_cancel_l := Zquot_mult_cancel_l (only parsing).
+Notation ZOmult_mod_distr_l := Zmult_rem_distr_l (only parsing).
+Notation ZOmult_mod_distr_r := Zmult_rem_distr_r (only parsing).
+Notation ZOmod_mod := Zrem_rem (only parsing).
+Notation ZOmult_mod := Zmult_rem (only parsing).
+Notation ZOplus_mod := Zplus_rem (only parsing).
+Notation ZOplus_mod_idemp_l := Zplus_rem_idemp_l (only parsing).
+Notation ZOplus_mod_idemp_r := Zplus_rem_idemp_r (only parsing).
+Notation ZOmult_mod_idemp_l := Zmult_rem_idemp_l (only parsing).
+Notation ZOmult_mod_idemp_r := Zmult_rem_idemp_r (only parsing).
+Notation ZOdiv_ZOdiv := Zquot_Zquot (only parsing).
+Notation ZOdiv_mult_le := Zquot_mult_le (only parsing).
+Notation ZOmod_divides := Zrem_divides (only parsing).
+
+Notation ZOdiv_eucl_Zdiv_eucl_pos := Zquotrem_Zdiv_eucl_pos (only parsing).
+Notation ZOdiv_Zdiv_pos := Zquot_Zdiv_pos (only parsing).
+Notation ZOmod_Zmod_pos := Zrem_Zmod_pos (only parsing).
+Notation ZOmod_Zmod_zero := Zrem_Zmod_zero (only parsing).
diff --git a/theories/ZArith/ZOdiv_def.v b/theories/ZArith/ZOdiv_def.v
index 71d6cad4..38d25797 100644
--- a/theories/ZArith/ZOdiv_def.v
+++ b/theories/ZArith/ZOdiv_def.v
@@ -1,136 +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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+Require Import BinInt.
 
-Require Import BinPos BinNat Nnat ZArith_base.
+Notation ZOdiv_eucl := Z.quotrem (only parsing).
+Notation ZOdiv := Z.quot (only parsing).
+Notation ZOmod := Z.rem (only parsing).
 
-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.
+Notation ZOdiv_eucl_correct := Z.quotrem_eq.
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..08d1a931 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-2012     *)
 (*   \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 (compat "8.3").
+Notation Zabs_non_eq := Z.abs_neq (compat "8.3").
+Notation Zabs_Zopp := Z.abs_opp (compat "8.3").
+Notation Zabs_pos := Z.abs_nonneg (compat "8.3").
+Notation Zabs_involutive := Z.abs_involutive (compat "8.3").
+Notation Zabs_eq_case := Z.abs_eq_cases (compat "8.3").
+Notation Zabs_triangle := Z.abs_triangle (compat "8.3").
+Notation Zsgn_Zabs := Z.sgn_abs (compat "8.3").
+Notation Zabs_Zsgn := Z.abs_sgn (compat "8.3").
+Notation Zabs_Zmult := Z.abs_mul (compat "8.3").
+Notation Zabs_square := Z.abs_square (compat "8.3").
 
 (** * 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 (compat "8.3").
+Notation Zsgn_Zopp := Z.sgn_opp (compat "8.3").
+Notation Zsgn_pos := Z.sgn_pos_iff (compat "8.3").
+Notation Zsgn_neg := Z.sgn_neg_iff (compat "8.3").
+Notation Zsgn_null := Z.sgn_null_iff (compat "8.3").
 
 (** A characterization of the sign function: *)
 
-Lemma Zsgn_spec : forall x:Z,
-  0 < x /\ Zsgn x = 1 \/
-  0 = x /\ Zsgn x = 0 \/
-  0 > x /\ Zsgn x = -1.
+Lemma Zsgn_spec x :
+  0 < x /\ Z.sgn x = 1 \/
+  0 = x /\ Z.sgn x = 0 \/
+  0 > x /\ Z.sgn 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 (compat "8.3").
+Notation Zabs_nat_Z_of_nat := Zabs2Nat.id (compat "8.3").
+Notation Zabs_nat_mult := Zabs2Nat.inj_mul (compat "8.3").
+Notation Zabs_nat_Zsucc := Zabs2Nat.inj_succ (compat "8.3").
+Notation Zabs_nat_Zplus := Zabs2Nat.inj_add (compat "8.3").
+Notation Zabs_nat_Zminus := (fun n m => Zabs2Nat.inj_sub m n) (compat "8.3").
+Notation Zabs_nat_compare := Zabs2Nat.inj_compare (compat "8.3").
+
+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 -> (Z.abs_nat n < Z.abs_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..f20bc4bb 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-2012     *)
 (*   \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,8 +13,7 @@ Require Import Zcompare.
 Require Import ZArith_dec.
 Require Import Sumbool.
 
-Unset Boxed Definitions.
-Open Local Scope Z_scope.
+Local Open Scope Z_scope.
 
 (** * Boolean operations from decidability of order *)
 (** The decidability of equality and order relations over
@@ -28,7 +25,7 @@ Definition Z_ge_lt_bool (x y:Z) := bool_of_sumbool (Z_ge_lt_dec x y).
 Definition Z_le_gt_bool (x y:Z) := bool_of_sumbool (Z_le_gt_dec x y).
 Definition Z_gt_le_bool (x y:Z) := bool_of_sumbool (Z_gt_le_dec x y).
 
-Definition Z_eq_bool (x y:Z) := bool_of_sumbool (Z_eq_dec x y).
+Definition Z_eq_bool (x y:Z) := bool_of_sumbool (Z.eq_dec x y).
 Definition Z_noteq_bool (x y:Z) := bool_of_sumbool (Z_noteq_dec x y).
 
 Definition Zeven_odd_bool (x:Z) := bool_of_sumbool (Zeven_odd_dec x).
@@ -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 (compat "8.3").
+Notation Zge_bool := Z.geb (compat "8.3").
+Notation Zlt_bool := Z.ltb (compat "8.3").
+Notation Zgt_bool := Z.gtb (compat "8.3").
 
-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 (compat "8.3").
 
-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..fe91698f 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $$ i*)
+(** Binary Integers : results about Z.compare *)
+(** 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 Z.add_compare_mono_l.
 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 (Z.mul_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 (compat "8.3").
+Notation Zcompare_Eq_eq := Z.compare_eq (compat "8.3").
+Notation Zcompare_Eq_iff_eq := Z.compare_eq_iff (compat "8.3").
+Notation Zcompare_spec := Z.compare_spec (compat "8.3").
+Notation Zmin_l := Z.min_l (compat "8.3").
+Notation Zmin_r := Z.min_r (compat "8.3").
+Notation Zmax_l := Z.max_l (compat "8.3").
+Notation Zmax_r := Z.max_r (compat "8.3").
+Notation Zabs_eq := Z.abs_eq (compat "8.3").
+Notation Zabs_non_eq := Z.abs_neq (compat "8.3").
+Notation Zsgn_0 := Z.sgn_null (compat "8.3").
+Notation Zsgn_1 := Z.sgn_pos (compat "8.3").
+Notation Zsgn_m1 := Z.sgn_neg (compat "8.3").
 
+(** Not kept: Zcompare_egal_dec *)
diff --git a/theories/ZArith/Zcomplements.v b/theories/ZArith/Zcomplements.v
index ca72f8a8..b4163ef9 100644
--- a/theories/ZArith/Zcomplements.v
+++ b/theories/ZArith/Zcomplements.v
@@ -1,46 +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-2012     *)
 (*   \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.
 Require Import Wf_nat.
-Open Local Scope Z_scope.
+Local Open 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 !Pos2Z.inj_xI, (Pos2Z.inj_xO (xO _)), Pos2Z.inj_xO. omega.
+ - rewrite (Pos2Z.inj_xO (xO _)), (Pos2Z.inj_xO p), Pos2Z.inj_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.
+  unfold Q; clear Q; intros.
+  split; apply HP.
+  rewrite Z.abs_eq; auto; intros.
+  elim (H (Z.abs m)); intros; auto with zarith.
   elim (Zabs_dec m); intro eq; rewrite eq; trivial.
-  rewrite 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.
+  unfold Q; 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.
 
 (**********************************************************************)
@@ -163,11 +107,11 @@ Require Import List.
 Fixpoint Zlength_aux (acc:Z) (A:Type) (l:list A) : Z :=
   match l with
     | nil => acc
-    | _ :: l => Zlength_aux (Zsucc acc) A l
+    | _ :: l => Zlength_aux (Z.succ acc) A l
   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..fa8f5c27 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-2012     *)
 (*   \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.
@@ -66,7 +64,7 @@ Section ENCODING_VALUE.
 
 (** We compute the binary value via a Horner scheme.
     Computation stops at the vector length without checks.
-    We define a function Zmod2 similar to Zdiv2 returning the
+    We define a function Zmod2 similar to Z.div2 returning the
     quotient of division z=2q+r with 0<=r<=1.
     The two's complement value is also computed via a Horner scheme
     with Zmod2, the parameter is the size minus one.
@@ -90,16 +88,16 @@ Section ENCODING_VALUE.
 
 
   Lemma Zmod2_twice :
-    forall z:Z, z = (2 * Zmod2 z + bit_value (Zeven.Zodd_bool z))%Z.
+    forall z:Z, z = (2 * Zmod2 z + bit_value (Z.odd z))%Z.
   Proof.
-    destruct z; simpl in |- *.
+    destruct z; simpl.
     trivial.
 
-    destruct p; simpl in |- *; trivial.
+    destruct p; simpl; trivial.
 
-    destruct p; simpl in |- *.
-    destruct p as [p| p| ]; simpl in |- *.
-    rewrite <- (Pdouble_minus_one_o_succ_eq_xI p); trivial.
+    destruct p; simpl.
+    destruct p as [p| p| ]; simpl.
+    rewrite <- (Pos.pred_double_succ p); trivial.
 
     trivial.
 
@@ -115,15 +113,15 @@ Section ENCODING_VALUE.
     simple induction n; intros.
     exact Bnil.
 
-    exact (Bcons (Zeven.Zodd_bool H0) n0 (H (Zeven.Zdiv2 H0))).
+    exact (Bcons (Z.odd H0) n0 (H (Z.div2 H0))).
   Defined.
 
   Lemma Z_to_two_compl : forall n:nat, Z -> Bvector (S n).
   Proof.
     simple induction n; intros.
-    exact (Bcons (Zeven.Zodd_bool H) 0 Bnil).
+    exact (Bcons (Z.odd H) 0 Bnil).
 
-    exact (Bcons (Zeven.Zodd_bool H0) (S n0) (H (Zmod2 H0))).
+    exact (Bcons (Z.odd H0) (S n0) (H (Zmod2 H0))).
   Defined.
 
 End ENCODING_VALUE.
@@ -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.
@@ -147,17 +145,17 @@ Section Z_BRIC_A_BRAC.
       (z >= 0)%Z ->
       Z_to_binary (S n) (bit_value b + 2 * z) = Bcons b n (Z_to_binary n z).
   Proof.
-    destruct b; destruct z; simpl in |- *; auto.
+    destruct b; destruct z; simpl; auto.
     intro H; elim H; trivial.
   Qed.
 
   Lemma binary_value_pos :
     forall (n:nat) (bv:Bvector n), (binary_value n bv >= 0)%Z.
   Proof.
-    induction bv as [| a n v IHbv]; simpl in |- *.
+    induction bv as [| a n v IHbv]; simpl.
     omega.
 
-    destruct a; destruct (binary_value n v); simpl in |- *; auto.
+    destruct a; destruct (binary_value n v); simpl; auto.
     auto with zarith.
   Qed.
 
@@ -176,34 +174,34 @@ Section Z_BRIC_A_BRAC.
   Proof.
     destruct b; destruct z as [| p| p]; auto.
     destruct p as [p| p| ]; auto.
-    destruct p as [p| p| ]; simpl in |- *; auto.
-    intros; rewrite (Psucc_o_double_minus_one_eq_xO p); trivial.
+    destruct p as [p| p| ]; simpl; auto.
+    intros; rewrite (Pos.succ_pred_double p); trivial.
   Qed.
 
   Lemma Z_to_binary_Sn_z :
     forall (n:nat) (z:Z),
       Z_to_binary (S n) z =
-      Bcons (Zeven.Zodd_bool z) n (Z_to_binary n (Zeven.Zdiv2 z)).
+      Bcons (Z.odd z) n (Z_to_binary n (Z.div2 z)).
   Proof.
     intros; auto.
   Qed.
 
   Lemma Z_div2_value :
     forall z:Z,
-      (z >= 0)%Z -> (bit_value (Zeven.Zodd_bool z) + 2 * Zeven.Zdiv2 z)%Z = z.
+      (z >= 0)%Z -> (bit_value (Z.odd z) + 2 * Z.div2 z)%Z = z.
   Proof.
     destruct z as [| p| p]; auto.
     destruct p; auto.
     intro H; elim H; trivial.
   Qed.
 
-  Lemma Pdiv2 : forall z:Z, (z >= 0)%Z -> (Zeven.Zdiv2 z >= 0)%Z.
+  Lemma Pdiv2 : forall z:Z, (z >= 0)%Z -> (Z.div2 z >= 0)%Z.
   Proof.
     destruct z as [| p| p].
     auto.
 
     destruct p; auto.
-    simpl in |- *; intros; omega.
+    simpl; intros; omega.
 
     intro H; elim H; trivial.
   Qed.
@@ -211,39 +209,39 @@ Section Z_BRIC_A_BRAC.
   Lemma Zdiv2_two_power_nat :
     forall (z:Z) (n:nat),
       (z >= 0)%Z ->
-      (z < two_power_nat (S n))%Z -> (Zeven.Zdiv2 z < two_power_nat n)%Z.
+      (z < two_power_nat (S n))%Z -> (Z.div2 z < two_power_nat n)%Z.
   Proof.
     intros.
-    cut (2 * Zeven.Zdiv2 z < 2 * two_power_nat n)%Z; intros.
+    cut (2 * Z.div2 z < 2 * two_power_nat n)%Z; intros.
     omega.
 
     rewrite <- two_power_nat_S.
     destruct (Zeven.Zeven_odd_dec z); intros.
     rewrite <- Zeven.Zeven_div2; auto.
 
-    generalize (Zeven.Zodd_div2 z H z0); omega.
+    generalize (Zeven.Zodd_div2 z z0); omega.
   Qed.
 
   Lemma Z_to_two_compl_Sn_z :
     forall (n:nat) (z:Z),
       Z_to_two_compl (S n) z =
-      Bcons (Zeven.Zodd_bool z) (S n) (Z_to_two_compl n (Zmod2 z)).
+      Bcons (Z.odd z) (S n) (Z_to_two_compl n (Zmod2 z)).
   Proof.
     intros; auto.
   Qed.
 
   Lemma Zeven_bit_value :
-    forall z:Z, Zeven.Zeven z -> bit_value (Zeven.Zodd_bool z) = 0%Z.
+    forall z:Z, Zeven.Zeven z -> bit_value (Z.odd z) = 0%Z.
   Proof.
-    destruct z; unfold bit_value in |- *; auto.
+    destruct z; unfold bit_value; auto.
     destruct p; tauto || (intro H; elim H).
     destruct p; tauto || (intro H; elim H).
   Qed.
 
   Lemma Zodd_bit_value :
-    forall z:Z, Zeven.Zodd z -> bit_value (Zeven.Zodd_bool z) = 1%Z.
+    forall z:Z, Zeven.Zodd z -> bit_value (Z.odd z) = 1%Z.
   Proof.
-    destruct z; unfold bit_value in |- *; auto.
+    destruct z; unfold bit_value; auto.
     intros; elim H.
     destruct p; tauto || (intros; elim H).
     destruct p; tauto || (intros; elim H).
@@ -312,7 +310,7 @@ Section COHERENT_VALUE.
       (z < two_power_nat n)%Z -> binary_value n (Z_to_binary n z) = z.
   Proof.
     induction n as [| n IHn].
-    unfold two_power_nat, shift_nat in |- *; simpl in |- *; intros; omega.
+    unfold two_power_nat, shift_nat; simpl; intros; omega.
 
     intros; rewrite Z_to_binary_Sn_z.
     rewrite binary_value_Sn.
@@ -330,7 +328,7 @@ Section COHERENT_VALUE.
       (z < two_power_nat n)%Z -> two_compl_value n (Z_to_two_compl n z) = z.
   Proof.
     induction n as [| n IHn].
-    unfold two_power_nat, shift_nat in |- *; simpl in |- *; intros.
+    unfold two_power_nat, shift_nat; simpl; intros.
     assert (z = (-1)%Z \/ z = 0%Z). omega.
     intuition; subst z; trivial.
 
diff --git a/theories/ZArith/Zdiv.v b/theories/ZArith/Zdiv.v
index df22371e..27fb21bc 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-2012     *)
 (*   \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 (compat "8.3").
+Notation Zdiv_eucl := Z.div_eucl (compat "8.3").
+Notation Zdiv := Z.div (compat "8.3").
+Notation Zmod := Z.modulo (compat "8.3").
 
-   * 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 (compat "8.3").
+Notation Z_div_mod_eq_full := Z.div_mod (compat "8.3").
+Notation Zmod_POS_bound := Z.pos_div_eucl_bound (compat "8.3").
+Notation Zmod_pos_bound := Z.mod_pos_bound (compat "8.3").
+Notation Zmod_neg_bound := Z.mod_neg_bound (compat "8.3").
 
-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,10 +61,10 @@ 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. *)
+(* In the last formulation, [ Z.sgn r <> - Z.sgn b ] is less nice than saying
+    [ Z.sgn r = Z.sgn b ], but at least it works even when [r] is null. *)
 
 Lemma Remainder_equiv : forall r b, Remainder r b <-> Remainder_alt r b.
 Proof.
@@ -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.
+(** The same results as before, stated separately in terms of Z.div and Z.modulo *)
 
-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 (Z.gt_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 *)
+(** * Order results about Z.modulo and Z.div *)
 
 (* 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. *)
+(** [Z.ge] 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 Z.le_ge. apply Z.div_le_mono; auto with zarith. Qed.
 
-(** Same, with [Zle]. *)
+(** Same, with [Z.le]. *)
 
 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 Z.le_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. *)
+(** Some additionnal inequalities about Z.div. *)
 
 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 *)
+(** * Relations between usual operations and Z.modulo and Z.div *)
 
 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].
+(** [Z.opp] and [Z.div], [Z.modulo].
     Due to the choice of convention for our Euclidean division,
-    some of the relations about [Zopp] and divisions are rather complex. *)
+    some of the relations about [Z.opp] 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 (Z.mul_comm c b); zero_or_not b.
+ rewrite (Z.mul_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 (Z.mul_comm c b); zero_or_not b.
+ rewrite (Z.mul_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 (Z.mul_comm b c); zero_or_not c.
+ rewrite (Z.mul_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,54 +443,53 @@ 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) Z.add.
 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) Z.sub.
 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) Z.mul.
 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) Z.opp.
 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.
 
-(* NB: Zmod and Zdiv are not morphisms with respect to eqm.
+(* NB: Z.modulo and Z.div are not morphisms with respect to eqm.
     For instance, let (==) be (eqm 2). Then we have (3 == 1) but:
     ~ (3 mod 3 == 1 mod 3)
     ~ (1 mod 3 == 1 mod 1)
@@ -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 Z.mul_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) *)
+(** Z.modulo 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 Z.even.
+Qed.
+
+Lemma Zodd_mod : forall a, Z.odd a = Zeq_bool (a mod 2) 1.
+Proof.
+ intros a. rewrite Zmod_odd. now destruct Z.odd.
+Qed.
+
+Lemma Zeven_mod : forall a, Z.even a = Zeq_bool (a mod 2) 0.
+Proof.
+ intros a. rewrite Zmod_even. now destruct Z.even.
 Qed.
 
 (** * Compatibility *)
@@ -1068,19 +593,19 @@ Proof.
   intros; apply Z_mod_zero_opp_full; auto with zarith.
 Qed.
 
-(** * A direct way to compute Zmod *)
+(** * A direct way to compute Z.modulo *)
 
 Fixpoint Zmod_POS (a : positive) (b : Z) : Z  :=
   match a with
    | 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,30 +663,46 @@ 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.
   exists (- q, r).
   elim Hqr; intros.
   split.
-  rewrite <- Zmult_opp_comm; assumption.
-  rewrite Zabs_non_eq; [ assumption | omega ].
+  rewrite <- Z.mul_opp_comm; assumption.
+  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 <- Nat2Z.inj_mul, <- Nat2Z.inj_add.
+ 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, <- Nat2Z.inj_mul, <- Nat2Z.inj_add 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..1dfe2fb3
--- /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-2012     *)
+(*   \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..dd48e84f 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-2012     *)
 (*   \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,251 @@ 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 (compat "8.3").
+Notation Zodd_bool := Z.odd (compat "8.3").
+
+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 (compat "8.3").
+Notation Zeven_bool_pred := Z.even_pred (compat "8.3").
+Notation Zodd_bool_succ := Z.odd_succ (compat "8.3").
+Notation Zodd_bool_pred := Z.odd_pred (compat "8.3").
 
 (******************************************************************)
-(** * Definition of [Zdiv2] and properties wrt [Zeven] and [Zodd] *)
+(** * Definition of [Z.quot2], [Z.div2] 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 (compat "8.3").
+Notation Zquot2 := Z.quot2 (compat "8.3").
 
-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).
+ { 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. }
+ 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.add_diag 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..40d2b129 100644
--- a/theories/ZArith/Zgcd_alt.v
+++ b/theories/ZArith/Zgcd_alt.v
@@ -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-2012     *)
 (*   \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 Z.gcd, based on Euclid's algorithm *)
 
 (**
 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
+(** The alternate [Zgcd_alt] given here used to be the main [Z.gcd]
+    function (see file [Znumtheory]), but this main [Z.gcd] 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 *)
 
@@ -37,22 +35,22 @@ Open Scope Z_scope.
    match n with
      | O => 1 (* arbitrary, since n should be big enough *)
      | S n => match a with
-  	        | Z0 => Zabs b
-  	        | Zpos _ => Zgcdn n (Zmod b a) a
-  	        | Zneg a => Zgcdn n (Zmod b (Zpos a)) (Zpos a)
+	        | Z0 => Z.abs b
+	        | Zpos _ => Zgcdn n (Z.modulo b a) a
+	        | Zneg a => Zgcdn n (Z.modulo b (Zpos a)) (Zpos a)
   	      end
    end.
 
  Definition Zgcd_bound (a:Z) :=
    match a with
      | Z0 => S O
-     | Zpos p => let n := Psize p in (n+n)%nat
-     | Zneg p => let n := Psize p in (n+n)%nat
+     | Zpos p => let n := Pos.size_nat p in (n+n)%nat
+     | Zneg p => let n := Pos.size_nat p in (n+n)%nat
    end.
 
  Definition Zgcd_alt a b := Zgcdn (Zgcd_bound a) a b.
 
- (** A first obvious fact : [Zgcd a b] is positive. *)
+ (** A first obvious fact : [Z.gcd a b] is positive. *)
 
  Lemma Zgcdn_pos : forall n a b,
    0 <= Zgcdn n a b.
@@ -64,28 +62,28 @@ Open Scope Z_scope.
 
  Lemma Zgcd_alt_pos : forall a b, 0 <= Zgcd_alt a b.
  Proof.
-   intros; unfold Zgcd; apply Zgcdn_pos; auto.
+   intros; unfold Z.gcd; apply Zgcdn_pos; auto.
  Qed.
 
- (** We now prove that Zgcd is indeed a gcd. *)
+ (** We now prove that Z.gcd is indeed a gcd. *)
 
  (** 1) We prove a weaker & easier bound. *)
 
  Lemma Zgcdn_linear_bound : forall n a b,
-   Zabs a < Z_of_nat n -> Zis_gcd a b (Zgcdn n a b).
+   Z.abs a < Z.of_nat n -> Zis_gcd a b (Zgcdn n a b).
  Proof.
    induction n.
    simpl; intros.
-   exfalso; generalize (Zabs_pos a); omega.
+   exfalso; generalize (Z.abs_nonneg a); omega.
    destruct a; intros; simpl;
      [ generalize (Zis_gcd_0_abs b); intuition | | ];
-   unfold Zmod;
-   generalize (Z_div_mod b (Zpos p) (refl_equal Gt));
-   destruct (Zdiv_eucl b (Zpos p)) as (q,r);
+   unfold Z.modulo;
+   generalize (Z_div_mod b (Zpos p) (eq_refl Gt));
+   destruct (Z.div_eucl b (Zpos p)) as (q,r);
    intros (H0,H1);
-   rewrite inj_S in H; simpl Zabs in H;
-   (assert (H2: Zabs r < Z_of_nat n) by
-    (rewrite Zabs_eq; auto with zarith));
+   rewrite Nat2Z.inj_succ in H; simpl Z.abs in H;
+   (assert (H2: Z.abs r < Z.of_nat n) by
+    (rewrite Z.abs_eq; auto with zarith));
     assert (IH:=IHn r (Zpos p) H2); clear IHn;
     simpl in IH |- *;
     rewrite H0.
@@ -124,7 +122,7 @@ Open Scope Z_scope.
  Proof.
    induction 1.
    auto with zarith.
-   apply Zle_trans with (fibonacci m); auto.
+   apply Z.le_trans with (fibonacci m); auto.
    clear.
    destruct m.
    simpl; auto with zarith.
@@ -144,53 +142,38 @@ Open Scope Z_scope.
    fibonacci (S (S n)) <= b.
  Proof.
    induction n.
-   simpl; intros.
-   destruct a; omega.
-   intros.
-   destruct a; [simpl in *; omega| | destruct H; discriminate].
-   revert H1; revert H0.
-   set (m:=S n) in *; (assert (m=S n) by auto); clearbody m.
-   pattern m at 2; rewrite H0.
-   simpl Zgcdn.
-   unfold Zmod; generalize (Z_div_mod b (Zpos p) (refl_equal Gt)).
-   destruct (Zdiv_eucl b (Zpos p)) as (q,r).
-   intros (H1,H2).
-   destruct H2.
-   destruct (Zle_lt_or_eq _ _ H2).
-   generalize (IHn _ _ (conj H4 H3)).
-   intros H5 H6 H7.
-   replace (fibonacci (S (S m))) with (fibonacci (S m) + fibonacci m) by auto.
-   assert (r = Zpos p * (-q) + b) by (rewrite H1; ring).
-   destruct H5; auto.
-   pattern r at 1; rewrite H8.
-   apply Zis_gcd_sym.
-   apply Zis_gcd_for_euclid2; auto.
-   apply Zis_gcd_sym; auto.
-   split; auto.
-   rewrite H1.
-   apply Zplus_le_compat; auto.
-   apply Zle_trans with (Zpos p * 1); auto.
-   ring_simplify (Zpos p * 1); auto.
-   apply Zmult_le_compat_l.
-   destruct q.
-   omega.
-   assert (0 < Zpos p0) by (compute; auto).
-   omega.
-   assert (Zpos p * Zneg p0 < 0) by (compute; auto).
-   omega.
-   compute; intros; discriminate.
-   (* r=0 *)
-   subst r.
-   simpl; rewrite H0.
-   intros.
-   simpl in H4.
-   simpl in H5.
-   destruct n.
-   simpl in H5.
-   simpl.
-   omega.
-   simpl in H5.
-   elim H5; auto.
+   intros [|a|a]; intros; simpl; omega.
+   intros [|a|a] b (Ha,Ha'); [simpl; omega | | easy ].
+   remember (S n) as m.
+   rewrite Heqm at 2. simpl Zgcdn.
+   unfold Z.modulo; generalize (Z_div_mod b (Zpos a) eq_refl).
+   destruct (Z.div_eucl b (Zpos a)) as (q,r).
+   intros (EQ,(Hr,Hr')).
+   Z.le_elim Hr.
+   - (* r > 0 *)
+     replace (fibonacci (S (S m))) with (fibonacci (S m) + fibonacci m) by auto.
+     intros.
+     destruct (IHn r (Zpos a) (conj Hr Hr')); auto.
+     + assert (EQ' : r = Zpos a * (-q) + b) by (rewrite EQ; ring).
+       rewrite EQ' at 1.
+       apply Zis_gcd_sym.
+       apply Zis_gcd_for_euclid2; auto.
+       apply Zis_gcd_sym; auto.
+     + split; auto.
+       rewrite EQ.
+       apply Z.add_le_mono; auto.
+       apply Z.le_trans with (Zpos a * 1); auto.
+       now rewrite Z.mul_1_r.
+       apply Z.mul_le_mono_nonneg_l; auto with zarith.
+       change 1 with (Z.succ 0). apply Z.le_succ_l.
+       destruct q; auto with zarith.
+       assert (Zpos a * Zneg p < 0) by now compute. omega.
+   - (* r = 0 *)
+     clear IHn EQ Hr'; intros _.
+     subst r; simpl; rewrite Heqm.
+     destruct n.
+     + simpl. omega.
+     + now destruct 1.
  Qed.
 
  (** 3b) We reformulate the previous result in a more positive way. *)
@@ -201,18 +184,18 @@ Open Scope Z_scope.
  Proof.
    destruct a; [ destruct 1; exfalso; omega | | destruct 1; discriminate].
    cut (forall k n b,
-     k = (S (nat_of_P p) - n)%nat ->
+     k = (S (Pos.to_nat p) - n)%nat ->
      0 < Zpos p < b -> Zpos p < fibonacci (S n) ->
      Zis_gcd (Zpos p) b (Zgcdn n (Zpos p) b)).
    destruct 2; eauto.
    clear n; induction k.
    intros.
-   assert (nat_of_P p < n)%nat by omega.
+   assert (Pos.to_nat p < n)%nat by omega.
    apply Zgcdn_linear_bound.
    simpl.
    generalize (inj_le _ _ H2).
-   rewrite inj_S.
-   rewrite <- Zpos_eq_Z_of_nat_o_nat_of_P; auto.
+   rewrite Nat2Z.inj_succ.
+   rewrite positive_nat_Z; auto.
    omega.
    intros.
    generalize (Zgcdn_worst_is_fibonacci n (Zpos p) b H0); intros.
@@ -235,77 +218,69 @@ Open Scope Z_scope.
    induction p; [ | | compute; auto ];
     simpl Zgcd_bound in *;
     rewrite plus_comm; simpl plus;
-    set (n:= (Psize p+Psize p)%nat) in *; simpl;
+    set (n:= (Pos.size_nat p+Pos.size_nat p)%nat) in *; simpl;
     assert (n <> O) by (unfold n; destruct p; simpl; auto).
 
    destruct n as [ |m]; [elim H; auto| ].
-   generalize (fibonacci_pos m); rewrite Zpos_xI; omega.
+   generalize (fibonacci_pos m); rewrite Pos2Z.inj_xI; omega.
 
    destruct n as [ |m]; [elim H; auto| ].
-   generalize (fibonacci_pos m); rewrite Zpos_xO; omega.
+   generalize (fibonacci_pos m); rewrite Pos2Z.inj_xO; omega.
  Qed.
 
  (* 5) the end: we glue everything together and take care of
     situations not corresponding to [0<a<b]. *)
 
- Lemma Zgcdn_is_gcd :
-   forall n a b, (Zgcd_bound a <= n)%nat ->
-     Zis_gcd a b (Zgcdn n a b).
+ Lemma Zgcd_bound_opp a : Zgcd_bound (-a) = Zgcd_bound a.
+ Proof.
+  now destruct a.
+ Qed.
+
+ Lemma Zgcdn_opp n a b : Zgcdn n (-a) b = Zgcdn n a b.
+ Proof.
+  induction n; simpl; auto.
+  destruct a; simpl; auto.
+ Qed.
+
+ Lemma Zgcdn_is_gcd_pos n a b : (Zgcd_bound (Zpos a) <= n)%nat ->
+   Zis_gcd (Zpos a) b (Zgcdn n (Zpos a) b).
+ Proof.
+  intros.
+  generalize (Zgcd_bound_fibonacci (Zpos a)).
+  simpl Zgcd_bound in *.
+  remember (Pos.size_nat a+Pos.size_nat a)%nat as m.
+  assert (1 < m)%nat.
+  { rewrite Heqm; destruct a; simpl; rewrite 1?plus_comm;
+    auto with arith. }
+  destruct m as [ |m]; [inversion H0; auto| ].
+  destruct n as [ |n]; [inversion H; auto| ].
+  simpl Zgcdn.
+  unfold Z.modulo.
+  generalize (Z_div_mod b (Zpos a) (eq_refl Gt)).
+  destruct (Z.div_eucl b (Zpos a)) as (q,r).
+  intros (->,(H1,H2)) H3.
+  apply Zis_gcd_for_euclid2.
+  Z.le_elim H1.
+  + apply Zgcdn_ok_before_fibonacci; auto.
+    apply Z.lt_le_trans with (fibonacci (S m));
+    [ omega | apply fibonacci_incr; auto].
+  + subst r; simpl.
+    destruct m as [ |m]; [exfalso; omega| ].
+    destruct n as [ |n]; [exfalso; omega| ].
+    simpl; apply Zis_gcd_sym; apply Zis_gcd_0.
+ Qed.
+
+ Lemma Zgcdn_is_gcd n a b :
+   (Zgcd_bound a <= n)%nat -> Zis_gcd a b (Zgcdn n a b).
  Proof.
-   destruct a; intros.
-   simpl in H.
-   destruct n; [exfalso; omega | ].
-   simpl; generalize (Zis_gcd_0_abs b); intuition.
-   (*Zpos*)
-   generalize (Zgcd_bound_fibonacci (Zpos p)).
-   simpl Zgcd_bound in *.
-   remember (Psize p+Psize p)%nat as m.
-   assert (1 < m)%nat.
-     rewrite Heqm; destruct p; simpl; rewrite 1? plus_comm;
-       auto with arith.
-   destruct m as [ |m]; [inversion H0; auto| ].
-   destruct n as [ |n]; [inversion H; auto| ].
-   simpl Zgcdn.
-   unfold Zmod.
-   generalize (Z_div_mod b (Zpos p) (refl_equal Gt)).
-   destruct (Zdiv_eucl b (Zpos p)) as (q,r).
-   intros (H2,H3) H4.
-   rewrite H2.
-   apply Zis_gcd_for_euclid2.
-   destruct H3.
-   destruct (Zle_lt_or_eq _ _ H1).
-   apply Zgcdn_ok_before_fibonacci; auto.
-   apply Zlt_le_trans with (fibonacci (S m)); [ omega | apply fibonacci_incr; auto].
-   subst r; simpl.
-   destruct m as [ |m]; [exfalso; omega| ].
-   destruct n as [ |n]; [exfalso; omega| ].
-   simpl; apply Zis_gcd_sym; apply Zis_gcd_0.
-   (*Zneg*)
-   generalize (Zgcd_bound_fibonacci (Zpos p)).
-   simpl Zgcd_bound in *.
-   remember (Psize p+Psize p)%nat as m.
-   assert (1 < m)%nat.
-     rewrite Heqm; destruct p; simpl; rewrite 1? plus_comm;
-       auto with arith.
-   destruct m as [ |m]; [inversion H0; auto| ].
-   destruct n as [ |n]; [inversion H; auto| ].
-   simpl Zgcdn.
-   unfold Zmod.
-   generalize (Z_div_mod b (Zpos p) (refl_equal Gt)).
-   destruct (Zdiv_eucl b (Zpos p)) as (q,r).
-   intros (H1,H2) H3.
-   rewrite H1.
-   apply Zis_gcd_minus.
-   apply Zis_gcd_sym.
-   apply Zis_gcd_for_euclid2.
-   destruct H2.
-   destruct (Zle_lt_or_eq _ _ H2).
-   apply Zgcdn_ok_before_fibonacci; auto.
-   apply Zlt_le_trans with (fibonacci (S m)); [ omega | apply fibonacci_incr; auto].
-   subst r; simpl.
-   destruct m as [ |m]; [exfalso; omega| ].
-   destruct n as [ |n]; [exfalso; omega| ].
-   simpl; apply Zis_gcd_sym; apply Zis_gcd_0.
+   destruct a.
+   - simpl; intros.
+     destruct n; [exfalso; omega | ].
+     simpl; generalize (Zis_gcd_0_abs b); intuition.
+   - apply Zgcdn_is_gcd_pos.
+   - rewrite <- Zgcd_bound_opp, <- Zgcdn_opp.
+     intros. apply Zis_gcd_minus, Zis_gcd_sym. simpl Z.opp.
+     now apply Zgcdn_is_gcd_pos.
  Qed.
 
  Lemma Zgcd_is_gcd :
diff --git a/theories/ZArith/Zhints.v b/theories/ZArith/Zhints.v
index c2348967..8b879fbe 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-2012     *)
 (*   \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  *)
 
@@ -45,495 +43,59 @@ Hint Resolve
   (** Should clearly be declared as hints                               *)
 
   (** Lemmas ending by eq *)
-  Zsucc_eq_compat (* :(n,m:Z)`n = m`->`(Zs n) = (Zs m)` *)
-
-  (** Lemmas ending by Zgt *)
-  Zsucc_gt_compat (* :(n,m:Z)`m > n`->`(Zs m) > (Zs n)` *)
-  Zgt_succ (* :(n:Z)`(Zs n) > n` *)
-  Zorder.Zgt_pos_0 (* :(p:positive)`(POS p) > 0` *)
-  Zplus_gt_compat_l (* :(n,m,p:Z)`n > m`->`p+n > p+m` *)
-  Zplus_gt_compat_r (* :(n,m,p:Z)`n > m`->`n+p > m+p` *)
-
-  (** Lemmas ending by Zlt *)
-  Zlt_succ (* :(n:Z)`n < (Zs n)` *)
-  Zsucc_lt_compat (* :(n,m:Z)`n < m`->`(Zs n) < (Zs m)` *)
-  Zlt_pred (* :(n:Z)`(Zpred n) < n` *)
-  Zplus_lt_compat_l (* :(n,m,p:Z)`n < m`->`p+n < p+m` *)
-  Zplus_lt_compat_r (* :(n,m,p:Z)`n < m`->`n+p < m+p` *)
-
-  (** Lemmas ending by Zle *)
-  Zle_0_nat (* :(n:nat)`0 <= (inject_nat n)` *)
-  Zorder.Zle_0_pos (* :(p:positive)`0 <= (POS p)` *)
-  Zle_refl (* :(n:Z)`n <= n` *)
-  Zle_succ (* :(n:Z)`n <= (Zs n)` *)
-  Zsucc_le_compat (* :(n,m:Z)`m <= n`->`(Zs m) <= (Zs n)` *)
-  Zle_pred (* :(n:Z)`(Zpred n) <= n` *)
-  Zle_min_l (* :(n,m:Z)`(Zmin n m) <= n` *)
-  Zle_min_r (* :(n,m:Z)`(Zmin n m) <= m` *)
-  Zplus_le_compat_l (* :(n,m,p:Z)`n <= m`->`p+n <= p+m` *)
-  Zplus_le_compat_r (* :(a,b,c:Z)`a <= b`->`a+c <= b+c` *)
-  Zabs_pos (* :(x:Z)`0 <= |x|` *)
+  Zsucc_eq_compat (* n = m -> Z.succ n = Z.succ m *)
+
+  (** Lemmas ending by Z.gt *)
+  Zsucc_gt_compat (* m > n -> Z.succ m > Z.succ n *)
+  Zgt_succ (* Z.succ n > n *)
+  Zorder.Zgt_pos_0 (* Z.pos p > 0 *)
+  Zplus_gt_compat_l (* n > m -> p+n > p+m *)
+  Zplus_gt_compat_r (* n > m -> n+p > m+p *)
+
+  (** Lemmas ending by Z.lt *)
+  Pos2Z.is_pos (* 0 < Z.pos p *)
+  Z.lt_succ_diag_r (* n < Z.succ n *)
+  Zsucc_lt_compat (* n < m -> Z.succ n < Z.succ m *)
+  Z.lt_pred_l (* Z.pred n < n *)
+  Zplus_lt_compat_l (* n < m -> p+n < p+m *)
+  Zplus_lt_compat_r (* n < m -> n+p < m+p *)
+
+  (** Lemmas ending by Z.le *)
+  Nat2Z.is_nonneg (* 0 <= Z.of_nat n *)
+  Pos2Z.is_nonneg (* 0 <= Z.pos p *)
+  Z.le_refl (* n <= n *)
+  Z.le_succ_diag_r (* n <= Z.succ n *)
+  Zsucc_le_compat (* m <= n -> Z.succ m <= Z.succ n *)
+  Z.le_pred_l (* Z.pred n <= n *)
+  Z.le_min_l (* Z.min n m <= n *)
+  Z.le_min_r (* Z.min n m <= m *)
+  Zplus_le_compat_l (* n <= m -> p+n <= p+m *)
+  Zplus_le_compat_r (* a <= b -> a+c <= b+c *)
+  Z.abs_nonneg (* 0 <= |x| *)
 
   (** ** Irreversible simplification lemmas *)
   (** Probably to be declared as hints, when no other simplification is possible *)
 
   (** Lemmas ending by eq *)
-  BinInt.Z_eq_mult (* :(x,y:Z)`y = 0`->`y*x = 0` *)
-  Zplus_eq_compat (* :(n,m,p,q:Z)`n = m`->`p = q`->`n+p = m+q` *)
+  Z_eq_mult (* y = 0 -> y*x = 0 *)
+  Zplus_eq_compat (* n = m -> p = q -> n+p = m+q *)
 
-  (** Lemmas ending by Zge *)
-  Zorder.Zmult_ge_compat_r (* :(a,b,c:Z)`a >= b`->`c >= 0`->`a*c >= b*c` *)
-  Zorder.Zmult_ge_compat_l (* :(a,b,c:Z)`a >= b`->`c >= 0`->`c*a >= c*b` *)
+  (** Lemmas ending by Z.ge *)
+  Zorder.Zmult_ge_compat_r (* a >= b -> c >= 0 -> a*c >= b*c *)
+  Zorder.Zmult_ge_compat_l (* a >= b -> c >= 0 -> c*a >= c*b *)
   Zorder.Zmult_ge_compat (* :
-      (a,b,c,d:Z)`a >= c`->`b >= d`->`c >= 0`->`d >= 0`->`a*b >= c*d` *)
+      a >= c -> b >= d -> c >= 0 -> d >= 0 -> a*b >= c*d *)
 
-  (** Lemmas ending by Zlt *)
-  Zorder.Zmult_gt_0_compat (* :(a,b:Z)`a > 0`->`b > 0`->`a*b > 0` *)
-  Zlt_lt_succ (* :(n,m:Z)`n < m`->`n < (Zs m)` *)
+  (** Lemmas ending by Z.lt *)
+  Zorder.Zmult_gt_0_compat (* a > 0 -> b > 0 -> a*b > 0 *)
+  Z.lt_lt_succ_r (* n < m -> n < Z.succ m *)
 
-  (** Lemmas ending by Zle *)
-  Zorder.Zmult_le_0_compat (* :(x,y:Z)`0 <= x`->`0 <= y`->`0 <= x*y` *)
-  Zorder.Zmult_le_compat_r (* :(a,b,c:Z)`a <= b`->`0 <= c`->`a*c <= b*c` *)
-  Zorder.Zmult_le_compat_l (* :(a,b,c:Z)`a <= b`->`0 <= c`->`c*a <= c*b` *)
-  Zplus_le_0_compat (* :(x,y:Z)`0 <= x`->`0 <= y`->`0 <= x+y` *)
-  Zle_le_succ (* :(x,y:Z)`x <= y`->`x <= (Zs y)` *)
-  Zplus_le_compat (* :(n,m,p,q:Z)`n <= m`->`p <= q`->`n+p <= m+q` *)
+  (** Lemmas ending by Z.le *)
+  Z.mul_nonneg_nonneg (* 0 <= x -> 0 <= y -> 0 <= x*y *)
+  Zorder.Zmult_le_compat_r (* a <= b -> 0 <= c -> a*c <= b*c *)
+  Zorder.Zmult_le_compat_l (* a <= b -> 0 <= c -> c*a <= c*b *)
+  Z.add_nonneg_nonneg (* 0 <= x -> 0 <= y -> 0 <= x+y *)
+  Z.le_le_succ_r (* x <= y -> x <= Z.succ y *)
+  Z.add_le_mono (* 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..319e2c26 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-2012     *)
 (*   \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,43 +33,64 @@ 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 => Z.succ (log_inf q)       (* 2n *)
+      | xI q => Z.succ (log_inf q)       (* 2n+1 *)
     end.
 
   Fixpoint log_sup (p:positive) : Z :=
     match p with
       | xH => 0	(* 1 *)
-      | xO n => Zsucc (log_sup n) (* 2n *)
-      | xI n => Zsucc (Zsucc (log_inf n))	(* 2n+1 *)
+      | xO n => Z.succ (log_sup n) (* 2n *)
+      | xI n => Z.succ (Z.succ (log_inf n))	(* 2n+1 *)
     end.
 
   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 ?Pos2Z.inj_succ, ?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 *)
 
-  Hint Resolve Zle_trans: zarith.
+  Hint Resolve Z.le_trans: zarith.
 
   Theorem log_inf_correct :
     forall x:positive,
-      0 <= log_inf x /\ two_p (log_inf x) <= Zpos x < two_p (Zsucc (log_inf x)).
+      0 <= log_inf x /\ two_p (log_inf x) <= Zpos x < two_p (Z.succ (log_inf x)).
   Proof.
-    simple induction x; intros; simpl in |- *;
+    simple induction x; intros; simpl;
       [ elim H; intros Hp HR; clear H; split;
 	[ auto with zarith
-	  | rewrite two_p_S with (x := Zsucc (log_inf p)) by (apply Zle_le_succ; trivial);
+	  | rewrite two_p_S with (x := Z.succ (log_inf p)) by (apply Z.le_le_succ_r; trivial);
 	    rewrite two_p_S by trivial;
-	    rewrite two_p_S in HR by trivial; rewrite (BinInt.Zpos_xI p);
+	    rewrite two_p_S in HR by trivial; rewrite (BinInt.Pos2Z.inj_xI p);
 		omega ]
 	| elim H; intros Hp HR; clear H; split;
 	  [ auto with zarith
-	    | rewrite two_p_S with (x := Zsucc (log_inf p)) by (apply Zle_le_succ; trivial);
+	    | rewrite two_p_S with (x := Z.succ (log_inf p)) by (apply Z.le_le_succ_r; trivial);
 	      rewrite two_p_S by trivial;
-	      rewrite two_p_S in HR by trivial; rewrite (BinInt.Zpos_xO p);
+	      rewrite two_p_S in HR by trivial; rewrite (BinInt.Pos2Z.inj_xO p);
 		  omega ]
-	| unfold two_power_pos in |- *; unfold shift_pos in |- *; simpl in |- *;
+	| unfold two_power_pos; unfold shift_pos; simpl;
 	  omega ].
   Qed.
 
@@ -81,7 +103,7 @@ Section Log_pos. (* Log of positive integers *)
 
   Lemma log_sup_correct1 : forall p:positive, 0 <= log_sup p.
   Proof.
-    simple induction p; intros; simpl in |- *; auto with zarith.
+    simple induction p; intros; simpl; auto with zarith.
   Qed.
 
   (** For every [p], either [p] is a power of two and [(log_inf p)=(log_sup p)]
@@ -90,46 +112,46 @@ Section Log_pos. (* Log of positive integers *)
   Theorem log_sup_log_inf :
     forall p:positive,
       IF Zpos p = two_p (log_inf p) then Zpos p = two_p (log_sup p)
-    else log_sup p = Zsucc (log_inf p).
+    else log_sup p = Z.succ (log_inf p).
   Proof.
     simple induction p; intros;
-      [ elim H; right; simpl in |- *;
+      [ elim H; right; simpl;
 	rewrite (two_p_S (log_inf p0) (log_inf_correct1 p0));
-	  rewrite BinInt.Zpos_xI; unfold Zsucc in |- *; omega
+	  rewrite BinInt.Pos2Z.inj_xI; unfold Z.succ; omega
 	| elim H; clear H; intro Hif;
-	  [ left; simpl in |- *;
+	  [ left; simpl;
 	    rewrite (two_p_S (log_inf p0) (log_inf_correct1 p0));
 	      rewrite (two_p_S (log_sup p0) (log_sup_correct1 p0));
 		rewrite <- (proj1 Hif); rewrite <- (proj2 Hif);
 		  auto
-	    | right; simpl in |- *;
+	    | right; simpl;
 	      rewrite (two_p_S (log_inf p0) (log_inf_correct1 p0));
-		rewrite BinInt.Zpos_xO; unfold Zsucc in |- *;
+		rewrite BinInt.Pos2Z.inj_xO; unfold Z.succ;
 		  omega ]
 	| left; auto ].
   Qed.
 
   Theorem log_sup_correct2 :
-    forall x:positive, two_p (Zpred (log_sup x)) < Zpos x <= two_p (log_sup x).
+    forall x:positive, two_p (Z.pred (log_sup x)) < Zpos x <= two_p (log_sup x).
   Proof.
     intro.
     elim (log_sup_log_inf x).
     (* x is a power of two and [log_sup = log_inf] *)
     intros [E1 E2]; rewrite E2.
-    split; [ apply two_p_pred; apply log_sup_correct1 | apply Zle_refl ].
+    split; [ apply two_p_pred; apply log_sup_correct1 | apply Z.le_refl ].
     intros [E1 E2]; rewrite E2.
-    rewrite <- (Zpred_succ (log_inf x)).
+    rewrite (Z.pred_succ (log_inf x)).
     generalize (log_inf_correct2 x); omega.
   Qed.
 
   Lemma log_inf_le_log_sup : forall p:positive, log_inf p <= log_sup p.
   Proof.
-    simple induction p; simpl in |- *; intros; omega.
+    simple induction p; simpl; intros; omega.
   Qed.
 
-  Lemma log_sup_le_Slog_inf : forall p:positive, log_sup p <= Zsucc (log_inf p).
+  Lemma log_sup_le_Slog_inf : forall p:positive, log_sup p <= Z.succ (log_inf p).
   Proof.
-    simple induction p; simpl in |- *; intros; omega.
+    simple induction p; simpl; intros; omega.
   Qed.
 
   (** Now it's possible to specify and build the [Log] rounded to the nearest *)
@@ -139,22 +161,20 @@ Section Log_pos. (* Log of positive integers *)
       | xH => 0
       | xO xH => 1
       | xI xH => 2
-      | xO y => Zsucc (log_near y)
-      | xI y => Zsucc (log_near y)
+      | xO y => Z.succ (log_near y)
+      | xI y => Z.succ (log_near y)
     end.
 
   Theorem log_near_correct1 : forall p:positive, 0 <= log_near p.
   Proof.
-    simple induction p; simpl in |- *; intros;
+    simple induction p; simpl; intros;
       [ elim p0; auto with zarith
 	| elim p0; auto with zarith
 	| trivial with zarith ].
-    intros; apply Zle_le_succ.
-    generalize H0; elim p1; intros; simpl in |- *;
-      [ assumption | assumption | apply Zorder.Zle_0_pos ].
-    intros; apply Zle_le_succ.
-    generalize H0; elim p1; intros; simpl in |- *;
-      [ assumption | assumption | apply Zorder.Zle_0_pos ].
+    intros; apply Z.le_le_succ_r.
+    generalize H0; now elim p1.
+    intros; apply Z.le_le_succ_r.
+    generalize H0; now elim p1.
   Qed.
 
   Theorem log_near_correct2 :
@@ -162,9 +182,9 @@ Section Log_pos. (* Log of positive integers *)
   Proof.
     simple induction p.
     intros p0 [Einf| Esup].
-    simpl in |- *. rewrite Einf.
+    simpl. rewrite Einf.
     case p0; [ left | left | right ]; reflexivity.
-    simpl in |- *; rewrite Esup.
+    simpl; rewrite Esup.
     elim (log_sup_log_inf p0).
     generalize (log_inf_le_log_sup p0).
     generalize (log_sup_le_Slog_inf p0).
@@ -172,10 +192,10 @@ Section Log_pos. (* Log of positive integers *)
     intros; omega.
     case p0; intros; auto with zarith.
     intros p0 [Einf| Esup].
-    simpl in |- *.
+    simpl.
     repeat rewrite Einf.
     case p0; intros; auto with zarith.
-    simpl in |- *.
+    simpl.
     repeat rewrite Esup.
     case p0; intros; auto with zarith.
     auto.
@@ -196,20 +216,20 @@ Section divers.
 
   Lemma ZERO_le_N_digits : forall x:Z, 0 <= N_digits x.
   Proof.
-    simple induction x; simpl in |- *;
-      [ apply Zle_refl | exact log_inf_correct1 | exact log_inf_correct1 ].
+    simple induction x; simpl;
+      [ apply Z.le_refl | exact log_inf_correct1 | exact log_inf_correct1 ].
   Qed.
 
-  Lemma log_inf_shift_nat : forall n:nat, log_inf (shift_nat n 1) = Z_of_nat n.
+  Lemma log_inf_shift_nat : forall n:nat, log_inf (shift_nat n 1) = Z.of_nat n.
   Proof.
     simple induction n; intros;
-      [ try trivial | rewrite Znat.inj_S; rewrite <- H; reflexivity ].
+      [ try trivial | rewrite Nat2Z.inj_succ; rewrite <- H; reflexivity ].
   Qed.
 
-  Lemma log_sup_shift_nat : forall n:nat, log_sup (shift_nat n 1) = Z_of_nat n.
+  Lemma log_sup_shift_nat : forall n:nat, log_sup (shift_nat n 1) = Z.of_nat n.
   Proof.
     simple induction n; intros;
-      [ try trivial | rewrite Znat.inj_S; rewrite <- H; reflexivity ].
+      [ try trivial | rewrite Nat2Z.inj_succ; rewrite <- H; reflexivity ].
   Qed.
 
   (** [Is_power p] means that p is a power of two *)
@@ -225,21 +245,21 @@ Section divers.
   Proof.
     split;
       [ elim p;
-	[ simpl in |- *; tauto
-	  | simpl in |- *; intros; generalize (H H0); intro H1; elim H1;
+	[ simpl; tauto
+	  | simpl; intros; generalize (H H0); intro H1; elim H1;
 	    intros y0 Hy0; exists (S y0); rewrite Hy0; reflexivity
 	  | intro; exists 0%nat; reflexivity ]
-	| intros; elim H; intros; rewrite H0; elim x; intros; simpl in |- *; trivial ].
+	| intros; elim H; intros; rewrite H0; elim x; intros; simpl; trivial ].
   Qed.
 
   Lemma Is_power_or : forall p:positive, Is_power p \/ ~ Is_power p.
   Proof.
     simple induction p;
-      [ intros; right; simpl in |- *; tauto
+      [ intros; right; simpl; tauto
 	| intros; elim H;
-	  [ intros; left; simpl in |- *; exact H0
-	    | intros; right; simpl in |- *; exact H0 ]
-	| left; simpl in |- *; trivial ].
+	  [ intros; left; simpl; exact H0
+	    | intros; right; simpl; exact H0 ]
+	| left; simpl; trivial ].
   Qed.
 
 End divers.
diff --git a/theories/ZArith/Zmax.v b/theories/ZArith/Zmax.v
index cb2fcf26..31880c17 100644
--- a/theories/ZArith/Zmax.v
+++ b/theories/ZArith/Zmax.v
@@ -1,106 +1,60 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i $Id: Zmax.v 14641 2011-11-06 11:59:10Z herbelin $ i*)
 
-(** THIS FILE IS DEPRECATED. Use [Zminmax] instead. *)
-
-Require Export BinInt Zorder Zminmax.
-
-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. *)
-
-
-(** * 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.
+(** THIS FILE IS DEPRECATED. *)
+
+Require Export BinInt Zcompare Zorder.
+
+Local Open Scope Z_scope.
+
+(** Definition [Z.max] is now [BinInt.Z.max]. *)
+
+(** Exact compatibility *)
+
+Notation Zmax_case := Z.max_case (compat "8.3").
+Notation Zmax_case_strong := Z.max_case_strong (compat "8.3").
+Notation Zmax_right := Z.max_r (compat "8.3").
+Notation Zle_max_l := Z.le_max_l (compat "8.3").
+Notation Zle_max_r := Z.le_max_r (compat "8.3").
+Notation Zmax_lub := Z.max_lub (compat "8.3").
+Notation Zmax_lub_lt := Z.max_lub_lt (compat "8.3").
+Notation Zle_max_compat_r := Z.max_le_compat_r (compat "8.3").
+Notation Zle_max_compat_l := Z.max_le_compat_l (compat "8.3").
+Notation Zmax_idempotent := Z.max_id (compat "8.3").
+Notation Zmax_n_n := Z.max_id (compat "8.3").
+Notation Zmax_comm := Z.max_comm (compat "8.3").
+Notation Zmax_assoc := Z.max_assoc (compat "8.3").
+Notation Zmax_irreducible_dec := Z.max_dec (compat "8.3").
+Notation Zmax_le_prime := Z.max_le (compat "8.3").
+Notation Zsucc_max_distr := Z.succ_max_distr (compat "8.3").
+Notation Zmax_SS := Z.succ_max_distr (compat "8.3").
+Notation Zplus_max_distr_l := Z.add_max_distr_l (compat "8.3").
+Notation Zplus_max_distr_r := Z.add_max_distr_r (compat "8.3").
+Notation Zmax_plus := Z.add_max_distr_r (compat "8.3").
+Notation Zmax1 := Z.le_max_l (compat "8.3").
+Notation Zmax2 := Z.le_max_r (compat "8.3").
+Notation Zmax_irreducible_inf := Z.max_dec (compat "8.3").
+Notation Zmax_le_prime_inf := Z.max_le (compat "8.3").
+Notation Zpos_max := Pos2Z.inj_max (compat "8.3").
+Notation Zpos_minus := Pos2Z.inj_sub_max (compat "8.3").
+
+(** Slightly different lemmas *)
+
+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.
-
-Definition Zmax_right : forall n m, n<=m -> Zmax n m = m := 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.
-
-Definition Zmax_lub : forall n m p, n <= p -> m <= p -> Zmax n m <= p
- := Z.max_lub.
-
-Definition Zmax_lub_lt : forall n m p:Z, n < p -> m < p -> Zmax n m < p
- := 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.
-
-Definition Zle_max_compat_l : forall n m p, n <= m -> Zmax p n <= Zmax p m
- := Z.max_le_compat_l.
-
+Lemma Zmax_left n m : n>=m -> Z.max n m = n.
+Proof. Z.swap_greater. apply Z.max_l. Qed.
 
-(** * Semi-lattice properties of max *)
-
-Definition Zmax_idempotent : forall n, Zmax n n = n := Z.max_id.
-Definition Zmax_comm : forall n m, Zmax n m = Zmax m n := Z.max_comm.
-Definition Zmax_assoc : forall n m p, Zmax n (Zmax m p) = Zmax (Zmax n m) p
- := Z.max_assoc.
-
-(** * Additional properties of max *)
-
-Lemma Zmax_irreducible_dec : forall n m, {Zmax n m = n} + {Zmax n m = m}.
-Proof. exact Z.max_dec. Qed.
-
-Definition Zmax_le_prime : forall n m p, p <= Zmax n m -> p <= n \/ p <= m
- := Z.max_le.
-
-
-(** * Operations preserving max *)
-
-Definition Zsucc_max_distr :
-  forall n m:Z, Zsucc (Zmax n m) = Zmax (Zsucc n) (Zsucc m)
- := 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.
-
-Definition Zplus_max_distr_r : forall n m p:Z, Zmax (n + p) (m + p) = Zmax n m + p
- := Z.plus_max_distr_r.
-
-(** * Maximum and Zpos *)
-
-Definition Zpos_max : forall p q, Zpos (Pmax p q) = Zmax (Zpos p) (Zpos q)
- := Z.pos_max.
-
-Definition Zpos_max_1 : forall p, Zmax 1 (Zpos p) = Zpos p
- := Z.pos_max_1.
-
-(** * Characterization of Pminus in term of Zminus and Zmax *)
-
-Definition Zpos_minus :
- forall p q, Zpos (Pminus p q) = Zmax 1 (Zpos p - Zpos q)
- := Zpos_minus.
-
-(* begin hide *)
-(* Compatibility *)
-Notation Zmax1 := Zle_max_l (only parsing).
-Notation Zmax2 := Zle_max_r (only parsing).
-Notation Zmax_irreducible_inf := Zmax_irreducible_dec (only parsing).
-Notation Zmax_le_prime_inf := Zmax_le_prime (only parsing).
-(* end hide *)
+Lemma Zpos_max_1 p : Z.max 1 (Z.pos p) = Z.pos p.
+Proof.
+ now destruct p.
+Qed.
diff --git a/theories/ZArith/Zmin.v b/theories/ZArith/Zmin.v
index 7b9ad469..30b88d8f 100644
--- a/theories/ZArith/Zmin.v
+++ b/theories/ZArith/Zmin.v
@@ -1,90 +1,57 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*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.
+Local Open 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. *)
+(** Definition [Z.min] is now [BinInt.Z.min]. *)
 
+(** Exact compatibility *)
 
-(** * Characterization of the minimum on binary integer numbers *)
+Notation Zmin_case := Z.min_case (compat "8.3").
+Notation Zmin_case_strong := Z.min_case_strong (compat "8.3").
+Notation Zle_min_l := Z.le_min_l (compat "8.3").
+Notation Zle_min_r := Z.le_min_r (compat "8.3").
+Notation Zmin_glb := Z.min_glb (compat "8.3").
+Notation Zmin_glb_lt := Z.min_glb_lt (compat "8.3").
+Notation Zle_min_compat_r := Z.min_le_compat_r (compat "8.3").
+Notation Zle_min_compat_l := Z.min_le_compat_l (compat "8.3").
+Notation Zmin_idempotent := Z.min_id (compat "8.3").
+Notation Zmin_n_n := Z.min_id (compat "8.3").
+Notation Zmin_comm := Z.min_comm (compat "8.3").
+Notation Zmin_assoc := Z.min_assoc (compat "8.3").
+Notation Zmin_irreducible_inf := Z.min_dec (compat "8.3").
+Notation Zsucc_min_distr := Z.succ_min_distr (compat "8.3").
+Notation Zmin_SS := Z.succ_min_distr (compat "8.3").
+Notation Zplus_min_distr_r := Z.add_min_distr_r (compat "8.3").
+Notation Zmin_plus := Z.add_min_distr_r (compat "8.3").
+Notation Zpos_min := Pos2Z.inj_min (compat "8.3").
 
-Definition Zmin_case := Z.min_case.
-Definition Zmin_case_strong := Z.min_case_strong.
+(** Slightly different lemmas *)
 
-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.
-
-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.
-
-(** * 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.
-
-(** * 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.
-
-(** * 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 : forall n m, Zmin n m = n \/ Zmin n m = m.
-Proof. intros; destruct (Z.min_dec n m); auto. Qed.
-
-Notation Zmin_or := Zmin_irreducible (only parsing).
-
-Lemma Zmin_le_prime_inf : forall n m p, Zmin n m <= p -> {n <= p} + {m <= p}.
-Proof. intros n m p; 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.
-
-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.
-
-Notation Zmin_plus := Z.plus_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 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 (compat "8.3").
 
+Lemma Zmin_le_prime_inf n m p : Z.min n m <= p -> {n <= p} + {m <= p}.
+Proof. apply Z.min_case; 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..ce589e28 100644
--- a/theories/ZArith/Zminmax.v
+++ b/theories/ZArith/Zminmax.v
@@ -1,202 +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-2012     *)
 (*   \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 *)
-Notation Zmin_max_absorption_r_r := Z.min_max_absorption (only parsing).
-Notation Zmax_min_absorption_r_r := Z.max_min_absorption (only parsing).
-Notation Zmax_min_distr_r := Z.max_min_distr (only parsing).
-Notation Zmin_max_distr_r := Z.min_max_distr (only parsing).
-Notation Zmax_min_modular_r := Z.max_min_modular (only parsing).
-Notation Zmin_max_modular_r := Z.min_max_modular (only parsing).
-Notation max_min_disassoc := Z.max_min_disassoc (only parsing).
-(*end hide*)
\ No newline at end of file
+Notation Zmin_max_absorption_r_r := Z.min_max_absorption (compat "8.3").
+Notation Zmax_min_absorption_r_r := Z.max_min_absorption (compat "8.3").
+Notation Zmax_min_distr_r := Z.max_min_distr (compat "8.3").
+Notation Zmin_max_distr_r := Z.min_max_distr (compat "8.3").
+Notation Zmax_min_modular_r := Z.max_min_modular (compat "8.3").
+Notation Zmin_max_modular_r := Z.min_max_modular (compat "8.3").
+Notation max_min_disassoc := Z.max_min_disassoc (compat "8.3").
+(*end hide*)
diff --git a/theories/ZArith/Zmisc.v b/theories/ZArith/Zmisc.v
index a8872bd5..d0ec1916 100644
--- a/theories/ZArith/Zmisc.v
+++ b/theories/ZArith/Zmisc.v
@@ -1,91 +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-2012     *)
 (*   \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.
 Require Import Zorder.
 Require Import Bool.
-Open Local Scope Z_scope.
+Local Open Scope Z_scope.
 
 (**********************************************************************)
 (** Iterators *)
 
 (** [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 (compat "8.3").
 
 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.
+  Z.iter n f x = iter_nat (Z.abs_nat n) A f x.
+Proof.
 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 Pos2Nat.inj_iter.
 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..27b7e6a0 100644
--- a/theories/ZArith/Znat.v
+++ b/theories/ZArith/Znat.v
@@ -1,286 +1,1017 @@
 (* -*- 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-2012     *)
 (*   \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.
+
+(** Conversions between integers and natural numbers
+
+    Seven sections:
+    - chains of conversions (combining two conversions)
+    - module N2Z : from N to Z
+    - module Z2N : from Z to N (negative numbers rounded to 0)
+    - module Zabs2N : from Z to N (via the absolute value)
+    - module Nat2Z : from nat to Z
+    - module Z2Nat : from Z to nat (negative numbers rounded to 0)
+    - module Zabs2Nat : from Z to nat (via the absolute value)
+*)
+
+(** * 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.
+
+Lemma Z_N_nat n : N.to_nat (Z.to_N n) = Z.to_nat n.
+Proof.
+ now destruct n.
+Qed.
+
+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.
+
+Lemma Zabs_N_nat n : N.to_nat (Z.abs_N n) = Z.abs_nat n.
+Proof.
+ now destruct n.
+Qed.
+
+Lemma Zabs_nat_N n : N.of_nat (Z.abs_nat n) = Z.abs_N n.
+Proof.
+ destruct n; simpl; trivial; apply positive_nat_N.
+Qed.
+
+
+(** * 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.
+ now destruct n.
+Qed.
+
+(** [Z.of_N] is hence injective *)
+
+Lemma inj n m : Z.of_N n = Z.of_N m -> n = m.
+Proof.
+ destruct n, m; simpl; congruence.
+Qed.
+
+Lemma inj_iff n m : Z.of_N n = Z.of_N m <-> n = m.
+Proof.
+ split. apply inj. intros; now f_equal.
+Qed.
+
+(** [Z.of_N] produce non-negative integers *)
+
+Lemma is_nonneg n : 0 <= Z.of_N n.
+Proof.
+ now destruct n.
+Qed.
+
+(** [Z.of_N], basic equations *)
+
+Lemma inj_0 : Z.of_N 0 = 0.
+Proof.
+ reflexivity.
+Qed.
+
+Lemma inj_pos p : Z.of_N (Npos p) = Zpos p.
+Proof.
+ reflexivity.
+Qed.
+
+(** [Z.of_N] and usual operations. *)
+
+Lemma inj_compare n m : (Z.of_N n ?= Z.of_N m) = (n ?= m)%N.
+Proof.
+ now destruct n, m.
+Qed.
+
+Lemma inj_le n m : (n<=m)%N <-> Z.of_N n <= Z.of_N m.
+Proof.
+ unfold Z.le. now rewrite inj_compare.
+Qed.
+
+Lemma inj_lt n m : (n<m)%N <-> Z.of_N n < Z.of_N m.
+Proof.
+ unfold Z.lt. now rewrite inj_compare.
+Qed.
+
+Lemma inj_ge n m : (n>=m)%N <-> Z.of_N n >= Z.of_N m.
+Proof.
+ unfold Z.ge. now rewrite inj_compare.
+Qed.
+
+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.
+
+Lemma inj_abs_N z : Z.of_N (Z.abs_N z) = Z.abs z.
+Proof.
+ now destruct z.
+Qed.
+
+Lemma inj_add n m : Z.of_N (n+m) = Z.of_N n + Z.of_N m.
+Proof.
+ now destruct n, m.
+Qed.
+
+Lemma inj_mul n m : Z.of_N (n*m) = Z.of_N n * Z.of_N m.
+Proof.
+ now destruct n, m.
+Qed.
+
+Lemma inj_sub_max n m : Z.of_N (n-m) = Z.max 0 (Z.of_N n - Z.of_N m).
+Proof.
+ 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.
+
+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.
+
+Lemma inj_succ n : Z.of_N (N.succ n) = Z.succ (Z.of_N n).
+Proof.
+ destruct n. trivial. simpl. now rewrite Pos.add_1_r.
+Qed.
+
+Lemma inj_pred_max n : Z.of_N (N.pred n) = Z.max 0 (Z.pred (Z.of_N n)).
+Proof.
+ unfold Z.pred. now rewrite N.pred_sub, inj_sub_max.
+Qed.
+
+Lemma inj_pred n : (0<n)%N -> Z.of_N (N.pred n) = Z.pred (Z.of_N n).
+Proof.
+ intros H. unfold Z.pred. rewrite N.pred_sub, inj_sub; trivial.
+ now apply N.le_succ_l in H.
+Qed.
+
+Lemma inj_min n m : Z.of_N (N.min n m) = Z.min (Z.of_N n) (Z.of_N m).
+Proof.
+ unfold Z.min, N.min. rewrite inj_compare. now case N.compare.
+Qed.
+
+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.
+
+Lemma inj_div n m : Z.of_N (n/m) = Z.of_N n / Z.of_N m.
+Proof.
+ 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.
+
+Lemma inj_mod n m : (m<>0)%N -> Z.of_N (n mod m) = (Z.of_N n) mod (Z.of_N m).
+Proof.
+ 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.
+
+Lemma inj_quot n m : Z.of_N (n/m) = Z.of_N n ÷ Z.of_N m.
+Proof.
+ destruct m.
+ - now destruct n.
+ - rewrite Z.quot_div_nonneg, inj_div; trivial. apply is_nonneg. easy.
+Qed.
+
+Lemma inj_rem n m : Z.of_N (n mod m) = Z.rem (Z.of_N n) (Z.of_N m).
+Proof.
+ destruct m.
+ - now destruct n.
+ - rewrite Z.rem_mod_nonneg, inj_mod; trivial. easy. apply is_nonneg. easy.
+Qed.
+
+Lemma inj_div2 n : Z.of_N (N.div2 n) = Z.div2 (Z.of_N n).
+Proof.
+ destruct n as [|p]; trivial. now destruct p.
+Qed.
+
+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.
+
+Lemma inj_pow n m : Z.of_N (n^m) = (Z.of_N n)^(Z.of_N m).
+Proof.
+ destruct n, m; trivial. now rewrite Z.pow_0_l. apply Pos2Z.inj_pow.
+Qed.
+
+Lemma inj_testbit a n :
+ Z.testbit (Z.of_N a) (Z.of_N n) = N.testbit a n.
+Proof. apply Z.Private_BootStrap.testbit_of_N. Qed.
+
+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.
+ destruct n; (now destruct 1) || trivial.
+Qed.
+
+(** [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.
+ intros. rewrite <- (id n), <- (id m) by trivial. now f_equal.
+Qed.
+
+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.
+
+Lemma inj_quot n m : 0<=n -> 0<=m -> Z.to_N (n÷m) = (Z.to_N n / Z.to_N m)%N.
+Proof.
+ destruct m.
+ - now destruct n.
+ - intros. now rewrite Z.quot_div_nonneg, inj_div.
+ - now destruct 2.
+Qed.
+
+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.
 
-(************************************************)
-(** Properties of the injection from nat into Z *)
+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.
+
+Lemma inj_testbit a n : 0<=n ->
+ Z.testbit (Z.of_N a) n = N.testbit a (Z.to_N n).
+Proof. apply Z.Private_BootStrap.testbit_of_N'. Qed.
+
+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 <- Pos2Z.opp_pos, Z.quot_opp_r, inj_opp.
+ - now rewrite <- Pos2Z.opp_pos, Z.quot_opp_l, inj_opp.
+ - now rewrite <- 2 Pos2Z.opp_pos, 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 <- Pos2Z.opp_pos, Z.rem_opp_r.
+ - now rewrite <- Pos2Z.opp_pos, Z.rem_opp_l, inj_opp.
+ - now rewrite <- 2 Pos2Z.opp_pos, 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 *)
+
+Lemma inj_0 : Z.of_nat 0 = 0.
+Proof.
+ reflexivity.
+Qed.
+
+Lemma inj_succ n : Z.of_nat (S n) = Z.succ (Z.of_nat n).
+Proof.
+ destruct n. trivial. simpl. apply Pos2Z.inj_succ.
+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.
 
-(** Injection and successor *)
+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.
 
-Theorem inj_0 : Z_of_nat 0 = 0%Z.
+Lemma inj_max n m : Z.of_nat (max n m) = Z.max (Z.of_nat n) (Z.of_nat m).
 Proof.
-  reflexivity.
+ now rewrite <- !nat_N_Z, Nat2N.inj_max, N2Z.inj_max.
 Qed.
 
-Theorem inj_S : forall n:nat, Z_of_nat (S n) = Zsucc (Z_of_nat n).
+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.
-  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 ].
+ intros. now rewrite <- Z_N_nat, <- nat_N_Z, N2Nat.id, Z2N.id.
 Qed.
 
-(** Injection and equality. *)
+(** [Z.to_nat] is hence injective for non-negative integers. *)
 
-Theorem inj_eq : forall n m:nat, n = m -> Z_of_nat n = Z_of_nat m.
+Lemma inj n m : 0<=n -> 0<=m -> Z.to_nat n = Z.to_nat m -> n = m.
 Proof.
-  intros x y H; rewrite H; trivial with arith.
+ intros. rewrite <- (id n), <- (id m) by trivial. now f_equal.
 Qed.
 
-Theorem inj_neq : forall n m:nat, neq n m -> Zne (Z_of_nat n) (Z_of_nat m).
+Lemma inj_iff n m : 0<=n -> 0<=m -> (Z.to_nat n = Z.to_nat 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 ].
+ intros. split. now apply inj. intros; now subst.
 Qed.
 
-Theorem inj_eq_rev : forall n m:nat, Z_of_nat n = Z_of_nat m -> n = m.
+(** [Z.to_nat], basic equations *)
+
+Lemma inj_0 : Z.to_nat 0 = O.
 Proof.
-  intros x y H.
-  destruct (eq_nat_dec x y) as [H'|H']; auto.
-  exfalso.
-  exact (inj_neq _ _ H' H).
+ reflexivity.
 Qed.
 
-Theorem inj_eq_iff : forall n m:nat, n=m <-> Z_of_nat n = Z_of_nat m.
+Lemma inj_pos n : Z.to_nat (Zpos n) = Pos.to_nat n.
 Proof.
- split; [apply inj_eq | apply inj_eq_rev].
+ reflexivity.
 Qed.
 
+Lemma inj_neg n : Z.to_nat (Zneg n) = O.
+Proof.
+ reflexivity.
+Qed.
 
-(** Injection and order relations: *)
+(** [Z.to_nat] and operations *)
 
-(** One way ... *)
+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.
 
-Theorem inj_le : forall n m:nat, (n <= m)%nat -> Z_of_nat n <= Z_of_nat m.
+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 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 ] ].
+ intros. now rewrite <- !Z_N_nat, Z2N.inj_mul, N2Nat.inj_mul.
 Qed.
 
-Theorem inj_lt : forall n m:nat, (n < m)%nat -> Z_of_nat n < Z_of_nat m.
+Lemma inj_succ n : 0<=n -> Z.to_nat (Z.succ n) = S (Z.to_nat n).
 Proof.
-  intros x y H; apply Zgt_lt; apply Zle_succ_gt; rewrite <- inj_S; apply inj_le;
-    exact H.
+ intros. now rewrite <- !Z_N_nat, Z2N.inj_succ, N2Nat.inj_succ.
 Qed.
 
-Theorem inj_ge : forall n m:nat, (n >= m)%nat -> Z_of_nat n >= Z_of_nat m.
+Lemma inj_sub n m : 0<=m -> Z.to_nat (n - m) = (Z.to_nat n - Z.to_nat m)%nat.
 Proof.
-  intros x y H; apply Zle_ge; apply inj_le; apply H.
+ intros. now rewrite <- !Z_N_nat, Z2N.inj_sub, N2Nat.inj_sub.
 Qed.
 
-Theorem inj_gt : forall n m:nat, (n > m)%nat -> Z_of_nat n > Z_of_nat m.
+Lemma inj_pred n : Z.to_nat (Z.pred n) = pred (Z.to_nat n).
 Proof.
-  intros x y H; apply Zlt_gt; apply inj_lt; exact H.
+ now rewrite <- !Z_N_nat, Z2N.inj_pred, N2Nat.inj_pred.
 Qed.
 
-(** The other way ... *)
+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.
 
-Theorem inj_le_rev : forall n m:nat, Z_of_nat n <= Z_of_nat m -> (n <= m)%nat.
+Lemma inj_le n m : 0<=n -> 0<=m -> (n<=m <-> (Z.to_nat n <= Z.to_nat m)%nat).
 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.
+ intros Hn Hm. unfold Z.le. now rewrite nat_compare_le, inj_compare.
 Qed.
 
-Theorem inj_lt_rev : forall n m:nat, Z_of_nat n < Z_of_nat m -> (n < m)%nat.
+Lemma inj_lt n m : 0<=n -> 0<=m -> (n<m <-> (Z.to_nat n < Z.to_nat m)%nat).
 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.
+ intros Hn Hm. unfold Z.lt. now rewrite nat_compare_lt, inj_compare.
 Qed.
 
-Theorem inj_ge_rev : forall n m:nat, Z_of_nat n >= Z_of_nat m -> (n >= m)%nat.
+Lemma inj_min n m : Z.to_nat (Z.min n m) = min (Z.to_nat n) (Z.to_nat 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 rewrite <- !Z_N_nat, Z2N.inj_min, N2Nat.inj_min.
 Qed.
 
-Theorem inj_gt_rev : forall n m:nat, Z_of_nat n > Z_of_nat m -> (n > m)%nat.
+Lemma inj_max n m : Z.to_nat (Z.max n m) = max (Z.to_nat n) (Z.to_nat 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.
+ now rewrite <- !Z_N_nat, Z2N.inj_max, N2Nat.inj_max.
 Qed.
 
-(* Both ways ... *)
+End Z2Nat.
 
-Theorem inj_le_iff : forall n m:nat, (n<=m)%nat <-> Z_of_nat n <= Z_of_nat m.
+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.
- split; [apply inj_le | apply inj_le_rev].
+ now destruct n.
 Qed.
 
-Theorem inj_lt_iff : forall n m:nat, (n<m)%nat <-> Z_of_nat n < Z_of_nat m.
+Lemma abs_nat_nonneg n : 0<=n -> Z.abs_nat n = Z.to_nat n.
 Proof.
- split; [apply inj_lt | apply inj_lt_rev].
+ destruct n; trivial; now destruct 1.
 Qed.
 
-Theorem inj_ge_iff : forall n m:nat, (n>=m)%nat <-> Z_of_nat n >= Z_of_nat m.
+Lemma id_abs n : Z.of_nat (Z.abs_nat n) = Z.abs n.
 Proof.
- split; [apply inj_ge | apply inj_ge_rev].
+ rewrite <-Zabs_N_nat, N_nat_Z. apply Zabs2N.id_abs.
 Qed.
 
-Theorem inj_gt_iff : forall n m:nat, (n>m)%nat <-> Z_of_nat n > Z_of_nat m.
+Lemma id n : Z.abs_nat (Z.of_nat n) = n.
 Proof.
- split; [apply inj_gt | apply inj_gt_rev].
+ now rewrite <-Zabs_N_nat, <-nat_N_Z, Zabs2N.id, Nat2N.id.
 Qed.
 
-(** Injection and usual operations *)
+(** [Z.abs_nat], basic equations *)
 
-Theorem inj_plus : forall n m:nat, Z_of_nat (n + m) = Z_of_nat n + Z_of_nat m.
+Lemma inj_0 : Z.abs_nat 0 = 0%nat.
 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 ].
+ reflexivity.
 Qed.
 
-Theorem inj_mult : forall n m:nat, Z_of_nat (n * m) = Z_of_nat n * Z_of_nat m.
+Lemma inj_pos p : Z.abs_nat (Zpos p) = Pos.to_nat p.
 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 ].
+ reflexivity.
 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_neg p : Z.abs_nat (Zneg p) = Pos.to_nat p.
 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.
+ reflexivity.
 Qed.
 
-Theorem inj_minus2 : forall n m:nat, (m > n)%nat -> Z_of_nat (n - m) = 0.
+(** [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 x y H; rewrite not_le_minus_0;
-    [ trivial with arith | apply gt_not_le; assumption ].
+ intros. now rewrite <- !Zabs_N_nat, Zabs2N.inj_succ, N2Nat.inj_succ.
 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_add n m : 0<=n -> 0<=m ->
+ Z.abs_nat (n+m) = (Z.abs_nat n + Z.abs_nat m)%nat.
 Proof.
- intros.
- rewrite Zmax_comm.
- unfold Zmax.
- destruct (le_lt_dec m n) as [H|H].
+ 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.
 
- 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_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.
 
- 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_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.
 
-Theorem inj_min : forall n m:nat,
-  Z_of_nat (min n m) = Zmin (Z_of_nat n) (Z_of_nat m).
+Lemma inj_le n m : 0<=n -> 0<=m -> (n<=m <-> (Z.abs_nat n <= Z.abs_nat m)%nat).
 Proof.
- induction n; destruct m; try (compute; auto; fail).
- simpl min.
- do 3 rewrite inj_S.
- rewrite <- Zsucc_min_distr; f_equal; auto.
+ intros Hn Hm. unfold Z.le. now rewrite nat_compare_le, inj_compare.
 Qed.
 
-Theorem inj_max : forall n m:nat,
-  Z_of_nat (max n m) = Zmax (Z_of_nat n) (Z_of_nat m).
+Lemma inj_lt n m : 0<=n -> 0<=m -> (n<m <-> (Z.abs_nat n < Z.abs_nat m)%nat).
 Proof.
- induction n; destruct m; try (compute; auto; fail).
- simpl max.
- do 3 rewrite inj_S.
- rewrite <- Zsucc_max_distr; f_equal; auto.
+ intros Hn Hm. unfold Z.lt. now rewrite nat_compare_lt, inj_compare.
 Qed.
 
-(** Composition of injections **)
+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.
 
-Theorem Zpos_eq_Z_of_nat_o_nat_of_P :
-  forall p:positive, Zpos p = Z_of_nat (nat_of_P p).
+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 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.
+ intros. now rewrite <- !Zabs_N_nat, Zabs2N.inj_max, N2Nat.inj_max.
 Qed.
 
-(** Misc *)
+(** [Z.abs_nat] and usual operations, statements with [Z.abs] *)
 
-Theorem intro_Z :
-  forall n:nat,  exists y : Z, Z_of_nat n = y /\ 0 <= y * 1 + 0.
+Lemma inj_succ_abs n : Z.abs_nat (Z.succ (Z.abs n)) = S (Z.abs_nat n).
 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 ].
+ now rewrite <- !Zabs_N_nat, Zabs2N.inj_succ_abs, N2Nat.inj_succ.
 Qed.
 
-Lemma Zpos_P_of_succ_nat : forall n:nat,
- Zpos (P_of_succ_nat n) = Zsucc (Z_of_nat n).
+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 (Pos.of_succ_nat n) = Z.succ (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 (compat "8.3").
+Notation inj_S := Nat2Z.inj_succ (compat "8.3").
+Notation inj_compare := Nat2Z.inj_compare (compat "8.3").
+Notation inj_eq_rev := Nat2Z.inj (compat "8.3").
+Notation inj_eq_iff := (fun n m => iff_sym (Nat2Z.inj_iff n m)) (compat "8.3").
+Notation inj_le_iff := Nat2Z.inj_le (compat "8.3").
+Notation inj_lt_iff := Nat2Z.inj_lt (compat "8.3").
+Notation inj_ge_iff := Nat2Z.inj_ge (compat "8.3").
+Notation inj_gt_iff := Nat2Z.inj_gt (compat "8.3").
+Notation inj_le_rev := (fun n m => proj2 (Nat2Z.inj_le n m)) (compat "8.3").
+Notation inj_lt_rev := (fun n m => proj2 (Nat2Z.inj_lt n m)) (compat "8.3").
+Notation inj_ge_rev := (fun n m => proj2 (Nat2Z.inj_ge n m)) (compat "8.3").
+Notation inj_gt_rev := (fun n m => proj2 (Nat2Z.inj_gt n m)) (compat "8.3").
+Notation inj_plus := Nat2Z.inj_add (compat "8.3").
+Notation inj_mult := Nat2Z.inj_mul (compat "8.3").
+Notation inj_minus1 := Nat2Z.inj_sub (compat "8.3").
+Notation inj_minus := Nat2Z.inj_sub_max (compat "8.3").
+Notation inj_min := Nat2Z.inj_min (compat "8.3").
+Notation inj_max := Nat2Z.inj_max (compat "8.3").
+
+Notation Z_of_nat_of_P := positive_nat_Z (compat "8.3").
+Notation Zpos_eq_Z_of_nat_o_nat_of_P :=
+  (fun p => eq_sym (positive_nat_Z p)) (compat "8.3").
+
+Notation Z_of_nat_of_N := N_nat_Z (compat "8.3").
+Notation Z_of_N_of_nat := nat_N_Z (compat "8.3").
+
+Notation Z_of_N_eq := (f_equal Z.of_N) (compat "8.3").
+Notation Z_of_N_eq_rev := N2Z.inj (compat "8.3").
+Notation Z_of_N_eq_iff := (fun n m => iff_sym (N2Z.inj_iff n m)) (compat "8.3").
+Notation Z_of_N_compare := N2Z.inj_compare (compat "8.3").
+Notation Z_of_N_le_iff := N2Z.inj_le (compat "8.3").
+Notation Z_of_N_lt_iff := N2Z.inj_lt (compat "8.3").
+Notation Z_of_N_ge_iff := N2Z.inj_ge (compat "8.3").
+Notation Z_of_N_gt_iff := N2Z.inj_gt (compat "8.3").
+Notation Z_of_N_le := (fun n m => proj1 (N2Z.inj_le n m)) (compat "8.3").
+Notation Z_of_N_lt := (fun n m => proj1 (N2Z.inj_lt n m)) (compat "8.3").
+Notation Z_of_N_ge := (fun n m => proj1 (N2Z.inj_ge n m)) (compat "8.3").
+Notation Z_of_N_gt := (fun n m => proj1 (N2Z.inj_gt n m)) (compat "8.3").
+Notation Z_of_N_le_rev := (fun n m => proj2 (N2Z.inj_le n m)) (compat "8.3").
+Notation Z_of_N_lt_rev := (fun n m => proj2 (N2Z.inj_lt n m)) (compat "8.3").
+Notation Z_of_N_ge_rev := (fun n m => proj2 (N2Z.inj_ge n m)) (compat "8.3").
+Notation Z_of_N_gt_rev := (fun n m => proj2 (N2Z.inj_gt n m)) (compat "8.3").
+Notation Z_of_N_pos := N2Z.inj_pos (compat "8.3").
+Notation Z_of_N_abs := N2Z.inj_abs_N (compat "8.3").
+Notation Z_of_N_le_0 := N2Z.is_nonneg (compat "8.3").
+Notation Z_of_N_plus := N2Z.inj_add (compat "8.3").
+Notation Z_of_N_mult := N2Z.inj_mul (compat "8.3").
+Notation Z_of_N_minus := N2Z.inj_sub_max (compat "8.3").
+Notation Z_of_N_succ := N2Z.inj_succ (compat "8.3").
+Notation Z_of_N_min := N2Z.inj_min (compat "8.3").
+Notation Z_of_N_max := N2Z.inj_max (compat "8.3").
+Notation Zabs_of_N := Zabs2N.id (compat "8.3").
+Notation Zabs_N_succ_abs := Zabs2N.inj_succ_abs (compat "8.3").
+Notation Zabs_N_succ := Zabs2N.inj_succ (compat "8.3").
+Notation Zabs_N_plus_abs := Zabs2N.inj_add_abs (compat "8.3").
+Notation Zabs_N_plus := Zabs2N.inj_add (compat "8.3").
+Notation Zabs_N_mult_abs := Zabs2N.inj_mul_abs (compat "8.3").
+Notation Zabs_N_mult := Zabs2N.inj_mul (compat "8.3").
+
+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..c1e01451 100644
--- a/theories/ZArith/Znumtheory.v
+++ b/theories/ZArith/Znumtheory.v
@@ -1,349 +1,217 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*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]
+     - a divisibility predicate [Z.divide]
      - a gcd predicate [gcd]
      - 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 (compat "8.3").
+Notation Zggcd := Z.ggcd (compat "8.3").
+Notation Zggcd_gcd := Z.ggcd_gcd (compat "8.3").
+Notation Zggcd_correct_divisors := Z.ggcd_correct_divisors (compat "8.3").
+Notation Zgcd_divide_l := Z.gcd_divide_l (compat "8.3").
+Notation Zgcd_divide_r := Z.gcd_divide_r (compat "8.3").
+Notation Zgcd_greatest := Z.gcd_greatest (compat "8.3").
+Notation Zgcd_nonneg := Z.gcd_nonneg (compat "8.3").
+Notation Zggcd_opp := Z.ggcd_opp (compat "8.3").
 
-Inductive Zdivide (a b:Z) : Prop :=
-    Zdivide_intro : forall q:Z, b = q * a -> Zdivide a b.
+(** The former specialized inductive predicate [Z.divide] is now
+    a generic existential predicate. *)
 
-(** Syntax for divisibility *)
+Notation Zdivide := Z.divide (compat "8.3").
 
-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.
+(** Results concerning divisibility*)
 
-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.
+Notation Zdivide_refl := Z.divide_refl (compat "8.3").
+Notation Zone_divide := Z.divide_1_l (compat "8.3").
+Notation Zdivide_0 := Z.divide_0_r (compat "8.3").
+Notation Zmult_divide_compat_l := Z.mul_divide_mono_l (compat "8.3").
+Notation Zmult_divide_compat_r := Z.mul_divide_mono_r (compat "8.3").
+Notation Zdivide_plus_r := Z.divide_add_r (compat "8.3").
+Notation Zdivide_minus_l := Z.divide_sub_r (compat "8.3").
+Notation Zdivide_mult_l := Z.divide_mul_l (compat "8.3").
+Notation Zdivide_mult_r := Z.divide_mul_r (compat "8.3").
+Notation Zdivide_factor_r := Z.divide_factor_l (compat "8.3").
+Notation Zdivide_factor_l := Z.divide_factor_r (compat "8.3").
 
-Hint Resolve Zmult_divide_compat_l Zmult_divide_compat_r: zarith.
+Lemma Zdivide_opp_r a b : (a | b) -> (a | - b).
+Proof. apply Z.divide_opp_r. Qed.
 
-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_rev a b : (a | - b) -> (a | b).
+Proof. apply Z.divide_opp_r. 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_l a b : (a | b) -> (- a | b).
+Proof. apply Z.divide_opp_l. 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.
+Lemma Zdivide_opp_l_rev a b : (- a | b) -> (a | b).
+Proof. apply Z.divide_opp_l. Qed.
 
-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.
+Theorem Zdivide_Zabs_l a b : (Z.abs a | b) -> (a | b).
+Proof. apply Z.divide_abs_l. Qed.
 
-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.
+Theorem Zdivide_Zabs_inv_l a b : (a | b) -> (Z.abs a | b).
+Proof. apply Z.divide_abs_l. 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_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_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_factor_r : forall a b:Z, (a | a * b).
-Proof.
-  intros; apply Zdivide_intro with b; ring.
-Qed.
-
-Lemma Zdivide_factor_l : forall a b:Z, (a | b * a).
-Proof.
-  intros; apply Zdivide_intro with b; ring.
-Qed.
-
-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.
+Hint Resolve Z.divide_refl Z.divide_1_l Z.divide_0_r: zarith.
+Hint Resolve Z.mul_divide_mono_l Z.mul_divide_mono_r: zarith.
+Hint Resolve Z.divide_add_r Zdivide_opp_r Zdivide_opp_r_rev Zdivide_opp_l
+  Zdivide_opp_l_rev Z.divide_sub_r Z.divide_mul_l Z.divide_mul_r
+  Z.divide_factor_l Z.divide_factor_r: 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 (compat "8.3").
 
 (** 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 (compat "8.3").
+Notation Zdivide_trans := Z.divide_trans (compat "8.3").
 
 (** 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]. *)
+(** [Z.divide] can be expressed using [Z.modulo]. *)
 
 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.
-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.
+ intros a b (c,->); apply Z_mod_mult.
 Qed.
 
-Theorem Zdivide_Zdiv_eq: forall a b : Z,
- 0 < a -> (a | b) ->  b = a * (b / a).
-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.
+(** [Z.divide] is hence decidable *)
 
-Theorem Zdivide_Zdiv_eq_2: forall a b c : Z,
- 0 < a -> (a | b) -> (c * b)/a = c * (b / a).
+Lemma Zdivide_dec a b : {(a | b)} + {~ (a | b)}.
 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). *)
 
-(** There is no unicity of the gcd; hence we define the predicate [gcd a b d]
-     expressing that [d] is a gcd of [a] and [b].
-     (We show later that the [gcd] is actually unique if we discard its sign.) *)
+(** There is no unicity of the gcd; hence we define the predicate
+    [Zis_gcd a b g] expressing that [g] is a gcd of [a] and [b].
+    (We show later that the [gcd] is actually unique if we discard its sign.) *)
 
-Inductive Zis_gcd (a b d:Z) : Prop :=
-  Zis_gcd_intro :
-  (d | a) ->
-  (d | b) -> (forall x:Z, (x | a) -> (x | b) -> (x | d)) -> Zis_gcd a b d.
+Inductive Zis_gcd (a b g:Z) : Prop :=
+ Zis_gcd_intro :
+  (g | a) ->
+  (g | b) ->
+  (forall x, (x | a) -> (x | b) -> (x | g)) ->
+  Zis_gcd a b g.
 
 (** 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 +226,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.
@@ -381,12 +248,10 @@ Hint Resolve Zis_gcd_sym Zis_gcd_0 Zis_gcd_minus Zis_gcd_opp: zarith.
 Theorem Zis_gcd_unique: forall a b c d : Z,
  Zis_gcd a b c -> Zis_gcd a b d ->  c = d \/ c = (- d).
 Proof.
-intros a b c d H1 H2.
-inversion_clear H1 as [Hc1 Hc2 Hc3].
-inversion_clear H2 as [Hd1 Hd2 Hd3].
-assert (H3: Zdivide c d); auto.
-assert (H4: Zdivide d c); auto.
-apply Zdivide_antisym; auto.
+intros a b c d [Hc1 Hc2 Hc3] [Hd1 Hd2 Hd3].
+assert (c|d) by auto.
+assert (d|c) by auto.
+apply Z.divide_antisym; auto.
 Qed.
 
 
@@ -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 :
@@ -440,7 +305,7 @@ Section extended_euclid_algorithm.
 	v1 * a + v2 * b = v3 ->
 	(forall d:Z, Zis_gcd u3 v3 d -> Zis_gcd a b d) -> Euclid.
   Proof.
-    intros v3 Hv3; generalize Hv3; pattern v3 in |- *.
+    intros v3 Hv3; generalize Hv3; pattern v3.
     apply Zlt_0_rec.
     clear v3 Hv3; intros.
     elim (Z_zerop x); intro.
@@ -454,8 +319,8 @@ Section extended_euclid_algorithm.
     apply Z_mod_lt; omega.
     assert (xpos : x > 0). omega.
     generalize (Z_div_mod_eq u3 x xpos).
-    unfold q in |- *.
-    intro eq; pattern u3 at 2 in |- *; rewrite eq; ring.
+    unfold q.
+    intro eq; pattern u3 at 2; rewrite eq; ring.
     apply (H (u3 - q * x) Hq (proj1 Hq) v1 v2 x (u1 - q * v1) (u2 - q * v2)).
     tauto.
     replace ((u1 - q * v1) * a + (u2 - q * v2) * b) with
@@ -492,7 +357,7 @@ Proof.
   intros H1 H2 H3; simple induction 1; intros.
   generalize (H3 d' H4 H5); intro Hd'd.
   generalize (H6 d H1 H2); intro Hdd'.
-  exact (Zdivide_antisym d d' Hdd' Hd'd).
+  exact (Z.divide_antisym d d' Hdd' Hd'd).
 Qed.
 
 (** * Bezout's coefficients *)
@@ -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.
 
@@ -584,21 +450,21 @@ Lemma rel_prime_cross_prod :
     rel_prime c d -> b > 0 -> d > 0 -> a * d = b * c -> a = c /\ b = d.
 Proof.
   intros a b c d; intros.
-  elim (Zdivide_antisym b d).
+  elim (Z.divide_antisym b d).
   split; auto with zarith.
   rewrite H4 in H3.
-  rewrite Zmult_comm in H3.
-  apply Zmult_reg_l with d; auto with zarith.
+  rewrite Z.mul_comm in H3.
+  apply Z.mul_reg_l with d; auto with zarith.
   intros; omega.
   apply Gauss with a.
   rewrite H3.
   auto with zarith.
-  red in |- *; auto with zarith.
+  red; auto with zarith.
   apply Gauss with c.
-  rewrite Zmult_comm.
+  rewrite Z.mul_comm.
   rewrite <- H3.
   auto with zarith.
-  red in |- *; auto with zarith.
+  red; auto with zarith.
 Qed.
 
 (** After factorization by a gcd, the original numbers are relatively prime. *)
@@ -613,7 +479,7 @@ Proof.
   elim H1; intros.
   elim H4; intros.
   rewrite H2 in H6; subst b; omega.
-  unfold rel_prime in |- *.
+  unfold rel_prime.
   destruct H1.
   destruct H1 as (a',H1).
   destruct H3 as (b',H3).
@@ -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)).
-  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.
+  destruct (H4 (x*g)) as (x',Hx').
+  exists xa; rewrite Z.mul_assoc; rewrite <- H5; auto.
+  exists xb; rewrite Z.mul_assoc; rewrite <- H6; auto.
+  replace g with (1*g) in Hx'; auto with zarith.
+  do 2 rewrite Z.mul_assoc in Hx'.
+  apply Z.mul_reg_r in Hx'; trivial.
+  rewrite Z.mul_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.
@@ -646,9 +512,9 @@ Theorem rel_prime_div: forall p q r,
 Proof.
   intros p q r H (u, H1); subst.
   inversion_clear H as [H1 H2 H3].
-  red; apply Zis_gcd_intro; try apply Zone_divide.
+  red; apply Zis_gcd_intro; try apply Z.divide_1_l.
   intros x H4 H5; apply H3; auto.
-  apply Zdivide_mult_r; auto.
+  apply Z.divide_mul_r; auto.
 Qed.
 
 Theorem rel_prime_1: forall n, rel_prime 1 n.
@@ -709,30 +575,29 @@ Lemma prime_divisors :
   forall p:Z,
     prime p -> forall a:Z, (a | p) -> a = -1 \/ a = 1 \/ a = p \/ a = - p.
 Proof.
-  simple induction 1; intros.
+  destruct 1; intros.
   assert
     (a = - p \/ - p < a < -1 \/ a = -1 \/ a = 0 \/ a = 1 \/ 1 < a < p \/ a = p).
-  assert (Zabs a <= Zabs p). apply Zdivide_bounds; [ assumption | omega ].
-  generalize H3.
-  pattern (Zabs a) in |- *; apply Zabs_ind; pattern (Zabs p) in |- *;
-    apply Zabs_ind; intros; omega.
+  { assert (Z.abs a <= Z.abs p) as H2.
+      apply Zdivide_bounds; [ assumption | omega ].
+    revert H2.
+    pattern (Z.abs a); apply Zabs_ind; pattern (Z.abs p); apply Zabs_ind;
+    intros; omega. }
   intuition idtac.
   (* -p < a < -1 *)
-  absurd (rel_prime (- a) p); intuition.
-  inversion H3.
-  assert (- a | - a); auto with zarith.
-  assert (- a | p); auto with zarith.
-  generalize (H8 (- a) H9 H10); intuition idtac.
-  generalize (Zdivide_1 (- a) H11); intuition.
+  - absurd (rel_prime (- a) p); intuition.
+    inversion H2.
+    assert (- a | - a) by auto with zarith.
+    assert (- a | p) by auto with zarith.
+    apply H7, Z.divide_1_r in H8; intuition.
   (* a = 0 *)
-  inversion H2. subst a; omega.
+  - inversion H1. subst a; omega.
   (* 1 < a < p *)
-  absurd (rel_prime a p); intuition.
-  inversion H3.
-  assert (a | a); auto with zarith.
-  assert (a | p); auto with zarith.
-  generalize (H8 a H9 H10); intuition idtac.
-  generalize (Zdivide_1 a H11); intuition.
+  - absurd (rel_prime a p); intuition.
+    inversion H2.
+    assert (a | a) by auto with zarith.
+    assert (a | p) by auto with zarith.
+    apply H7, Z.divide_1_r in H8; intuition.
 Qed.
 
 (** A prime number is relatively prime with any number it does not divide *)
@@ -757,7 +622,7 @@ Proof.
   intros a p Hp [H1 H2].
   apply rel_prime_sym; apply prime_rel_prime; auto.
   intros [q Hq]; subst a.
-  case (Zle_or_lt q 0); intros Hl.
+  case (Z.le_gt_cases q 0); intros Hl.
   absurd (q * p <= 0 * p); auto with zarith.
   absurd (1 * p <= q * p); auto with zarith.
 Qed.
@@ -787,87 +652,79 @@ Qed.
 Lemma prime_2: prime 2.
 Proof.
   apply prime_intro; auto with zarith.
-  intros n [H1 H2]; case Zle_lt_or_eq with ( 1 := H1 ); auto with zarith;
-   clear H1; intros H1.
-  contradict H2; auto with zarith.
-  subst n; red; auto with zarith.
-  apply Zis_gcd_intro; auto with zarith.
+  intros n (H,H'); Z.le_elim H; auto with zarith.
+  - contradict H'; auto with zarith.
+  - subst n. constructor; auto with zarith.
 Qed.
 
 Theorem prime_3: prime 3.
 Proof.
   apply prime_intro; auto with zarith.
-  intros n [H1 H2]; case Zle_lt_or_eq with ( 1 := H1 ); auto with zarith;
-   clear H1; intros H1.
-  case (Zle_lt_or_eq 2 n); auto with zarith; clear H1; intros H1.
-  contradict H2; auto with zarith.
-  subst n; red; auto with zarith.
-  apply Zis_gcd_intro; auto with zarith.
-  intros x [q1 Hq1] [q2 Hq2].
-  exists (q2 - q1).
-  apply trans_equal with (3 - 2); auto with zarith.
-  rewrite Hq1; rewrite Hq2; ring.
-  subst n; red; auto with zarith.
-  apply Zis_gcd_intro; auto with zarith.
+  intros n (H,H'); Z.le_elim H; auto with zarith.
+  - replace n with 2 by omega.
+    constructor; auto with zarith.
+    intros x (q,Hq) (q',Hq').
+    exists (q' - q). ring_simplify. now rewrite <- Hq, <- Hq'.
+  - replace n with 1 by trivial.
+    constructor; auto with zarith.
 Qed.
 
-Theorem prime_ge_2: forall p, prime p ->  2 <= p.
+Theorem prime_ge_2 p : prime p ->  2 <= p.
 Proof.
-  intros p Hp; inversion Hp; auto with zarith.
+  intros (Hp,_); auto with zarith.
 Qed.
 
 Definition prime' p := 1<p /\ (forall n, 1<n<p -> ~ (n|p)).
 
-Theorem prime_alt:
- forall p, prime' p <-> prime p.
+Lemma Z_0_1_more x : 0<=x -> x=0 \/ x=1 \/ 1<x.
 Proof.
-  split; destruct 1; intros.
-  (* prime -> prime' *)
-  constructor; auto; intros.
-  red; apply Zis_gcd_intro; auto with zarith; intros.
-  case (Zle_lt_or_eq 0 (Zabs x)); auto with zarith; intros H6.
-  case (Zle_lt_or_eq 1 (Zabs x)); auto with zarith; intros H7.
-  case (Zle_lt_or_eq (Zabs x) p); auto with zarith.
-  apply Zdivide_le; auto with zarith.
-  apply Zdivide_Zabs_inv_l; auto.
-  intros H8; case (H0 (Zabs x)); auto.
-  apply Zdivide_Zabs_inv_l; auto.
-  intros H8; subst p; absurd (Zabs x <= n); auto with zarith.
-  apply Zdivide_le; auto with zarith.
-  apply Zdivide_Zabs_inv_l; auto.
-  rewrite H7; pattern (Zabs x); apply Zabs_intro; auto with zarith.
-  absurd (0%Z = p); auto with zarith.
-  assert (x=0) by (destruct x; simpl in *; now auto).
-  subst x; elim H3; intro q; rewrite Zmult_0_r; auto.
-  (* prime' -> prime *)
-  split; auto; intros.
-  intros H2.
-  case (Zis_gcd_unique n p n 1); auto with zarith.
-  apply Zis_gcd_intro; auto with zarith.
-  apply H0; auto with zarith.
+ intros H. Z.le_elim H; auto.
+ apply Z.le_succ_l in H. change (1 <= x) in H. Z.le_elim H; auto.
+Qed.
+
+Theorem prime_alt p : prime' p <-> prime p.
+Proof.
+  split; intros (Hp,H).
+  - (* prime -> prime' *)
+    constructor; trivial; intros n Hn.
+    constructor; auto with zarith; intros x Hxn Hxp.
+    rewrite <- Z.divide_abs_l in Hxn, Hxp |- *.
+    assert (Hx := Z.abs_nonneg x).
+    set (y:=Z.abs x) in *; clearbody y; clear x; rename y into x.
+    destruct (Z_0_1_more x Hx) as [->|[->|Hx']].
+    + exfalso. apply Z.divide_0_l in Hxn. omega.
+    + now exists 1.
+    + elim (H x); auto.
+      split; trivial.
+      apply Z.le_lt_trans with n; auto with zarith.
+      apply Z.divide_pos_le; auto with zarith.
+  - (* prime' -> prime *)
+    constructor; trivial. intros n Hn Hnp.
+    case (Zis_gcd_unique n p n 1); auto with zarith.
+    constructor; auto with zarith.
+    apply H; auto with zarith.
 Qed.
 
 Theorem square_not_prime: forall a, ~ prime (a * a).
 Proof.
   intros a Ha.
-  rewrite <- (Zabs_square a) in Ha.
-  assert (0 <= Zabs a) by auto with zarith.
-  set (b:=Zabs a) in *; clearbody b.
-  rewrite <- prime_alt in Ha; destruct Ha.
-  case (Zle_lt_or_eq 0 b); auto with zarith; intros Hza1; [ | subst; omega].
-  case (Zle_lt_or_eq 1 b); auto with zarith; intros Hza2; [ | subst; omega].
-  assert (Hza3 := Zmult_lt_compat_r 1 b b Hza1 Hza2).
-  rewrite Zmult_1_l in Hza3.
-  elim (H1 _ (conj Hza2 Hza3)).
-  exists b; auto.
+  rewrite <- (Z.abs_square a) in Ha.
+  assert (H:=Z.abs_nonneg a).
+  set (b:=Z.abs a) in *; clearbody b; clear a; rename b into a.
+  rewrite <- prime_alt in Ha; destruct Ha as (Ha,Ha').
+  assert (H' : 1 < a) by now apply (Z.square_lt_simpl_nonneg 1).
+  apply (Ha' a).
+  + split; trivial.
+    rewrite <- (Z.mul_1_l a) at 1. apply Z.mul_lt_mono_pos_r; omega.
+  + exists a; auto.
 Qed.
 
 Theorem prime_div_prime: forall p q,
  prime p -> prime q -> (p | q) -> p = q.
 Proof.
   intros p q H H1 H2;
-  assert (Hp: 0 < p); try apply Zlt_le_trans with 2; try apply prime_ge_2; auto with zarith.
-  assert (Hq: 0 < q); try apply Zlt_le_trans with 2; try apply prime_ge_2; auto with zarith.
+  assert (Hp: 0 < p); try apply Z.lt_le_trans with 2; try apply prime_ge_2; auto with zarith.
+  assert (Hq: 0 < q); try apply Z.lt_le_trans with 2; try apply prime_ge_2; auto with zarith.
   case prime_divisors with (2 := H2); auto.
   intros H4; contradict Hp; subst; auto with zarith.
   intros [H4| [H4 | H4]]; subst; auto.
@@ -875,311 +732,101 @@ 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
-*)
-
-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.
-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.
+Notation Zgcd_is_pos := Z.gcd_nonneg (compat "8.3").
 
-Lemma Pgcdn_correct : forall n a b, (Psize a + Psize b<=n)%nat ->
-  Zis_gcd (Zpos a) (Zpos b) (Zpos (Pgcdn n a b)).
+Lemma Zgcd_is_gcd : forall a b, Zis_gcd a b (Z.gcd 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.
+  case (Zis_gcd_uniqueness_apart_sign a b c (Z.gcd 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 (compat "8.3").
+Notation Zgcd_inv_0_r := Z.gcd_eq_0_r (compat "8.3").
 
 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.
-  repeat rewrite Zmult_assoc; f_equal.
-  rewrite Zmult_comm.
+  pattern b at 2; rewrite (Zdivide_Zdiv_eq (Z.gcd a b) b); auto.
+  repeat rewrite Z.mul_assoc; f_equal.
+  rewrite Z.mul_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].
-  pattern b at 2; rewrite (Zdivide_Zdiv_eq (Zgcd a b) b); auto.
-  repeat rewrite Zmult_assoc; f_equal.
+  pattern b at 2; rewrite (Zdivide_Zdiv_eq (Z.gcd a b) b); auto.
+  repeat rewrite Z.mul_assoc; f_equal.
   rewrite Zdivide_Zdiv_eq_2; auto.
-  repeat rewrite <- Zmult_assoc; f_equal.
-  rewrite Zmult_comm.
+  repeat rewrite <- Z.mul_assoc; f_equal.
+  rewrite Z.mul_comm.
   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.
+Notation Zgcd_comm := Z.gcd_comm (compat "8.3").
 
-Lemma Zgcd_ass : forall a b c, Zgcd (Zgcd a b) c = Zgcd a (Zgcd b c).
+Lemma Zgcd_ass a b c : Z.gcd (Z.gcd a b) c = Z.gcd a (Z.gcd 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.
+ symmetry. apply Z.gcd_assoc.
 Qed.
 
-Lemma Zgcd_Zabs : forall a b, Zgcd (Zabs a) b = Zgcd a b.
-Proof.
-  destruct a; simpl; auto.
-Qed.
-
-Lemma Zgcd_0 : forall a, Zgcd a 0 = Zabs a.
-Proof.
-  destruct a; simpl; auto.
-Qed.
+Notation Zgcd_Zabs := Z.gcd_abs_l (compat "8.3").
+Notation Zgcd_0 := Z.gcd_0_r (compat "8.3").
+Notation Zgcd_1 := Z.gcd_1_r (compat "8.3").
 
-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.
+Hint Resolve Z.gcd_0_r Z.gcd_1_r : 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.
-  case (Zis_gcd_unique a b (Zgcd a b) 1); auto.
+  case (Zis_gcd_unique a b (Z.gcd a b) 1); auto.
   apply Zgcd_is_gcd.
-  intros H2; absurd (0 <= Zgcd a b); auto with zarith.
-  generalize (Zgcd_is_pos a b); auto with zarith.
+  intros H2; absurd (0 <= Z.gcd a b); auto with zarith.
+  generalize (Z.gcd_nonneg a b); auto with zarith.
 Qed.
 
 Definition rel_prime_dec: forall a b,
  { rel_prime a b }+{ ~ rel_prime a b }.
 Proof.
-  intros a b; case (Z_eq_dec (Zgcd a b) 1); intros H1.
+  intros a b; case (Z.eq_dec (Z.gcd a b) 1); intros H1.
   left; apply -> Zgcd_1_rel_prime; auto.
   right; contradict H1; apply <- Zgcd_1_rel_prime; auto.
 Defined.
@@ -1197,25 +844,24 @@ Proof.
   intros x Hx IH; destruct IH as [F|E].
   destruct (rel_prime_dec x p) as [Y|N].
   left; intros n [HH1 HH2].
-  case (Zgt_succ_gt_or_eq x n); auto with zarith.
-  intros HH3; subst x; auto.
-  case (Z_lt_dec 1 x); intros HH1.
-  right; exists x; split; auto with zarith.
-  left; intros n [HHH1 HHH2]; contradict HHH1; auto with zarith.
-  right; destruct E as (n,((H0,H2),H3)); exists n; auto with zarith.
+  rewrite Z.lt_succ_r in HH2.
+  Z.le_elim HH2; subst; auto with zarith.
+  - case (Z_lt_dec 1 x); intros HH1.
+    * right; exists x; split; auto with zarith.
+    * left; intros n [HHH1 HHH2]; contradict HHH1; auto with zarith.
+  - right; destruct E as (n,((H0,H2),H3)); exists n; auto with zarith.
 Defined.
 
 Definition prime_dec: forall p, { prime p }+{ ~ prime p }.
 Proof.
   intros p; case (Z_lt_dec 1 p); intros H1.
-  case (prime_dec_aux p p); intros H2.
-  left; apply prime_intro; auto.
-  intros n [Hn1 Hn2]; case Zle_lt_or_eq with ( 1 := Hn1 ); auto.
-  intros HH; subst n.
-  red; apply Zis_gcd_intro; auto with zarith.
-  right; intros H3; inversion_clear H3 as [Hp1 Hp2].
-  case H2; intros n [Hn1 Hn2]; case Hn2; auto with zarith.
-  right; intros H3; inversion_clear H3 as [Hp1 Hp2]; case H1; auto.
+  + case (prime_dec_aux p p); intros H2.
+    * left; apply prime_intro; auto.
+      intros n (Hn1,Hn2). Z.le_elim Hn1; auto; subst n.
+      constructor; auto with zarith.
+    * right; intros H3; inversion_clear H3 as [Hp1 Hp2].
+      case H2; intros n [Hn1 Hn2]; case Hn2; auto with zarith.
+  + right; intros H3; inversion_clear H3 as [Hp1 Hp2]; case H1; auto.
 Defined.
 
 Theorem not_prime_divide:
@@ -1223,193 +869,16 @@ Theorem not_prime_divide:
 Proof.
   intros p Hp Hp1.
   case (prime_dec_aux p p); intros H1.
-  elim Hp1; constructor; auto.
-  intros n [Hn1 Hn2].
-  case Zle_lt_or_eq with ( 1 := Hn1 ); auto with zarith.
-  intros H2; subst n; red; apply Zis_gcd_intro; auto with zarith.
-  case H1; intros n [Hn1 Hn2].
-  generalize (Zgcd_is_pos n p); intros Hpos.
-  case (Zle_lt_or_eq 0 (Zgcd n p)); auto with zarith; intros H3.
-  case (Zle_lt_or_eq 1 (Zgcd n p)); auto with zarith; intros H4.
-  exists (Zgcd n p); split; auto.
-  split; auto.
-  apply Zle_lt_trans with n; auto with zarith.
-  generalize (Zgcd_is_gcd n p); intros tmp; inversion_clear tmp as [Hr1 Hr2 Hr3].
-  case Hr1; intros q Hq.
-  case (Zle_or_lt q 0); auto with zarith; intros Ht.
-  absurd (n <= 0 * Zgcd n p) ; auto with zarith.
-  pattern n at 1; rewrite Hq; auto with zarith.
-  apply Zle_trans with (1 * Zgcd n p); auto with zarith.
-  pattern n at 2; rewrite Hq; auto with zarith.
-  generalize (Zgcd_is_gcd n p); intros Ht; inversion Ht; auto.
-  case Hn2; red.
-  rewrite H4; apply Zgcd_is_gcd.
-  generalize (Zgcd_is_gcd n p); rewrite <- H3; intros tmp;
-  inversion_clear tmp as [Hr1 Hr2 Hr3].
-  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.
+  - elim Hp1; constructor; auto.
+    intros n (Hn1,Hn2).
+    Z.le_elim Hn1; auto with zarith.
+    subst n; constructor; auto with zarith.
+  - case H1; intros n (Hn1,Hn2).
+    destruct (Z_0_1_more _ (Z.gcd_nonneg n p)) as [H|[H|H]].
+    + exfalso. apply Z.gcd_eq_0_l in H. omega.
+    + elim Hn2. red. rewrite <- H. apply Zgcd_is_gcd.
+    + exists (Z.gcd n p); split; [ split; auto | apply Z.gcd_divide_r ].
+      apply Z.le_lt_trans with n; auto with zarith.
+      apply Z.divide_pos_le; auto with zarith.
+      apply Z.gcd_divide_l.
 Qed.
diff --git a/theories/ZArith/Zorder.v b/theories/ZArith/Zorder.v
index 91c16929..b1d1f8b5 100644
--- a/theories/ZArith/Zorder.v
+++ b/theories/ZArith/Zorder.v
@@ -1,337 +1,202 @@
 (* -*- 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-2012     *)
 (*   \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.
+Notation dec_eq := Z.eq_decidable (compat "8.3").
+Notation dec_Zle := Z.le_decidable (compat "8.3").
+Notation dec_Zlt := Z.lt_decidable (compat "8.3").
 
-Theorem dec_Zle : forall n m:Z, decidable (n <= m).
+Theorem dec_Zne n m : decidable (Zne 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 ].
+  destruct (Z.eq_decidable n m); [right|left]; subst; auto.
 Qed.
 
-Theorem dec_Zgt : forall n m:Z, decidable (n > m).
+Theorem dec_Zgt n m : decidable (n > m).
 Proof.
-  intros x y; unfold decidable, Zgt in |- *; elim (x ?= y);
-    [ right; discriminate | right; discriminate | auto with arith ].
+  destruct (Z.lt_decidable m n); [left|right]; Z.swap_greater; auto.
 Qed.
 
-Theorem dec_Zge : forall n m:Z, decidable (n >= m).
+Theorem dec_Zge 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.le_decidable m n); [left|right]; Z.swap_greater; auto.
 Qed.
 
-Theorem dec_Zlt : forall n m:Z, decidable (n < m).
+Theorem not_Zeq n m : n <> m -> n < m \/ m < n.
 Proof.
-  intros x y; unfold decidable, Zlt in |- *; elim (x ?= y);
-    [ right; discriminate | auto with arith | right; discriminate ].
-Qed.
-
-Theorem not_Zeq : forall n m:Z, 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.
+Notation Zgt_lt := Z.gt_lt (compat "8.3").
+Notation Zlt_gt := Z.lt_gt (compat "8.3").
+Notation Zge_le := Z.ge_le (compat "8.3").
+Notation Zle_ge := Z.le_ge (compat "8.3").
+Notation Zgt_iff_lt := Z.gt_lt_iff (compat "8.3").
+Notation Zge_iff_le := Z.ge_le_iff (compat "8.3").
 
-Lemma Zlt_gt : forall n m:Z, n < m -> m > n.
+Lemma Zle_not_lt n m : n <= m -> ~ m < n.
 Proof.
-  unfold Zgt, Zlt in |- *; intros m n H; elim (Zcompare_Gt_Lt_antisym n m);
-    auto with arith.
+ apply Z.le_ngt.
 Qed.
 
-Lemma Zge_le : 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 Zgt_lt; assumption.
+ apply Z.lt_nge.
 Qed.
 
-Lemma Zle_ge : forall n m:Z, 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.
-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.
-Proof.
-  intros n m H1 H2; apply H2; assumption.
-Qed.
-
-Lemma Zle_not_lt : forall n m:Z, n <= m -> ~ m < n.
-Proof.
-  intros n m H1 H2.
-  assert (H3 := Zlt_gt _ _ H2).
-  apply Zle_not_gt with n m; assumption.
-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.
+Lemma Zgt_not_le n m : n > m -> ~ n <= m.
 Proof.
-  unfold Zge, Zlt in |- *; intros x y H; apply dec_not_not;
-    [ exact (dec_Zlt x y) | assumption ].
+  Z.swap_greater. apply Z.lt_nge.
 Qed.
 
-Lemma Znot_lt_ge : forall n m:Z, ~ n < m -> n >= m.
+Lemma Znot_ge_lt n m : ~ n >= m -> n < m.
 Proof.
-  unfold Zlt, Zge in |- *; auto with arith.
+  Z.swap_greater. apply Z.nle_gt.
 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.
-
-Lemma Zeq_le : forall n m:Z, n = m -> n <= m.
-Proof.
-  intros; rewrite H; apply Zle_refl.
-Qed.
+Notation Zle_refl := Z.le_refl (compat "8.3").
+Notation Zeq_le := Z.eq_le_incl (compat "8.3").
 
-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 (compat "8.3").
 
 (** 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 (compat "8.3").
 
-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.
+Notation Zlt_irrefl := Z.lt_irrefl (compat "8.3").
+Notation Zlt_not_eq := Z.lt_neq (compat "8.3").
 
-Lemma Zlt_irrefl : forall n:Z, ~ n < n.
+Lemma Zgt_irrefl n : ~ n > n.
 Proof.
-  intros n H; apply (Zlt_asym n n H H).
-Qed.
-
-Lemma Zlt_not_eq : forall n m:Z, n < m -> n <> m.
-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.
+Notation Zlt_le_weak := Z.lt_le_incl (compat "8.3").
+Notation Zle_lt_or_eq_iff := Z.lt_eq_cases (compat "8.3").
 
-Lemma Zle_lt_or_eq : forall n m:Z, n <= m -> n < m \/ n = m.
+Lemma Zle_lt_or_eq n m : 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.
-
-Lemma Zle_lt_or_eq_iff : forall n m, n <= m <-> n < m \/ n = m.
-Proof.
-  unfold Zle, Zlt. intros.
-  generalize (Zcompare_Eq_iff_eq n m).
-  destruct (n ?= m); intuition; discriminate.
+  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 (compat "8.3").
 
 (** 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 (compat "8.3").
 
-Lemma Zlt_trans : forall n m p:Z, n < m -> m < p -> n < p.
+Lemma Zgt_trans n m p : n > m -> m > p -> n > p.
 Proof.
-  exact Zcompare_Lt_trans.
+  Z.swap_greater. intros; now transitivity m.
 Qed.
 
 (** 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 (compat "8.3").
+Notation Zle_lt_trans := Z.le_lt_trans (compat "8.3").
 
-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 ].
-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 ].
+  Z.swap_greater. Z.order.
 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 (compat "8.3").
 
-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 +204,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 (compat "8.3").
+Notation Zlt_pred := Z.lt_pred_l (compat "8.3").
 
-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 (compat "8.3").
+Notation Zle_succ_l := Z.le_succ_l (compat "8.3").
 
-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.
+Notation Zle_succ := Z.le_succ_diag_r (compat "8.3").
+Notation Zle_pred := Z.le_pred_l (compat "8.3").
+Notation Zlt_lt_succ := Z.lt_lt_succ_r (compat "8.3").
+Notation Zle_le_succ := Z.le_le_succ_r (compat "8.3").
 
-Lemma Zle_pred : forall n:Z, Zpred n <= n.
+Lemma Zle_succ_le n m : Z.succ n <= m -> n <= m.
 Proof.
-  intros n; pattern n at 2 in |- *; rewrite Zsucc_pred; apply Zle_succ.
+  intros. now apply Z.lt_le_incl, Z.le_succ_l.
 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.
-
-Lemma Zle_le_succ : forall n m:Z, n <= m -> n <= Zsucc 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 ].
-Qed.
-
-Hint Resolve Zle_le_succ: zarith.
+Hint Resolve Z.le_succ_diag_r: zarith.
+Hint Resolve Z.le_le_succ_r: 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 (compat "8.3").
+Notation Zle_0_1 := Z.le_0_1 (compat "8.3").
 
 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) *)
+(* weaker but useful (in [Z.pow] 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.
+Hint Immediate Z.eq_le_incl: zarith.
 
 (** 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 (compat "8.3").
+Notation Zplus_le_lt_compat := Z.add_le_lt_mono (compat "8.3").
+Notation Zplus_le_compat := Z.add_le_mono (compat "8.3").
+Notation Zplus_lt_compat := Z.add_lt_mono (compat "8.3").
 
-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 (compat "8.3").
 
 (** 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 (compat "8.3").
+Notation Zmult_lt_0_compat := Z.mul_pos_pos (compat "8.3").
+Notation Zmult_lt_O_compat := Z.mul_pos_pos (compat "8.3").
+
+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 (compat "8.3").
+Notation Zlt_plus_swap := Z.lt_add_lt_sub_r (compat "8.3").
+Notation Zlt_minus_simpl_swap := Z.lt_sub_pos (compat "8.3").
 
-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..f3eb63a8
--- /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-2012     *)
+(*   \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, Pos2Z.inj_pow.
+Qed.
diff --git a/theories/ZArith/Zpow_def.v b/theories/ZArith/Zpow_def.v
index 620d6324..a1c60bf2 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-2012     *)
+(*   \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 (compat "8.3").
+Notation Zpower := Z.pow (compat "8.3").
+Notation Zpower_0_r := Z.pow_0_r (compat "8.3").
+Notation Zpower_succ_r := Z.pow_succ_r (compat "8.3").
+Notation Zpower_neg_r := Z.pow_neg_r (compat "8.3").
+Notation Zpower_Ppow := Pos2Z.inj_pow (compat "8.3").
+
+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..8ff641a3 100644
--- a/theories/ZArith/Zpow_facts.v
+++ b/theories/ZArith/Zpow_facts.v
@@ -1,298 +1,112 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*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 (compat "8.3").
+Notation Zpower_1_l := Z.pow_1_l (compat "8.3").
+Notation Zpower_0_l := Z.pow_0_l' (compat "8.3").
+Notation Zpower_0_r := Z.pow_0_r (compat "8.3").
+Notation Zpower_2 := Z.pow_2_r (compat "8.3").
+Notation Zpower_gt_0 := Z.pow_pos_nonneg (compat "8.3").
+Notation Zpower_ge_0 := Z.pow_nonneg (compat "8.3").
+Notation Zpower_Zabs := Z.abs_pow (compat "8.3").
+Notation Zpower_Zsucc := Z.pow_succ_r (compat "8.3").
+Notation Zpower_mult := Z.pow_mul_r (compat "8.3").
+Notation Zpower_le_monotone2 := Z.pow_le_mono_r (compat "8.3").
 
-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 Pos2Z.inj_xI, Nat2Z.inj_succ, Z.pow_succ_r; omega.
+  - specialize IHn with p.
+    rewrite Pos2Z.inj_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 *)
+(** * Z.pow 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 **)
+(** A direct way to compute Z.pow modulo **)
 
 Fixpoint Zpow_mod_pos (a: Z)(m: positive)(n : Z) : Z :=
   match m with
@@ -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.
+(** * Z.square: a direct definition of [z^2] *)
 
-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 (compat "8.3").
+Notation Zsquare := Z.square (compat "8.3").
+Notation Psquare_correct := Pos.square_spec (compat "8.3").
+Notation Zsquare_correct := Z.square_spec (compat "8.3").
diff --git a/theories/ZArith/Zpower.v b/theories/ZArith/Zpower.v
index 038748b5..0d9b08d6 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-2012     *)
 (*   \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.
+Hint Unfold Z.pow_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) = Z.pow_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 Pos2Z.inj_xI, Z.mul_add_distr_r in H.
+     rewrite Z.mul_shuffle3, Z.mul_assoc. omega.
+   - rewrite Pos2Z.inj_xO in H.
+     rewrite Z.mul_shuffle3, Z.mul_assoc. omega.
+   - rewrite Pos2Z.neg_xI, Z.mul_sub_distr_r in H.
+     rewrite Z.mul_sub_distr_r, Z.mul_shuffle3, Z.mul_assoc. omega.
+   - rewrite Pos2Z.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..c02f0ae6
--- /dev/null
+++ b/theories/ZArith/Zquot.v
@@ -0,0 +1,453 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+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 [Z.quotrem], whose projections are [Z.quot] (noted ÷)
+  and [Z.rem].
+
+  This division and [Z.div] agree only on positive numbers.
+  Otherwise, [Z.div] performs Round-Toward-Bottom (a.k.a Floor).
+
+  This [Z.quot] 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.
+
+  The definition of this division is now in file [BinIntDef],
+  while most of the results about here are now in the main module
+  [BinInt.Z], thanks to the generic "Numbers" layer. Remain here:
+
+  - some compatibility notation for old names.
+
+  - some extra results with less preconditions (in particular
+      exploiting the arbitrary value of division by 0).
+*)
+
+Notation Ndiv_Zquot := N2Z.inj_quot (compat "8.3").
+Notation Nmod_Zrem := N2Z.inj_rem (compat "8.3").
+Notation Z_quot_rem_eq := Z.quot_rem' (compat "8.3").
+Notation Zrem_lt := Z.rem_bound_abs (compat "8.3").
+Notation Zquot_unique := Z.quot_unique (compat "8.3").
+Notation Zrem_unique := Z.rem_unique (compat "8.3").
+Notation Zrem_1_r := Z.rem_1_r (compat "8.3").
+Notation Zquot_1_r := Z.quot_1_r (compat "8.3").
+Notation Zrem_1_l := Z.rem_1_l (compat "8.3").
+Notation Zquot_1_l := Z.quot_1_l (compat "8.3").
+Notation Z_quot_same := Z.quot_same (compat "8.3").
+Notation Z_quot_mult := Z.quot_mul (compat "8.3").
+Notation Zquot_small := Z.quot_small (compat "8.3").
+Notation Zrem_small := Z.rem_small (compat "8.3").
+Notation Zquot2_quot := Zquot2_quot (compat "8.3").
+
+(** Particular values taken for [a÷0] and [(Z.rem a 0)].
+    We avise to not rely on these arbitrary values. *)
+
+Lemma Zquot_0_r a : a ÷ 0 = 0.
+Proof. now destruct a. Qed.
+
+Lemma Zrem_0_r a : Z.rem a 0 = a.
+Proof. now destruct a. Qed.
+
+(** The following results are expressed without the [b<>0] condition
+    whenever possible. *)
+
+Lemma Zrem_0_l a : Z.rem 0 a = 0.
+Proof. now destruct a. Qed.
+
+Lemma Zquot_0_l a : 0÷a = 0.
+Proof. now destruct a. Qed.
+
+Hint Resolve Zrem_0_l Zrem_0_r Zquot_0_l Zquot_0_r Z.quot_1_r Z.rem_1_r
+ : zarith.
+
+Ltac zero_or_not a :=
+  destruct (Z.eq_decidable a 0) as [->|?];
+  [rewrite ?Zquot_0_l, ?Zrem_0_l, ?Zquot_0_r, ?Zrem_0_r;
+   auto with zarith|].
+
+Lemma Z_rem_same a : Z.rem a a = 0.
+Proof. zero_or_not a. now apply Z.rem_same. Qed.
+
+Lemma Z_rem_mult a b : Z.rem (a*b) b = 0.
+Proof. zero_or_not b. now apply Z.rem_mul. Qed.
+
+(** * Division and Opposite *)
+
+(* The precise equalities that are invalid with "historic" Zdiv. *)
+
+Theorem Zquot_opp_l a b : (-a)÷b = -(a÷b).
+Proof. zero_or_not b. now apply Z.quot_opp_l. Qed.
+
+Theorem Zquot_opp_r a b : a÷(-b) = -(a÷b).
+Proof. zero_or_not b. now apply Z.quot_opp_r. Qed.
+
+Theorem Zrem_opp_l a b : Z.rem (-a) b = -(Z.rem a b).
+Proof. zero_or_not b. now apply Z.rem_opp_l. Qed.
+
+Theorem Zrem_opp_r a b : Z.rem a (-b) = Z.rem a b.
+Proof. zero_or_not b. now apply Z.rem_opp_r. Qed.
+
+Theorem Zquot_opp_opp a b : (-a)÷(-b) = a÷b.
+Proof. zero_or_not b. now apply Z.quot_opp_opp. Qed.
+
+Theorem Zrem_opp_opp a b : Z.rem (-a) (-b) = -(Z.rem a b).
+Proof. zero_or_not b. now apply Z.rem_opp_opp. 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.
+  zero_or_not b.
+  - apply Z.square_nonneg.
+  - zero_or_not (Z.rem a b).
+    rewrite Z.rem_sign_nz; trivial. apply Z.square_nonneg.
+Qed.
+
+(** This can also be said in a simplier way: *)
+
+Theorem Zrem_sgn2 a b : 0 <= (Z.rem a b) * a.
+Proof.
+  zero_or_not b.
+  - apply Z.square_nonneg.
+  - now apply Z.rem_sign_mul.
+Qed.
+
+(** Reformulation of [Z.rem_bound_abs] 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; generalize (Z.rem_nonneg a b) (Z.rem_bound_abs a b);
+   romega with *.
+Qed.
+
+Theorem Zrem_lt_neg a b : a<=0 -> b<>0 -> -Z.abs b < Z.rem a b <= 0.
+Proof.
+  intros; generalize (Z.rem_nonpos a b) (Z.rem_bound_abs a b);
+   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.
+
+
+(** * 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 <-(Z.mul_opp_opp). apply Z.mul_nonneg_nonneg; romega.
+  - assert (0 <= Z.sgn r * Z.sgn a).
+    { rewrite <-Z.sgn_mul, Z.sgn_nonneg; auto. }
+    destruct r; simpl Z.sgn in *; romega with *.
+Qed.
+
+Theorem Zquot_mod_unique_full 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'.
+
+  rewrite <- (Z.opp_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', Z.mul_opp_r, <-Z.opp_add_distr, <-H1.
+  romega with *.
+Qed.
+
+Theorem Zquot_unique_full 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 Zrem_unique_full 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.
+
+(** * Order results about Zrem and Zquot *)
+
+(* Division of positive numbers is positive. *)
+
+Lemma Z_quot_pos 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 a b : 0 < a -> 2 <= b -> a÷b < a.
+Proof. intros. apply Z.quot_lt; auto with zarith. Qed.
+
+(** [<=] is compatible with a positive division. *)
+
+Lemma Z_quot_monotone 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 0: *)
+
+Lemma Z_mult_quot_le a b : 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 a b : 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 a b : 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 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 Z.mul_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 Z.mul_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 Z.mul_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 (Z.mul_comm c b). zero_or_not b.
+ rewrite (Z.mul_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 (Z.mul_comm c b). zero_or_not b.
+ rewrite (Z.mul_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 (Z.mul_comm b c). zero_or_not c.
+ rewrite (Z.mul_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 Z.mul_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 Z.mul_comm. zero_or_not c.
+ rewrite Z.mul_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.
+
+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 (Z.quot2 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 Z.even.
+Qed.
+
+Lemma Zeven_rem : forall a, Z.even a = Z.eqb (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 (Z.eqb (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 Z.abs_eq; auto with *; apply Z_mod_lt; auto with *.
+  rewrite <- Z_div_mod_eq; auto with *.
+  symmetry; apply Z.quot_rem; auto with *.
+Qed.
+
+Theorem Zquot_Zdiv_pos : forall a b, 0 <= a -> 0 <= b ->
+  a÷b = a/b.
+Proof.
+ intros a b Ha Hb. Z.le_elim Hb.
+ - generalize (Zquotrem_Zdiv_eucl_pos a b Ha Hb); intuition.
+ - subst; now rewrite Zquot_0_r, Zdiv_0_r.
+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..a6c83241 100644
--- a/theories/ZArith/Zsqrt.v
+++ b/theories/ZArith/Zsqrt_compat.v
@@ -1,17 +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-2012     *)
 (*   \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.
+Local Open 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 *)
@@ -23,12 +32,12 @@ Ltac compute_POS :=
     |  |- context [(Zpos (xI ?X1))] =>
       match constr:X1 with
 	| context [1%positive] => fail 1
-	| _ => rewrite (BinInt.Zpos_xI X1)
+	| _ => rewrite (Pos2Z.inj_xI X1)
       end
     |  |- context [(Zpos (xO ?X1))] =>
       match constr:X1 with
 	| context [1%positive] => fail 1
-	| _ => rewrite (BinInt.Zpos_xO X1)
+	| _ => rewrite (Pos2Z.inj_xO X1)
       end
   end.
 
@@ -106,7 +115,7 @@ Definition Zsqrt :
           fun h =>
             match sqrtrempos p with
               | c_sqrt s r Heq Hint =>
-		existS
+		existT
                 (fun s:Z =>
                   {r : Z |
                     Zpos p = s * s + r /\ s * s <= Zpos p < (s + 1) * (s + 1)})
@@ -122,10 +131,10 @@ Definition Zsqrt :
             {s : Z &
               {r : Z |
 		Zneg p = s * s + r /\ s * s <= Zneg p < (s + 1) * (s + 1)}}
-            (h (refl_equal Datatypes.Gt))
+            (h (eq_refl Datatypes.Gt))
 	| Z0 =>
           fun h =>
-            existS
+            existT
             (fun s:Z =>
               {r : Z | 0 = s * s + r /\ s * s <= 0 < (s + 1) * (s + 1)}) 0
             (exist
@@ -140,8 +149,8 @@ Defined.
 Definition Zsqrt_plain (x:Z) : Z :=
   match x with
     | Zpos p =>
-      match Zsqrt (Zpos p) (Zorder.Zle_0_pos p) with
-	| existS s _ => s
+      match Zsqrt (Zpos p) (Pos2Z.is_nonneg p) with
+	| existT s _ => s
       end
     | Zneg p => 0
     | Z0 => 0
@@ -155,12 +164,11 @@ Theorem Zsqrt_interval :
     Zsqrt_plain n * Zsqrt_plain n <= n <
     (Zsqrt_plain n + 1) * (Zsqrt_plain n + 1).
 Proof.
-  intros x; case x.
-  unfold Zsqrt_plain in |- *; omega.
-  intros p; unfold Zsqrt_plain in |- *;
-    case (Zsqrt (Zpos p) (Zorder.Zle_0_pos p)).
-  intros s [r [Heq Hint]] Hle; assumption.
-  intros p Hle; elim Hle; auto.
+  intros [|p|p] Hp.
+  - now compute.
+  - unfold Zsqrt_plain.
+    now destruct Zsqrt as (s & r & Heq & Hint).
+  - now elim Hp.
 Qed.
 
 (** Positivity *)
@@ -168,9 +176,9 @@ Qed.
 Theorem Zsqrt_plain_is_pos: forall n, 0 <= n ->  0 <= Zsqrt_plain n.
 Proof.
   intros n m; case (Zsqrt_interval n); auto with zarith.
-  intros H1 H2; case (Zle_or_lt 0 (Zsqrt_plain n)); auto.
-  intros H3; contradict H2; auto; apply Zle_not_lt.
-  apply Zle_trans with ( 2 := H1 ).
+  intros H1 H2; case (Z.le_gt_cases 0 (Zsqrt_plain n)); auto.
+  intros H3; contradict H2; auto; apply Z.le_ngt.
+  apply Z.le_trans with ( 2 := H1 ).
   replace ((Zsqrt_plain n + 1) * (Zsqrt_plain n + 1))
      with (Zsqrt_plain n * Zsqrt_plain n + (2 * Zsqrt_plain n + 1));
   auto with zarith.
@@ -185,13 +193,13 @@ Proof.
   generalize (Zsqrt_plain_is_pos (a * a)); auto with zarith; intros Haa.
   case (Zsqrt_interval (a * a)); auto with zarith.
   intros H1 H2.
-  case (Zle_or_lt a (Zsqrt_plain (a * a))); intros H3; auto.
-  case Zle_lt_or_eq with (1:=H3); auto; clear H3; intros H3.
-  contradict H1; auto; apply Zlt_not_le; auto with zarith.
-  apply Zle_lt_trans with (a * Zsqrt_plain (a * a)); auto with zarith.
-  apply Zmult_lt_compat_r; auto with zarith.
-  contradict H2; auto; apply Zle_not_lt; auto with zarith.
-  apply Zmult_le_compat; auto with zarith.
+  case (Z.le_gt_cases a (Zsqrt_plain (a * a))); intros H3.
+  - Z.le_elim H3; auto.
+    contradict H1; auto; apply Z.lt_nge; auto with zarith.
+    apply Z.le_lt_trans with (a * Zsqrt_plain (a * a)); auto with zarith.
+    apply Z.mul_lt_mono_pos_r; auto with zarith.
+  - contradict H2; auto; apply Z.le_ngt; auto with zarith.
+    apply Z.mul_le_mono_nonneg; auto with zarith.
 Qed.
 
 (** [Zsqrt_plain] is increasing *)
@@ -199,17 +207,26 @@ Qed.
 Theorem Zsqrt_le:
  forall p q, 0 <= p <= q  ->  Zsqrt_plain p <= Zsqrt_plain q.
 Proof.
-  intros p q [H1 H2]; case Zle_lt_or_eq with (1:=H2); clear H2; intros H2;
-  [ | subst q; auto with zarith].
-  case (Zle_or_lt (Zsqrt_plain p) (Zsqrt_plain q)); auto; intros H3.
+  intros p q [H1 H2].
+  Z.le_elim H2; [ | subst q; auto with zarith].
+  case (Z.le_gt_cases (Zsqrt_plain p) (Zsqrt_plain q)); auto; intros H3.
   assert (Hp: (0 <= Zsqrt_plain q)).
-   apply Zsqrt_plain_is_pos; auto with zarith.
+  { apply Zsqrt_plain_is_pos; auto with zarith. }
   absurd (q <= p); auto with zarith.
-  apply Zle_trans with ((Zsqrt_plain q + 1) * (Zsqrt_plain q + 1)).
+  apply Z.le_trans with ((Zsqrt_plain q + 1) * (Zsqrt_plain q + 1)).
   case (Zsqrt_interval q); auto with zarith.
-  apply Zle_trans with (Zsqrt_plain p * Zsqrt_plain p); auto with zarith.
-  apply Zmult_le_compat; auto with zarith.
+  apply Z.le_trans with (Zsqrt_plain p * Zsqrt_plain p); auto with zarith.
+  apply Z.mul_le_mono_nonneg; auto with zarith.
   case (Zsqrt_interval p); auto with zarith.
 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..e07fc715 100644
--- a/theories/ZArith/Zwf.v
+++ b/theories/ZArith/Zwf.v
@@ -1,17 +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-2012     *)
 (*   \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.
-Open Local Scope Z_scope.
+Local Open Scope Z_scope.
 
 (** Well-founded relations on Z. *)
 
@@ -31,28 +29,28 @@ Section wf_proof.
   (** The proof of well-foundness is classic: we do the proof by induction
       on a measure in nat, which is here [|x-c|] *)
 
-  Let f (z:Z) := Zabs_nat (z - c).
+  Let f (z:Z) := Z.abs_nat (z - c).
 
   Lemma Zwf_well_founded : well_founded (Zwf c).
-    red in |- *; intros.
+    red; intros.
     assert (forall (n:nat) (a:Z), (f a < n)%nat \/ a < c -> Acc (Zwf c) a).
     clear a; simple induction n; intros.
   (** n= 0 *)
     case H; intros.
     case (lt_n_O (f a)); auto.
-    apply Acc_intro; unfold Zwf in |- *; intros.
+    apply Acc_intro; unfold Zwf; intros.
     assert False; omega || contradiction.
   (** inductive case *)
     case H0; clear H0; intro; auto.
     apply Acc_intro; intros.
     apply H.
     unfold Zwf in H1.
-    case (Zle_or_lt c y); intro; auto with zarith.
+    case (Z.le_gt_cases c y); intro; auto with zarith.
     left.
     red in H0.
     apply lt_le_trans with (f a); auto with arith.
-    unfold f in |- *.
-    apply Zabs.Zabs_nat_lt; omega.
+    unfold f.
+    apply Zabs2Nat.inj_lt; omega.
     apply (H (S (f a))); auto.
   Qed.
 
@@ -77,18 +75,15 @@ Section wf_proof_up.
   (** The proof of well-foundness is classic: we do the proof by induction
       on a measure in nat, which is here [|c-x|] *)
 
-  Let f (z:Z) := Zabs_nat (c - z).
+  Let f (z:Z) := Z.abs_nat (c - z).
 
   Lemma Zwf_up_well_founded : well_founded (Zwf_up c).
   Proof.
     apply well_founded_lt_compat with (f := f).
-    unfold Zwf_up, f in |- *.
+    unfold Zwf_up, f.
     intros.
-    apply Zabs.Zabs_nat_lt.
-    unfold Zminus in |- *. split.
-    apply Zle_left; intuition.
-    apply Zplus_lt_compat_l; unfold Zlt in |- *; rewrite <- Zcompare_opp;
-      intuition.
+    apply Zabs2Nat.inj_lt; try (apply Z.le_0_sub; intuition).
+    now apply Z.sub_lt_mono_l.
   Qed.
 
 End wf_proof_up.
diff --git a/theories/ZArith/auxiliary.v b/theories/ZArith/auxiliary.v
index ade35bef..af7d5a2e 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-2012     *)
 (*   \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..88751cc0 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
@@ -23,10 +25,11 @@ 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..663f8d44 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-2012     *)
 (*   \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..aabf7288
--- /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-2012     *)
+(*   \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..2f104da7 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-2012     *)
 (*   \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..f7e08115
--- /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-2012     *)
+(*   \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..6f0071a4
--- /dev/null
+++ b/tools/coq_makefile.ml
@@ -0,0 +1,720 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* 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\n";
+	   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 $(HASNATDYNLINK_OR_EMPTY),install-natdynlink)";
+    print "\n";
+    if not_empty vfiles then install_include_by_root "VOFILES" vfiles inc;
+    if (not_empty cmofiles) then
+      install_include_by_root "CMOFILES" cmofiles inc;
+    if (not_empty cmifiles) then
+      install_include_by_root "CMIFILES" cmifiles inc;
+    if (not_empty mllibfiles) then
+      install_include_by_root "CMAFILES" mllibfiles inc;
+    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$(COQDEP) -slash $(OCAMLLIBS) \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" in
+  let ml_rules () =
+    print "%.cmo: %.ml\n\t$(CAMLC) $(ZDEBUG) $(ZFLAGS) $<\n\n";
+    print "%.cmx: %.ml\n\t$(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) $<\n\n";
+    print "%.ml.d: %.ml\n";
+    print "\t$(OCAMLDEP) -slash $(OCAMLLIBS) \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" in
+  let cmxs_rules () =
+    print "%.cmxs: %.cmxa\n\t$(CAMLOPTLINK) $(ZDEBUG) $(ZFLAGS) -linkall -shared -o $@ $<\n\n";
+    print "%.cmxs: %.cmx\n\t$(CAMLOPTLINK) $(ZDEBUG) $(ZFLAGS) -shared -o $@ $<\n\n" in
+  let mllib_rules () =
+    print "%.cma: | %.mllib\n\t$(CAMLLINK) $(ZDEBUG) $(ZFLAGS) -a -o $@ $^\n\n";
+    print "%.cmxa: | %.mllib\n\t$(CAMLOPTLINK) $(ZDEBUG) $(ZFLAGS) -a -o $@ $^\n\n";
+    print "%.mllib.d: %.mllib\n";
+    print "\t$(COQDEP) -slash $(COQLIBS) -c \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" in
+  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) $(COQDOCFLAGS) -latex $< -o $@\n\n";
+    print "%.html: %.v %.glob\n\t$(COQDOC) $(COQDOCFLAGS) -html $< -o $@\n\n";
+    print "%.g.tex: %.v\n\t$(COQDOC) $(COQDOCFLAGS) -latex -g $< -o $@\n\n";
+    print "%.g.html: %.v %.glob\n\t$(COQDOC)$(COQDOCFLAGS)  -html -g $< -o $@\n\n";
+    print "%.v.d: %.v\n";
+    print "\t$(COQDEP) -slash $(COQLIBS) \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n";
+    print "%.v.beautified:\n\t$(COQC) $(COQDEBUG) $(COQFLAGS) -beautify $*\n\n"
+  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 || !some_mlpackfile || !some_mllibfile then
+      print "COQDEP?=$(COQBIN)coqdep -c\n";
+    if !some_vfile then begin
+    print "COQFLAGS?=-q $(OPT) $(COQLIBS) $(OTHERFLAGS) $(COQ_XML)\n";
+    print "COQCHKFLAGS?=-silent -o\n";
+    print "COQDOCFLAGS?=-interpolate -utf8\n";
+    print "COQC?=$(COQBIN)coqc\n";
+    print "GALLINA?=$(COQBIN)gallina\n";
+    print "COQDOC?=$(COQBIN)coqdoc\n";
+    print "COQCHK?=$(COQBIN)coqchk\n\n";
+    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?=-loc loc\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 -d '\\r' | tr '\\n' '@'; })))\n";
+  print "$(call includecmdwithout@,$(COQBIN)coqtop -config)\n\n"
+
+let include_dirs (inc_i,inc_r) =
+  let parse_includes l = List.map (fun (x,_) -> "-I " ^ x) l in
+  let parse_rec_includes l =
+    List.map (fun (p,l,_) ->
+      let l' = if l = "" then "\"\"" else l in "-R " ^ p ^ " " ^ l')
+      l in
+  let inc_i' = List.filter (fun (_,i) -> not (List.exists (fun (_,_,i') -> is_prefix i' i) inc_r)) inc_i in
+  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 || !some_mllibfile || !some_mlpackfile then begin
+      print "COQLIBS?="; print_list "\\\n  " str_i'; print " "; print_list "\\\n  " str_r; print "\n";
+      print "COQDOCLIBS?=";   print_list "\\\n  " str_r; print "\n\n";
+    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 "ifeq '$(HASNATDYNLINK)' 'true'\n";
+  print "HASNATDYNLINK_OR_EMPTY := yes\n";
+  print "else\n";
+  print "HASNATDYNLINK_OR_EMPTY :=\n";
+  print "endif\n\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 $(HASNATDYNLINK_OR_EMPTY),$(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 $(COQDOCFLAGS) -html $(COQDOCLIBS) -d html $(VFILES)\n\n";
+      print "gallinahtml: $(GLOBFILES) $(VFILES)\n";
+      print "\t- mkdir -p html\n";
+      print "\t$(COQDOC) -toc $(COQDOCFLAGS) -html -g $(COQDOCLIBS) -d html $(VFILES)\n\n";
+      print "all.ps: $(VFILES)\n";
+      print "\t$(COQDOC) -toc $(COQDOCFLAGS) -ps $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^`\n\n";
+      print "all-gal.ps: $(VFILES)\n";
+      print "\t$(COQDOC) -toc $(COQDOCFLAGS) -ps -g $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^`\n\n";
+      print "all.pdf: $(VFILES)\n";
+      print "\t$(COQDOC) -toc $(COQDOCFLAGS) -pdf $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^`\n\n";
+      print "all-gal.pdf: $(VFILES)\n";
+      print "\t$(COQDOC) -toc $(COQDOCFLAGS) -pdf -g $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^`\n\n";
+      print "validate: $(VOFILES)\n";
+      print "\t$(COQCHK) $(COQCHKFLAGS) $(COQLIBS) $(notdir $(^:.vo=))\n\n";
+      print "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.ml
index 14a37a2e..350b59aa 100644
--- a/tools/coq_tex.ml4
+++ b/tools/coq_tex.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-2012     *)
 (*   \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)
@@ -15,15 +13,6 @@
  * Perl isn't as portable as it pretends to be, and is quite difficult
  * to read and maintain... Let us rewrite the stuff in Caml! *)
 
-let _ =
-  match Sys.os_type with
-    | "Unix" -> ()
-    | _ -> begin
-      	print_string "This program only runs under Unix !\n";
-      	flush stdout;
-      	exit 1
-      end
-
 let linelen = ref 72
 let output = ref ""
 let output_specified = ref false
@@ -33,6 +22,7 @@ let verbose = ref false
 let slanted = ref false
 let hrule = ref false
 let small = ref false
+let boot = ref false
 
 let coq_prompt = Str.regexp "Coq < "
 let any_prompt = Str.regexp "^[A-Z0-9a-z_\\$']* < "
@@ -88,21 +78,23 @@ let bang    = Str.regexp "!"
 let expos   = Str.regexp "^"
 
 let tex_escaped s =
-  let rec trans = parser
-    | [< s1 = (parser
-		 | [< ''_'|'$'|'{'|'}'|'&'|'%'|'#' as c >] ->
-		     "\\" ^ (String.make 1 c)
-		 | [< ''\\' >] -> "{\\char'134}"
-		 | [< ''^'  >] -> "{\\char'136}"
-		 | [< ''~'  >] -> "{\\char'176}"
-		 | [< '' '  >] -> "~"
-		 | [< ''<'  >] -> "{<}"
-		 | [< ''>'  >] -> "{>}"
-		 | [< 'c >]    -> String.make 1 c);
-	 s2 = trans >] -> s1 ^ s2
-    | [< >] -> ""
+  let dollar = "\\$" and  backslash = "\\\\" and expon = "\\^" in
+  let delims = Str.regexp ("[_{}&%#" ^ dollar ^ backslash ^ expon ^"~ <>]") in
+  let adapt_delim = function
+    | "_" | "{" | "}" | "&" | "%" | "#" | "$" as c -> "\\"^c
+    | "\\" -> "{\\char'134}"
+    | "^" -> "{\\char'136}"
+    | "~" -> "{\\char'176}"
+    | " " -> "~"
+    | "<" -> "{<}"
+    | ">" -> "{>}"
+    | _ -> assert false
   in
-  trans (Stream.of_string s)
+  let adapt = function
+    | Str.Text s -> s
+    | Str.Delim s -> adapt_delim s
+  in
+  String.concat "" (List.map adapt (Str.full_split delims s))
 
 let encapsule sl c_out s =
   if sl then
@@ -198,11 +190,11 @@ let insert texfile coq_output result =
     else begin
       if !verbose then Printf.printf "Coq < %s\n" s;
       if has_match dot_end_line s then
-       	let bl = next_block (succ k) in
+	let bl = next_block (succ k) in
 	if !verbose then List.iter print_endline bl;
 	eval 0
       else
-       	eval (succ k)
+	eval (succ k)
     end
   in
   try
@@ -268,18 +260,29 @@ let parse_cl () =
 	"-hrule", Arg.Set hrule,
 	"           Coq parts are written between 2 horizontal lines";
 	"-small", Arg.Set small,
-	"           Coq parts are written in small font"
+	"           Coq parts are written in small font";
+	"-boot", Arg.Set boot,
+	"           Launch coqtop with the -boot option"
       ]
       (fun s -> files := s :: !files)
       "coq-tex [options] file ..."
 
+let find_coqtop () =
+  let prog = Sys.executable_name in
+  try
+    let size = String.length prog in
+    let i = Str.search_backward (Str.regexp_string "coq-tex") prog (size-7) in
+    (String.sub prog 0 i)^"coqtop"^(String.sub prog (i+7) (size-i-7))
+  with Not_found -> begin
+    Printf.printf "Warning: preprocessing with default image \"coqtop\"\n";
+    "coqtop"
+  end
+
 let main () =
   parse_cl ();
-  if !image = "" then begin
-    Printf.printf "Warning: preprocessing with default image \"coqtop\"\n";
-    image := "coqtop"
-  end;
-  if Sys.command (!image ^ " -batch > /dev/null 2>&1") <> 0 then begin
+  if !image = "" then image := Filename.quote (find_coqtop ());
+  if !boot then image := !image ^ " -boot";
+  if Sys.command (!image ^ " -batch -silent") <> 0 then begin
     Printf.printf "Error: ";
     let _ = Sys.command (!image ^ " -batch") in
     exit 1
diff --git a/tools/coqdep.ml b/tools/coqdep.ml
index d36fdae3..90cdd12d 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-2012     *)
 (*   \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..19aba41d 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-2012     *)
 (*   \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..4977a94c 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-2012     *)
 (*   \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
@@ -257,7 +288,7 @@ let canonize f =
     | (f,_) :: _ -> escape f
     | _ -> escape f
 
-let traite_fichier_Coq verbose f =
+let rec traite_fichier_Coq verbose f =
   try
     let chan = open_in f in
     let buf = Lexing.from_channel chan in
@@ -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 ->
@@ -313,12 +347,15 @@ let traite_fichier_Coq verbose f =
 	        addQueue deja_vu_v [str];
                 try
                   let file_str = Hashtbl.find vKnown [str] in
-                  printf " %s.v" (canonize file_str)
+                  let canon = canonize file_str in
+                  printf " %s.v" canon;
+                  traite_fichier_Coq true (canon ^ ".v")
                 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 +383,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 +418,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 +428,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 +481,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 +489,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..afc171cb
--- /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-2012     *)
+(*   \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..7cea9743
--- /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-2012     *)
+(*   \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..f59d6a0f 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-2012     *)
 (*   \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..8802c0ef 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-2012     *)
 (*   \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..792b71fc 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-2012     *)
 (*   \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..f37db46b 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-2012     *)
 (*   \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..adc49ed4 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-2012     *)
 (*   \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 a2bcb987..d7b54fd0 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i $Id: cpretty.mll 14868 2011-12-26 17:07:24Z herbelin $ i*)
-
 (*s Utility functions for the scanners *)
 
 {
@@ -80,8 +77,17 @@
   let in_proof = ref None
   let in_emph = ref false
 
-  let start_emph () = in_emph := true; Output.start_emph ()
-  let stop_emph () = if !in_emph then (Output.stop_emph (); in_emph := false)
+  let in_env start stop = 
+    let r = ref false in
+    let start_env () = r := true; start () in
+    let stop_env () = if !r then stop (); r := false in
+      (fun x -> !r), start_env, stop_env
+      
+  let in_emph, start_emph, stop_emph = in_env Output.start_emph Output.stop_emph
+  let in_quote, start_quote, stop_quote = in_env Output.start_quote Output.stop_quote
+
+  let url_buffer = Buffer.create 40
+  let url_name_buffer = Buffer.create 40
 
   let backtrack lexbuf = lexbuf.lex_curr_pos <- lexbuf.lex_start_pos;
     lexbuf.lex_curr_p <- lexbuf.lex_start_p
@@ -257,7 +263,7 @@
     let nbsp,isp = count_spaces s in
     Output.indentation nbsp;
     let s = String.sub s isp (String.length s - isp) in
-    Output.ident s (lexeme_start lexbuf + isp)
+    Output.keyword s (lexeme_start lexbuf + isp)
 
 }
 
@@ -323,6 +329,7 @@ let def_token =
   | "SubClass"
   | "Example"
   | "Fixpoint"
+  | "Function"
   | "Boxed"
   | "CoFixpoint"
   | "Record"
@@ -371,13 +378,17 @@ let commands =
   | "Drop"
   | "ProtectedLoop"
   | "Quit"
+  | "Restart"
   | "Load"
   | "Add"
   | "Remove" space+ "Loadpath"
   | "Print"
   | "Inspect"
   | "About"
+  | "SearchAbout"
+  | "SearchRewrite"
   | "Search"
+  | "Locate"
   | "Eval"
   | "Reset"
   | "Check"
@@ -405,6 +416,14 @@ let prog_kw =
   | "Obligations"
   | "Solve"
 
+let hint_kw = 
+  "Extern" | "Rewrite" | "Resolve" | "Immediate" | "Transparent" | "Opaque" | "Unfold" | "Constructors"
+
+let set_kw =
+    "Printing" space+ ("Coercions" | "Universes" | "All")
+  | "Implicit" space+ "Arguments"
+  
+
 let gallina_kw_to_hide =
     "Implicit" space+ "Arguments"
   | "Ltac"
@@ -412,15 +431,16 @@ let gallina_kw_to_hide =
   | "Import"
   | "Export"
   | "Load"
-  | "Hint"
+  | "Hint" space+ hint_kw
   | "Open"
   | "Close"
   | "Delimit"
   | "Transparent"
   | "Opaque"
   | ("Declare" space+ ("Morphism" | "Step") )
-  | ("Set" | "Unset") space+ "Printing" space+ "Coercions"
+  | ("Set" | "Unset") space+ set_kw
   | "Declare" space+ ("Left" | "Right") space+ "Step"
+  | "Debug" space+ ("On" | "Off")
 
 
 let section = "*" | "**" | "***" | "****"
@@ -512,7 +532,7 @@ rule coq_bol = parse
 	output_indented_keyword s lexbuf;
 	let eol= body lexbuf in
 	if eol then coq_bol lexbuf else coq lexbuf }
-  | space* notation_kw space*
+  | space* notation_kw
       {	let s = lexeme lexbuf in
 	output_indented_keyword s lexbuf;
 	let eol= start_notation_string lexbuf in
@@ -639,7 +659,7 @@ and coq = parse
 	  Output.ident s (lexeme_start lexbuf);
 	let eol = body lexbuf in
 	  if eol then coq_bol lexbuf else coq lexbuf }
-  | notation_kw space*
+  | notation_kw
       { let s = lexeme lexbuf in
 	Output.ident s (lexeme_start lexbuf);
 	let eol= start_notation_string lexbuf in
@@ -663,8 +683,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
@@ -674,33 +692,26 @@ 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 }
+      { Output.start_verbatim false; verbatim false lexbuf; doc_bol lexbuf }
   | eof
       { true }
   | '_'
@@ -724,8 +735,8 @@ and doc_list_bol indents = parse
             backtrack lexbuf; doc_bol lexbuf
       }
   | "<<" space*
-      { Output.start_verbatim ();
-        verbatim lexbuf;
+      { Output.start_verbatim false;
+        verbatim false lexbuf;
         doc_list_bol indents lexbuf }
   | "[[" nl
       { formatted := true;
@@ -734,6 +745,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 *)
@@ -769,9 +782,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* _
@@ -780,7 +800,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,_) ->
@@ -808,8 +831,11 @@ 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 }
+  | "{{" { url lexbuf; doc indents lexbuf }
   | "["
       { if !Cdglobals.plain_comments then Output.char '['
         else (brackets := 1;  Output.start_inline_coq (); escaped_coq lexbuf;
@@ -823,6 +849,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 }
   | '*'* "*)"
@@ -857,6 +895,15 @@ and doc indents = parse
       { if !Cdglobals.plain_comments then Output.char '_' else stop_emph () ;
         Output.char (lexeme_char lexbuf 1);
         doc indents lexbuf }
+  | "<<" space*
+      { Output.start_verbatim true; verbatim true lexbuf; doc_bol lexbuf }
+  | '"'
+      { if !Cdglobals.plain_comments 
+	then Output.char '"' 
+	else if in_quote ()
+	then stop_quote () 
+	else start_quote ();
+        doc indents lexbuf }
   | eof
       { false }
   | _
@@ -883,11 +930,22 @@ and escaped_html = parse
   | eof { () }
   | _   { Output.html_char (lexeme_char lexbuf 0); escaped_html lexbuf }
 
-and verbatim = parse
-  | nl ">>" space* nl { Output.verbatim_char '\n'; Output.stop_verbatim () }
-  | nl ">>" { Output.verbatim_char '\n'; Output.stop_verbatim () }
-  | eof { Output.stop_verbatim () }
-  | _ { Output.verbatim_char (lexeme_char lexbuf 0); verbatim lexbuf }
+and verbatim inline = parse
+  | nl ">>" space* nl { Output.verbatim_char inline '\n'; Output.stop_verbatim inline }
+  | nl ">>" { Output.verbatim_char inline '\n'; Output.stop_verbatim inline }
+  | ">>" { Output.stop_verbatim inline }
+  | eof { Output.stop_verbatim inline }
+  | _ { Output.verbatim_char inline (lexeme_char lexbuf 0); verbatim inline lexbuf }
+
+and url = parse
+  | "}}" { Output.url (Buffer.contents url_buffer) None; Buffer.clear url_buffer }
+  | "}" { url_name lexbuf }
+  | _ { Buffer.add_char url_buffer (lexeme_char lexbuf 0); url lexbuf }
+
+and url_name = parse
+  | "}" { Output.url (Buffer.contents url_buffer) (Some (Buffer.contents url_name_buffer));
+	  Buffer.clear url_buffer; Buffer.clear url_name_buffer }
+  | _ { Buffer.add_char url_name_buffer (lexeme_char lexbuf 0); url_name lexbuf }
 
 (*s Coq, inside quotations *)
 
@@ -911,10 +969,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 }
 
@@ -1081,7 +1145,7 @@ and body = parse
 	     if eol
 	     then begin if not !Cdglobals.parse_comments then Output.line_break(); body_bol lexbuf end
 	     else body lexbuf }
-  | "where" space*
+  | "where" 
       { Tokens.flush_sublexer();
         Output.ident (lexeme lexbuf) (lexeme_start lexbuf);
 	start_notation_string lexbuf }
@@ -1105,6 +1169,8 @@ and body = parse
         body lexbuf }
 
 and start_notation_string = parse
+  | space { Tokens.flush_sublexer(); Output.char (lexeme_char lexbuf 0);
+	    start_notation_string lexbuf }
   | '"' (* a true notation *)
       { Output.sublexer '"' (lexeme_start lexbuf);
         notation_string lexbuf;
@@ -1141,6 +1207,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..14447b06 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-2012     *)
 (*   \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
@@ -38,17 +35,18 @@ type entry_type =
 type index_entry =
   | Def of string * entry_type
   | Ref of coq_module * string * entry_type
-  | Mod of coq_module * string
 
 let current_type : entry_type ref = ref Library
 let current_library = ref ""
   (** refers to the file being parsed *)
 
-(** [deftable] stores only definitions and is used to interpolate idents
-    inside comments, which are not globalized otherwise. *)
-
+(** [deftable] stores only definitions and is used to build the index *)
 let deftable = Hashtbl.create 97
 
+(** [byidtable] is used to interpolate idents inside comments, which are not
+    globalized otherwise. *)
+let byidtable = Hashtbl.create 97
+
 (** [reftable] stores references and definitions *)
 let reftable = Hashtbl.create 97
 
@@ -62,25 +60,25 @@ let full_ident sp id =
   else ""
 
 let add_def loc1 loc2 ty sp id =
+  let fullid = full_ident sp id in
+  let def = Def (fullid, ty) in
   for loc = loc1 to loc2 do
-    Hashtbl.add reftable (!current_library, loc) (Def (full_ident sp id, ty))
+    Hashtbl.add reftable (!current_library, loc) def
   done;
-  Hashtbl.add deftable id (Ref (!current_library, full_ident sp id, ty))
+  Hashtbl.add deftable !current_library (fullid, ty);
+  Hashtbl.add byidtable id (!current_library, fullid, ty)
 
 let add_ref m loc m' sp id ty =
+  let fullid = full_ident sp id in
   if Hashtbl.mem reftable (m, loc) then ()
-  else Hashtbl.add reftable (m, loc) (Ref (m', full_ident sp id, ty));
+  else Hashtbl.add reftable (m, loc) (Ref (m', fullid, ty));
   let idx = if id = "<>" then m' else id in
-    if Hashtbl.mem deftable idx then ()
-    else Hashtbl.add deftable idx (Ref (m', full_ident sp id, ty))
-
-let add_mod m loc m' id =
-  Hashtbl.add reftable (m, loc) (Mod (m', id));
-  Hashtbl.add deftable m (Mod (m', id))
+    if Hashtbl.mem byidtable idx then ()
+    else Hashtbl.add byidtable idx (m', fullid, ty)
 
 let find m l = Hashtbl.find reftable (m, l)
 
-let find_string m s = Hashtbl.find deftable s
+let find_string m s = let (m,s,t) = Hashtbl.find byidtable s in Ref (m,s,t)
 
 (*s Manipulating path prefixes *)
 
@@ -238,18 +236,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 +268,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;
@@ -290,11 +290,8 @@ let all_entries () =
     let l = try Hashtbl.find bt t with Not_found -> [] in
       Hashtbl.replace bt t ((s,m) :: l)
   in
-  let classify (m,_) e = match e with
-    | Def (s,t) -> add_g s m t; add_bt t s m
-    | Ref _ | Mod _ -> ()
-  in
-    Hashtbl.iter classify reftable;
+  let classify m (s,t) = (add_g s m t; add_bt t s m) in
+    Hashtbl.iter classify deftable;
     Hashtbl.iter (fun id m -> add_g id m Library; add_bt Library id m) modules;
     { idx_name = "global";
       idx_entries = sort_entries !gl;
@@ -324,8 +321,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
@@ -341,7 +357,16 @@ let read_glob f =
 		Scanf.sscanf s "R%d:%d %s %s %s %s"
 		  (fun loc1 loc2 lib_dp sp id ty ->
 		    for loc=loc1 to loc2 do
-		      add_ref !cur_mod loc lib_dp sp id (type_of_string ty)
+		      add_ref !cur_mod loc lib_dp sp id (type_of_string ty);
+
+                      (* Also add an entry for each module mentioned in [lib_dp],
+                       * to use in interpolation. *)
+                      ignore (List.fold_right (fun thisPiece priorPieces ->
+                                                let newPieces = match priorPieces with
+                                                                | "" -> thisPiece
+                                                                | _ -> thisPiece ^ "." ^ priorPieces in
+                                                add_ref !cur_mod loc "" "" newPieces Library;
+                                                newPieces) (Str.split (Str.regexp_string ".") lib_dp) "")
 		    done)
 	       with _ -> ())
 	  | _ ->
diff --git a/tools/coqdoc/index.mli b/tools/coqdoc/index.mli
index a009e9dc..0f62a086 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-2012     *)
 (*   \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
@@ -36,10 +34,11 @@ val type_name : entry_type -> string
 type index_entry =
   | Def of string * entry_type
   | Ref of coq_module * string * entry_type
-  | Mod of coq_module * string
 
+(* Find what symbol coqtop said is located at loc in the source file *)
 val find : coq_module -> loc -> index_entry
 
+(* Find what data is referred to by some string in some coq module *)
 val find_string : coq_module -> string -> index_entry
 
 val add_module : coq_module -> unit
@@ -54,7 +53,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..b33ec1f0 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-2012     *)
 (*   \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..0dc86bc8 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-2012     *)
 (*   \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,24 +29,27 @@ let build_table l =
 
 let is_keyword =
   build_table
-    [ "AddPath"; "Axiom"; "Abort"; "Boxed"; "Chapter"; "Check"; "Coercion"; "CoFixpoint";
+    [ "About"; "AddPath"; "Axiom"; "Abort"; "Chapter"; "Check"; "Coercion"; "Compute"; "CoFixpoint";
       "CoInductive"; "Corollary"; "Defined"; "Definition"; "End"; "Eval"; "Example";
-      "Export"; "Fact"; "Fix"; "Fixpoint"; "Global"; "Grammar"; "Goal"; "Hint";
+      "Export"; "Fact"; "Fix"; "Fixpoint"; "Function"; "Generalizable"; "Global"; "Grammar";
+      "Guarded"; "Goal"; "Hint"; "Debug"; "On";
       "Hypothesis"; "Hypotheses";
-      "Resolve"; "Unfold"; "Immediate"; "Extern"; "Implicit"; "Import"; "Inductive";
+      "Resolve"; "Unfold"; "Immediate"; "Extern"; "Constructors"; "Rewrite";
+      "Implicit"; "Import"; "Inductive";
       "Infix"; "Lemma"; "Let"; "Load"; "Local"; "Ltac";
       "Module"; "Module Type"; "Declare Module"; "Include";
-      "Mutual"; "Parameter"; "Parameters"; "Print"; "Proof"; "Proof with"; "Qed";
-      "Record"; "Recursive"; "Remark"; "Require"; "Save"; "Scheme";
+      "Mutual"; "Parameter"; "Parameters"; "Print"; "Printing"; "All"; "Proof"; "Proof with"; "Qed";
+      "Record"; "Recursive"; "Remark"; "Require"; "Save"; "Scheme"; "Assumptions"; "Axioms"; "Universes";
       "Induction"; "for"; "Sort"; "Section"; "Show"; "Structure"; "Syntactic"; "Syntax"; "Tactic"; "Theorem";
+      "Search"; "SearchAbout"; "SearchRewrite";
       "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";
-      "Opaque"; "Transparent";
+      "subgoal"; "subgoals"; "vm_compute";
+      "Opaque"; "Transparent"; "Time";
+      "Extraction"; "Extract";
       (* Program *)
       "Program Definition"; "Program Example"; "Program Fixpoint"; "Program Lemma";
       "Obligation"; "Obligations"; "Solve"; "using"; "Next Obligation"; "Next";
@@ -57,14 +57,20 @@ let is_keyword =
       (*i (* coq terms *) *)
       "forall"; "match"; "as"; "in"; "return"; "with"; "end"; "let"; "fun";
       "if"; "then"; "else"; "Prop"; "Set"; "Type"; ":="; "where"; "struct"; "wf"; "measure";
+      "fix"; "cofix";
       (* Ltac *)
-      "before"; "after"
+      "before"; "after"; "constr"; "ltac"; "goal"; "context"; "beta"; "delta"; "iota"; "zeta";
+      (* Notations *)
+      "level"; "associativity"; "no"
        ]
 
 let is_tactic =
   build_table
     [ "intro"; "intros"; "apply"; "rewrite"; "refine"; "case"; "clear"; "injection";
-      "elimtype"; "progress"; "setoid_rewrite";
+      "elimtype"; "progress"; "setoid_rewrite"; "left"; "right"; "constructor"; 
+      "econstructor"; "decide equality"; "abstract"; "exists"; "cbv"; "simple destruct";
+      "info"; "fourier"; "field"; "specialize"; "evar"; "solve"; "instanciate";
+      "quote"; "eexact"; "autorewrite";
       "destruct"; "destruction"; "destruct_call"; "dependent"; "elim"; "extensionality";
       "f_equal"; "generalize"; "generalize_eqs"; "generalize_eqs_vars"; "induction"; "rename"; "move"; "omega";
       "set"; "assert"; "do"; "repeat";
@@ -73,8 +79,10 @@ let is_tactic =
       "reflexivity"; "symmetry"; "transitivity";
       "replace"; "setoid_replace"; "inversion"; "inversion_clear";
       "pattern"; "intuition"; "congruence"; "fail"; "fresh";
-      "trivial"; "exact"; "tauto"; "firstorder"; "ring";
-      "clapply"; "program_simpl"; "program_simplify"; "eapply"; "auto"; "eauto" ]
+      "trivial"; "tauto"; "firstorder"; "ring";
+      "clapply"; "program_simpl"; "program_simplify"; "eapply"; "auto"; "eauto";
+      "change"; "fold"; "hnf"; "lazy"; "simple"; "eexists"; "debug"; "idtac"; "first"; "type of"; "pose";
+      "eval"; "instantiate"; "until" ]
 
 (*s Current Coq module *)
 
@@ -118,9 +126,12 @@ let initialize_texmacs () =
 
 let token_tree_texmacs = ref (initialize_texmacs ())
 
+let token_tree_latex = ref Tokens.empty_ttree
+let token_tree_html = ref Tokens.empty_ttree
+
 let initialize_tex_html () =
   let if_utf8 = if !Cdglobals.utf8 then fun x -> Some x else fun _ -> None in
-    List.fold_right (fun (s,l,l') (tt,tt') ->
+  let (tree_latex, tree_html) = List.fold_right (fun (s,l,l') (tt,tt') ->
       (Tokens.ttree_add tt s l,
        match l' with None -> tt' | Some l' -> Tokens.ttree_add tt' s l'))
       [ "*" ,  "\\ensuremath{\\times}", if_utf8 "×";
@@ -143,10 +154,9 @@ let initialize_tex_html () =
 	"Π", "\\ensuremath{\\Pi}", if_utf8 "Π";
 	"λ", "\\ensuremath{\\lambda}", if_utf8 "λ";
 	(* "fun", "\\ensuremath{\\lambda}" ? *)
-      ] (Tokens.empty_ttree,Tokens.empty_ttree)
-
-let token_tree_latex = ref (fst (initialize_tex_html ()))
-let token_tree_html = ref (snd (initialize_tex_html ()))
+      ] (Tokens.empty_ttree,Tokens.empty_ttree) in
+  token_tree_latex := tree_latex;
+  token_tree_html  := tree_html
 
 let add_printing_token s (t1,t2) =
   (match t1 with None -> () | Some t1 ->
@@ -182,10 +192,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";
@@ -255,6 +275,12 @@ module Latex = struct
 	| '^' | '~' as c ->
 	    Buffer.add_char buff '\\'; Buffer.add_char buff c;
 	    Buffer.add_string buff "{}"
+        | '\'' ->
+            if i < String.length s - 1 && s.[i+1] = '\'' then begin
+              Buffer.add_char buff '\''; Buffer.add_char buff '{';
+              Buffer.add_char buff '}'
+            end else
+              Buffer.add_char buff '\''
 	| c ->
 	    Buffer.add_char buff c
       done;
@@ -276,9 +302,23 @@ module Latex = struct
 
   let stop_latex_math () = output_char '$'
 
-  let start_verbatim () = printf "\\begin{verbatim}"
+  let start_quote () = output_char '`'; output_char '`'
+  let stop_quote () = output_char '\''; output_char '\''
+    
+  let start_verbatim inline = 
+    if inline then printf "\\texttt{"
+    else printf "\\begin{verbatim}"
 
-  let stop_verbatim () = printf "\\end{verbatim}\n"
+  let stop_verbatim inline =
+    if inline then printf "}"
+    else printf "\\end{verbatim}\n"
+
+  let url addr name = 
+    printf "%s\\footnote{\\url{%s}}"
+      (match name with
+       | None -> ""
+       | Some n -> n)
+      addr
 
   let indentation n =
     if n == 0 then
@@ -287,9 +327,6 @@ module Latex = struct
       let space = 0.5 *. (float n) in
       printf "\\coqdocindent{%2.2fem}\n" space
 
-  let module_ref m s =
-    printf "\\coqdocmodule{%s}{%s}" m (escaped s)
-
   let ident_ref m fid typ s =
     let id = if fid <> "" then (m ^ "." ^ fid) else m in
     match find_module m with
@@ -306,18 +343,20 @@ 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) ->
 	defref (get_module false) fullid typ s
-    | Mod (m,s') when s = s' ->
-	module_ref m s
     | Ref (m,fullid,typ) ->
 	ident_ref m fullid typ s
-    | Mod _ ->
-	printf "\\coqdocvar{%s}" (escaped s)
 
   (*s The sublexer buffers symbol characters and attached
        uninterpreted ident and try to apply special translation such as,
@@ -330,13 +369,22 @@ module Latex = struct
     | Some ref -> reference s ref
     | None -> if issymbchar then output_string s else printf "\\coqdocvar{%s}" s
 
+  let last_was_in = ref false
+
   let sublexer c loc =
-    let tag =
-      try Some (Index.find (get_module false) loc) with Not_found -> None
-    in
-    Tokens.output_tagged_symbol_char tag c
+    if c = '*' && !last_was_in then begin
+      Tokens.flush_sublexer ();
+      output_char '*'
+    end else begin
+      let tag =
+        try Some (Index.find (get_module false) loc) with Not_found -> None
+      in
+      Tokens.output_tagged_symbol_char tag c
+    end;
+    last_was_in := false
 
   let initialize () =
+    initialize_tex_html ();
     Tokens.token_tree := token_tree_latex;
     Tokens.outfun := output_sublexer_string
 
@@ -345,7 +393,11 @@ module Latex = struct
   let translate s =
     match Tokens.translate s with Some s -> s | None -> escaped s
 
+  let keyword s loc = 
+    printf "\\coqdockw{%s}" (translate s)
+
   let ident s loc =
+    last_was_in := s = "in";
     try
       let tag = Index.find (get_module false) loc in
       reference (translate s) tag
@@ -478,8 +530,7 @@ module Html = struct
 	end
 
   let trailer () =
-    if !header_trailer then
-      if !footer_file_spec then
+    if !header_trailer && !footer_file_spec then
 	let cin = Pervasives.open_in !footer_file in
 	  try
 	    while true do
@@ -487,14 +538,14 @@ module Html = struct
 		printf "%s\n" s
 	    done
 	  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>"
-	end
+    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>"
+      end
 
   let start_module () =
     let ln = !lib_name in
@@ -547,17 +598,22 @@ module Html = struct
   let start_latex_math () = ()
   let stop_latex_math () = ()
 
-  let start_verbatim () = printf "<pre>"
-  let stop_verbatim () = printf "</pre>\n"
+  let start_quote () = char '"'
+  let stop_quote () = start_quote ()
 
-  let module_ref m s =
-    match find_module m with
-      | Local ->
-	  printf "<a class=\"modref\" href=\"%s.html\">%s</a>" m s
-      | External m when !externals ->
-	  printf "<a class=\"modref\" href=\"%s.html\">%s</a>" m s
-      | External _ | Unknown ->
-	  output_string s
+  let start_verbatim inline = 
+    if inline then printf "<tt>"
+    else printf "<pre>"
+
+  let stop_verbatim inline = 
+    if inline then printf "</tt>" 
+    else printf "</pre>\n"
+
+  let url addr name = 
+    printf "<a href=\"%s\">%s</a>" addr 
+      (match name with
+       | Some n -> n
+       | None -> addr)
 
   let ident_ref m fid typ s =
     match find_module m with
@@ -575,12 +631,8 @@ module Html = struct
     | Def (fullid,ty) ->
 	printf "<a name=\"%s\">" fullid;
 	printf "<span class=\"id\" type=\"%s\">%s</span></a>" (type_name ty) s
-    | Mod (m,s') when s = s' ->
-	module_ref m s
     | Ref (m,fullid,ty) ->
 	ident_ref m fullid (type_name ty) s
-    | Mod _ ->
-	printf "<span class=\"id\" type=\"mod\">%s</span>" s
 
   let output_sublexer_string doescape issymbchar tag s =
     let s = if doescape then escaped s else s in
@@ -597,12 +649,16 @@ module Html = struct
     Tokens.output_tagged_symbol_char tag c
 
   let initialize () =
+    initialize_tex_html();
     Tokens.token_tree := token_tree_html;
     Tokens.outfun := output_sublexer_string
 
   let translate s =
     match Tokens.translate s with Some s -> s | None -> escaped s
 
+  let keyword s loc = 
+    printf "<span class=\"id\" type=\"keyword\">%s</span>" (translate s)
+
   let ident s loc =
     if is_keyword s then begin
       printf "<span class=\"id\" type=\"keyword\">%s</span>" (translate s)
@@ -624,7 +680,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 +718,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 +728,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
@@ -858,19 +959,28 @@ module TeXmacs = struct
 
   let stop_latex_math () = output_char '>'
 
-  let start_verbatim () = in_doc := true; printf "<\\verbatim>"
+  let start_verbatim inline = in_doc := true; printf "<\\verbatim>"
+  let stop_verbatim inline = in_doc := false; printf "</verbatim>"
+
+  let url addr name = 
+    printf "%s<\\footnote><\\url>%s</url></footnote>" addr
+      (match name with
+       | None -> ""
+       | Some n -> n)
 
-  let stop_verbatim () = in_doc := false; printf "</verbatim>"
+  let start_quote () = output_char '`'; output_char '`'
+  let stop_quote () = output_char '\''; output_char '\''
 
   let indentation n = ()
 
+  let keyword s =
+    printf "<kw|"; raw_ident s; printf ">"
+
   let ident_true s =
-    if is_keyword s then begin
-      printf "<kw|"; raw_ident s; printf ">"
-    end else begin
-      raw_ident s
-    end
+    if is_keyword s then keyword s
+    else raw_ident s
 
+  let keyword s loc = keyword s
   let ident s _ = if !in_doc then ident_true s else raw_ident s
 
   let output_sublexer_string doescape issymbchar tag s =
@@ -985,13 +1095,21 @@ module Raw = struct
   let start_latex_math () = ()
   let stop_latex_math () = ()
 
-  let start_verbatim () = ()
+  let start_verbatim inline = ()
+  let stop_verbatim inline = ()
 
-  let stop_verbatim () = ()
+  let url addr name = 
+    match name with
+    | Some n -> printf "%s (%s)" n addr
+    | None -> printf "%s" addr
+
+  let start_quote () = printf "\""
+  let stop_quote () = printf "\""
 
   let indentation n =
       for i = 1 to n do printf " " done
 
+  let keyword s loc = raw_ident s
   let ident s loc = raw_ident s
 
   let sublexer c l = char c
@@ -1105,6 +1223,7 @@ let rule = select Latex.rule Html.rule TeXmacs.rule Raw.rule
 
 let nbsp = select Latex.nbsp Html.nbsp TeXmacs.nbsp Raw.nbsp
 let char = select Latex.char Html.char TeXmacs.char Raw.char
+let keyword = select Latex.keyword Html.keyword TeXmacs.keyword Raw.keyword
 let ident = select Latex.ident Html.ident TeXmacs.ident Raw.ident
 let sublexer = select Latex.sublexer Html.sublexer TeXmacs.sublexer Raw.sublexer
 let initialize = select Latex.initialize Html.initialize TeXmacs.initialize Raw.initialize
@@ -1132,10 +1251,33 @@ let start_verbatim =
   select Latex.start_verbatim Html.start_verbatim TeXmacs.start_verbatim Raw.start_verbatim
 let stop_verbatim =
   select Latex.stop_verbatim Html.stop_verbatim TeXmacs.stop_verbatim Raw.stop_verbatim
-let verbatim_char =
-  select output_char Html.char TeXmacs.char Raw.char
+let verbatim_char inline =
+  select (if inline then Latex.char else output_char) Html.char TeXmacs.char Raw.char
 let hard_verbatim_char = output_char
 
+let url = 
+  select Latex.url Html.url TeXmacs.url Raw.url
+
+let start_quote =
+  select Latex.start_quote Html.start_quote TeXmacs.start_quote Raw.start_quote
+let stop_quote =
+  select Latex.stop_quote Html.stop_quote TeXmacs.stop_quote Raw.stop_quote
+
+let inf_rule_dumb assumptions (midsp,midln,midnm) conclusions = 
+  start_verbatim false;
+  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 false
+
+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..80f39011 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-2012     *)
 (*   \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
 
@@ -62,6 +60,7 @@ val rule : unit -> unit
 
 val nbsp : unit -> unit
 val char : char -> unit
+val keyword : string -> loc -> unit
 val ident : string -> loc -> unit
 val sublexer : char -> loc -> unit
 val initialize : unit -> unit
@@ -72,13 +71,34 @@ val latex_char : char -> unit
 val latex_string : string -> unit
 val html_char : char -> unit
 val html_string : string -> unit
-val verbatim_char : char -> unit
+val verbatim_char : bool -> char -> unit
 val hard_verbatim_char : char -> unit
 
 val start_latex_math : unit -> unit
 val stop_latex_math : unit -> unit
-val start_verbatim : unit -> unit
-val stop_verbatim : unit -> unit
+val start_verbatim : bool -> unit
+val stop_verbatim : bool -> unit
+val start_quote : unit -> unit
+val stop_quote : unit -> unit
+
+val url : string -> string option -> 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
diff --git a/tools/coqdoc/tokens.ml b/tools/coqdoc/tokens.ml
index 9de39083..10a105f9 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-2012     *)
 (*   \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..e9c74307 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-2012     *)
 (*   \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..a5376ec4 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-2012     *)
 (*   \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/escape_string.ml b/tools/escape_string.ml
new file mode 100644
index 00000000..50e8faad
--- /dev/null
+++ b/tools/escape_string.ml
@@ -0,0 +1 @@
+print_string (String.escaped Sys.argv.(1))
diff --git a/tools/fake_ide.ml b/tools/fake_ide.ml
new file mode 100644
index 00000000..22a36ede
--- /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-2012     *)
+(*   \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 call in
+  prerr_endline (Ide_intf.pr_full_value call res);
+  match res with Interface.Fail _ -> exit 1 | _ -> ()
+
+let commands =
+  [ "INTERPRAWSILENT", (fun s -> eval_call (Ide_intf.interp (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..7b051d1c 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-2012     *)
 (*   \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..cfbfac98 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-2012     *)
 (*   \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/tools/mingwpath.ml b/tools/mingwpath.ml
new file mode 100644
index 00000000..f01b62cc
--- /dev/null
+++ b/tools/mingwpath.ml
@@ -0,0 +1,15 @@
+(** Mingwpath *)
+
+(** Converts mingw-encoded filenames such as:
+
+      /c/Program Files/Ocaml/bin
+
+    to a more windows-friendly form (but still with / instead of \) :
+
+      c:/Program Files/Ocaml/bin
+
+    This nice hack was suggested by Benjamin Monate (cf bug #2526)
+    to mimic the cygwin-specific tool cygpath
+*)
+
+print_string Sys.argv.(1)
diff --git a/tools/win32hack.mllib b/tools/win32hack.mllib
new file mode 100644
index 00000000..42395f65
--- /dev/null
+++ b/tools/win32hack.mllib
@@ -0,0 +1 @@
+Win32hack_filename
\ No newline at end of file
diff --git a/tools/win32hack_filename.ml b/tools/win32hack_filename.ml
new file mode 100644
index 00000000..74f70686
--- /dev/null
+++ b/tools/win32hack_filename.ml
@@ -0,0 +1,4 @@
+(* The mingw32-ocaml cross-compiler currently uses Filename.dir_sep="/".
+   Let's tweak that... *)
+
+let _ = Filename.dir_sep.[0] <- '\\'
diff --git a/toplevel/auto_ind_decl.ml b/toplevel/auto_ind_decl.ml
index 16ceffed..b9ab68ec 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-2012     *)
 (*   \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
@@ -94,7 +111,7 @@ let mkFullInd ind n =
 
 let check_bool_is_defined () =
   try let _ = Global.type_of_global Coqlib.glob_bool in ()
-  with _ -> raise (UndefinedCst "bool")
+  with e when Errors.noncritical e -> raise (UndefinedCst "bool")
 
 let beq_scheme_kind_aux = ref (fun _ -> failwith "Undefined")
 
@@ -287,8 +304,9 @@ let destruct_ind c =
     try let u,v =  destApp c in
           let indc = destInd u in
             indc,v
-    with _-> let indc = destInd c in
-            indc,[||]
+    with e when Errors.noncritical e ->
+      let indc = destInd c in
+      indc,[||]
 
 (*
   In the following, avoid is the list of names to avoid.
@@ -312,8 +330,9 @@ let do_replace_lb lb_scheme_key aavoid narg gls p q =
             else error ("Var "^(string_of_id s)^" seems unknown.")
       )
     in mkVar (find 1)
-  with _ -> (* if this happen then the args have to be already declared as a
-              Parameter*)
+  with e when Errors.noncritical e ->
+      (* if this happen then the args have to be already declared as a
+         Parameter*)
       (
         let mp,dir,lbl = repr_con (destConst v) in
           mkConst (make_con mp dir (mk_label (
@@ -329,13 +348,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
@@ -360,8 +378,9 @@ let do_replace_bl bl_scheme_key ind gls aavoid narg lft rgt =
             else error ("Var "^(string_of_id s)^" seems unknown.")
       )
     in mkVar (find 1)
-  with _ -> (* if this happen then the args have to be already declared as a
-              Parameter*)
+  with e when Errors.noncritical e ->
+      (* if this happen then the args have to be already declared as a
+         Parameter*)
       (
         let mp,dir,lbl = repr_con (destConst v) in
           mkConst (make_con mp dir (mk_label (
@@ -378,7 +397,7 @@ let do_replace_bl bl_scheme_key ind gls aavoid narg lft rgt =
         else (
           let u,v = try  destruct_ind tt1
           (* trick so that the good sequence is returned*)
-                with _ -> ind,[||]
+                with e when Errors.noncritical e -> ind,[||]
           in if u = ind
              then (Equality.replace t1 t2)::(Auto.default_auto)::(aux q1 q2)
              else (
@@ -387,13 +406,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 =
@@ -412,17 +430,19 @@ let do_replace_bl bl_scheme_key ind gls aavoid narg lft rgt =
     | ([],[]) -> []
     | _ -> error "Both side of the equality must have the same arity."
   in
-  let (ind1,ca1) = try destApp lft with
-    _ -> error "replace failed."
-  and (ind2,ca2) = try destApp rgt with
-    _ -> error "replace failed."
+  let (ind1,ca1) =
+    try destApp lft with e when Errors.noncritical e -> error "replace failed."
+  and (ind2,ca2) =
+    try destApp rgt with e when Errors.noncritical e -> error "replace failed."
   in
-  let (sp1,i1) = try destInd ind1 with
-    _ -> (try fst (destConstruct ind1) with _ ->
-                error "The expected type is an inductive one.")
-  and (sp2,i2) = try destInd ind2 with
-    _ -> (try fst (destConstruct ind2)  with _ ->
-                error "The expected type is an inductive one.")
+  let (sp1,i1) =
+    try destInd ind1 with e when Errors.noncritical e ->
+      try fst (destConstruct ind1) with e when Errors.noncritical e ->
+        error "The expected type is an inductive one."
+  and (sp2,i2) =
+    try destInd ind2 with e when Errors.noncritical e ->
+      try fst (destConstruct ind2) with e when Errors.noncritical e ->
+        error "The expected type is an inductive one."
   in
     if (sp1 <> sp2) || (i1 <> i2)
       then (error "Eq should be on the same type")
@@ -513,17 +533,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 +553,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 +563,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 +595,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 +663,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 +707,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)|]
 
@@ -715,7 +719,8 @@ let _ = lb_scheme_kind_aux := fun () -> lb_scheme_kind
 (* Decidable equality *)
 
 let check_not_is_defined () =
-  try ignore (Coqlib.build_coq_not ()) with _ -> raise (UndefinedCst "not")
+  try ignore (Coqlib.build_coq_not ())
+  with e when Errors.noncritical e -> raise (UndefinedCst "not")
 
 (* {n=m}+{n<>m}  part  *)
 let compute_dec_goal ind lnamesparrec nparrec =
@@ -810,24 +815,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 +842,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 +862,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..1eaf6b76 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-2012     *)
 (*   \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..f43fc505 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-2012     *)
 (*   \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,17 @@ 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 when Errors.noncritical e ->
+    msgnl (str"Error defining instance := "++pr_constr def++str" : "++pr_constr typ++str"  "++Errors.print e)
 
 let rec iter_under_prod (f:rel_context->constr->unit) (ctx:rel_context) t = f ctx t;
   match kind_of_term t with
@@ -255,7 +258,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 +313,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..3ce8459b 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-2012     *)
 (*   \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/backtrack.ml b/toplevel/backtrack.ml
new file mode 100644
index 00000000..f444fc2d
--- /dev/null
+++ b/toplevel/backtrack.ml
@@ -0,0 +1,243 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Names
+open Vernacexpr
+
+(** Command history stack
+
+    We maintain a stack of the past states of the system. Each
+    successfully interpreted command adds an [info] element
+    to this stack, storing what were the (label / current proof / ...)
+    just _after_ the interpretation of this command.
+
+    - A label is just an integer, starting from Lib.first_command_label
+      initially, and incremented at each new successful command.
+    - If some proofs are opened, we have their number in [nproofs],
+      the name of the current proof in [prfname], the current depth in
+      [prfdepth].
+    - Otherwise, [nproofs = 0], [prfname = None], [prfdepth = 0]
+    - The text of the command is stored (for Show Script currently).
+    - A command can be tagged later as non-"reachable" when the current proof
+      at the time of this command has been ended by Qed/Abort/Restart,
+      meaning we can't backtrack there.
+*)
+
+type info = {
+  label : int;
+  nproofs : int;
+  prfname : identifier option;
+  prfdepth : int;
+  ngoals : int;
+  cmd : vernac_expr;
+  mutable reachable : bool;
+}
+
+let history : info Stack.t = Stack.create ()
+
+(** Is this stack active (i.e. nonempty) ?
+    The stack is currently inactive when compiling files (coqc). *)
+
+let is_active () = not (Stack.is_empty history)
+
+(** For debug purpose, a dump of the history *)
+
+let dump_history () =
+  let l = ref [] in
+  Stack.iter (fun i -> l:=i::!l) history;
+  !l
+
+(** Basic manipulation of the command history stack *)
+
+exception Invalid
+
+let pop () = ignore (Stack.pop history)
+
+let npop n =
+ (* Since our history stack always contains an initial entry,
+    it's invalid to try to completely empty it *)
+ if n < 0 || n >= Stack.length history then raise Invalid
+ else for i = 1 to n do pop () done
+
+let top () =
+  try Stack.top history with Stack.Empty -> raise Invalid
+
+(** Search the history stack for a suitable location. We perform first
+    a non-destructive search: in case of search failure, the stack is
+    unchanged. *)
+
+exception Found of info
+
+let search test =
+  try
+    Stack.iter (fun i -> if test i then raise (Found i)) history;
+    raise Invalid
+  with Found i ->
+    while i != Stack.top history do pop () done
+
+(** An auxiliary function to retrieve the number of remaining subgoals *)
+
+let get_ngoals () =
+  try
+    let prf = Proof_global.give_me_the_proof () in
+    List.length (Evd.sig_it (Proof.V82.background_subgoals prf))
+  with Proof_global.NoCurrentProof -> 0
+
+(** Register the end of a command and store the current state *)
+
+let mark_command ast =
+  Lib.add_frozen_state();
+  Lib.mark_end_of_command();
+  Stack.push
+    { label = Lib.current_command_label ();
+      nproofs = List.length (Pfedit.get_all_proof_names ());
+      prfname =
+        (try Some (Pfedit.get_current_proof_name ())
+         with Proof_global.NoCurrentProof -> None);
+      prfdepth = max 0 (Pfedit.current_proof_depth ());
+      reachable = true;
+      ngoals = get_ngoals ();
+      cmd = ast }
+    history
+
+(** Backtrack by aborting [naborts] proofs, then setting proof-depth back to
+    [pnum] and finally going to state number [snum]. *)
+
+let raw_backtrack snum pnum naborts =
+  for i = 1 to naborts do Pfedit.delete_current_proof () done;
+  Pfedit.undo_todepth pnum;
+  Lib.reset_label snum
+
+(** Re-sync the state of the system (label, proofs) with the top
+    of the history stack. We may end on some earlier state to avoid
+    re-opening proofs. This function will return the final label
+    and the number of extra backtracking steps performed. *)
+
+let sync nb_opened_proofs =
+  (* Backtrack by enough additional steps to avoid re-opening proofs.
+     Typically, when a Qed has been crossed, we backtrack to the proof start.
+     NB: We cannot reach the empty stack, since the first entry in the
+     stack has no opened proofs and is tagged as reachable.
+  *)
+  let extra = ref 0 in
+  while not (top()).reachable do incr extra; pop () done;
+  let target = top ()
+  in
+  (* Now the opened proofs at target is a subset of the opened proofs before
+     the backtrack, we simply abort the extra proofs (if any).
+     NB: It is critical here that proofs are nested in a regular way
+     (i.e. no more Resume or Suspend commands as earlier). This way, we can
+     simply count the extra proofs to abort instead of taking care of their
+     names.
+  *)
+  let naborts = nb_opened_proofs - target.nproofs in
+  (* We are now ready to do a low-level backtrack *)
+  raw_backtrack target.label target.prfdepth naborts;
+  (target.label, !extra)
+
+(** Backtracking by a certain number of (non-state-preserving) commands.
+    This is used by Coqide.
+    It may actually undo more commands than asked : for instance instead
+    of jumping back in the middle of a finished proof, we jump back before
+    this proof. The number of extra backtracked command is returned at
+    the end. *)
+
+let back count =
+  if count = 0 then 0
+  else
+    let nb_opened_proofs = List.length (Pfedit.get_all_proof_names ()) in
+    npop count;
+    snd (sync nb_opened_proofs)
+
+(** Backtracking to a certain state number, and reset proofs accordingly.
+    We may end on some earlier state if needed to avoid re-opening proofs.
+    Return the final state number. *)
+
+let backto snum =
+  if snum = Lib.current_command_label () then snum
+  else
+    let nb_opened_proofs = List.length (Pfedit.get_all_proof_names ()) in
+    search (fun i -> i.label = snum);
+    fst (sync nb_opened_proofs)
+
+(** Old [Backtrack] code with corresponding update of the history stack.
+    [Backtrack] is now deprecated (in favor of [BackTo]) but is kept for
+    compatibility with ProofGeneral. It's completely up to ProofGeneral
+    to decide where to go and how to adapt proofs. Note that the choices
+    of ProofGeneral are currently not always perfect (for instance when
+    backtracking an Undo). *)
+
+let backtrack snum pnum naborts =
+  raw_backtrack snum pnum naborts;
+  search (fun i -> i.label = snum)
+
+(** [reset_initial] resets the system and clears the command history
+    stack, only pushing back the initial entry. It should be equivalent
+    to [backto Lib.first_command_label], but sligthly more efficient. *)
+
+let reset_initial () =
+  let init_label = Lib.first_command_label in
+  if Lib.current_command_label () = init_label then ()
+  else begin
+    Pfedit.delete_all_proofs ();
+    Lib.reset_label init_label;
+    Stack.clear history;
+    Stack.push
+      { label = init_label;
+	nproofs = 0;
+	prfname = None;
+	prfdepth = 0;
+	ngoals = 0;
+	reachable = true;
+	cmd = VernacNop }
+      history
+  end
+
+(** Reset to the last known state just before defining [id] *)
+
+let reset_name id =
+  let lbl =
+    try Lib.label_before_name id with Not_found -> raise Invalid
+  in
+  ignore (backto lbl)
+
+(** When a proof is ended (via either Qed/Admitted/Restart/Abort),
+    old proof steps should be marked differently to avoid jumping back
+    to them:
+     - either this proof isn't there anymore in the proof engine
+     - either it's there but it's a more recent attempt after a Restart,
+       so we shouldn't mix the two.
+    We also mark as unreachable the proof steps cancelled via a Undo. *)
+
+let mark_unreachable ?(after=0) prf_lst =
+  let fix i = match i.prfname with
+    | None -> raise Not_found (* stop hacking the history outside of proofs *)
+    | Some p ->
+      if List.mem p prf_lst && i.prfdepth > after
+      then i.reachable <- false
+  in
+  try Stack.iter fix history with Not_found -> ()
+
+(** Parse the history stack for printing the script of a proof *)
+
+let get_script prf =
+  let script = ref [] in
+  let select i = match i.prfname with
+    | None -> raise Not_found
+    | Some p when p=prf && i.reachable -> script := i :: !script
+    | _ -> ()
+  in
+  (try Stack.iter select history with Not_found -> ());
+  (* Get rid of intermediate commands which don't grow the proof depth *)
+  let rec filter n = function
+    | [] -> []
+    | {prfdepth=d; cmd=c; ngoals=ng}::l when n < d -> (c,ng) :: filter d l
+    | {prfdepth=d}::l -> filter d l
+  in
+  (* initial proof depth (after entering the lemma statement) is 1 *)
+  filter 1 !script
diff --git a/toplevel/backtrack.mli b/toplevel/backtrack.mli
new file mode 100644
index 00000000..413ecd2e
--- /dev/null
+++ b/toplevel/backtrack.mli
@@ -0,0 +1,99 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Command history stack
+
+    We maintain a stack of the past states of the system after each
+    (non-state-preserving) interpreted commands
+*)
+
+(** [mark_command ast] marks the end of a command:
+    - it stores a frozen state and a end of command in the Lib stack,
+    - it stores the current state information in the command history
+    stack *)
+
+val mark_command : Vernacexpr.vernac_expr -> unit
+
+(** Is this history stack active (i.e. nonempty) ?
+    The stack is currently inactive when compiling files (coqc). *)
+
+val is_active : unit -> bool
+
+(** The [Invalid] exception is raised when one of the following function
+    tries to empty the history stack, or reach an unknown states, etc.
+    The stack is preserved in these cases. *)
+
+exception Invalid
+
+(** Nota Bene: it is critical for the following functions that proofs
+    are nested in a regular way (i.e. no more Resume or Suspend commands
+    as earlier). *)
+
+(** Backtracking by a certain number of (non-state-preserving) commands.
+    This is used by Coqide.
+    It may actually undo more commands than asked : for instance instead
+    of jumping back in the middle of a finished proof, we jump back before
+    this proof. The number of extra backtracked command is returned at
+    the end. *)
+
+val back : int -> int
+
+(** Backtracking to a certain state number, and reset proofs accordingly.
+    We may end on some earlier state if needed to avoid re-opening proofs.
+    Return the state number on which we finally end. *)
+
+val backto : int -> int
+
+(** Old [Backtrack] code with corresponding update of the history stack.
+    [Backtrack] is now deprecated (in favor of [BackTo]) but is kept for
+    compatibility with ProofGeneral. It's completely up to ProofGeneral
+    to decide where to go and how to adapt proofs. Note that the choices
+    of ProofGeneral are currently not always perfect (for instance when
+    backtracking an Undo). *)
+
+val backtrack : int -> int -> int -> unit
+
+(** [reset_initial] resets the system and clears the command history
+    stack, only pushing back the initial entry. It should be equivalent
+    to [backto Lib.first_command_label], but sligthly more efficient. *)
+
+val reset_initial : unit -> unit
+
+(** Reset to the last known state just before defining [id] *)
+
+val reset_name : Names.identifier Util.located -> unit
+
+(** When a proof is ended (via either Qed/Admitted/Restart/Abort),
+    old proof steps should be marked differently to avoid jumping back
+    to them:
+     - either this proof isn't there anymore in the proof engine
+     - either a proof with the same name is there, but it's a more recent
+       attempt after a Restart/Abort, we shouldn't mix the two.
+    We also mark as unreachable the proof steps cancelled via a Undo.
+*)
+
+val mark_unreachable : ?after:int -> Names.identifier list -> unit
+
+(** Parse the history stack for printing the script of a proof *)
+
+val get_script : Names.identifier -> (Vernacexpr.vernac_expr * int) list
+
+
+(** For debug purpose, a dump of the history *)
+
+type info = {
+  label : int;
+  nproofs : int;
+  prfname : Names.identifier option;
+  prfdepth : int;
+  ngoals : int;
+  cmd : Vernacexpr.vernac_expr;
+  mutable reachable : bool;
+}
+
+val dump_history : unit -> info list
diff --git a/toplevel/cerrors.ml b/toplevel/cerrors.ml
index 095f50c6..3b6f0f7c 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: cerrors.ml 15025 2012-03-09 14:27:07Z glondu $ *)
-
+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 ".")
-  | Compat.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))
-  | Compat.Exc_located (loc,exc) ->
-      Compat.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..96c73eb6 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-2012     *)
 (*   \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..52d507a1 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-2012     *)
 (*   \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
 
@@ -255,7 +255,7 @@ let add_new_coercion_core coef stre source target isid =
   in
   check_source (Some cls);
   if not (uniform_cond (llp-ind) lvs) then
-    raise (CoercionError NotUniform);
+    warning (Pp.string_of_ppcmds (explain_coercion_error coef NotUniform));
   let clt =
     try
       get_target tg ind
@@ -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..2228143b 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-2012     *)
 (*   \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..de4d1ab1 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-2012     *)
 (*   \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,24 @@ 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 e when Errors.noncritical e -> 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 +56,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 +71,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 +104,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 +143,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 +185,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 +221,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 +234,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 +249,32 @@ 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 _ = 
+	  evars := Evarutil.nf_evar_map !evars;
+	  evars := Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals ~fail:true
+            env !evars;
+	  (* Try resolving fields that are typeclasses automatically. *)
+	  evars := Typeclasses.resolve_typeclasses ~filter:Typeclasses.all_evars ~fail:false
+	    env !evars
 	in
 	let termtype = Evarutil.nf_evar !evars termtype in
-	let term = 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,33 +293,30 @@ 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;
-  let ctx = try named_of_rel_context fullctx with _ ->
-    error "Anonymous variables not allowed in contexts."
+  let ctx =
+    try named_of_rel_context fullctx
+    with e when Errors.noncritical e ->
+      error "Anonymous variables not allowed in contexts."
   in
   let fn (id, _, t) =
     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 +324,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..a61f4f65 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-2012     *)
 (*   \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..8bbe9454 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-2012     *)
 (*   \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,40 @@ 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,
+	(* Check that all implicit arguments inferable from the term is inferable from the type *)
+	if not (try List.for_all (fun (key,va) -> List.assoc key impsty = va) imps2 with Not_found -> false)
+	then warn (str "Implicit arguments declaration relies on type." ++
+		     spc () ++ str "The term declares more implicits than the type here.");
+	imps1@(Impargs.lift_implicits nb_args impsty),
 	{ 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 +118,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 +142,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 +155,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 +232,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
@@ -247,7 +254,7 @@ let interp_mutual_inductive (paramsl,indl) notations finite =
   let mldatas = List.map2 (mk_mltype_data evdref env_params params) arities indnames in
 
   let constructors =
-    States.with_state_protection (fun () ->
+    Metasyntax.with_syntax_protection (fun () ->
      (* Temporary declaration of notations and scopes *)
      List.iter (Metasyntax.set_notation_for_interpretation impls) notations;
      (* Interpret the constructor types *)
@@ -256,7 +263,7 @@ let interp_mutual_inductive (paramsl,indl) notations finite =
 
   (* Instantiate evars and check all are resolved *)
   let evd = consider_remaining_unif_problems env_params !evdref in
-  let evd = Typeclasses.resolve_typeclasses ~onlyargs:false ~fail:true env_params evd in
+  let evd = Typeclasses.resolve_typeclasses ~filter:(Typeclasses.no_goals) ~fail:true env_params evd in
   let sigma = evd in
   let constructors = List.map (fun (idl,cl,impsl) -> (idl,List.map (nf_evar sigma) cl,impsl)) constructors in
   let ctx_params = Sign.map_rel_context (nf_evar sigma) ctx_params in
@@ -287,17 +294,14 @@ let interp_mutual_inductive (paramsl,indl) notations finite =
     mind_entry_inds = entries },
     impls
 
-let eq_constr_expr c1 c2 =
-  try let _ = Constrextern.check_same_type c1 c2 in true with _ -> false
-
 (* Very syntactical equality *)
 let eq_local_binder d1 d2 = match d1,d2 with
   | LocalRawAssum (nal1,k1,c1), LocalRawAssum (nal2,k2,c2) ->
       List.length nal1 = List.length nal2 && k1 = k2 &&
       List.for_all2 (fun (_,na1) (_,na2) -> na1 = na2) nal1 nal2 &&
-      eq_constr_expr c1 c2
+      Constrextern.is_same_type c1 c2
   | LocalRawDef ((_,id1),c1), LocalRawDef ((_,id2),c2) ->
-      id1 = id2 && eq_constr_expr c1 c2
+      id1 = id2 && Constrextern.is_same_type c1 c2
   | _ ->
       false
 
@@ -321,7 +325,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 +339,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 +446,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,13 +459,13 @@ 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 impl_env', ((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)
-      
-let interp_fix_ccl evdref (env,_) fix =
-  interp_type_evars evdref env fix.fix_type
+    ((env'', ctx' @ ctx), (impl_env',imps @ imps'), annot)
+
+let interp_fix_ccl evdref impls (env,_) fix =
+  interp_type_evars_impls ~impls ~evdref ~fail_evar:false env fix.fix_type
 
 let interp_fix_body evdref env_rec impls (_,ctx) fix ccl =
   Option.map (fun body ->
@@ -471,13 +475,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);
@@ -511,11 +515,15 @@ let interp_recursive isfix fixl notations =
 
   (* Interp arities allowing for unresolved types *)
   let evdref = ref Evd.empty in
-  let fixctxs, fiximps, fixannots =
+  let fixctxs, fiximppairs, fixannots =
     list_split3 (List.map (interp_fix_context evdref env isfix) fixl) in
-  let fixccls = List.map2 (interp_fix_ccl evdref) fixctxs fixl in
+  let fixctximpenvs, fixctximps = List.split fiximppairs in
+  let fixccls,fixcclimps = List.split (list_map3 (interp_fix_ccl evdref) fixctximpenvs fixctxs fixl) in
   let fixtypes = List.map2 build_fix_type fixctxs fixccls in
   let fixtypes = List.map (nf_evar !evdref) fixtypes in
+  let fiximps = list_map3
+    (fun ctximps cclimps (_,ctx) -> ctximps@(Impargs.lift_implicits (List.length ctx) cclimps))
+    fixctximps fixcclimps fixctxs in
   let env_rec = push_named_types env fixnames fixtypes in
 
   (* Get interpretation metadatas *)
@@ -523,9 +531,11 @@ let interp_recursive isfix fixl notations =
 
   (* Interp bodies with rollback because temp use of notations/implicit *)
   let fixdefs =
-    States.with_state_protection (fun () ->
+    Metasyntax.with_syntax_protection (fun () ->
       List.iter (Metasyntax.set_notation_for_interpretation impls) notations;
-      list_map3 (interp_fix_body evdref env_rec impls) fixctxs fixl fixccls)
+      list_map4
+	(fun fixctximpenv -> interp_fix_body evdref env_rec (Idmap.fold Idmap.add fixctximpenv impls))
+	fixctximpenvs fixctxs fixl fixccls)
       () in
 
   (* Instantiate evars and check all are resolved *)
@@ -533,7 +543,7 @@ let interp_recursive isfix fixl notations =
   let fixdefs = List.map (Option.map (nf_evar evd)) fixdefs in
   let fixtypes = List.map (nf_evar evd) fixtypes in
   let fixctxnames = List.map (fun (_,ctx) -> List.map pi1 ctx) fixctxs in
-  let evd = Typeclasses.resolve_typeclasses ~onlyargs:false ~fail:true env evd in
+  let evd = Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals ~fail:true env evd in
   List.iter (Option.iter (check_evars env_rec Evd.empty evd)) fixdefs;
   List.iter (check_evars env Evd.empty evd) fixtypes;
   if not (List.mem None fixdefs) then begin
@@ -547,7 +557,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 +575,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 +598,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 +624,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..b1cf2053 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-2012     *)
 (*   \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..8f954573 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-2012     *)
 (*   \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,26 +33,29 @@ 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 ->
+    with reraise ->
       (msgnl (str"Load of rcfile failed.");
-       raise e)
+       raise reraise)
   else
     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,12 +127,19 @@ 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
       [ [ "config" ]; [ "dev" ]; [ "lib" ]; [ "kernel" ]; [ "library" ];
 	[ "pretyping" ]; [ "interp" ]; [ "parsing" ]; [ "proofs" ];
 	[ "tactics" ]; [ "toplevel" ]; [ "translate" ]; [ "ide" ] ]
+
+let get_compat_version = function
+  | "8.3" -> Flags.V8_3
+  | "8.2" -> Flags.V8_2
+  | ("8.1" | "8.0") as s ->
+    warning ("Compatibility with version "^s^" not supported.");
+    Flags.V8_2
+  | s -> Util.error ("Unknown compatibility version \""^s^"\".")
diff --git a/toplevel/coqinit.mli b/toplevel/coqinit.mli
index c0f59a56..9ca1deb4 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-2012     *)
 (*   \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
@@ -25,3 +22,5 @@ val init_load_path : unit -> unit
 val init_library_roots : unit -> unit
 
 val init_ocaml_path : unit -> unit
+
+val get_compat_version : string -> Flags.compat_version
diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml
index 7887a060..adbdb31b 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-2012     *)
 (*   \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
@@ -26,7 +24,8 @@ let get_version_date () =
     let ver = input_line ch in
     let rev = input_line ch in
       (ver,rev)
-  with _ -> (Coq_config.version,Coq_config.date)
+  with e when Errors.noncritical e ->
+    (Coq_config.version,Coq_config.date)
 
 let print_header () =
   let (ver,rev) = (get_version_date ()) in
@@ -121,52 +120,13 @@ let compile_files () =
 	   Vernac.compile v f)
       (List.rev !compile_list)
 
-let set_compat_version = function
-  | "8.2" -> compat_version := Some V8_2
-  | "8.1" -> warning "Compatibility with version 8.1 not supported."
-  | "8.0" -> warning "Compatibility with version 8.0 not supported."
-  | s -> error ("Unknown compatibility version \""^s^"\".")
-
-let re_exec_version = ref ""
-let set_byte () = re_exec_version := "byte"
-let set_opt () = re_exec_version := "opt"
-
-(* 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 +143,16 @@ let usage () =
 
 let warning s = msg_warning (str s)
 
+let ide_slave = ref false
+let filter_opts = ref false
+
+let verb_compat_ntn = ref false
+let no_compat_ntn = 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 +180,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 +229,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
 
@@ -273,35 +240,40 @@ let parse_args is_ide =
 
     | "-debug" :: rem -> set_debug (); parse rem
 
-    | "-compat" :: v :: rem -> set_compat_version v; parse rem
+    | "-compat" :: v :: rem ->
+        Flags.compat_version := get_compat_version v; parse rem
     | "-compat" :: []       -> usage ()
 
+    | "-verbose-compat-notations" :: rem -> verb_compat_ntn := true; parse rem
+    | "-no-compat-notations" :: rem -> no_compat_ntn := true; parse rem
+
     | "-vm" :: rem -> use_vm := true; parse rem
-    | "-emacs" :: rem -> Flags.print_emacs := true; Pp.make_pp_emacs(); parse rem
-    | "-emacs-U" :: rem -> Flags.print_emacs := true;
-	Flags.print_emacs_safechar := true; Pp.make_pp_emacs(); parse rem
+    | "-emacs" :: rem ->
+	Flags.print_emacs := true; Pp.make_pp_emacs();
+	Vernacentries.qed_display_script := false;
+	parse rem
+    | "-emacs-U" :: rem ->
+	warning "Obsolete option \"-emacs-U\", use -emacs instead.";	
+	parse ("-emacs" :: rem)
 
     | "-unicode" :: rem -> add_require "Utf8_core"; parse rem
 
     | "-coqlib" :: d :: rem -> Flags.coqlib_spec:=true; Flags.coqlib:=d; parse rem
     | "-coqlib" :: [] -> usage ()
 
-    | "-where" :: _ -> print_endline (Envars.coqlib ()); exit 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,37 +292,50 @@ 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
+    | any -> begin msgnl (Errors.print any); 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 ();
+      Mltop.init_known_plugins ();
       set_vm_opt ();
       engage ();
+      (* Be careful to set these variables after the inputstate *)
+      Syntax_def.set_verbose_compat_notations !verb_compat_ntn;
+      Syntax_def.set_compat_notations (not !no_compat_ntn);
       if (not !batch_mode|| !compile_list=[]) && Global.env_is_empty() then
         Option.iter Declaremods.start_library !toplevel_name;
       init_library_roots ();
@@ -360,10 +345,10 @@ let init is_ide =
       load_vernacular ();
       compile_files ();
       outputstate ()
-    with e ->
+    with any ->
       flush_all();
       if not !batch_mode then message "Error during initialization:";
-      msgnl (Toplevel.print_toplevel_error e);
+      msgnl (Toplevel.print_toplevel_error any);
       exit 1
   end;
   if !batch_mode then
@@ -372,15 +357,17 @@ let init is_ide =
        Pp.ppnl (with_option raw_print Prettyp.print_full_pure_context ());
      Profile.print_profile ();
      exit 0);
-  Lib.declare_initial_state ()
+  (* We initialize the command history stack with a first entry *)
+  Backtrack.mark_command Vernacexpr.VernacNop
 
-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..73e21484 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-2012     *)
 (*   \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..7d8807ea 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-2012     *)
 (*   \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..8c64f3ed 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-2012     *)
 (*   \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..f550df16 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-2012     *)
 (*   \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,12 +26,13 @@ open Reduction
 open Cases
 open Logic
 open Printer
-open Rawterm
+open Glob_term
 open Evd
+open Libnames
+open Declarations
 
 let pr_lconstr c = quote (pr_lconstr c)
 let pr_lconstr_env e c = quote (pr_lconstr_env e c)
-let pr_lconstr_env_at_top e c = quote (pr_lconstr_env_at_top e c)
 let pr_ljudge_env e c = let v,t = pr_ljudge_env e c in (quote v,quote t)
 
 let pr_db env i =
@@ -52,7 +51,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 +111,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 +124,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 +133,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 +155,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 +166,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 +192,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 +213,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 +244,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 +263,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 +290,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 ++
@@ -293,9 +309,11 @@ let explain_ill_formed_rec_body env err names i fixenv vdefj =
       let fixenv = make_all_name_different fixenv in
       let pvd = pr_lconstr_env fixenv vdefj.(i).uj_val in
 	str"Recursive definition is:" ++ spc () ++ pvd ++ str "."
-    with _ -> mt ())
+    with e when Errors.noncritical e -> 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 +323,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 +374,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
@@ -369,15 +390,12 @@ let explain_unsolvability = function
       strbrk " (several distinct possible instances found)"
 
 let explain_typeclass_resolution env evi k =
-  match k with
-  | GoalEvar | InternalHole | ImplicitArg _ ->
-      (match Typeclasses.class_of_constr evi.evar_concl with
-      | Some c ->
-	  let env = Evd.evar_env evi in
-	    fnl () ++ str "Could not find an instance for " ++
-	      pr_lconstr_env env evi.evar_concl ++
-	      pr_ne_context_of (str " in environment:"++ fnl ()) (str ".") env
-      | None -> mt())
+  match Typeclasses.class_of_constr evi.evar_concl with
+  | Some c ->
+    let env = Evd.evar_env evi in
+      fnl () ++ str "Could not find an instance for " ++
+      pr_lconstr_env env evi.evar_concl ++
+      pr_ne_context_of (str " in environment:"++ fnl ()) (str ".") env
   | _ -> mt()
 
 let explain_unsolvable_implicit env evi k explain =
@@ -401,13 +419,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 +469,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 +477,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 +485,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 +525,158 @@ 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 (env, typ1, typ2) ->
+    str "expected type" ++ spc ()  ++
+    quote (Printer.safe_pr_lconstr_env env typ2) ++ spc () ++
+    str "but found type" ++ spc () ++
+    quote (Printer.safe_pr_lconstr_env env typ1)
+  | 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 *)
 
@@ -524,8 +697,11 @@ let explain_no_instance env (_,id) l =
   str "applied to arguments" ++ spc () ++
     prlist_with_sep pr_spc (pr_lconstr_env env) l
 
+let is_goal_evar evi = match evi.evar_source with (_, GoalEvar) -> true | _ -> false
+
 let pr_constraints printenv env evm =
   let l = Evd.to_list evm in
+  assert(l <> []);
   let (ev, evi) = List.hd l in
     if List.for_all (fun (ev', evi') ->
       eq_named_context_val evi.evar_hyps evi'.evar_hyps) l
@@ -534,23 +710,30 @@ 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 undef = Evd.undefined_evars evm in
+  let evm = Evd.undefined_evars (Evarutil.nf_evar_map_undefined evd) in
+  (* Remove goal evars *)
+  let undef = fold_undefined 
+    (fun ev evi evm' -> 
+       if is_goal_evar evi then Evd.remove evm' ev else evm') evm evm
+  in
   match constr with
   | None ->
       str"Unable to satisfy the following constraints:" ++ fnl() ++
 	pr_constraints true env undef
   | Some (ev, k) ->
-      explain_unsolvable_implicit env (Evd.find evm ev) k None ++ fnl () ++
-	if List.length (Evd.to_list undef) > 1 then
-	  str"With the following constraints:" ++ fnl() ++
-	    pr_constraints false env (Evd.remove undef ev)
-	else mt ()
+      explain_typeclass_resolution env (Evd.find evm ev) k ++ fnl () ++
+	(let remaining = Evd.remove undef ev in
+	   if Evd.has_undefined remaining then
+	     str"With the following constraints:" ++ fnl() ++
+	       pr_constraints false env remaining
+	   else mt ())
 
 let explain_mismatched_contexts env c i j =
   str"Mismatched contexts while declaring instance: " ++ brk (1,1) ++
@@ -644,8 +827,12 @@ let error_ill_formed_constructor env id c v nparams nargs =
    else
      mt()) ++ str "."
 
+let pr_ltype_using_barendregt_convention_env env c =
+  (* Use goal_concl_style as an approximation of Barendregt's convention (?) *)
+  quote (pr_goal_concl_style_env env c)
+
 let error_bad_ind_parameters env c n v1 v2  =
-  let pc = pr_lconstr_env_at_top env c in
+  let pc = pr_ltype_using_barendregt_convention_env env c in
   let pv1 = pr_lconstr_env env v1 in
   let pv2 = pr_lconstr_env env v2 in
   str "Last occurrence of " ++ pv2 ++ str " must have " ++ pv1 ++
@@ -684,7 +871,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 () ++
@@ -803,13 +990,19 @@ let explain_pattern_matching_error env = function
 
 let explain_reduction_tactic_error = function
   | Tacred.InvalidAbstraction (env,c,(env',e)) ->
-      str "The abstracted term" ++ spc () ++ pr_lconstr_env_at_top env c ++
+      str "The abstracted term" ++ spc () ++
+      quote (pr_goal_concl_style_env 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 =
     (nrep,last) :: List.rev (List.map(fun(n,_,ck)->(n,ck))trace) in
+  let tacexpr_differ te te' =
+    (* NB: The following comparison may raise an exception
+       since a tacexpr may embed a functional part via a TacExtend *)
+    try te <> te' with Invalid_argument _ -> false
+  in
   let pr_call (n,ck) =
     (match ck with
        | Proof_type.LtacNotationCall s -> quote (str s)
@@ -821,17 +1014,17 @@ let explain_ltac_call_trace (nrep,last,trace,loc) =
 	   (Pptactic.pr_glob_tactic (Global.env())
 	      (Tacexpr.TacAtom (dummy_loc,te)))
 	   ++ (match !otac with
-		 | Some te' when (Obj.magic te' <> te) ->
-		     strbrk " (expanded to " ++ quote
-		       (Pptactic.pr_tactic (Global.env())
-			  (Tacexpr.TacAtom (dummy_loc,te')))
-		     ++ str ")"
+		 | Some te' when tacexpr_differ (Obj.magic te') te ->
+		   strbrk " (expanded to " ++ quote
+		     (Pptactic.pr_tactic (Global.env())
+			(Tacexpr.TacAtom (dummy_loc,te')))
+		   ++ str ")"
 		 | _ -> mt ())
        | Proof_type.LtacConstrInterp (c,(vars,unboundvars)) ->
 	   let filter =
 	     function (id,None) -> None | (id,Some id') -> Some(id,([],mkVar id')) in
 	   let unboundvars = list_map_filter filter unboundvars in
-	   quote (pr_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..84d3ec95 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-2012     *)
 (*   \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..6937eeb8
--- /dev/null
+++ b/toplevel/ide_intf.ml
@@ -0,0 +1,599 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Protocol version of this file. This is the date of the last modification. *)
+
+(** WARNING: TO BE UPDATED WHEN MODIFIED! *)
+
+let protocol_version = "20120710"
+
+(** * 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
+  | Search of search_flags
+  | GetOptions
+  | SetOptions of (option_name * option_value) list
+  | InLoadPath of string
+  | MkCases of string
+  | Quit
+  | About
+
+(** 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;
+  search : search_flags -> string coq_object list;
+  get_options : unit -> (option_name * option_state) list;
+  set_options : (option_name * option_value) list -> unit;
+  inloadpath : string -> bool;
+  mkcases : string -> string list list;
+  quit : unit -> unit;
+  about : unit -> coq_info;
+  handle_exn : exn -> location * 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 search flags : string coq_object list call = Search flags
+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
+let quit : unit call = Quit
+
+(** * 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)
+      | Search flags -> Obj.magic (handler.search flags : string coq_object list)
+      | 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)
+      | Quit -> Obj.magic (handler.quit () : unit)
+      | About -> Obj.magic (handler.about () : coq_info)
+    in Good res
+  with any ->
+    let (l, str) = handler.handle_exn any 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_unit () = Element ("unit", [], [])
+
+let to_unit = function
+  | Element ("unit", [], []) -> ()
+  | _ -> raise Marshal_error
+
+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]) ->
+  (try int_of_string s with Failure _ -> raise Marshal_error)
+| _ -> 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_search_constraint = function
+| Name_Pattern s ->
+  constructor "search_constraint" "name_pattern" [of_string s]
+| Type_Pattern s ->
+  constructor "search_constraint" "type_pattern" [of_string s]
+| SubType_Pattern s ->
+  constructor "search_constraint" "subtype_pattern" [of_string s]
+| In_Module m ->
+  constructor "search_constraint" "in_module" [of_list of_string m]
+| Include_Blacklist ->
+  constructor "search_constraint" "include_blacklist" []
+
+let to_search_constraint xml = do_match xml "search_constraint"
+  (fun s args -> match s with
+  | "name_pattern" -> Name_Pattern (to_string (singleton args))
+  | "type_pattern" -> Type_Pattern (to_string (singleton args))
+  | "subtype_pattern" -> SubType_Pattern (to_string (singleton args))
+  | "in_module" -> In_Module (to_list to_string (singleton args))
+  | "include_blacklist" -> Include_Blacklist
+  | _ -> raise Marshal_error)
+
+let of_coq_object f ans =
+  let prefix = of_list of_string ans.coq_object_prefix in
+  let qualid = of_list of_string ans.coq_object_qualid in
+  let obj = f ans.coq_object_object in
+  Element ("coq_object", [], [prefix; qualid; obj])
+
+let to_coq_object f = function
+| Element ("coq_object", [], [prefix; qualid; obj]) ->
+  let prefix = to_list to_string prefix in
+  let qualid = to_list to_string qualid in
+  let obj = f obj in {
+    coq_object_prefix = prefix;
+    coq_object_qualid = qualid;
+    coq_object_object = obj;
+  }
+| _ -> raise Marshal_error
+
+let of_value f = function
+| Good x -> Element ("value", ["val", "good"], [f x])
+| Fail (loc, msg) ->
+  let loc = match loc with
+  | None -> []
+  | Some (s, e) -> [("loc_s", string_of_int s); ("loc_e", string_of_int e)]
+  in
+  Element ("value", ["val", "fail"] @ loc, [PCData msg])
+
+let to_value f = function
+| Element ("value", attrs, l) ->
+  let ans = massoc "val" attrs in
+  if ans = "good" then Good (f (singleton l))
+  else if ans = "fail" then
+    let loc =
+      try
+        let loc_s = int_of_string (List.assoc "loc_s" attrs) in
+        let loc_e = int_of_string (List.assoc "loc_e" attrs) in
+        Some (loc_s, loc_e)
+      with e when e <> Sys.Break -> 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"], [])
+| Search flags ->
+  let args = List.map (of_pair of_search_constraint of_bool) flags in
+  Element ("call", ["val", "search"], args)
+| GetOptions ->
+  Element ("call", ["val", "getoptions"], [])
+| SetOptions opts ->
+  let args = List.map (of_pair (of_list of_string) of_option_value) opts in
+  Element ("call", ["val", "setoptions"], args)
+| InLoadPath file ->
+  Element ("call", ["val", "inloadpath"], [PCData file])
+| MkCases ind ->
+  Element ("call", ["val", "mkcases"], [PCData ind])
+| Quit ->
+  Element ("call", ["val", "quit"], [])
+| About ->
+  Element ("call", ["val", "about"], [])
+
+let to_call = function
+| Element ("call", attrs, l) ->
+  let ans = massoc "val" attrs in
+  begin match ans with
+  | "interp" ->
+    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
+  | "search" ->
+    let args = List.map (to_pair to_search_constraint to_bool) l in
+    Search args
+  | "getoptions" -> GetOptions
+  | "setoptions" ->
+    let args = List.map (to_pair (to_list to_string) to_option_value) l in
+    SetOptions args
+  | "inloadpath" -> InLoadPath (raw_string l)
+  | "mkcases" -> MkCases (raw_string l)
+  | "hints" -> Hints
+  | "quit" -> Quit
+  | "about" -> About
+  | _ -> raise Marshal_error
+  end
+| _ -> raise Marshal_error
+
+let of_status s =
+  let of_so = of_option of_string in
+  let of_sl = of_list of_string in
+  Element ("status", [],
+    [
+      of_sl s.status_path;
+      of_so s.status_proofname;
+      of_sl s.status_allproofs;
+      of_int s.status_statenum;
+      of_int s.status_proofnum;
+    ]
+  )
+
+let to_status = function
+| Element ("status", [], [path; name; prfs; snum; pnum]) ->
+  {
+    status_path = to_list to_string path;
+    status_proofname = to_option to_string name;
+    status_allproofs = to_list to_string prfs;
+    status_statenum = to_int snum;
+    status_proofnum = to_int pnum;
+  }
+| _ -> raise Marshal_error
+
+let of_evar s =
+  Element ("evar", [], [PCData s.evar_info])
+
+let to_evar = function
+| Element ("evar", [], data) -> { evar_info = raw_string data; }
+| _ -> raise Marshal_error
+
+let of_goal g =
+  let hyp = of_list of_string g.goal_hyp in
+  let ccl = of_string g.goal_ccl in
+  let id = of_string g.goal_id in
+  Element ("goal", [], [id; hyp; ccl])
+
+let to_goal = function
+| Element ("goal", [], [id; hyp; ccl]) ->
+  let hyp = to_list to_string hyp in
+  let ccl = to_string ccl in
+  let id = to_string id in
+  { goal_hyp = hyp; goal_ccl = ccl; goal_id = id; }
+| _ -> raise Marshal_error
+
+let of_goals g =
+  let of_glist = of_list of_goal in
+  let fg = of_list of_goal g.fg_goals in
+  let bg = of_list (of_pair of_glist of_glist) g.bg_goals in
+  Element ("goals", [], [fg; bg])
+
+let to_goals = function
+| Element ("goals", [], [fg; bg]) ->
+  let to_glist = to_list to_goal in
+  let fg = to_list to_goal fg in
+  let bg = to_list (to_pair to_glist to_glist) bg in
+  { fg_goals = fg; bg_goals = bg; }
+| _ -> raise Marshal_error
+
+let of_coq_info info =
+  let version = of_string info.coqtop_version in
+  let protocol = of_string info.protocol_version in
+  let release = of_string info.release_date in
+  let compile = of_string info.compile_date in
+  Element ("coq_info", [], [version; protocol; release; compile])
+
+let to_coq_info = function
+| Element ("coq_info", [], [version; protocol; release; compile]) ->
+  {
+    coqtop_version = to_string version;
+    protocol_version = to_string protocol;
+    release_date = to_string release;
+    compile_date = to_string compile;
+  }
+| _ -> raise Marshal_error
+
+(** Conversions between ['a value] and xml answers
+
+  When decoding an xml answer, we dynamically check that it is compatible
+  with the original call. For that we now rely on the fact that all
+  sub-fonctions [to_xxx : xml -> xxx] check that the current xml element
+  is "xxx", and raise [Marshal_error] if anything goes wrong.
+*)
+
+type value_type =
+  | Unit | String | Int | Bool | Goals | Evar | State | Option_state | Coq_info
+  | Option of value_type
+  | List of value_type
+  | Coq_object of value_type
+  | Pair of value_type * value_type
+
+let hint = List (Pair (String, String))
+let option_name = List String
+
+let expected_answer_type = function
+  | Interp _ -> String
+  | Rewind _ -> Int
+  | Goal -> Option Goals
+  | Evars -> Option (List Evar)
+  | Hints -> Option (Pair (List hint, hint))
+  | Status -> State
+  | Search _ -> List (Coq_object String)
+  | GetOptions -> List (Pair (option_name, Option_state))
+  | SetOptions _ -> Unit
+  | InLoadPath _ -> Bool
+  | MkCases _ -> List (List String)
+  | Quit -> Unit
+  | About -> Coq_info
+
+let of_answer (q : 'a call) (r : 'a value) : xml =
+  let rec convert ty : 'a -> xml = match ty with
+    | Unit -> Obj.magic of_unit
+    | Bool -> Obj.magic of_bool
+    | String -> Obj.magic of_string
+    | Int -> Obj.magic of_int
+    | State -> Obj.magic of_status
+    | Option_state -> Obj.magic of_option_state
+    | Coq_info -> Obj.magic of_coq_info
+    | Goals -> Obj.magic of_goals
+    | Evar -> Obj.magic of_evar
+    | List t -> Obj.magic (of_list (convert t))
+    | Option t -> Obj.magic (of_option (convert t))
+    | Coq_object t -> Obj.magic (of_coq_object (convert t))
+    | Pair (t1,t2) -> Obj.magic (of_pair (convert t1) (convert t2))
+  in
+  of_value (convert (expected_answer_type q)) r
+
+let to_answer xml (c : 'a call) : 'a value =
+  let rec convert ty : xml -> 'a = match ty with
+    | Unit -> Obj.magic to_unit
+    | Bool -> Obj.magic to_bool
+    | String -> Obj.magic to_string
+    | Int -> Obj.magic to_int
+    | State -> Obj.magic to_status
+    | Option_state -> Obj.magic to_option_state
+    | Coq_info -> Obj.magic to_coq_info
+    | Goals -> Obj.magic to_goals
+    | Evar -> Obj.magic to_evar
+    | List t -> Obj.magic (to_list (convert t))
+    | Option t -> Obj.magic (to_option (convert t))
+    | Coq_object t -> Obj.magic (to_coq_object (convert t))
+    | Pair (t1,t2) -> Obj.magic (to_pair (convert t1) (convert t2))
+  in
+  to_value (convert (expected_answer_type c)) 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"
+  | Search _ -> "SEARCH"
+  | GetOptions -> "GETOPTIONS"
+  | SetOptions l -> "SETOPTIONS" ^ " [" ^ pr_setoptions l ^ "]"
+  | InLoadPath s -> "INLOADPATH "^s
+  | MkCases s -> "MKCASES "^s
+  | Quit -> "QUIT"
+  | About -> "ABOUT"
+
+let pr_value_gen pr = function
+  | Good v -> "GOOD " ^ pr v
+  | Fail (_,str) -> "FAIL ["^str^"]"
+
+let pr_value v = pr_value_gen (fun _ -> "") v
+
+let pr_string s = "["^s^"]"
+let pr_bool b = if b then "true" else "false"
+
+let pr_status s =
+  let path =
+    let l = String.concat "." s.status_path in
+    "path=" ^ l ^ ";"
+  in
+  let name = match s.status_proofname with
+  | None -> "no proof;"
+  | Some n -> "proof = " ^ n ^ ";"
+  in
+  "Status: " ^ path ^ name
+
+let pr_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
+      let rec pr_focus _ = function
+      | [] -> assert false
+      | [lg, rg] -> Printf.sprintf "%i" (List.length lg + List.length rg)
+      | (lg, rg) :: l ->
+        Printf.sprintf "%i:%a" (List.length lg + List.length rg) pr_focus l
+      in
+      Printf.sprintf "Still focussed: [%a]." pr_focus g.bg_goals
+  else
+    let pr_menu s = s in
+    let pr_goal { goal_hyp = hyps; goal_ccl = goal } =
+      "[" ^ String.concat "; " (List.map pr_menu hyps) ^ " |- " ^ pr_menu goal ^ "]"
+    in
+    String.concat " " (List.map pr_goal g.fg_goals)
+
+let pr_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)
+    | Search _ -> pr_value 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)
+    | Quit -> pr_value value
+    | About -> pr_value value
+
diff --git a/toplevel/ide_intf.mli b/toplevel/ide_intf.mli
new file mode 100644
index 00000000..7d0685b1
--- /dev/null
+++ b/toplevel/ide_intf.mli
@@ -0,0 +1,113 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** * 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
+
+(** Quit gracefully the interpreter. *)
+val quit : unit call
+
+(** 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;
+  search : search_flags -> string coq_object list;
+  get_options : unit -> (option_name * option_state) list;
+  set_options : (option_name * option_value) list -> unit;
+  inloadpath : string -> bool;
+  mkcases : string -> string list list;
+  quit : unit -> unit;
+  about : unit -> coq_info;
+  handle_exn : exn -> location * string;
+}
+
+val abstract_eval_call : handler -> 'a call -> 'a value
+
+(** * Protocol version *)
+
+val protocol_version : string
+
+(** * 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 call -> '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..6e9a0ee0
--- /dev/null
+++ b/toplevel/ide_slave.ml
@@ -0,0 +1,466 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Vernacexpr
+open Names
+open Compat
+open Util
+open Pp
+open Printer
+open Namegen
+
+(** Ide_slave : an implementation of [Interface], i.e. mainly an interp
+    function and a rewind function. This specialized loop is triggered
+    when the -ideslave option is passed to Coqtop. Currently CoqIDE is
+    the only one using this mode, but we try here to be as generic as
+    possible, so this may change in the future... *)
+
+(** Signal handling: we postpone ^C during input and output phases,
+    but make it directly raise a Sys.Break during evaluation of the request. *)
+
+let catch_break = ref false
+
+let init_signal_handler () =
+  let f _ = if !catch_break then raise Sys.Break else Util.interrupt := true in
+  Sys.set_signal Sys.sigint (Sys.Signal_handle f)
+
+
+(** Redirection of standard output to a printable buffer *)
+
+let orig_stdout = ref stdout
+
+let init_stdout,read_stdout =
+  let out_buff = Buffer.create 100 in
+  let out_ft = Format.formatter_of_buffer out_buff in
+  let deep_out_ft = Format.formatter_of_buffer out_buff in
+  let _ = Pp_control.set_gp deep_out_ft Pp_control.deep_gp in
+  (fun () ->
+     flush_all ();
+     orig_stdout := Unix.out_channel_of_descr (Unix.dup Unix.stdout);
+     Unix.dup2 Unix.stderr Unix.stdout;
+     Pp_control.std_ft := out_ft;
+     Pp_control.err_ft := out_ft;
+     Pp_control.deep_ft := deep_out_ft;
+     set_binary_mode_out !orig_stdout true;
+     set_binary_mode_in stdin true;
+  ),
+  (fun () -> Format.pp_print_flush out_ft ();
+             let r = Buffer.contents out_buff in
+             Buffer.clear out_buff; r)
+
+let pr_debug s =
+  if !Flags.debug then Printf.eprintf "[pid %d] %s\n%!" (Unix.getpid ()) s
+
+(** Categories of commands *)
+
+let coqide_known_option table = List.mem table [
+  ["Printing";"Implicit"];
+  ["Printing";"Coercions"];
+  ["Printing";"Matching"];
+  ["Printing";"Synth"];
+  ["Printing";"Notations"];
+  ["Printing";"All"];
+  ["Printing";"Records"];
+  ["Printing";"Existential";"Instances"];
+  ["Printing";"Universes"]]
+
+let is_known_option cmd = match cmd with
+  | VernacSetOption (_,o,BoolValue true)
+  | VernacUnsetOption (_,o) -> coqide_known_option o
+  | _ -> false
+
+let is_debug cmd = match cmd with
+  | VernacSetOption (_,["Ltac";"Debug"], _) -> true
+  | _ -> false
+
+let is_query cmd = match cmd with
+  | VernacChdir None
+  | VernacMemOption _
+  | VernacPrintOption _
+  | VernacCheckMayEval _
+  | VernacGlobalCheck _
+  | VernacPrint _
+  | VernacSearch _
+  | VernacLocate _ -> true
+  | _ -> false
+
+let is_undo cmd = match cmd with
+  | VernacUndo _ | VernacUndoTo _ -> true
+  | _ -> false
+
+(** Check whether a command is forbidden by CoqIDE *)
+
+let coqide_cmd_checks (loc,ast) =
+  let user_error s =
+    raise (Loc.Exc_located (loc, Util.UserError ("CoqIde", str s)))
+  in
+  if is_debug ast then
+    user_error "Debug mode not available within CoqIDE";
+  if is_known_option ast then
+    user_error "Use CoqIDE display menu instead";
+  if is_navigation_vernac ast then
+    user_error "Use CoqIDE navigation instead";
+  if is_undo ast then
+    msgerrnl (str "Warning: rather use CoqIDE navigation instead");
+  if is_query ast then
+    msgerrnl (str "Warning: query commands should not be inserted in scripts")
+
+(** Interpretation (cf. [Ide_intf.interp]) *)
+
+let interp (raw,verbosely,s) =
+  let pa = Pcoq.Gram.parsable (Stream.of_string s) in
+  let loc_ast = Vernac.parse_sentence (pa,None) in
+  if not raw then coqide_cmd_checks loc_ast;
+  Flags.make_silent (not verbosely);
+  Vernac.eval_expr ~preserving:raw loc_ast;
+  Flags.make_silent true;
+  read_stdout ()
+
+(** Goal display *)
+
+let hyp_next_tac sigma env (id,_,ast) =
+  let id_s = Names.string_of_id id in
+  let type_s = string_of_ppcmds (pr_ltype_env env ast) in
+  [
+    ("clear "^id_s),("clear "^id_s^".");
+    ("apply "^id_s),("apply "^id_s^".");
+    ("exact "^id_s),("exact "^id_s^".");
+    ("generalize "^id_s),("generalize "^id_s^".");
+    ("absurd <"^id_s^">"),("absurd "^type_s^".")
+  ] @ [
+    ("discriminate "^id_s),("discriminate "^id_s^".");
+    ("injection "^id_s),("injection "^id_s^".")
+  ] @ [
+    ("rewrite "^id_s),("rewrite "^id_s^".");
+    ("rewrite <- "^id_s),("rewrite <- "^id_s^".")
+  ] @ [
+    ("elim "^id_s), ("elim "^id_s^".");
+    ("inversion "^id_s), ("inversion "^id_s^".");
+    ("inversion clear "^id_s), ("inversion_clear "^id_s^".")
+  ]
+
+let concl_next_tac sigma concl =
+  let expand s = (s,s^".") in
+  List.map expand ([
+    "intro";
+    "intros";
+    "intuition"
+  ] @ [
+    "reflexivity";
+    "discriminate";
+    "symmetry"
+  ] @ [
+    "assumption";
+    "omega";
+    "ring";
+    "auto";
+    "eauto";
+    "tauto";
+    "trivial";
+    "decide equality";
+    "simpl";
+    "subst";
+    "red";
+    "split";
+    "left";
+    "right"
+  ])
+
+let process_goal sigma g =
+  let env = Goal.V82.env sigma g in
+  let id = Goal.uid g in
+  let ccl =
+    let norm_constr = Reductionops.nf_evar sigma (Goal.V82.concl sigma g) in
+    string_of_ppcmds (pr_goal_concl_style_env env norm_constr) in
+  let process_hyp h_env d acc =
+    let d = Term.map_named_declaration (Reductionops.nf_evar sigma) d in
+    (string_of_ppcmds (pr_var_decl h_env d)) :: acc in
+  let hyps =
+    List.rev (Environ.fold_named_context process_hyp env ~init: []) in
+  { Interface.goal_hyp = hyps; Interface.goal_ccl = ccl; Interface.goal_id = id; }
+
+let goals () =
+  try
+    let pfts = Proof_global.give_me_the_proof () in
+    let (goals, zipper, sigma) = Proof.proof pfts in
+    let fg = List.map (process_goal sigma) goals in
+    let map_zip (lg, rg) =
+      let lg = List.map (process_goal sigma) lg in
+      let rg = List.map (process_goal sigma) rg in
+      (lg, rg)
+    in
+    let bg = List.map map_zip zipper in
+    Some { Interface.fg_goals = fg; Interface.bg_goals = bg; }
+  with Proof_global.NoCurrentProof -> None
+
+let evars () =
+  try
+    let pfts = Proof_global.give_me_the_proof () in
+    let { Evd.it = all_goals ; sigma = sigma } = Proof.V82.subgoals pfts in
+    let exl = Evarutil.non_instantiated sigma in
+    let map_evar ev = { Interface.evar_info = string_of_ppcmds (pr_evar ev); } in
+    let el = List.map map_evar exl in
+    Some el
+  with Proof_global.NoCurrentProof -> None
+
+let hints () =
+  try
+    let pfts = Proof_global.give_me_the_proof () in
+    let { Evd.it = all_goals ; sigma = sigma } = Proof.V82.subgoals pfts in
+    match all_goals with
+    | [] -> None
+    | g :: _ ->
+      let env = Goal.V82.env sigma g in
+      let hint_goal = concl_next_tac sigma g in
+      let get_hint_hyp env d accu = hyp_next_tac sigma env d :: accu in
+      let hint_hyps = List.rev (Environ.fold_named_context get_hint_hyp env ~init: []) in
+      Some (hint_hyps, hint_goal)
+  with Proof_global.NoCurrentProof -> None
+
+(** Other API calls *)
+
+let inloadpath dir =
+  Library.is_in_load_paths (System.physical_path_of_string dir)
+
+let status () =
+  (** We remove the initial part of the current [dir_path]
+      (usually Top in an interactive session, cf "coqtop -top"),
+      and display the other parts (opened sections and modules) *)
+  let path =
+    let l = Names.repr_dirpath (Lib.cwd ()) in
+    List.rev_map Names.string_of_id l
+  in
+  let proof =
+    try Some (Names.string_of_id (Proof_global.get_current_proof_name ()))
+    with Proof_global.NoCurrentProof -> None
+  in
+  let allproofs =
+    let l = Proof_global.get_all_proof_names () in
+    List.map Names.string_of_id l
+  in
+  {
+    Interface.status_path = path;
+    Interface.status_proofname = proof;
+    Interface.status_allproofs = allproofs;
+    Interface.status_statenum = Lib.current_command_label ();
+    Interface.status_proofnum = Pfedit.current_proof_depth ();
+  }
+
+(** This should be elsewhere... *)
+let search flags =
+  let env = Global.env () in
+  let rec extract_flags name tpe subtpe mods blacklist = function
+  | [] -> (name, tpe, subtpe, mods, blacklist)
+  | (Interface.Name_Pattern s, b) :: l ->
+    let regexp =
+      try Str.regexp s
+      with e when Errors.noncritical e ->
+        Util.error ("Invalid regexp: " ^ s)
+    in
+    extract_flags ((regexp, b) :: name) tpe subtpe mods blacklist l
+  | (Interface.Type_Pattern s, b) :: l ->
+    let constr = Pcoq.parse_string Pcoq.Constr.lconstr_pattern s in
+    let (_, pat) = Constrintern.intern_constr_pattern Evd.empty env constr in
+    extract_flags name ((pat, b) :: tpe) subtpe mods blacklist l
+  | (Interface.SubType_Pattern s, b) :: l ->
+    let constr = Pcoq.parse_string Pcoq.Constr.lconstr_pattern s in
+    let (_, pat) = Constrintern.intern_constr_pattern Evd.empty env constr in
+    extract_flags name tpe ((pat, b) :: subtpe) mods blacklist l
+  | (Interface.In_Module m, b) :: l ->
+    let path = String.concat "." m in
+    let m = Pcoq.parse_string Pcoq.Constr.global path in
+    let (_, qid) = Libnames.qualid_of_reference m in
+    let id =
+      try Nametab.full_name_module qid
+      with Not_found ->
+        Util.error ("Module " ^ path ^ " not found.")
+    in
+    extract_flags name tpe subtpe ((id, b) :: mods) blacklist l
+  | (Interface.Include_Blacklist, b) :: l ->
+    extract_flags name tpe subtpe mods b l
+  in
+  let (name, tpe, subtpe, mods, blacklist) =
+    extract_flags [] [] [] [] false flags
+  in
+  let filter_function ref env constr =
+    let id = Names.string_of_id (Nametab.basename_of_global ref) in
+    let path = Libnames.dirpath (Nametab.path_of_global ref) in
+    let toggle x b = if x then b else not b in
+    let match_name (regexp, flag) =
+      toggle (Str.string_match regexp id 0) flag
+    in
+    let match_type (pat, flag) =
+      toggle (Matching.is_matching pat constr) flag
+    in
+    let match_subtype (pat, flag) =
+      toggle (Matching.is_matching_appsubterm ~closed:false pat constr) flag
+    in
+    let match_module (mdl, flag) =
+      toggle (Libnames.is_dirpath_prefix_of mdl path) flag
+    in
+    let in_blacklist =
+      blacklist || (Search.filter_blacklist ref env constr)
+    in
+    List.for_all match_name name &&
+    List.for_all match_type tpe &&
+    List.for_all match_subtype subtpe &&
+    List.for_all match_module mods && in_blacklist
+  in
+  let ans = ref [] in
+  let print_function ref env constr =
+     let fullpath = repr_dirpath (Nametab.dirpath_of_global ref) in
+     let qualid = Nametab.shortest_qualid_of_global Idset.empty ref in
+     let (shortpath, basename) = Libnames.repr_qualid qualid in
+     let shortpath = repr_dirpath shortpath in
+     (* [shortpath] is a suffix of [fullpath] and we're looking for the missing
+        prefix *)
+     let rec prefix full short accu = match full, short with
+     | _, [] ->
+       let full = List.rev_map string_of_id full in
+       (full, accu)
+     | _ :: full, m :: short ->
+       prefix full short (string_of_id m :: accu)
+     | _ -> assert false
+     in
+     let (prefix, qualid) = prefix fullpath shortpath [string_of_id basename] in
+     let answer = {
+       Interface.coq_object_prefix = prefix;
+       Interface.coq_object_qualid = qualid;
+       Interface.coq_object_object = string_of_ppcmds (pr_lconstr_env env constr);
+     } in
+    ans := answer :: !ans;
+  in
+  let () = Search.gen_filtered_search filter_function print_function in
+  !ans
+
+let get_options () =
+  let table = Goptions.get_tables () in
+  let fold key state accu = (key, state) :: accu in
+  Goptions.OptionMap.fold fold table []
+
+let set_options options =
+  let iter (name, value) = match value with
+  | BoolValue b -> Goptions.set_bool_option_value name b
+  | IntValue i -> Goptions.set_int_option_value name i
+  | StringValue s -> Goptions.set_string_option_value name s
+  in
+  List.iter iter options
+
+let about () = {
+  Interface.coqtop_version = Coq_config.version;
+  Interface.protocol_version = Ide_intf.protocol_version;
+  Interface.release_date = Coq_config.date;
+  Interface.compile_date = Coq_config.compile_date;
+}
+
+(** Grouping all call handlers together + error handling *)
+
+exception Quit
+
+let eval_call c =
+  let rec handle_exn e =
+    catch_break := false;
+    let pr_exn e = (read_stdout ())^("\n"^(string_of_ppcmds (Errors.print e))) in
+    match e with
+      | Quit ->
+        (* Here we do send an acknowledgement message to prove everything went 
+          OK. *)
+        let dummy = Interface.Good () in
+        let xml_answer = Ide_intf.of_answer Ide_intf.quit dummy in
+        let () = Xml_utils.print_xml !orig_stdout xml_answer in
+        let () = flush !orig_stdout in
+        let () = pr_debug "Exiting gracefully." in
+        exit 0
+      | Vernacexpr.Drop -> None, "Drop is not allowed by coqide!"
+      | Vernacexpr.Quit -> None, "Quit is not allowed by coqide!"
+      | Vernac.DuringCommandInterp (_,inner) -> handle_exn inner
+      | Error_in_file (_,_,inner) -> None, pr_exn inner
+      | Loc.Exc_located (loc, inner) when loc = dummy_loc -> None, pr_exn inner
+      | Loc.Exc_located (loc, inner) -> Some (Util.unloc loc), pr_exn inner
+      | e -> None, pr_exn e
+  in
+  let interruptible f x =
+    catch_break := true;
+    Util.check_for_interrupt ();
+    let r = f x in
+    catch_break := false;
+    r
+  in
+  let handler = {
+    Ide_intf.interp = interruptible interp;
+    Ide_intf.rewind = interruptible Backtrack.back;
+    Ide_intf.goals = interruptible goals;
+    Ide_intf.evars = interruptible evars;
+    Ide_intf.hints = interruptible hints;
+    Ide_intf.status = interruptible status;
+    Ide_intf.search = interruptible search;
+    Ide_intf.inloadpath = interruptible inloadpath;
+    Ide_intf.get_options = interruptible get_options;
+    Ide_intf.set_options = interruptible set_options;
+    Ide_intf.mkcases = interruptible Vernacentries.make_cases;
+    Ide_intf.quit = (fun () -> raise Quit);
+    Ide_intf.about = interruptible about;
+    Ide_intf.handle_exn = handle_exn; }
+  in
+  (* If the messages of last command are still there, we remove them *)
+  ignore (read_stdout ());
+  Ide_intf.abstract_eval_call handler c
+
+
+(** The main loop *)
+
+(** Exceptions during eval_call should be converted into [Interface.Fail]
+    messages by [handle_exn] above. Otherwise, we die badly, after having
+    tried to send a last message to the ide: trying to recover from errors
+    with the current protocol would most probably bring desynchronisation
+    between coqtop and ide. With marshalling, reading an answer to
+    a different request could hang the ide... *)
+
+let fail err =
+  Ide_intf.of_value (fun _ -> assert false) (Interface.Fail (None, err))
+
+let loop () =
+  let p = Xml_parser.make () in
+  let () = Xml_parser.check_eof p false in
+  init_signal_handler ();
+  catch_break := false;
+  (* We'll handle goal fetching and display in our own way *)
+  Vernacentries.enable_goal_printing := false;
+  Vernacentries.qed_display_script := false;
+  try
+    while true do
+      let xml_answer =
+        try
+          let xml_query = Xml_parser.parse p (Xml_parser.SChannel stdin) in
+          let q = Ide_intf.to_call xml_query in
+          let () = pr_debug ("<-- " ^ Ide_intf.pr_call q) in
+          let r = eval_call q in
+          let () = pr_debug ("--> " ^ Ide_intf.pr_full_value q r) in
+          Ide_intf.of_answer q r
+        with
+	| Xml_parser.Error (Xml_parser.Empty, _) ->
+	  pr_debug ("End of input, exiting");
+	  exit 0
+        | Xml_parser.Error (err, loc) ->
+          let msg = "Syntax error in query: " ^ Xml_parser.error_msg err in
+          fail msg
+        | Ide_intf.Marshal_error ->
+          fail "Incorrect query."
+      in
+      Xml_utils.print_xml !orig_stdout xml_answer;
+      flush !orig_stdout
+    done
+  with any ->
+    let msg = Printexc.to_string any in
+    let r = "Fatal exception in coqtop:\n" ^ msg in
+    pr_debug ("==> " ^ r);
+    (try
+      Xml_utils.print_xml !orig_stdout (fail r);
+      flush !orig_stdout
+    with any -> ());
+    exit 1
diff --git a/toplevel/ide_slave.mli b/toplevel/ide_slave.mli
new file mode 100644
index 00000000..fb927cf3
--- /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-2012     *)
+(*   \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..77cfa6fa 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-2012     *)
 (*   \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);
@@ -88,8 +86,9 @@ let scheme_object_table =
   (Hashtbl.create 17 : (string, string * scheme_object_function) Hashtbl.t)
 
 let declare_scheme_object s aux f =
-  (try check_ident ("ind"^s) with _ ->
-    error ("Illegal induction scheme suffix: "^s));
+  (try check_ident ("ind"^s)
+   with e when Errors.noncritical e ->
+     error ("Illegal induction scheme suffix: "^s));
   let key = if aux = "" then s else aux in
   try
     let _ = Hashtbl.find scheme_object_table key in
@@ -111,21 +110,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..7032eb46 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-2012     *)
 (*   \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..e30404e1 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-2012     *)
 (*   \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 ".")
-    | _ ->
+    | e when Errors.noncritical e ->
 	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
@@ -244,7 +245,8 @@ let try_declare_eq_decidability kn =
 
 let declare_eq_decidability = declare_eq_decidability_scheme_with []
 
-let ignore_error f x = try ignore (f x) with _ -> ()
+let ignore_error f x =
+  try ignore (f x) with e when Errors.noncritical e -> ()
 
 let declare_rewriting_schemes ind =
   if Hipattern.is_inductive_equality ind then begin
@@ -265,7 +267,7 @@ let declare_congr_scheme ind =
   if Hipattern.is_equality_type (mkInd ind) then begin
     if
       try Coqlib.check_required_library Coqlib.logic_module_name; true
-      with _ -> false
+      with e when Errors.noncritical e -> false
     then
       ignore (define_individual_scheme congr_scheme_kind KernelVerbose None ind)
     else
diff --git a/toplevel/indschemes.mli b/toplevel/indschemes.mli
index 707b9e00..8ce27708 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-2012     *)
 (*   \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..7b4312a3
--- /dev/null
+++ b/toplevel/interface.mli
@@ -0,0 +1,112 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** * 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_id : string;
+  (** Unique goal identifier *)
+  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 list;
+  (** Module path of the current proof *)
+  status_proofname : string option;
+  (** Current proof name. [None] if no focussed proof is in progress *)
+  status_allproofs : string list;
+  (** List of all pending proofs. Order is not significant *)
+  status_statenum : int;
+  (** A unique id describing the state of coqtop *)
+  status_proofnum : int;
+  (** An id describing the state of the current proof. *)
+}
+
+type goals = {
+  fg_goals : goal list;
+  (** List of the focussed goals *)
+  bg_goals : (goal list * goal list) list;
+  (** Zipper representing the unfocussed 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 *)
+}
+
+type search_constraint =
+(** Whether the name satisfies a regexp (uses Ocaml Str syntax) *)
+| Name_Pattern of string
+(** Whether the object type satisfies a pattern *)
+| Type_Pattern of string
+(** Whether some subtype of object type satisfies a pattern *)
+| SubType_Pattern of string
+(** Whether the object pertains to a module *)
+| In_Module of string list
+(** Bypass the Search blacklist *)
+| Include_Blacklist
+
+(** A list of search constraints; the boolean flag is set to [false] whenever
+    the flag should be negated. *)
+type search_flags = (search_constraint * bool) list
+
+(** A named object in Coq. [coq_object_qualid] is the shortest path defined for 
+    the user. [coq_object_prefix] is the missing part to recover the fully 
+    qualified name, i.e [fully_qualified = coq_object_prefix + coq_object_qualid].
+    [coq_object_object] is the actual content of the object. *)
+type 'a coq_object = {
+  coq_object_prefix : string list;
+  coq_object_qualid : string list;
+  coq_object_object : 'a;
+}
+
+type coq_info = {
+  coqtop_version : string;
+  protocol_version : string;
+  release_date : string;
+  compile_date : string;
+}
+
+(** * 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)
diff --git a/toplevel/lemmas.ml b/toplevel/lemmas.ml
index 8ef82105..30f07fed 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-2012     *)
 (*   \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,30 +215,46 @@ 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 p = Proof_global.give_me_the_proof () in
+  Proof.transaction p begin fun () ->
+    let id,const,do_guard,persistence,hook = get_proof opacity in
+    save id const do_guard persistence hook
+  end
 
 let check_anonymity id save_ident =
-  if atompart_of_id id <> "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
-  check_anonymity id save_ident;
-  save save_ident const do_guard persistence hook
+  let p = Proof_global.give_me_the_proof () in
+  Proof.transaction p begin fun () ->
+    let id,const,do_guard,persistence,hook = get_proof opacity in
+    check_anonymity id save_ident;
+    save save_ident const do_guard persistence hook
+  end
 
 let save_anonymous_with_strength kind opacity save_ident =
-  let id,(const,do_guard,_,hook) = Pfedit.cook_proof !save_hook in
-  let const = { const with const_entry_opaque = opacity } in
-  check_anonymity id save_ident;
-  (* we consider that non opaque behaves as local for discharge *)
-  save save_ident const do_guard (Global, Proof kind) hook
+  let p = Proof_global.give_me_the_proof () in
+  Proof.transaction p begin fun () ->
+    let id,const,do_guard,_,hook = get_proof opacity in
+    check_anonymity id save_ident;
+    (* we consider that non opaque behaves as local for discharge *)
+    save save_ident const do_guard (Global, Proof kind) hook
+  end
 
 (* Starting a goal *)
 
@@ -256,8 +262,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 +319,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 +338,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..e48cb210 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-2012     *)
 (*   \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..5977591c 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-2012     *)
 (*   \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..cec3597a 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-2012     *)
 (*   \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..006dc5ec 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-2012     *)
 (*   \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."
 
 (**********************************************************************)
@@ -232,8 +237,8 @@ let parse_format (loc,str) =
       | _ -> error "Box closed without being opened in format."
     else
       error "Empty format."
-  with e ->
-    Stdpp.raise_with_loc loc e
+  with e when Errors.noncritical e ->
+    Loc.raise loc e
 
 (***********************)
 (* Analyzing notations *)
@@ -272,6 +277,9 @@ let split_notation_string str =
 
 let out_nt = function NonTerminal x -> x | _ -> assert false
 
+let msg_expected_form_of_recursive_notation =
+  "In the notation, the special symbol \"..\" must occur in\na configuration of the form \"x symbs .. symbs y\"."
+
 let rec find_pattern nt xl = function
   | Break n as x :: l, Break n' :: l' when n=n' ->
       find_pattern nt (x::xl) (l,l')
@@ -279,18 +287,19 @@ 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\".")
+      error msg_expected_form_of_recursive_notation
   | ((SProdList _ | NonTerminal _) :: _), _ | _, (SProdList _ :: _) ->
       anomaly "Only Terminal or Break expected on left, non-SProdList on right"
 
 let rec interp_list_parser hd = function
   | [] -> [], List.rev hd
   | NonTerminal id :: tl when id = ldots_var ->
+      if hd = [] then error msg_expected_form_of_recursive_notation;
       let hd = List.rev hd in
       let ((x,y,sl),tl') = find_pattern (List.hd hd) [] (List.tl hd,tl) in
       let xyl,tl'' = interp_list_parser [] tl' in
@@ -311,13 +320,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 +331,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
@@ -337,7 +341,8 @@ let rec raw_analyze_notation_tokens = function
 let is_numeral symbs =
   match List.filter (function Break _ -> false | _ -> true) symbs with
   | ([Terminal "-"; Terminal x] | [Terminal x]) ->
-      (try let _ = Bigint.of_string x in true with _ -> false)
+      (try let _ = Bigint.of_string x in true
+       with e when Errors.noncritical e -> false)
   | _ ->
       false
 
@@ -363,11 +368,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 +375,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 +403,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 +592,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 +667,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 +720,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;
@@ -762,7 +762,7 @@ let interp_modifiers modl =
     | SetAssoc a :: l ->
 	if assoc <> None then error"An associativity is given more than once.";
 	interp (Some a) level etyps format l
-    | SetOnlyParsing :: l ->
+    | SetOnlyParsing _ :: l ->
 	onlyparsing := true;
 	interp assoc level etyps format l
     | SetFormat s :: l ->
@@ -775,8 +775,13 @@ let check_infix_modifiers modifiers =
   if t <> [] then
     error "Explicit entry level or type unexpected in infix notation."
 
-let no_syntax_modifiers modifiers =
-  modifiers = [] or modifiers = [SetOnlyParsing]
+let no_syntax_modifiers = function
+  | [] | [SetOnlyParsing _] -> true
+  | _ -> false
+
+let is_only_parsing = function
+  | [SetOnlyParsing _] -> true
+  | _ -> false
 
 (* Compute precedences from modifiers (or find default ones) *)
 
@@ -891,15 +896,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 +914,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 +983,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;
@@ -986,6 +996,18 @@ let (inNotation, outNotation) =
        classify_function = classify_notation}
 
 (**********************************************************************)
+
+let with_lib_stk_protection f x =
+  let fs = Lib.freeze () in
+  try let a = f x in Lib.unfreeze fs; a
+  with reraise -> Lib.unfreeze fs; raise reraise
+
+let with_syntax_protection f x =
+  with_lib_stk_protection
+    (with_grammar_rule_protection
+       (with_notation_protection f)) x
+
+(**********************************************************************)
 (* Recovering existing syntax                                         *)
 
 let contract_notation ntn =
@@ -1106,7 +1128,7 @@ let add_notation local c ((loc,df),modifiers) sc =
   let df' =
    if no_syntax_modifiers modifiers then
     (* No syntax data: try to rely on a previously declared rule *)
-    let onlyparse = modifiers=[SetOnlyParsing] in
+    let onlyparse = is_only_parsing modifiers in
     try add_notation_interpretation_core local df c sc onlyparse
     with NoSyntaxRule ->
       (* Try to determine a default syntax rule *)
@@ -1153,7 +1175,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;
@@ -1181,6 +1203,9 @@ let add_syntactic_definition ident (vars,c) local onlyparse =
       let vars,pat = interp_aconstr i_vars [] c in
       List.map (fun (id,(sc,kind)) -> (id,sc)) vars, pat
   in
-  let onlyparse = onlyparse or is_not_printable pat in
+  let onlyparse = match onlyparse with
+    | None when (is_not_printable pat) -> Some Flags.Current
+    | p -> p
+  in
   Syntax_def.declare_syntactic_definition local ident onlyparse (vars,pat)
 
diff --git a/toplevel/metasyntax.mli b/toplevel/metasyntax.mli
index 2c4e29bb..38a0ae59 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-2012     *)
 (*   \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,33 +31,35 @@ 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
+  bool -> Flags.compat_version option -> unit
 
-(* Print the Camlp4 state of a grammar *)
+(** Print the Camlp4 state of a grammar *)
 
 val print_grammar : string -> unit
 
 val check_infix_modifiers : syntax_modifier list -> unit
+
+val with_syntax_protection : ('a -> 'b) -> 'a -> 'b
diff --git a/toplevel/mltop.ml4 b/toplevel/mltop.ml4
index 59bc01d0..f08308d3 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-2012     *)
 (*   \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
@@ -99,8 +92,9 @@ let dir_ml_load s =
       (try t.load_obj s
        with
        | (UserError _ | Failure _ | Anomaly _ | Not_found as u) -> raise u
-       | _ -> errorlabstrm "Mltop.load_object" (str"Cannot link ml-object " ++
-                str s ++ str" to Coq code."))
+       | e when Errors.noncritical e ->
+         errorlabstrm "Mltop.load_object"
+           (str"Cannot link ml-object " ++ str s ++ str" to Coq code."))
 (* TO DO: .cma loading without toplevel *)
     | WithoutTop ->
       IFDEF HasDynlink THEN
@@ -133,8 +127,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 *)
 
@@ -149,25 +143,25 @@ 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)");
+  with e when Errors.noncritical e ->
+    if_warn msg_warning
+      (str ("Directory "^d^" cannot be used as a Coq identifier (skipped)"));
     flush_all ();
     failwith "caught"
 
-let add_rec_path ~unix_path: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,17 +218,10 @@ 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. *)
 
-type ml_module_object = {
-  mlocal : Vernacexpr.locality_flag;
-  mnames : string list
-}
-
 let known_loaded_modules = ref Stringset.empty
 
 let add_known_module mname =
@@ -244,75 +231,98 @@ let add_known_module mname =
 let module_is_known mname =
   Stringset.mem (String.capitalize mname) !known_loaded_modules
 
-let load_object mname fname=
+(** A plugin is just an ML module with an initialization function. *)
+
+let known_loaded_plugins = ref Stringmap.empty
+
+let add_known_plugin init name =
+  let name = String.capitalize name in
+  add_known_module name;
+  known_loaded_plugins := Stringmap.add name init !known_loaded_plugins
+
+let init_known_plugins () =
+  Stringmap.iter (fun _ f -> f()) !known_loaded_plugins
+
+(** ml object = ml module or plugin *)
+
+let init_ml_object mname =
+  try Stringmap.find mname !known_loaded_plugins ()
+  with Not_found -> ()
+
+let load_ml_object mname fname=
   dir_ml_load fname;
-  add_known_module mname
+  add_known_module mname;
+  init_ml_object mname
 
 (* Summary of declared ML Modules *)
 
-(* List and not Stringset because order is important *)
+(* List and not Stringset because order is important: most recent first. *)
+
 let loaded_modules = ref []
-let get_loaded_modules () = !loaded_modules
+let get_loaded_modules () = List.rev !loaded_modules
 let add_loaded_module md = loaded_modules := md :: !loaded_modules
+let reset_loaded_modules () = loaded_modules := []
 
-let orig_loaded_modules = ref !loaded_modules
-let init_ml_modules () = loaded_modules := !orig_loaded_modules
+let if_verbose_load verb f name fname =
+  if not verb then f name fname
+  else
+    let info = "[Loading ML file "^fname^" ..." in
+    try
+      f name fname;
+      msgnl (str (info^" done]"));
+    with reraise ->
+      msgnl (str (info^" failed]"));
+      raise reraise
+
+(** Load a module for the first time (i.e. dynlink it)
+    or simulate its reload (i.e. doing nothing except maybe
+    an initialization function). *)
+
+let cache_ml_object verb reinit name =
+  begin
+    if module_is_known name then
+      (if reinit then init_ml_object name)
+    else if not has_dynlink then
+      error ("Dynamic link not supported (module "^name^")")
+    else
+      if_verbose_load (verb && is_verbose ())
+	load_ml_object name (file_of_name name)
+  end;
+  add_loaded_module name
 
 let unfreeze_ml_modules x =
-  loaded_modules := [];
-  List.iter
-    (fun name ->
-       let mname = mod_of_name name in
-       if not (module_is_known mname) then
-         if has_dynlink then
-           let fname = file_of_name mname in
-           load_object mname fname
-         else
-	   errorlabstrm "Mltop.unfreeze_ml_modules"
-             (str"Loading of ML object file forbidden in a native Coq.");
-       add_loaded_module mname)
-    x
+  reset_loaded_modules ();
+  List.iter (cache_ml_object false false) x
 
 let _ =
   Summary.declare_summary "ML-MODULES"
-    { Summary.freeze_function = (fun () -> List.rev (get_loaded_modules()));
-      Summary.unfreeze_function = (fun x -> unfreeze_ml_modules x);
-      Summary.init_function = (fun () -> init_ml_modules ()) }
-
-(* Same as restore_ml_modules, but verbosely *)
-
-let cache_ml_module_object (_,{mnames=mnames}) =
-  List.iter
-    (fun name ->
-       let mname = mod_of_name name in
-       if not (module_is_known mname) then
-	 if has_dynlink then
-           let fname = file_of_name mname in
-	   try
-	     if_verbose
-	       msg (str"[Loading ML file " ++ str fname ++ str" ...");
-             load_object mname fname;
-             if_verbose msgnl (str" done]");
-             add_loaded_module mname
-           with e ->
-	     if_verbose msgnl (str" failed]");
-	     raise e
-	 else
-	     (if_verbose msgnl (str" failed]");
-	      error ("Dynamic link not supported (module "^name^")")))
-    mnames
-
-let classify_ml_module_object ({mlocal=mlocal} as o) =
+    { Summary.freeze_function = get_loaded_modules;
+      Summary.unfreeze_function = unfreeze_ml_modules;
+      Summary.init_function = reset_loaded_modules }
+
+(* Liboject entries of declared ML Modules *)
+
+type ml_module_object = {
+  mlocal : Vernacexpr.locality_flag;
+  mnames : string list
+}
+
+let cache_ml_objects (_,{mnames=mnames}) =
+  List.iter (cache_ml_object true true) mnames
+
+let classify_ml_objects ({mlocal=mlocal} as o) =
   if mlocal then Dispose else Substitute o
 
-let (inMLModule,outMLModule) =
-  declare_object {(default_object "ML-MODULE") with
-                    load_function = (fun _ -> cache_ml_module_object);
-                    cache_function = cache_ml_module_object;
-                    subst_function = (fun (_,o) -> o);
-                    classify_function = classify_ml_module_object }
+let inMLModule : ml_module_object -> obj =
+  declare_object
+    {(default_object "ML-MODULE") with
+      load_function = (fun _ -> cache_ml_objects);
+      cache_function = cache_ml_objects;
+      subst_function = (fun (_,o) -> o);
+      classify_function = classify_ml_objects }
 
 let declare_ml_modules local l =
+  let l = List.map mod_of_name l in
   Lib.add_anonymous_leaf (inMLModule {mlocal=local; mnames=l})
 
 let print_ml_path () =
@@ -320,7 +330,7 @@ let print_ml_path () =
   ppnl (str"ML Load Path:" ++ fnl () ++ str"  " ++
           hv 0 (prlist_with_sep pr_fnl pr_str l))
 
-	  (* Printing of loaded ML modules *)
+(* Printing of loaded ML modules *)
 
 let print_ml_modules () =
   let l = get_loaded_modules () in
diff --git a/toplevel/mltop.mli b/toplevel/mltop.mli
index ae562bd2..ebea73f1 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-2012     *)
 (*   \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,55 +14,52 @@ 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
-
-(* Summary of Declared ML Modules *)
-val get_loaded_modules : unit -> string list
-val add_loaded_module : string -> unit
-val init_ml_modules : unit -> unit
-val unfreeze_ml_modules : string list -> unit
-
-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 load_ml_object : string -> string -> unit
+
+(** Declare a plugin and its initialization function.
+    A plugin is just an ML module with an initialization function.
+    Adding a known plugin implies adding it as a known ML module.
+    The initialization function is granted to be called after Coq is fully
+    bootstrapped, even if the plugin is statically linked with the toplevel *)
+val add_known_plugin : (unit -> unit) -> string -> unit
+
+(** Calls all initialization functions in a non-specified order *)
+val init_known_plugins : unit -> unit
 
 val declare_ml_modules : Vernacexpr.locality_flag -> string list -> unit
 
diff --git a/toplevel/record.ml b/toplevel/record.ml
index ee9b8d66..3708c2f7 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-2012     *)
 (*   \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
@@ -72,8 +81,8 @@ let typecheck_params_and_fields id t ps nots fs =
   let newps = Evarutil.nf_rel_context_evar sigma newps in
   let newfs = Evarutil.nf_rel_context_evar sigma newfs in
   let ce t = Evarutil.check_evars env0 Evd.empty evars t in
-    List.iter (fun (n, b, t) -> Option.iter ce b; ce t) newps;
-    List.iter (fun (n, b, t) -> Option.iter ce b; ce t) newfs;
+    List.iter (fun (n, b, t) -> Option.iter ce b; ce t) (List.rev newps);
+    List.iter (fun (n, b, t) -> Option.iter ce b; ce t) (List.rev newfs);
     imps, newps, impls, newfs
 
 let degenerate_decl (na,b,t) =
@@ -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,8 +262,8 @@ 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
-	error "Records declared with the keyword Record or Structure cannot be recursive. Maybe you meant to define an Inductive or CoInductive record."
+      if Termops.dependent (mkRel (nparams+1)) (it_mkProd_or_LetIn mkProp fields) then
+	error "Records declared with the keyword Record or Structure cannot be recursive. You can, however, define recursive records using the Inductive or CoInductive command."
   | _ -> ()
   end;
   let mie =
@@ -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..f4ae7832 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-2012     *)
 (*   \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..19d696a1 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-2012     *)
 (*   \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 =
@@ -133,7 +137,7 @@ let pattern_filter pat _ a c =
   try
     try
       is_matching pat (head c)
-    with _ ->
+    with e when Errors.noncritical e ->
       is_matching
 	pat (head (Typing.type_of (Global.env()) Evd.empty c))
     with UserError _ ->
@@ -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..76821e62 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-2012     *)
 (*   \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,16 @@ 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.
+val filter_blacklist : global_reference -> env -> constr -> bool
+
+(** raw search functions can be used for various extensions.
    They are also used for pcoq. *)
 val gen_filtered_search : (global_reference -> env -> constr -> bool) ->
       (global_reference -> env -> constr -> unit) -> unit
diff --git a/toplevel/toplevel.ml b/toplevel/toplevel.ml
index 551e5574..cc659e36 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: toplevel.ml 15025 2012-03-09 14:27:07Z glondu $ *)
-
 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 when Errors.noncritical e ->
+        (close_in ic;
+         hov 1 (errstrm ++ spc() ++ str"(invalid location):") ++ fnl ())
 
 let print_command_location ib dloc =
   match dloc with
@@ -210,7 +208,7 @@ let valid_buffer_loc ib dloc loc =
 let make_prompt () =
   try
     (Names.string_of_id (Pfedit.get_current_proof_name ())) ^ " < "
-  with _ ->
+  with Proof_global.NoCurrentProof ->
     "Coq < "
 
 (*let build_pending_list l =
@@ -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
-  | Compat.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
-      | Compat.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 Compat.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()
 
 
@@ -342,7 +340,7 @@ let process_error = function
 	  discard_to_dot (); e
 	with
           | End_of_input -> End_of_input
-          | de -> if is_pervasive_exn de then de else e
+          | any -> if is_pervasive_exn any then any else e
 
 (* do_vernac reads and executes a toplevel phrase, and print error
    messages when an exception is raised, except for the following:
@@ -356,8 +354,8 @@ let do_vernac () =
   begin
     try
       raw_do_vernac top_buffer.tokens
-    with e ->
-      msgnl (print_toplevel_error (process_error e))
+    with any ->
+      msgnl (print_toplevel_error (process_error any))
   end;
   flush_all()
 
@@ -369,9 +367,6 @@ let do_vernac () =
 
 let rec loop () =
   Sys.catch_break true;
-  (* ensure we have a command separator object (DOT) so that the first
-     command can be reseted. *)
-  Lib.mark_end_of_command();
   try
     reset_input_buffer stdin top_buffer;
     while true do do_vernac() done
@@ -379,6 +374,6 @@ let rec loop () =
     | Vernacexpr.Drop -> ()
     | End_of_input -> msgerrnl (mt ()); pp_flush(); exit 0
     | Vernacexpr.Quit -> exit 0
-    | e ->
+    | any ->
 	msgerrnl (str"Anomaly. Please report.");
 	loop ()
diff --git a/toplevel/toplevel.mli b/toplevel/toplevel.mli
index 022a6541..0af05d02 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-2012     *)
 (*   \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..e1e349a6 100644
--- a/toplevel/toplevel.mllib
+++ b/toplevel/toplevel.mllib
@@ -13,11 +13,14 @@ Command
 Classes
 Record
 Ppvernac
+Backtrack
 Vernacinterp
 Mltop
 Vernacentries
 Whelp
 Vernac
+Ide_intf
+Ide_slave
 Toplevel
 Usage
 Coqinit
diff --git a/toplevel/usage.ml b/toplevel/usage.ml
index 0282f30a..f6505e30 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-2012     *)
 (*   \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,61 @@ 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  -verbose-compat-notations  be warned when using compatibility notations\
+\n  -no-compat-notations   get an error when using compatibility notations\
+\n\
+\n  -load-ml-object f      load ML object file f\
+\n  -load-ml-source f      load ML file f\
+\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 +82,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..45cedf44 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-2012     *)
 (*   \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 de732618..ed8e215f 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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* $Id: vernac.ml 15025 2012-03-09 14:27:07Z glondu $ *)
-
 (* 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
@@ -27,6 +26,30 @@ exception DuringCommandInterp of Util.loc * exn
 
 exception HasNotFailed
 
+(* When doing Load on a file, two behaviors are possible:
+
+   - either the history stack is grown by only one command,
+     the "Load" itself. This is mandatory for command-counting
+     interfaces (CoqIDE).
+
+   - either each individual sub-commands in the file is added
+     to the history stack. This allows commands like Show Script
+     to work across the loaded file boundary (cf. bug #2820).
+
+   The best of the two could probably be combined someday,
+   in the meanwhile we use a flag. *)
+
+let atomic_load = ref true
+
+let _ =
+  Goptions.declare_bool_option
+    { Goptions.optsync  = true;
+      Goptions.optdepr  = false;
+      Goptions.optname  = "atomic registration of commands in a Load";
+      Goptions.optkey   = ["Atomic";"Load"];
+      Goptions.optread  = (fun () -> !atomic_load);
+      Goptions.optwrite = ((:=) atomic_load) }
+
 (* Specifies which file is read. The intermediate file names are
    discarded here. The Drop exception becomes an error. We forget
    if the error ocurred during interpretation or not *)
@@ -41,17 +64,19 @@ let raise_with_file file exc =
     match re with
       | Error_in_file (_, (b,f,loc), e) when loc <> dummy_loc ->
           ((b, f, loc), e)
-      | Compat.Exc_located (loc, e) when loc <> dummy_loc ->
+      | Loc.Exc_located (loc, e) when loc <> dummy_loc ->
           ((false,file, loc), e)
-      | Compat.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
-  | Compat.Exc_located (_, e) -> e
+  | Loc.Exc_located (_, e) -> e
   | Error_in_file (_, _, e) -> e
   | e -> e
 
+let user_error loc s = Util.user_err_loc (loc,"_",str s)
+
 (** Timeout handling *)
 
 (** A global default timeout, controled by option "Set Default Timeout n".
@@ -62,6 +87,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);
@@ -97,6 +123,18 @@ let restore_timeout = function
     (* restore handler *)
     Sys.set_signal Sys.sigalrm psh
 
+
+(* Open an utf-8 encoded file and skip the byte-order mark if any *)
+
+let open_utf8_file_in fname =
+  let is_bom s =
+    Char.code s.[0] = 0xEF && Char.code s.[1] = 0xBB && Char.code s.[2] = 0xBF
+  in
+  let in_chan = open_in fname in
+  let s = "   " in
+  if input in_chan s 0 3 < 3 || not (is_bom s) then seek_in in_chan 0;
+  in_chan
+
 (* Opening and closing a channel. Open it twice when verbose: the first
    channel is used to read the commands, and the second one to print them.
    Note: we could use only one thanks to seek_in, but seeking on and on in
@@ -106,8 +144,9 @@ let open_file_twice_if verbosely fname =
   let paths = Library.get_load_paths () in
   let _,longfname =
     find_file_in_path ~warn:(Flags.is_verbose()) paths fname in
-  let in_chan = open_in longfname in
-  let verb_ch = if verbosely then Some (open_in longfname) else None in
+  let in_chan = open_utf8_file_in longfname in
+  let verb_ch =
+    if verbosely then Some (open_utf8_file_in longfname) else None in
   let po = Pcoq.Gram.parsable (Stream.of_channel in_chan) in
   (in_chan, longfname, (po, verb_ch))
 
@@ -117,7 +156,7 @@ let close_input in_chan (_,verb) =
     match verb with
       | Some verb_ch -> close_in verb_ch
       | _ -> ()
-  with _ -> ()
+  with e when Errors.noncritical e -> ()
 
 let verbose_phrase verbch loc =
   let loc = unloc loc in
@@ -133,8 +172,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
 
@@ -166,7 +205,7 @@ let pr_new_syntax loc ocom =
   States.unfreeze fs;
   Format.set_formatter_out_channel stdout
 
-let rec vernac_com interpfun (loc,com) =
+let rec vernac_com interpfun checknav (loc,com) =
   let rec interp = function
     | VernacLoad (verbosely, fname) ->
 	let fname = expand_path_macros fname in
@@ -193,98 +232,117 @@ let rec vernac_com interpfun (loc,com) =
               Lexer.restore_com_state cs;
               Pp.comments := cl;
               Dumpglob.coqdoc_unfreeze cds
-	    with e ->
+	    with reraise ->
 	      if !Flags.beautify_file then close_out !chan_beautify;
               chan_beautify := ch;
               Lexer.restore_com_state cs;
               Pp.comments := cl;
               Dumpglob.coqdoc_unfreeze cds;
-	      raise e
+	      raise reraise
 	  end
 
     | VernacList l -> List.iter (fun (_,v) -> interp v) l
 
+    | v when !just_parsing -> ()
+
     | VernacFail v ->
-	if not !just_parsing then begin try
+	begin try
 	  (* If the command actually works, ignore its effects on the state *)
 	  States.with_state_protection
 	    (fun v -> interp v; raise HasNotFailed) v
-	with e -> match real_error e with
+	with e when Errors.noncritical e -> match real_error e with
 	  | HasNotFailed ->
 	      errorlabstrm "Fail" (str "The command has not failed !")
 	  | e ->
-	      (* if [e] is an anomaly, the next function will re-raise it *)
-	      let msg = Cerrors.explain_exn_no_anomaly e in
-	      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 ->
-	if not !just_parsing then begin
 	  let tstart = System.get_time() in
           interp v;
 	  let tend = System.get_time() in
           msgnl (str"Finished transaction in " ++
                    System.fmt_time_difference tstart tend)
-	end
 
     | VernacTimeout(n,v) ->
-	if not !just_parsing then begin
 	  current_timeout := Some n;
 	  interp v
-	end
 
     | v ->
-        if not !just_parsing then
 	  let psh = default_set_timeout () in
 	  try
             States.with_heavy_rollback interpfun
               Cerrors.process_vernac_interp_error v;
 	    restore_timeout psh
-	  with e -> restore_timeout psh; raise e
+	  with reraise -> restore_timeout psh; raise reraise
   in
     try
+      checknav loc com;
       current_timeout := !default_timeout;
       if do_beautify () then pr_new_syntax loc (Some com);
       interp com
-    with e ->
+    with any ->
       Format.set_formatter_out_channel stdout;
-      raise (DuringCommandInterp (loc, e))
-
-and vernac interpfun input =
-  vernac_com interpfun (parse_phrase input)
+      raise (DuringCommandInterp (loc, any))
 
 and read_vernac_file verbosely s =
   Flags.make_warn verbosely;
   let interpfun =
-    if verbosely then
-      Vernacentries.interp
+    if verbosely then Vernacentries.interp
+    else Flags.silently Vernacentries.interp
+  in
+  let checknav loc cmd =
+    if is_navigation_vernac cmd && not (is_reset cmd) then
+	user_error loc "Navigation commands forbidden in files"
+  in
+  let end_inner_command cmd =
+    if !atomic_load || is_reset cmd then
+      Lib.mark_end_of_command () (* for Reset in coqc or coqtop -l *)
     else
-      Flags.silently Vernacentries.interp
+      Backtrack.mark_command cmd; (* for Show Script, cf bug #2820 *)
   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
-  with e ->   (* whatever the exception *)
+    while true do
+      let loc_ast = parse_sentence input in
+      vernac_com interpfun checknav loc_ast;
+      end_inner_command (snd loc_ast);
+      pp_flush ()
+    done
+  with reraise ->   (* whatever the exception *)
     Format.set_formatter_out_channel stdout;
     close_input in_chan input;    (* we must close the file first *)
-    match real_error e with
+    match real_error reraise with
       | End_of_input ->
           if do_beautify () then pr_new_syntax (make_loc (max_int,max_int)) None
-      | _ -> raise_with_file fname e
+      | _ -> raise_with_file fname reraise
+
+(** [eval_expr : ?preserving:bool -> Pp.loc * Vernacexpr.vernac_expr -> unit]
+   It executes one vernacular command. By default the command is
+   considered as non-state-preserving, in which case we add it to the
+   Backtrack stack (triggering a save of a frozen state and the generation
+   of a new state label). An example of state-preserving command is one coming
+   from the query panel of Coqide. *)
 
-(* 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 checknav loc ast =
+  if is_deep_navigation_vernac ast then
+    user_error loc "Navigation commands forbidden in nested commands"
 
-let raw_do_vernac po =
-  vernac Vernacentries.interp (po,None);
-  Lib.add_frozen_state();
-  Lib.mark_end_of_command()
+let eval_expr ?(preserving=false) loc_ast =
+  vernac_com Vernacentries.interp checknav loc_ast;
+  if not preserving && not (is_navigation_vernac (snd loc_ast)) then
+    Backtrack.mark_command (snd loc_ast)
+
+(* raw_do_vernac : Pcoq.Gram.parsable -> unit
+ * vernac_step . parse_sentence *)
+let raw_do_vernac po = eval_expr (parse_sentence (po,None))
 
 (* XML output hooks *)
 let xml_start_library = ref (fun _ -> ())
@@ -298,24 +356,22 @@ let load_vernac verb file =
   chan_beautify :=
     if !Flags.beautify_file then open_out (file^beautify_suffix) else stdout;
   try
+    Lib.mark_end_of_command (); (* in case we're still in coqtop init *)
     read_vernac_file verb file;
     if !Flags.beautify_file then close_out !chan_beautify;
-  with e ->
+  with reraise ->
     if !Flags.beautify_file then close_out !chan_beautify;
-    raise_with_file file e
+    raise_with_file file reraise
 
 (* 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..96bc8865 100644
--- a/toplevel/vernac.mli
+++ b/toplevel/vernac.mli
@@ -1,46 +1,46 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*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
+
+(** [eval_expr] executes one vernacular command. By default the command is
+   considered as non-state-preserving, in which case we add it to the
+   Backtrack stack (triggering a save of a frozen state and the generation
+   of a new state label). An example of state-preserving command is one coming
+   from the query panel of Coqide. *)
+
+val eval_expr : ?preserving:bool -> Util.loc * Vernacexpr.vernac_expr -> unit
 val raw_do_vernac : Pcoq.Gram.parsable -> unit
 
-(* Set XML hooks *)
+(** 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..75efe139 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-2012     *)
 (*   \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,60 +62,102 @@ 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) *)
+  ()
+
+(* indentation code for Show Script, initially contributed
+   by D. de Rauglaudre *)
+
+let indent_script_item ((ng1,ngl1),nl,beginend,ppl) (cmd,ng) =
+  (* ng1 : number of goals remaining at the current level (before cmd)
+     ngl1 : stack of previous levels with their remaining goals
+     ng : number of goals after the execution of cmd
+     beginend : special indentation stack for { } *)
+  let ngprev = List.fold_left (+) ng1 ngl1 in
+  let new_ngl =
+    if ng > ngprev then
+      (* We've branched *)
+      (ng - ngprev + 1, ng1 - 1 :: ngl1)
+    else if ng < ngprev then
+      (* A subgoal have been solved. Let's compute the new current level
+	 by discarding all levels with 0 remaining goals. *)
+      let _ = assert (ng = ngprev - 1) in
+      let rec loop = function
+	| (0, ng2::ngl2) -> loop (ng2,ngl2)
+	| p -> p
+      in loop (ng1-1, ngl1)
+    else
+      (* Standard case, same goal number as before *)
+      (ng1, ngl1)
+  in
+  (* When a subgoal have been solved, separate this block by an empty line *)
+  let new_nl = (ng < ngprev)
+  in
+  (* Indentation depth *)
+  let ind = List.length ngl1
+  in
+  (* Some special handling of bullets and { }, to get a nicer display *)
+  let pred n = max 0 (n-1) in
+  let ind, nl, new_beginend = match cmd with
+    | VernacSubproof _ -> pred ind, nl, (pred ind)::beginend
+    | VernacEndSubproof -> List.hd beginend, false, List.tl beginend
+    | VernacBullet _ -> pred ind, nl, beginend
+    | _ -> ind, nl, beginend
+  in
+  let pp =
+    (if nl then fnl () else mt ()) ++
+    (hov (ind+1) (str (String.make ind ' ') ++ Ppvernac.pr_vernac cmd))
+  in
+  (new_ngl, new_nl, new_beginend, pp :: ppl)
 
 let show_script () =
-  let 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)
+  let prf = Pfedit.get_current_proof_name () in
+  let cmds = Backtrack.get_script prf in
+  let _,_,_,indented_cmds =
+    List.fold_left indent_script_item ((1,[]),false,[],[]) cmds
+  in
+  let indented_cmds = List.rev (indented_cmds) in
+  msgnl (v 0 (Util.prlist_with_sep Pp.fnl (fun x -> x) indented_cmds))
 
 let show_thesis () =
      msgnl (anomaly "TODO" )
 
 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 enable_goal_printing = ref true
+
+let print_subgoals () =
+  if !enable_goal_printing && is_verbose ()
+  then msg (pr_open_subgoals ())
+
+let try_print_subgoals () =
+  Pp.flush_all();
+  try print_subgoals () with Proof_global.NoCurrentProof | UserError _ -> ()
 
-let print_subgoals () = if_verbose (fun () -> msg (pr_open_subgoals ())) ()
 
   (* Simulate the Intro(s) tactic *)
 
 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 +169,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 +184,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 () ++ str "end" ++ fnl ()))
 
 (* "Print" commands *)
 
@@ -220,18 +252,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
+      reraise -> close (); raise reraise
+
+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 *)
@@ -262,7 +331,7 @@ let msg_notfound_library loc qid = function
 let print_located_library r =
   let (loc,qid) = qualid_of_reference r in
   try msg_found_library (Library.locate_qualified_library false qid)
-  with e -> msg_notfound_library loc qid e
+  with e when Errors.noncritical e -> msg_notfound_library loc qid e
 
 let print_located_module r =
   let (loc,qid) = qualid_of_reference r in
@@ -291,6 +360,11 @@ let smart_global r =
     Dumpglob.add_glob (Genarg.loc_of_or_by_notation loc_of_reference r) gr;
     gr
 
+let dump_global r =
+  try
+    let gr = Smartlocate.smart_global r in
+    Dumpglob.add_glob (Genarg.loc_of_or_by_notation loc_of_reference r) gr
+  with e when Errors.noncritical e -> ()
 (**********)
 (* Syntax *)
 
@@ -314,11 +388,12 @@ let vernac_notation = Metasyntax.add_notation
 (* Gallina *)
 
 let start_proof_and_print k l hook =
+  check_locality (); (* early check, cf #2975 *)
   start_proof_com k l hook;
   print_subgoals ();
   if !pcoq <> None then (Option.get !pcoq).start_proof ()
 
-let 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
@@ -331,8 +406,8 @@ let vernac_definition (local,boxed,k) (loc,id as lid) def hook =
           | None -> None
           | 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
+ 		Some (snd (interp_redexp env evc r)) in
+	let ce,imps = interp_definition bl red_option c typ_opt in
 	declare_definition id (local,k) ce imps hook)
 
 let vernac_start_proof kind l lettop hook =
@@ -347,27 +422,32 @@ let vernac_start_proof kind l lettop hook =
 	(str "Let declarations can only be used in proof editing mode.");
   start_proof_and_print (Global, Proof kind) l hook
 
+let qed_display_script = ref true
+
 let vernac_end_proof = function
-  | Admitted -> admit ()
+  | Admitted ->
+    Backtrack.mark_unreachable [Pfedit.get_current_proof_name ()];
+    admit ()
   | Proved (is_opaque,idopt) ->
-    if not !Flags.print_emacs then if_verbose show_script ();
-    match idopt with
+    let prf = Pfedit.get_current_proof_name () in
+    if is_verbose () && !qed_display_script then (show_script (); msg (fnl()));
+    begin match idopt with
     | None -> save_named is_opaque
     | Some ((_,id),None) -> save_anonymous is_opaque id
     | Some ((_,id),Some kind) -> save_anonymous_with_strength kind is_opaque id
+    end;
+    Backtrack.mark_unreachable [prf]
 
   (* A stupid macro that should be replaced by ``Exact c. Save.'' all along
      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. *)
+  let prf = Pfedit.get_current_proof_name () in
+  by (Tactics.exact_proof c);
+  save_named true;
+  Backtrack.mark_unreachable [prf]
 
 let vernac_assumption kind l nl=
   let global = fst kind = Global in
@@ -386,7 +466,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 +489,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,19 +505,31 @@ 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
-
-let vernac_scheme = Indschemes.do_scheme
+  do_cofixpoint l
 
-let vernac_combined_scheme = Indschemes.do_combined_scheme
+let vernac_scheme l =
+  if Dumpglob.dump () then
+    List.iter (fun (lid, s) ->
+	       Option.iter (fun lid -> Dumpglob.dump_definition lid false "def") lid;
+	       match s with
+	       | InductionScheme (_, r, _)
+	       | CaseScheme (_, r, _) 
+	       | EqualityScheme r -> dump_global r) l;
+  Indschemes.do_scheme l
+
+let vernac_combined_scheme lid l =
+  if Dumpglob.dump () then
+    (Dumpglob.dump_definition lid false "def";
+     List.iter (fun lid -> dump_global (Genarg.AN (Ident lid))) l);
+ Indschemes.do_combined_scheme lid l
 
 (**********************)
 (* Modules            *)
@@ -585,10 +678,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 +701,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 +718,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 +759,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 +782,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)
@@ -733,28 +809,14 @@ let vernac_chdir = function
 (********************)
 (* State management *)
 
-let abort_refine f x =
-  if Pfedit.refining() then delete_all_proofs ();
-  f x
-  (* used to be: error "Must save or abort current goal first" *)
-
-let vernac_write_state file = abort_refine States.extern_state file
-
-let vernac_restore_state file = abort_refine States.intern_state file
-
-
-(*************)
-(* Resetting *)
-
-let vernac_reset_name id = abort_refine Lib.reset_name id
+let vernac_write_state file =
+  Pfedit.delete_all_proofs ();
+  States.extern_state file
 
-let vernac_reset_initial () = abort_refine Lib.reset_initial ()
+let vernac_restore_state file =
+  Pfedit.delete_all_proofs ();
+  States.intern_state file
 
-let vernac_back n = Lib.back n
-
-let vernac_backto n = Lib.reset_label n
-
-(* see also [vernac_backtrack] which combines undoing and resetting *)
 (************)
 (* Commands *)
 
@@ -764,6 +826,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 +843,105 @@ 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 extra_scope_flag = List.mem `ExtraScopes flags in
+  let names = List.map (List.map (fun (id, _,_,_,_) -> id)) l in
+  let names, rest = List.hd names, List.tl names in
+  let scopes = List.map (List.map (fun (_,_, s, _,_) -> s)) l in
+  if List.exists ((<>) names) rest then
+    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 ls = match li, ld, ls with
+    | [], [], [] -> ()
+    | [], Anonymous::ld, (Some _)::ls when extra_scope_flag -> check li ld ls
+    | [], _::_, (Some _)::ls when extra_scope_flag ->
+       error "Extra notation scopes can be set on anonymous arguments only"
+    | [], x::_, _ -> 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, _::ls -> check li ld ls 
+    | _ -> assert false in
+  if l <> [[]] then
+    List.iter2 (fun l -> check inf_names l) (names :: rest) scopes;
+  (* we take extra scopes apart, and we check they are consistent *)
+  let l, scopes = 
+    let scopes, rest = List.hd scopes, List.tl scopes in
+    if List.exists (List.exists ((<>) None)) rest then
+      error "Notation scopes can be given only once";
+    if not extra_scope_flag then l, scopes else
+    let l, _ = List.split (List.map (list_chop (List.length inf_names)) l) in
+    l, scopes in
+  (* we interpret _ as the inferred names *)
+  let l = 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 e when Errors.noncritical e ->
+          Some (Notation.find_delimiters_scope o k)) scopes
+  in
+  let some_scopes_specified = List.exists ((<>) None) scopes in
+  let rargs =
+    Util.list_map_filter (function (n, true) -> Some n | _ -> None)
+      (Util.list_map_i (fun i (_, b, _,_,_) -> i, b) 0 l) in
+  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 +954,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 +963,7 @@ let _ =
 let _ =
   declare_bool_option
     { optsync  = true;
+      optdepr  = false;
       optname  = "implicit arguments";
       optkey   = ["Implicit";"Arguments"];
       optread  = Impargs.is_implicit_args;
@@ -811,6 +972,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 +981,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 +990,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 +1008,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 +1017,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 +1026,7 @@ let _ =
 let _ =
   declare_bool_option
     { optsync  = true;
+      optdepr  = false;
       optname  = "coercion printing";
       optkey   = ["Printing";"Coercions"];
       optread  = (fun () -> !Constrextern.print_coercions);
@@ -875,13 +1035,16 @@ 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);
       optwrite = (:=) Constrextern.print_evar_arguments }
+
 let _ =
   declare_bool_option
     { optsync  = true;
+      optdepr  = false;
       optname  = "implicit arguments printing";
       optkey   = ["Printing";"Implicit"];
       optread  = (fun () -> !Constrextern.print_implicits);
@@ -890,6 +1053,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 +1062,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 +1071,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 +1080,7 @@ let _ =
 let _ =
   declare_bool_option
     { optsync  = true;
+      optdepr  = false;
       optname  = "raw printing";
       optkey   = ["Printing";"All"];
       optread  = (fun () -> !Flags.raw_print);
@@ -922,38 +1089,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 +1148,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 +1157,7 @@ let _ =
 let _ =
   declare_int_option
     { optsync  = true;
+      optdepr  = false;
       optname  = "the printing width";
       optkey   = ["Printing";"Width"];
       optread  = Pp_control.get_margin;
@@ -978,6 +1166,7 @@ let _ =
 let _ =
   declare_bool_option
     { optsync  = true;
+      optdepr  = false;
       optname  = "printing of universes";
       optkey   = ["Printing";"Universes"];
       optread  = (fun () -> !Constrextern.print_universes);
@@ -989,11 +1178,21 @@ 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);
       optwrite = vernac_debug }
 
+let _ =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "explicitly parsing implicit arguments";
+      optkey   = ["Parsing";"Explicit"];
+      optread  = (fun () -> !Constrintern.parsing_explicit);
+      optwrite = (fun b ->  Constrintern.parsing_explicit := b) }
+
 let vernac_set_opacity local str =
   let glob_ref r =
     match smart_global r with
@@ -1006,7 +1205,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,21 +1245,31 @@ 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 sigma' = Evarconv.consider_remaining_unif_problems env sigma' 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
+        Tacinterp.dump_glob_red_expr r;
+        let (sigma',r_interp) = interp_redexp env sigma' r in
+	let redfun = fst (reduction_of_red_expr r_interp) in
 	if !pcoq <> None
-	then (Option.get !pcoq).print_eval redfun env 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)
+  declare_red_expr locality s (snd (interp_redexp (Global.env()) Evd.empty r))
 
   (* The same but avoiding the current goal context if any *)
 let vernac_global_check c =
@@ -1095,21 +1304,26 @@ 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)
-  | PrintAbout qid -> msg (print_about qid)
-  | PrintImplicit qid -> msg (print_impargs qid)
+      pp (Notation.pr_visibility (Constrextern.without_symbols pr_lglob_constr) s)
+  | PrintAbout qid -> 
+    msg (print_about qid)
+  | PrintImplicit qid -> 
+    dump_global qid; msg (print_impargs qid)
   | PrintAssumptions (o,r) ->
       (* Prints all the axioms and section variables used by a term *)
       let cstr = constr_of_global (smart_global r) in
@@ -1145,7 +1359,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,31 +1383,93 @@ 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
   | LocateFile f -> locate_file f
 
+(****************)
+(* Backtracking *)
+
+(** NB: these commands are now forbidden in non-interactive use,
+    e.g. inside VernacLoad, VernacList, ... *)
+
+let vernac_backto lbl =
+  try
+    let lbl' = Backtrack.backto lbl in
+    if lbl <> lbl' then
+      Pp.msg_warning
+	(str "Actually back to state "++ Pp.int lbl' ++ str ".");
+    try_print_subgoals ()
+  with Backtrack.Invalid -> error "Invalid backtrack."
+
+let vernac_back n =
+  try
+    let extra = Backtrack.back n in
+    if extra <> 0 then
+      Pp.msg_warning
+	(str "Actually back by " ++ Pp.int (extra+n) ++ str " steps.");
+    try_print_subgoals ()
+  with Backtrack.Invalid -> error "Invalid backtrack."
+
+let vernac_reset_name id =
+  try
+    let globalized =
+      try
+	let gr = Smartlocate.global_with_alias (Ident id) in
+	Dumpglob.add_glob (fst id) gr;
+	true
+      with e when Errors.noncritical e -> false in
+
+    if not globalized then begin
+       try begin match Lib.find_opening_node (snd id) with
+          | Lib.OpenedSection _ -> Dumpglob.dump_reference (fst id)
+              (string_of_dirpath (Lib.current_dirpath true)) "<>" "sec";
+          (* Might be nice to implement module cases, too.... *)
+          | _ -> ()
+       end with UserError _ -> ()
+    end;
+
+    if Backtrack.is_active () then
+      (Backtrack.reset_name id; try_print_subgoals ())
+    else
+      (* When compiling files, Reset is now allowed again
+	 as asked by A. Chlipala. we emulate a simple reset,
+	 that discards all proofs. *)
+      let lbl = Lib.label_before_name id in
+      Pfedit.delete_all_proofs ();
+      Pp.msg_warning (str "Reset command occurred in non-interactive mode.");
+      Lib.reset_label lbl
+  with Backtrack.Invalid | Not_found -> error "Invalid Reset."
+
+
+let vernac_reset_initial () =
+  if Backtrack.is_active () then
+    Backtrack.reset_initial ()
+  else begin
+    Pp.msg_warning (str "Reset command occurred in non-interactive mode.");
+    Lib.reset_label Lib.first_command_label
+  end
+
+(* For compatibility with ProofGeneral: *)
+
+let vernac_backtrack snum pnum naborts =
+  Backtrack.backtrack snum pnum naborts;
+  try_print_subgoals ()
+
+
 (********************)
 (* 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 ->
+      Backtrack.mark_unreachable [Pfedit.get_current_proof_name ()];
       delete_current_proof ();
       if_verbose message "Current goal aborted";
       if !pcoq <> None then (Option.get !pcoq).abort ""
   | Some id ->
+      Backtrack.mark_unreachable [snd id];
       delete_proof id;
       let s = string_of_id (snd id) in
       if_verbose message ("Goal "^s^" aborted");
@@ -1201,76 +1477,85 @@ let vernac_abort = function
 
 let vernac_abort_all () =
   if refining() then begin
+    Backtrack.mark_unreachable (Pfedit.get_all_proof_names ());
     delete_all_proofs ();
     message "Current goals aborted"
   end else
     error "No proof-editing in progress."
 
-let vernac_restart () = restart_proof(); print_subgoals ()
+let vernac_restart () =
+  Backtrack.mark_unreachable [Pfedit.get_current_proof_name ()];
+  restart_proof(); print_subgoals ()
 
-  (* Proof switching *)
+let vernac_undo n =
+  let d = Pfedit.current_proof_depth () - n in
+  Backtrack.mark_unreachable ~after:d [Pfedit.get_current_proof_name ()];
+  Pfedit.undo n; print_subgoals ()
 
-let vernac_suspend = suspend_proof
+let vernac_undoto n =
+  Backtrack.mark_unreachable ~after:n [Pfedit.get_current_proof_name ()];
+  Pfedit.undo_todepth n;
+  print_subgoals ()
 
-let vernac_resume = function
-  | None -> resume_last_proof ()
-  | Some id -> resume_proof id
+let vernac_focus gln =
+  let p = Proof_global.give_me_the_proof () in
+  let n = match gln with None -> 1 | Some n -> n in
+  if n = 0 then
+    Util.error "Invalid goal number: 0. Goal numbering starts with 1."
+  else
+    Proof.focus focus_command_cond () n p; print_subgoals ()
 
-let vernac_undo n =
-  undo n;
+  (* Unfocuses one step in the focus stack. *)
+let vernac_unfocus () =
+  let p = Proof_global.give_me_the_proof () in
+  Proof.unfocus command_focus p; print_subgoals ()
+
+(* Checks that a proof is fully unfocused. Raises an error if not. *)
+let vernac_unfocused () =
+  let p = Proof_global.give_me_the_proof () in
+  if Proof.unfocused p then
+    msg (str"The proof is indeed fully unfocused.")
+  else
+    error "The proof is not fully unfocused."
+
+
+(* 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 ()
 
-(* backtrack with [naborts] abort, then undo_todepth to [pnum], then
-   back-to state number [snum]. This allows to backtrack proofs and
-   state with one command (easier for proofgeneral). *)
-let vernac_backtrack snum pnum naborts =
-  for i = 1 to naborts do vernac_abort None done;
-  undo_todepth pnum;
-  vernac_backto snum;
-  Pp.flush_all();
-  (* there may be no proof in progress, even if no abort *)
-  (try print_subgoals () with UserError _ -> ())
+let vernac_end_subproof () =
+  let p = Proof_global.give_me_the_proof () in
+  Proof.unfocus subproof_kind p ; print_subgoals ()
 
 
-let vernac_focus gln =
-  check_not_proof_mode "No focussing or Unfocussing in Proof Mode.";
-  match gln with
-    | None -> traverse_nth_goal 1; print_subgoals ()
-    | Some n -> traverse_nth_goal n; 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 ()
 
-  (* Reset the focus to the top of the tree *)
-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 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 +1570,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 +1608,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 +1637,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
@@ -1382,7 +1657,6 @@ let interp c = match c with
   | VernacRestoreState s -> vernac_restore_state s
 
   (* Resetting *)
-  | VernacRemoveName id -> Lib.remove_name id
   | VernacResetName id -> vernac_reset_name id
   | VernacResetInitial -> vernac_reset_initial ()
   | VernacBack n -> vernac_back n
@@ -1391,9 +1665,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
@@ -1417,17 +1693,23 @@ let interp c = match c with
   | VernacAbort id -> vernac_abort id
   | VernacAbortAll -> vernac_abort_all ()
   | VernacRestart -> vernac_restart ()
-  | VernacSuspend -> vernac_suspend ()
-  | VernacResume id -> vernac_resume id
   | VernacUndo n -> vernac_undo n
-  | VernacUndoTo n -> undo_todepth n
+  | VernacUndoTo n -> vernac_undoto n
   | VernacBacktrack (snum,pnum,naborts) -> vernac_backtrack snum pnum naborts
   | VernacFocus n -> vernac_focus n
   | VernacUnfocus -> vernac_unfocus ()
-  | VernacGo g -> vernac_go g
+  | VernacUnfocused -> vernac_unfocused ()
+  | 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) -> print_subgoals ()
+  | VernacProof (Some tac, None) -> vernac_set_end_tac tac ; print_subgoals ()
+  | VernacProof (None, Some l) -> vernac_set_used_variables l ; print_subgoals ()
+  | VernacProof (Some tac, Some l) -> 
+      vernac_set_end_tac tac; vernac_set_used_variables l ; print_subgoals ()
+  | 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..b0d41b15 100644
--- a/toplevel/vernacentries.mli
+++ b/toplevel/vernacentries.mli
@@ -1,38 +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-2012     *)
 (*   \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 *)
+val dump_global : Libnames.reference Genarg.or_by_notation -> unit
+
+(** Vernacular entries *)
 
 val show_script : unit -> unit
 val show_prooftree : unit -> unit
 
 val show_node : unit -> unit
 
-(* This function can be used by any command that want to observe terms
+(** 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.
-   It is used in pcoq. *) (*i anciennement: inside_outside i*)
-val interp_search_restriction : search_restriction -> dir_path list * bool
-i*)
-
 type pcoq_hook = {
   start_proof : unit -> unit;
   solve : int -> unit;
@@ -42,16 +34,36 @@ 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
-   by a command aborting all proofs if necessary.
-   It is used in pcoq. *)
-val abort_refine : ('a -> unit) -> 'a -> unit;;
+(** The main interpretation function of vernacular expressions *)
 
 val interp : Vernacexpr.vernac_expr -> unit
 
-val vernac_reset_name : identifier Util.located -> unit
+(** Print subgoals when the verbose flag is on.
+    Meant to be used inside vernac commands from plugins. *)
+
+val print_subgoals : unit -> unit
+
+(** The printing of goals via [print_subgoals] or during
+    [interp] can be controlled by the following flag.
+    Used for instance by coqide, since it has its own
+    goal-fetching mechanism. *)
+
+val enable_goal_printing : bool ref
+
+(** Should Qed try to display the proof script ?
+    True by default, but false in ProofGeneral and coqIDE *)
+
+val qed_display_script : bool ref
+
+(** 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..3106e866 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-2012     *)
 (*   \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
@@ -115,8 +114,6 @@ type hints_expr =
   | HintsTransparency of reference list * bool
   | HintsConstructors of reference list
   | HintsExtern of int * constr_expr option * raw_tactic_expr
-  | HintsDestruct of identifier *
-      int * (bool,unit) location * constr_expr * raw_tactic_expr
 
 type search_restriction =
   | SearchInside of reference list
@@ -126,24 +123,28 @@ 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
-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 onlyparsing_flag = Flags.compat_version option
+ (* Some v = Parse only;  None = Print also.
+    If v<>Current, it contains the name of the coq version
+    which this notation is trying to be compatible with *)
 
-type option_value =
-  | 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 +166,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 +180,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,9 +190,9 @@ 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
+  | SetOnlyParsing of Flags.compat_version
   | SetFormat of string located
 
 type proof_end =
@@ -200,6 +204,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 +225,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 +239,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 +264,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 +288,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
@@ -299,7 +301,6 @@ type vernac_expr =
   | VernacRestoreState of string
 
   (* Resetting *)
-  | VernacRemoveName of lident
   | VernacResetName of lident
   | VernacResetInitial
   | VernacBack of int
@@ -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 | `ExtraScopes
+            | `ClearImplicits | `ClearScopes | `DefaultImplicits ] list
+  | VernacArgumentsScope of locality_flag * reference or_by_notation *
+      scope_name option list
   | VernacReserve of simple_binder list
   | VernacGeneralizable of locality_flag * (lident list) option
   | VernacSetOpacity of
@@ -338,17 +346,19 @@ type vernac_expr =
   | VernacAbort of lident option
   | VernacAbortAll
   | VernacRestart
-  | VernacSuspend
-  | VernacResume of lident option
   | VernacUndo of int
   | VernacUndoTo of int
   | VernacBacktrack of int*int*int
   | VernacFocus of int option
   | VernacUnfocus
-  | VernacGo of goable
+  | VernacUnfocused
+  | 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
 
@@ -357,6 +367,33 @@ type vernac_expr =
 
 and located_vernac_expr = loc * vernac_expr
 
+
+(** Categories of [vernac_expr] *)
+
+let rec strip_vernac = function
+  | VernacTime c | VernacTimeout(_,c) | VernacFail c -> strip_vernac c
+  | c -> c (* TODO: what about VernacList ? *)
+
+let rec is_navigation_vernac = function
+  | VernacResetInitial
+  | VernacResetName _
+  | VernacBacktrack _
+  | VernacBackTo _
+  | VernacBack _ -> true
+  | VernacTime c -> is_navigation_vernac c (* Time Back* is harmless *)
+  | c -> is_deep_navigation_vernac c
+
+and is_deep_navigation_vernac = function
+  | VernacTimeout (_,c) | VernacFail c -> is_navigation_vernac c
+  | VernacList l -> List.exists (fun (_,c) -> is_navigation_vernac c) l
+  | _ -> false
+
+(* NB: Reset is now allowed again as asked by A. Chlipala *)
+
+let is_reset = function
+  | VernacResetInitial | VernacResetName _ -> true
+  | _ -> false
+
 (* Locating errors raised just after the dot is parsed but before the
    interpretation phase *)
 
@@ -369,9 +406,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 +429,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..a1b76d3d 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-2012     *)
 (*   \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
@@ -62,11 +60,7 @@ let call (opn,converted_args) =
     hunk()
   with
     | Drop -> raise Drop
-    | e ->
+    | reraise ->
         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")
+        raise reraise
diff --git a/toplevel/vernacinterp.mli b/toplevel/vernacinterp.mli
index 780e4e28..efe7e073 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-2012     *)
 (*   \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..f90cae73 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-2012     *)
 (*   \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..fed8332b 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-2012     *)
 (*   \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