This commit adds full universe polymorphism and fast projections to Coq.

Add [Polymorphic] and [Monomorphic] local flag for definitions as well as
[Set Universe Polymorphism] global flag to make all following definitions
polymorphic. Mainly syntax for now.

First part of the big changes to the kernel:
- Const, Ind, Construct now come with a universe level instance
- It is used for type inference in the kernel, which now also takes
a graph as input: actually a set of local universe variables and their
constraints. Type inference just checks that the constraints are enough
to satisfy its own rules.
- Remove polymorphic_arity and _knowing_parameters everywhere: we
don't need full applications for polymorphism to apply anymore, as
we generate fresh variables at each constant/inductive/constructor
application. However knowing_parameters variants might be reinstated
later for optimization.
- New structures exported in univ.mli:
  - universe_list for universe level instances
  - universe_context(_set) for the local universe constraints, also
recording which variables will be local and hence generalized after
inference if defining a polymorphic ind/constant.
- this patch makes coq stop compiling at indtypes.ml

Adapt kernel, library, pretyping, tactics and toplevel to universe polymorphism.
Various degrees of integration, places where I was not sure what to do or
just postponed bigger reorganizations of the code are marked with FIXMEs.
Main changes:
- Kernel now checks constraints and does not infer them anymore.
- The inference functions produce a context of constraints that were checked
during inference, useful to do double-checking of the univ. poly. code
but might be removed later.
- Constant, Inductive entries now have a universe context (local variables
and constraints) associated to them.
- Printing, debugging functions for the new structures are also implemented.
- Now stopping at Logic.v
- Lots of new code in kernel/univ.ml that should be reviewed.
- kernel/indtypes probably does not do what's right when inferring inductive
type constraints.
- Adapted evd to use the new universe context structure.
- Did not deal with unification/evar_conv.

- Add externalisation code for universe level instances.
- Support for polymorphism in pretyping/command and proofs/proofview etc.
  Needed wrapping of [fresh_.._instance] through the evar_map, which
  contains the local state of universes during type-checking.
- Correct the inductive scheme generation to support polymorphism as well.
- Have to review kernel code for correctness, and especially rework the
  computation of universe constraints for inductives.
Stops somewhat later in Logic.v

- Fix naming of local/toplevel universes to be correctly done at typechecking time:
  local variables have no dirpath.
- Add code to do substitution of universes in modules, not finished yet.
- Move fresh_* functions out of kernel, it won't ever build a universe level again!
- Adapt a lot of new_Type to use the correct dirpath and declare the new types in the evar_map
so we keep track of them.
- A bit of code factorization (evd_comb moved, pretype_global).

- Refactor more code
- Adapt plugins code (sometimes wrong, marked with FIXME)
- Fix cases generating unneeded universe (not sure it's ok though)
- Fix scheme generation for good, might have opportunity to cleanup
the terms later.

Init compiles now (which means rewrite, inversion, elim etc.. work as well).
- Unsolved issue of pretyping to lower sorts properly (to Prop for example).
  This has to do with the (Retyping.get_type_of) giving algebraic universes that
  would appear on the right of constraints.
  This makes checking for dangling universes at the end of pretyping fail,
  hence the check in kernel/univ was removed. It should come back when we have
  a fix for this.
- Correctly (?) compute the levels of inductive types.
  Removed old code pertaining to universe polymorphism. Note that we generate
  constraint variables for the conclusion of inductive types invariably.
- Shrink constraints before going to the kernel, combine substitution of the
  smaller universe set with normalization of evars (maybe not done everywhere,
  only ordinary inductives, definitions and proofs)
- More API reworks overall. tclPUSHCONTEXT can be used to add fresh universes
  to the proof goal (used in a few places to get the right instance.
- Quick fix for auto that won't work in the long run. It should always have been
  restricted to take constant references as input, without any loss of generality
  over constrs.

Fix some plugins and insertion of non-polymorphic constants in a module.
Now stops in relation classes.

Cleanup and move code from kernel to library and from pretyping to library too.
Now there is a unique universe counter declared in library/universes.ml along
with all the functions to generate new universes and get fresh constant/inductive
terms.
- Various function renamings
- One important change in kernel/univ.ml: now [sup] can be applied to Prop.
- Adapt records/classes to universe polymorphism
- Now stops in EqDepFacts due to imprecise universe polymorphism.

Forgot to git add those files.

interp_constr returns the universe context

The context is then pushed through the environment (or proof goal
sigma).
- Fix insertion of constants/inductives in env, pushing constraints to
the global env for non-polymorphic ones.
- Add Prop as a universe level to do proper type inference with sorts.
It is allowed to take [sup] of [Prop] now.
- New nf_evar based on new Evd.map(_undefined)
- In proofs/logic.ml: conv_leq_goal might create some constraints that
are now recorded.
- Adapt Program code to universes.

Merge with latest trunk + fixes

-Use new constr_of_global from universes
- fix eqschemes to use polymorphic universes
- begin fixing cctac but f_equal still fails
- fix [simpl] and rest of tacred
- all the eq_constr with mkConst foo should be fixed as well, only
partially done

- Fix term hashing function to recognize equal terms up to universe instances.
- Fix congruence closure to equate terms that differ only in universe instances,
these will be resolved by constraints.

Add a set of undefined universe variables to unification.
Universe variables can now be declared rigid or flexible (unifiable).
Flexible variables are resolved at the end of typechecking by instantiating
them to their glb, adding upper bound constraints associated to them.
Also:
- Add polymorphic flag for inductives.
- Fix cooking partially
- Fix kernel/univ.ml to do normalization of universe expressions at
the end of substitution.

Correct classes/structures universe inference

- Required a bit of extension in Univ to handle Max properly (sup u
(u+1)) was returning (max(u,u+1)) for example.
- Try a version where substitution of universe expressions for universe
levels is allowed at the end of unification. By an invariant this
should only instantiate with max() types that are morally "on the
right" only.
This is controlled using a rigidity attribute of universe variables,
also allowing to properly do unification w.r.t. universes during
typechecking/inference.
- Currently fails in Vectors/Fin.v because case compilation generates
"flexible" universes that actually appear in the term...

Fix unification of universe variables.

- Fix choice of canonical universe in presence of universe constraints,
and do so by relying on a trichotomy for universe variables: rigid
(won't be substituted), flexible (might be if not substituted by an
algebraic) and flexible_alg (always substituted).
- Fix romega code and a few more plugins, most of the standard library
goes through now.
- Had to define some inductives as Polymorphic explicitly to make
proofs go through, more to come, and definitions should be polymorphic
too, otherwise inconsistencies appear quickly (two uses of the same
polymorphic ind through monomorphic functions (like nth on lists of
Props and nats) will fix the monomorphic function's universe with eq
constraints that are incompatible).
- Correct universe polymorphism handling for fixpoint/cofixpoint
definitions.

- Fix romega to use the right universes for list constructors.
- Fix internalization/externalization to deal properly with the
implicit parsing of params.
- Fix fourier tactic w.r.t. GRefs

- Fix substitution saturation of universes.
- Fix number syntax plugin.
- Fix setoid_ring to take its coefficients in a Set rather
than a Type, avoiding a large number of useless universe constraints.

- Fix minor checker decl
- Fix btauto w.r.t. GRef
- Fix proofview to normalize universes in the original types as well.
- Fix definitions of projections to not take two universes at the same level,
but at different levels instead, avoiding unnecessary constraints that could
lower the level of one component depending on the use of the other component.

Fix simpl fst, snd to use @fst @snd as they have maximal implicits now.

- More simpl snd, fst fixes.
- Try to make the nth theory of lists polymorphic.

Check with Enrico if this change is ok. Case appearing in RingMicromega's call
to congruence l417, through a call to refine -> the_conv_x_leq.

Compile everything.
- "Fix" checker by deactivating code related to polymorphism, should
be updated.
- Make most of List.v polymorphic to help with following definitions.
- When starting a lemma, normalize w.r.t. universes, so that the types
get a fixed universe, not refinable later.
- In record, don't assign a fully flexible universe variable to the record
type if it is a definitional typeclass, as translate_constant doesn't expect
an algebraic universe in the type of a constant. It certainly should though.
- Fix micromega code.

Fix after rebase.

Update printing functions to print the polymorphic status of definitions
and their universe context.

Refine printing of universe contexts

- Fix printer for universe constraints
- Rework normalization of constraints to separate the Union-Find result
  from computation of lubs/glbs.

Keep universe contexts of inductives/constants in entries for correct
substitution inside modules. Abstract interface to get an instantiation
of an inductive with its universe substitution in the kernel (no
substitution if the inductive is not polymorphic, even if mind_universes
is non-empty).

Make fst and snd polymorphic, fix instances in RelationPairs to use
different universes for the two elements of a pair.

- Fix bug in nf_constraints: was removing Set <= constraints, but should
remove Prop <= constraints only.
- Make proj1_sig, projT1... polymorphic to avoid weird universe unifications,
giving rise to universe inconsistenties.

Adapt auto hints to polymorphic references.

Really produce polymorphic hints... second try

- Remove algebraic universes that can't appear in the goal when taking the
  type of a lemma to start.

Proper handling of universe contexts in clenv and auto so that
polymorphic hints are really refreshed at each application.

Fix erroneous shadowing of sigma variable.

- Make apparent the universe context used in pretyping, including information
about flexibility of universe variables.
- Fix induction to generate a fresh constant instance with flexible universe variables.

Add function to do conversion w.r.t. an evar map and its local universes.

- Fix define_evar_as_sort to not forget constraints coming from the refinement.
- Do not nf_constraints while we don't have the whole term at hand to substitute in.

- Move substitution of full universes to Universes
- Normalize universes inside an evar_map when doing nf_evar_map_universes.
- Normalize universes at each call to interp_ltac (potentially expensive)

Do not normalize all evars at each call to interp_gen in tactics: rather
incrementally normalize the terms at hand, supposing the normalization of universes
will concern only those appearing in it (dangerous but much more efficient).

Do not needlessly generate new universes constraints for projections of records.

Correct polymorphic discharge of section variables.

Fix autorewrite w.r.t. universes: polymorphic rewrite hints get fresh universe
instances at each application.

Fix r2l rewrite scheme to support universe polymorphism

Fix a bug in l2r_forward scheme and fix congruence scheme to handle polymorphism correctly.

Second try at fixing autorewrite, cannot do without pushing the constraints and the set of fresh
universe variables into the proof context.

- tclPUSHCONTEXT allow to set the ctx universe variables as flexible or rigid
- Fix bug in elimschemes, not taking the right sigma

Wrong sigma used in leibniz_rewrite

Avoid recomputation of bounds for equal universes in normalization of constraints,
only the canonical one need to be computed.

Make coercions work with universe polymorphic projections.

Fix eronneous bound in universes constraint solving.

Make kernel reduction and term comparison strictly aware of universe instances,
with variants for relaxed comparison that output constraints.
Otherwise some constraints that should appear during pretyping don't and we generate
unnecessary constraints/universe variables.
Have to adapt a few tactics to this new behavior by making them universe aware.

- Fix elimschemes to minimize universe variables
- Fix coercions to not forget the universe constraints generated by an application
- Change universe substitutions to maps instead of assoc lists.
- Fix absurd tactic to handle univs properly
- Make length and app polymorphic in List, unification sets their levels otherwise.

Move to modules for namespace management instead of long names in universe code.

More putting things into modules.

Change evar_map structure to support an incremental substitution of universes
(populated from Eq constraints), allowing safe and fast inference of precise levels,
without computing lubs.
- Add many printers and reorganize code
- Extend nf_evar to normalize universe variables according to the substitution.
- Fix ChoiceFacts.v in Logic, no universe inconsistencies anymore. But Diaconescu
still has one (something fixes a universe to Set).
- Adapt omega, functional induction to the changes.

Fix congruence, eq_constr implem, discharge of polymorphic inductives.

Fix merge in auto.

The [-parameters-matter] option (formerly relevant_equality).

Add -parameters-matter to coqc

Do compute the param levels at elaboration time if parameters_matter.

- Fix generalize tactic
- add ppuniverse_subst
- Start fixing normalize_universe_context w.r.t. normalize_univ_variables.

- Fix HUGE bug in Ltac interpretation not folding the sigma correctly if interpreting a tactic application
to multiple arguments.
- Fix bug in union of universe substitution.

- rename parameters-matter to indices-matter
- Fix computation of levels from indices not parameters.

- Fixing parsing so that [Polymorphic] can be applied to gallina extensions.
- When elaborating definitions, make the universes from the type rigid when
checking the term: they should stay abstracted.
- Fix typeclasses eauto's handling of universes for exact hints.

Rework all the code for infering the levels of inductives and checking their
allowed eliminations sorts.

This is based on the computation of a natural level for an inductive type I.
The natural level [nat] of [I : args -> sort := c1 : A1 -> I t1 .. cn : An -> I tn] is
computed by taking the max of the levels of the args (if indices matter) and the
levels of the constructor arguments.
The declared level [decl] of I is [sort], which might be Prop, Set or some Type u (u fresh
or not).
If [decl >= nat && not (decl = Prop && n >= 2)], the level of the inductive is [decl],
otherwise, _smashing_ occured.
If [decl] is impredicative (Prop or Set when Set is impredicative), we accept the
declared level, otherwise it's an error.

To compute the allowed elimination sorts, we have the following situations:
- No smashing occured: all sorts are allowed. (Recall props that are not
smashed are Empty/Unitary props)
- Some smashing occured:
 - if [decl] is Type, we allow all eliminations (above or below [decl],
   not sure why this is justified in general).
 - if [decl] is Set, we used smashing for impredicativity, so only
   small sorts are allowed (Prop, Set).
 - if [decl] is Prop, only logical sorts are allowed: I has either
   large universes inside it or more than 1 constructor.
   This does not treat the case where only a Set appeared in I which
   was previously accepted it seems.

All the standard library works with these changes. Still have to cleanup
kernel/indtypes.ml. It is a good time to have a whiskey with OJ.

Thanks to Peter Lumsdaine for bug reporting:
- fix externalisation of universe instances (still appearing when no Printing Universes)
- add [convert] and [convert_leq] tactics that keep track of evars and universe constraints.
- use them in [exact_check].

Fix odd behavior in inductive type declarations allowing to silently lower a Type i parameter
to Set for squashing a naturally Type i inductive to Set. Reinstate the LargeNonPropInductiveNotInType
exception.

Fix the is_small function not dealing properly with aliases of Prop/Set in Type.

Add check_leq in Evd and use it to decide if we're trying to squash an
inductive naturally in some Type to Set.

- Fix handling of universe polymorphism in typeclasses Class/Instance declarations.
- Don't allow lowering a rigid Type universe to Set silently.

- Move Ring/Field back to Type. It was silently putting R in Set due to the definition of ring_morph.
- Rework inference of universe levels for inductive definitions.
- Make fold_left/right polymorphic on both levels A and B (the list's type). They don't have to be
at the same level.

Handle selective Polymorphic/Monomorphic flag right for records.

Remove leftover command

Fix after update with latest trunk.

Backport patches on HoTT/coq to rebased version of universe polymorphism.

- Fix autorewrite wrong handling of universe-polymorphic rewrite rules. Fixes part of issue #7.
- Fix the [eq_constr_univs] and add an [leq_constr_univs] to avoid eager equation of universe
 levels that could just be inequal. Use it during kernel conversion. Fixes issue #6.
- Fix a bug in unification that was failing too early if a choice in unification of universes
 raised an inconsistency.
- While normalizing universes, remove Prop in the le part of Max expressions.
- Stop rigidifying the universes on the right hand side of a : in definitions.
- Now Hints can be declared polymorphic or not. In the first case they
 must be "refreshed" (undefined universes are renamed) at each application.
- Have to refresh the set of universe variables associated to a hint
 when it can be used multiple times in a single proof to avoid fixing
 a level... A better & less expensive solution should exist.
- Do not include the levels of let-ins as part of records levels.
- Fix a NotConvertible uncaught exception to raise a more informative
 error message.
- Better substitution of algebraics in algebraics (for universe variables that
 can be algebraics).
- Fix issue #2, Context was not properly normalizing the universe context.
- Fix issue with typeclasses that were not catching UniverseInconsistencies
  raised by unification, resulting in early failure of proof-search.
- Let the result type of definitional classes be an algebraic.
- Adapt coercions to universe polymorphic flag (Identity Coercion etc..)
- Move away a dangerous call in autoinstance that added constraints for every
polymorphic definitions once in the environment for no use.

Forgot one part of the last patch on coercions.

- Adapt auto/eauto to polymorphic hints as well.
- Factor out the function to refresh a clenv w.r.t. undefined universes.

Use leq_univ_poly in evarconv to avoid fixing universes.

Disallow polymorphic hints based on a constr as it is not possible to infer their universe
context. Only global references can be made polymorphic. Fixes issue #8.

Fix SearchAbout bug (issue #10).

Fix program w.r.t. universes: the universe context of a definition changes
according to the successive refinements due to typechecking obligations.
This requires the Proof modules to return the generated universe substitution
when finishing a proof, and this information is passed in the closing hook.
The interface is not very clean, will certainly change in the future.

- Better treatment of polymorphic hints in auto: terms can be polymorphic now, we refresh their
context as well.
- Needs a little change in test-pattern that seems breaks multiary uses of destruct in NZDiv.v, l495.
FIX to do.

Fix [make_pattern_test] to keep the universe information around and still
allow tactics to take multiple patterns at once.

- Fix printing of universe instances that should not be factorized blindly
- Fix handling of the universe context in program definitions by allowing the
hook at the end of an interactive proof to give back the refined universe context,
before it is transformed in the kernel.
- Fix a bug in evarconv where solve_evar_evar was not checking types of instances,
resulting in a loss of constraints in unification of universes and a growing number
of useless parametric universes.

- Move from universe_level_subst to universe_subst everywhere.

- Changed representation of universes for a canonical one
- Adapt the code so that universe variables might be substituted by
arbitrary universes (including algebraics). Not used yet except for
polymorphic universe variables instances.

- Adapt code to new constraint structure.
- Fix setoid rewrite handling of evars that was forgetting the initial
universe substitution !
- Fix code that was just testing conversion instead of keeping the
resulting universe constraints around in the proof engine.
- Make a version of reduction/fconv that deals with the more general
set of universe constraints.

- [auto using] should use polymorphic versions of the constants.
- When starting a proof, don't forget about the algebraic universes in
the universe context.

Rationalize substitution and normalization functions for universes.
Also change back the structure of universes to avoid considering levels
n+k as pure levels: they are universe expressions like max.
Everything is factored out in the Universes and Univ modules now and
the normalization functions can be efficient in the sense that they
can cache the normalized universes incrementally.

- Adapt normalize_context code to new normalization/substitution functions.
- Set more things to be polymorphic, e.g. in Ring or SetoidList for the rest
of the code to work properly while the constraint generation code is not adapted.
And temporarily extend the universe constraint code in univ to solve max(is) = max(js)
by first-order unification (these constraints should actually be implied not enforced).
- Fix romega plugin to use the right universes for polymorphic lists.
- Fix auto not refreshing the poly hints correctly.

- Proper postponing of universe constraints during unification, avoid making
arbitrary choices.
- Fix nf_evars_and* to keep the substitution around for later normalizations.
- Do add simplified universe constraints coming from unification during typechecking.
- Fix solve_by_tac in obligations to handle universes right, and the corresponding
substitution function.

Test global universe equality early during simplication of constraints.

Better hashconsing, but still not good on universe lists.

- Add postponing of "lub" constraints that should not be checked early,
they are implied by the others.
- Fix constructor tactic to use a fresh constructor instance avoiding
fixing universes.
- Use [eq_constr_universes] instead of [eq_constr_univs] everywhere,
this is the comparison function that doesn't care about the universe
instances.
- Almost all the library compiles in this new setting, but some more tactics
need to be adapted.

- Reinstate hconsing.
- Keep Prop <= u constraints that can be used to set the level of a universe
metavariable.

Add better hashconsing and unionfind in normalisation of constraints.
Fix a few problems in choose_canonical, normalization and substitution functions.

Fix after merge

Fixes after rebase with latest Coq trunk, everything compiles again,
albeit slowly in some cases.
- Fix module substitution and comparison of table keys in conversion
using the wrong order (should always be UserOrd now)
- Cleanup in universes, removing commented code.
- Fix normalization of universe context which was assigning global
levels to local ones. Should always be the other way!
- Fix universe implementation to implement sorted cons of universes
preserving order. Makes Univ.sup correct again, keeping universe in
normalized form.
- In evarconv.ml, allow again a Fix to appear as head of a weak-head normal
form (due to partially applied fixpoints).
- Catch anomalies of conversion as errors in reductionops.ml, sad but
necessary as eta-expansion might build ill-typed stacks like FProd,
[shift;app Rel 1], as it expands not only if the other side is rigid.
- Fix module substitution bug in auto.ml

- Fix case compilation: impossible cases compilation was generating useless universe
levels. Use an IDProp constant instead of the polymorphic identity to not influence
the level of the original type when building the case construct for the return type.
- Simplify normalization of universe constraints.
- Compute constructor levels of records correctly.

Fall back to levels for universe instances, avoiding issues of unification.
Add more to the test-suite for universe polymorphism.

Fix after rebase with trunk

Fix substitution of universes inside fields/params of records to be made
after all normalization is done and the level of the record has been
computed.

Proper sharing of lower bounds with fixed universes.

Conflicts:
	library/universes.ml
	library/universes.mli

Constraints were not enforced in compilation of cases

Fix after rebase with trunk

- Canonical projections up to universes
- Fix computation of class/record universe levels to allow
squashing to Prop/Set in impredicative set mode.

- Fix descend_in_conjunctions to properly instantiate projections with universes
- Avoid Context-bound variables taking extra universes in their associated universe context.

- Fix evar_define using the wrong direction when refreshing a universe under cumulativity
- Do not instantiate a local universe with some lower bound to a global one just because
they have the same local glb (they might not have the same one globally).

- Was loosing some global constraints during normalization (brought again by the kernel), fixed now.
- Proper [abstract] with polymorphic lemmas (polymorphic if the current proof is).
- Fix silly bug in autorewrite: any hint after the first one was always monomorphic.

- Fix fourier after rebase
- Refresh universes when checking types of metas in unification (avoid (sup (sup univ))).
- Speedup a script in FSetPositive.v

Rework definitions in RelationClasses and Morphisms to share universe
levels as much as possible. This factorizes many useless x <=
RelationClasses.foo constraints in code that uses setoid rewriting.
Slight incompatible change in the implicits for Reflexivity and
Irreflexivity as well.

- Share even more universes in Morphisms using a let.
- Use splay_prod instead of splay_prod_assum which doesn't reduce let's
to find a relation in setoid_rewrite
- Fix [Declare Instance] not properly dealing with let's in typeclass contexts.

Fixes in inductiveops, evarutil.

Patch by Yves Bertot to allow naming universes in inductive definitions.

Fixes in tacinterp not propagating evars correctly.

Fix for issue #27: lowering a Type to Prop is allowed during
inference (resulting in a Type (* Set *)) but kernel reduction
was wrongly refusing the equation [Type (*Set*) = Set].

Fix in interface of canonical structures: an instantiated polymorphic
projection is not needed to lookup a structure, just the projection name
is enough (reported by C. Cohen).

Move from universe inference to universe checking in the kernel.

All tactics have to be adapted so that they carry around their generated
constraints (living in their sigma), which is mostly straightforward.
The more important changes are when refering to Coq constants, the
tactics code is adapted so that primitive eq, pairing and sigma types might
be polymorphic.
Fix another few places in tacinterp and evarconv/evarsolve where the sigma
was not folded correctly.

- Fix discharge adding spurious global constraints on polymorphic universe variables
appearing in assumptions.
- Fixes in inductiveops not taking into account universe polymorphic inductives.

WIP on checked universe polymorphism, it is clearly incompatible
with the previous usage of polymorphic inductives + non-polymorphic
definitions on them as universe levels now appear in the inductive type,
and add equality constraints between universes that were otherwise just
in a cumulativity relation (not sure that was actually correct).

Refined version of unification of universe instances for first-order unification,
prefering unfolding to arbitrary identification of universes.

Moved kernel to universe checking only.

Adapt the code to properly infer constraints during typechecking and
refinement (tactics) and only check constraints when adding
constants/inductives to the environment. Exception made of module
subtyping that needs inference of constraints...  The kernel conversion
(fconv) has two modes: checking only and inference, the later being used
by modules only. Evarconv/unification make use of a different strategy for
conversion of constants that prefer unfolding to blind unification of
rigid universes. Likewise, conversion checking backtracks on different universe
instances (modulo the constraints).

- adapt congruence/funind/ring plugins to this new mode, forcing them to
declare their constraints.
- To avoid big performance penalty with reification, make ring/field non-polymorphic
(non-linear explosion in run time to be investigated further).
- pattern and change tactics need special treatment: as they are not _reduction_
but conversion functions, their operation requires to update an evar_map with
new universe constraints.
- Fix vm_compute to work better with universes. If the normal
form is made only of constructors then the readback is correct. However a deeper change will
be needed to treat substitution of universe instances when unfolding constants.

Remove libtypes.ml

Fix after merge.

Fix after rebase with trunk.

**** Add projections to the kernel, as optimized implementations of constants.

- New constructor Proj expects a projection constant applied to its principal
inductive argument.
- Reduction machines shortcut the expansion to a case and directly project the
right argument.
- No need to keep parameters as part of the projection's arguments as they
are inferable from the type of the principal argument.
- ML code now compiles, debugging needed.

Start debugging the implementation of projections. Externalisation should
keep the information about projections.

Internalization, pattern-matching, unification and reduction
of projections.

Fix some code that used to have _ for parameters that are no longer
present in projections.

Fixes in unification, reduction, term indexing, auto hints based on projections,
add debug printers.

Fix byte-compilation of projections, unification, congruence with projections.
Adapt .v files using "@proj _ _ record" syntax, should come back on this later.
Fix coercion insertion code to properly deal with projection coercions.
Fix [simpl proj]... TODO [unfold proj], proj is not considered evaluable.

- Fix whnf of projections, now respecting opacity information.
- Fix conversion of projections to try first-order first and then
incrementally unfold them.
- Fix computation of implicit args for projections, simply dropping
the information for parameters.
- Fix a few scripts that relied on projections carrying their parameters (few at's,
rewrites).
- Fix unify_with_subterm to properly match under projections.
- Fix bug in cooking of projections.
- Add pattern PProj for projections.
- A very strange bug appeared in BigZ.v, making coqtop segfault on the export
of BigN... tofix

Fixes after rebase with trunk. Everything compiles now, with efficient
projections.

Fixes after rebase with trunk (esp. reductionops).

Remove warnings, backport patch from old univs+projs branch.

Proper expansion of projections during unification.

They are considered as maybe flexible keys in evarconv/unification. We
try firstorder unification and otherwise expand them as necessary,
completely mimicking the original behavior, when they were
constants.  Fix head_constr_bound interface, the arguments are never
needed (they're outside their environment actually).  [simpl] and
[red]/[intro] should behave just like before now.

Fix evarconv that was giving up on proj x = ?e problems too early.

- Port patch by Maxime Denes implementing fast projections in the native conversion.
- Backport patch to add eta-expansion for records.

Do not raise an exception but simply fails if trying to do eta on an inductive that is not a record.

Fix projections detyping/matching and unification.ml not always
recovering on first-order universe inequalities.

Correct eta-expansion for records, and change strategy for conversion
with projections to favor reduction over first-order unification a
little more. Fix a bug in Ltac pattern matching on projections.

Fix evars_reset_evd to not recheck existing constraints in case it is just an update
(performance improvement for typeclass resolution).

- Respect Global/Transparent oracle during unification. Opaque means
_never_ unfolded there.
- Add empty universes as well as the initial universes (having Prop < Set).
- Better display of universe inconsistencies.

- Add Beta Ziliani's patch to go fast avoiding imitation when possible.
- Allow instantiation by lower bound even if there are universes above
- (tentative) In refinement, avoid incremental refinement of terms
  containing no holes and do it in one step (much faster on big terms).
  Turned on only if not a checked command.

Remove dead code in univ/universes.ml and cleanup setup of hashconsing,
for a small speed and memory footprint improvement.

- Fix bug in unification using cumulativity when conversion should have been used.
- Fix unification of evars having type Type, no longer forcing them to be equal
(potentially more constraints): algorithm is now complete w.r.t. cumulativity.
- In clenvtac, use refine_nocheck as we are guaranteed to get well-typed terms
from unification now, including sufficient universe constraints. Small general
speedup.

- Fix inference of universe levels of inductive types to avoid smashing
  inadvertently from Set to Prop.
- Fix computation of discharged hypotheses forgetting the arity in inductives.

- Fix wrong order in printing of universe inconsistency explanation
- Allow coercions between two polymorphic instances of the same inductive/constant.
- Do evar normalization and saturation by classes before trying to use program coercion
  during pretyping.
- In unification, force equalities of universes when unifying the same rigid head constants.

- Fix omission of projections in constr_leq
- Fix [admit] tactic's handling of normalized universes.

Fix typing of projections not properly normalizing w.r.t. evars, resulting in anomaly sometimes.

Adapt rewrite to work with computational relations (in Type), while
maintaining backward compatibility with Propositional rewriting.

Introduce a [diff] function on evar maps and universe contexts to
properly deal with clause environments. Local hints in auto now store
just the extension of the evar map they rely on, so merging them becomes
efficient. This fixes an important performance issue in auto and typeclass
resolution in presence of a large number of universe constraints.

Change FSetPositive and MSetPositive to put their [elt] and [t] universes in
Type to avoid restricting global universes to [Set]. This is due to [flip]s
polymorphic type being fixed in monomorphic instances of Morphisms.v,
and rewriting hence forcing unification of levels that could be left unrelated.

- Try a fast_typeops implementation of kernel type inference that
  allocates less by not rebuilding the term, shows a little performance
  improvement, and less allocation.
- Build universe inconsistency explanations lazily, avoiding huge blowup
  (x5) in check_constraints/merge_constraints in time and space (these
  are stressed in universe polymorphic mode).
- Hashcons universe instances.

Add interface file for fast_typeops

Use monomorphic comparisons, little optimizations of hashconsing and
comparison in univ.ml.

Fix huge slowdown due to building huge error messages. Lazy is not
enough to tame this completely.

Fix last performance issue, due to abstracts building huge terms abstracting on parts of the section
context. Was due to wrong handling of Let... Qed.s in abstract. Performance is a tiny bit better than the
trunk now.

First step at compatibility layer for projections.

Compatibility mode for projections. c.(p), p c use primitive projs,
while @p refers to an expansion [λ params c, c.(p)]. Recovers almost
entire source compatibility with trunk scripts, except when mixing
@p and p and doing syntactic matching (they're unifiable though).

Add a [Set Primitive Projections] flag to set/unset the use of primitive
projections, selectively for each record. Adapt code to handle both the
legacy encoding and the primitive projections. Library is almost
source-to-source compatible, except for syntactic operations relying
on the presence of parameters. In primitive projections mode, @p refers
to an expansion [λ params r. p.(r)]. More information in CHANGES (to be
reformated/moved to reference manual).

Backport changes from HoTT/coq:

- Fix anomaly on uncatched NotASort in retyping.
- Better recognition of evars that are subject to typeclass resolution.
  Fixes bug reported by J. Gross on coq-club.
- Print universe polymorphism information for parameters as well.

Fix interface for unsatisfiable constraints error, now a type error.
Try making ring polymorphic again, with a big slowdown, to be investigated.
Fix evar/universe leak in setoid rewrite.

- Add profiling flag
- Move setoid_ring back to non-polymorphic mode to compare perfs with trunk
- Change unification to allow using infer_conv more often (big perf culprit),
  but semantics of backtracking on unification of constants is not properly
  implemented there.
- Fix is_empty/union_evar_universe_context forgetting about some assignments.
- Performance is now very close to the trunk from june,
  with projections deactivated.

35 files changed, 2607 insertions, 1444 deletions

diff --git a/tactics/auto.ml b/tactics/auto.ml
index 152556c74..0f296c6af 100644
--- a/tactics/auto.ml
+++ b/tactics/auto.ml
@@ -36,16 +36,17 @@ open Tacexpr
 open Mod_subst
 open Locus
 open Proofview.Notations
+open Decl_kinds
 
 (****************************************************************************)
 (*            The Type of Constructions Autotactic Hints                    *)
 (****************************************************************************)
 
 type 'a auto_tactic =
-  | Res_pf     of constr * 'a (* Hint Apply *)
-  | ERes_pf    of constr * 'a (* Hint EApply *)
-  | Give_exact of constr
-  | Res_pf_THEN_trivial_fail of constr * 'a (* Hint Immediate *)
+  | Res_pf     of 'a (* Hint Apply *)
+  | ERes_pf    of 'a (* Hint EApply *)
+  | Give_exact of 'a
+  | Res_pf_THEN_trivial_fail of 'a (* Hint Immediate *)
   | Unfold_nth of evaluable_global_reference       (* Hint Unfold *)
   | Extern     of glob_tactic_expr       (* Hint Extern *)
 
@@ -61,16 +62,22 @@ type hints_path =
   | PathEmpty
   | PathEpsilon
 
+type hint_term =
+  | IsGlobRef of global_reference
+  | IsConstr of constr * Univ.universe_context_set
+
 type 'a gen_auto_tactic = {
   pri  : int;            (* A number lower is higher priority *)
+  poly  : polymorphic;    (** Is the hint polymorpic and hence should be refreshed at each application *)
   pat  : constr_pattern option; (* A pattern for the concl of the Goal *)
   name  : hints_path_atom; (* A potential name to refer to the hint *) 
   code : 'a auto_tactic     (* the tactic to apply when the concl matches pat *)
 }
 
-type pri_auto_tactic = clausenv gen_auto_tactic
+type pri_auto_tactic = (constr * clausenv) gen_auto_tactic
 
-type hint_entry = global_reference option * types gen_auto_tactic
+type hint_entry = global_reference option * 
+  (constr * types * Univ.universe_context_set) gen_auto_tactic
 
 let eq_hints_path_atom p1 p2 = match p1, p2 with
 | PathHints gr1, PathHints gr2 -> List.equal eq_gr gr1 gr2
@@ -80,7 +87,7 @@ let eq_hints_path_atom p1 p2 = match p1, p2 with
 let eq_auto_tactic t1 t2 = match t1, t2 with
 | Res_pf (c1, _), Res_pf (c2, _) -> Constr.equal c1 c2
 | ERes_pf (c1, _), ERes_pf (c2, _) -> Constr.equal c1 c2
-| Give_exact c1, Give_exact c2 -> Constr.equal c1 c2
+| Give_exact (c1, _), Give_exact (c2, _) -> Constr.equal c1 c2
 | Res_pf_THEN_trivial_fail (c1, _), Res_pf_THEN_trivial_fail (c2, _) -> Constr.equal c1 c2
 | Unfold_nth gr1, Unfold_nth gr2 -> eq_egr gr1 gr2
 | Extern tac1, Extern tac2 -> tac1 == tac2 (** May cause redundancy in addkv *)
@@ -134,17 +141,23 @@ type search_entry = stored_data list * stored_data list * Bounded_net.t
 
 let empty_se = ([],[],Bounded_net.create ())
 
+let eq_constr_or_reference x y = 
+  match x, y with
+  | IsConstr (x,_), IsConstr (y,_) -> eq_constr x y
+  | IsGlobRef x, IsGlobRef y -> eq_gr x y
+  | _, _ -> false
+
 let eq_pri_auto_tactic (_, x) (_, y) =
   if Int.equal x.pri y.pri && Option.equal constr_pattern_eq x.pat y.pat then
     match x.code,y.code with
-      | Res_pf(cstr,_),Res_pf(cstr1,_) -> 
+      | Res_pf (cstr,_),Res_pf (cstr1,_) -> 
 	   eq_constr cstr cstr1
-      | ERes_pf(cstr,_),ERes_pf(cstr1,_) -> 
+      | ERes_pf (cstr,_),ERes_pf (cstr1,_) -> 
 	  eq_constr cstr cstr1
-      | Give_exact cstr,Give_exact cstr1  -> 
+      | Give_exact (cstr,_),Give_exact (cstr1,_)  -> 
 	  eq_constr cstr cstr1
-      | Res_pf_THEN_trivial_fail(cstr,_)
-	  ,Res_pf_THEN_trivial_fail(cstr1,_) -> 
+      | Res_pf_THEN_trivial_fail (cstr,_)
+	  ,Res_pf_THEN_trivial_fail (cstr1,_) -> 
 	  eq_constr cstr cstr1
       | _,_ -> false
   else
@@ -176,20 +189,44 @@ let is_transparent_gr (ids, csts) = function
 
 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 }
+let instantiate_constr_or_ref env sigma c =
+  let c, ctx = Universes.fresh_global_or_constr_instance env c in
+  let cty = Retyping.get_type_of env sigma c in
+    (c, cty), ctx
+
+let strip_params env c = 
+  match kind_of_term c with
+  | App (f, args) -> 
+    (match kind_of_term f with
+    | Const (p,_) ->
+      let cb = lookup_constant p env in
+	(match cb.Declarations.const_proj with
+	| Some pb -> 
+	  let n = pb.Declarations.proj_npars in
+	    mkApp (mkProj (p, args.(n)), 
+		   Array.sub args (n+1) (Array.length args - (n + 1)))
+	| None -> c)
+    | _ -> c)
+  | _ -> c
+
+let instantiate_hint p =
+  let mk_clenv c cty ctx =
+    let sigma = Evd.merge_context_set univ_flexible dummy_goal.sigma ctx in
+    let goal = { dummy_goal with sigma = sigma } in
+    let cl = mk_clenv_from goal (c,cty) in 
+      {cl with templval = 
+	  { cl.templval with rebus = strip_params (Global.env()) cl.templval.rebus };
+	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
+    | Res_pf (c, cty, ctx) -> Res_pf (c, mk_clenv c cty ctx)
+    | ERes_pf (c, cty, ctx) -> ERes_pf (c, mk_clenv c cty ctx)
+    | Res_pf_THEN_trivial_fail (c, cty, ctx) ->
+      Res_pf_THEN_trivial_fail (c, mk_clenv c cty ctx)
+    | Give_exact (c, cty, ctx) -> Give_exact (c, mk_clenv c cty ctx)
     | Unfold_nth e -> Unfold_nth e
     | Extern t -> Extern t
-  in
-  (go,{ p with code = code })
+  in { pri = p.pri; poly = p.poly; name = p.name; pat = p.pat; code = code }
 
 let hints_path_atom_eq h1 h2 = match h1, h2 with
 | PathHints l1, PathHints l2 -> List.equal eq_gr l1 l2
@@ -350,17 +387,19 @@ module Hint_db = struct
     try Constr_map.find key db.hintdb_map
     with Not_found -> empty_se
  
+  let realize_tac (id,tac) = tac
+
   let map_none db =
-    List.map snd (List.merge pri_order_int (List.map snd db.hintdb_nopat) [])
+    List.map realize_tac (Sort.merge pri_order (List.map snd db.hintdb_nopat) [])
     
   let map_all k db =
     let (l,l',_) = find k db in
-      List.map snd (List.merge pri_order_int (List.map snd db.hintdb_nopat @ l) l')
+      List.map realize_tac (Sort.merge pri_order (List.map snd db.hintdb_nopat @ l) l')
 
   let map_auto (k,c) db =
     let st = if db.use_dn then Some db.hintdb_state else None in
     let l' = lookup_tacs (k,c) st (find k db) in
-      List.map snd (List.merge pri_order_int (List.map snd db.hintdb_nopat) l')
+      List.map realize_tac (Sort.merge pri_order (List.map snd db.hintdb_nopat) l')
 
   let is_exact = function
     | Give_exact _ -> true
@@ -384,6 +423,7 @@ module Hint_db = struct
           (** ppedrot: this equality here is dubious. Maybe we can remove it? *)
           let is_present (_, (_, v')) = eq_gen_auto_tactic v v' in
 	  if not (List.exists is_present db.hintdb_nopat) then
+	    (** FIXME *)
 	    { db with hintdb_nopat = (gr,idv) :: db.hintdb_nopat }
 	  else db
       | Some gr ->
@@ -397,8 +437,8 @@ module Hint_db = struct
     in
       List.fold_left (fun db (gr,(id,v)) -> addkv gr id v db) db' db.hintdb_nopat
 
-  let add_one kv db =
-    let (k,v) = translate_hint kv in
+  let add_one (k, v) db =
+    let v = instantiate_hint v in
     let st',db,rebuild =
       match v.code with
       | Unfold_nth egr ->
@@ -432,8 +472,8 @@ module Hint_db = struct
   let remove_one gr db = remove_list [gr] db
 
   let iter f db =
-    f None (List.map (fun x -> snd (snd x)) db.hintdb_nopat);
-    Constr_map.iter (fun k (l,l',_) -> f (Some k) (List.map snd (l@l'))) db.hintdb_map
+    f None (List.map (fun x -> realize_tac (snd x)) db.hintdb_nopat);
+    Constr_map.iter (fun k (l,l',_) -> f (Some k) (List.map realize_tac (l@l'))) db.hintdb_map
 
   let fold f db accu =
     let accu = f None (List.map (fun x -> snd (snd x)) db.hintdb_nopat) accu in
@@ -516,7 +556,7 @@ let try_head_pattern c =
   try head_pattern_bound c
   with BoundPattern -> error "Bound head variable."
 
-let make_exact_entry sigma pri ?(name=PathAny) (c,cty) =
+let make_exact_entry env sigma pri poly ?(name=PathAny) (c, cty, ctx) =
   let cty = strip_outer_cast cty in
     match kind_of_term cty with
     | Prod _ -> failwith "make_exact_entry"
@@ -528,15 +568,17 @@ let make_exact_entry sigma pri ?(name=PathAny) (c,cty) =
 	in
           (Some hd,
 	  { pri = (match pri with None -> 0 | Some p -> p);
+	    poly = poly;
 	    pat = Some pat;
 	    name = name;
-	    code = Give_exact c })
+	    code = Give_exact (c, cty, ctx) })
 
-let make_apply_entry env sigma (eapply,hnf,verbose) pri ?(name=PathAny) (c,cty) =
+let make_apply_entry env sigma (eapply,hnf,verbose) pri poly ?(name=PathAny) (c, cty, ctx) =
   let cty = if hnf then hnf_constr env sigma cty else cty in
     match kind_of_term cty with
     | Prod _ ->
-        let ce = mk_clenv_from dummy_goal (c,cty) in
+        let sigma' = Evd.merge_context_set univ_flexible dummy_goal.sigma ctx in
+        let ce = mk_clenv_from { dummy_goal with sigma = sigma' } (c,cty) in
 	let c' = clenv_type (* ~reduce:false *) ce in
 	let pat = snd (Patternops.pattern_of_constr sigma c') in
         let hd =
@@ -546,9 +588,10 @@ let make_apply_entry env sigma (eapply,hnf,verbose) pri ?(name=PathAny) (c,cty)
 	if Int.equal nmiss 0 then
 	  (Some hd,
           { pri = (match pri with None -> nb_hyp cty | Some p -> p);
+	    poly = poly;
             pat = Some pat;
 	    name = name;
-            code = Res_pf(c,cty) })
+            code = Res_pf(c,cty,ctx) })
 	else begin
 	  if not eapply then failwith "make_apply_entry";
           if verbose then
@@ -556,9 +599,10 @@ let make_apply_entry env sigma (eapply,hnf,verbose) pri ?(name=PathAny) (c,cty)
 	    str " will only be used by eauto");
           (Some hd,
            { pri = (match pri with None -> nb_hyp cty + nmiss | Some p -> p);
+	     poly = poly;
              pat = Some pat;
 	     name = name;
-             code = ERes_pf(c,cty) })
+             code = ERes_pf(c,cty,ctx) })
         end
     | _ -> failwith "make_apply_entry"
 
@@ -566,12 +610,18 @@ let make_apply_entry env sigma (eapply,hnf,verbose) pri ?(name=PathAny) (c,cty)
    c is a constr
    cty is the type of constr *)
 
-let make_resolves env sigma flags pri ?name c =
+let fresh_global_or_constr env sigma poly cr =
+  match cr with
+  | IsGlobRef gr -> Universes.fresh_global_instance env gr
+  | IsConstr (c, ctx) -> (c, ctx)
+
+let make_resolves env sigma flags pri poly ?name cr =
+  let c, ctx = fresh_global_or_constr env sigma poly cr in
   let cty = Retyping.get_type_of env sigma c in
   let try_apply f =
-    try Some (f (c, cty)) with Failure _ -> None in
+    try Some (f (c, cty, ctx)) with Failure _ -> None in
   let ents = List.map_filter try_apply
-      [make_exact_entry sigma pri ?name; make_apply_entry env sigma flags pri ?name]
+    [make_exact_entry env sigma pri poly ?name; make_apply_entry env sigma flags pri poly ?name]
   in
   if List.is_empty ents then
     errorlabstrm "Hint"
@@ -583,9 +633,9 @@ let make_resolves env sigma flags pri ?name 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 false
        ~name:(PathHints [VarRef hname])
-       (mkVar hname, htyp)]
+       (mkVar hname, htyp, Univ.ContextSet.empty)]
   with
     | Failure _ -> []
     | e when Logic.catchable_exception e -> anomaly (Pp.str "make_resolve_hyp")
@@ -595,6 +645,7 @@ let make_unfold eref =
   let g = global_of_evaluable_reference eref in
   (Some g,
    { pri = 4;
+     poly = false;
      pat = None;
      name = PathHints [g];
      code = Unfold_nth eref })
@@ -603,19 +654,21 @@ let make_extern pri pat tacast =
   let hdconstr = Option.map try_head_pattern pat in
   (hdconstr,
    { pri = pri;
+     poly = false;
      pat = pat;
      name = PathAny;
      code = Extern tacast })  
 
-let make_trivial env sigma ?(name=PathAny) r =
-  let c = constr_of_global_or_constr r in
+let make_trivial env sigma poly ?(name=PathAny) r =
+  let c,ctx = fresh_global_or_constr env sigma poly r in
   let t = hnf_constr env sigma (type_of env sigma c) in
-  let hd = head_of_constr_reference (fst (head_constr t)) in
+  let hd = head_of_constr_reference (head_constr t) in
   let ce = mk_clenv_from dummy_goal (c,t) in
   (Some hd, { pri=1;
+	      poly = poly;
               pat = Some (snd (Patternops.pattern_of_constr sigma (clenv_type ce)));
 	      name = name;
-              code=Res_pf_THEN_trivial_fail(c,t) })
+              code=Res_pf_THEN_trivial_fail(c,t,ctx) })
   
 open Vernacexpr
 
@@ -675,11 +728,21 @@ let cache_autohint (_,(local,name,hints)) =
 
 let (forward_subst_tactic, extern_subst_tactic) = Hook.make ()
 
+  (* let subst_mps_or_ref subst cr =  *)
+  (*   match cr with *)
+  (*   | IsConstr c -> let c' = subst_mps subst c in  *)
+  (* 		      if c' == c then cr *)
+  (* 		      else IsConstr c' *)
+  (*   | IsGlobal r -> let r' = subst_global_reference subst r in *)
+  (* 			 if r' == r then cr *)
+  (* 			 else IsGlobal r' *)
+  (* in *)
+
 let subst_autohint (subst,(local,name,hintlist as obj)) =
   let subst_key gr =
     let (lab'', elab') = subst_global subst gr in
     let gr' =
-      (try head_of_constr_reference (fst (head_constr_bound elab'))
+      (try head_of_constr_reference (head_constr_bound elab')
        with Tactics.Bound -> lab'')
     in if gr' == gr then gr else gr'
   in
@@ -687,21 +750,22 @@ let subst_autohint (subst,(local,name,hintlist as obj)) =
     let k' = Option.smartmap subst_key k in
     let pat' = Option.smartmap (subst_pattern subst) data.pat in
     let code' = match data.code with
-      | Res_pf (c,t) ->
+      | Res_pf (c,t,ctx) ->
           let c' = subst_mps subst c in
           let t' = subst_mps subst t in
-          if c==c' && t'==t then data.code else Res_pf (c', t')
-      | ERes_pf (c,t) ->
+          if c==c' && t'==t then data.code else Res_pf (c', t',ctx)
+      | ERes_pf (c,t,ctx) ->
           let c' = subst_mps subst c in
           let t' = subst_mps subst t in
-          if c==c' && t'==t then data.code else ERes_pf (c',t')
-      | Give_exact c ->
+          if c==c' && t'==t then data.code else ERes_pf (c',t',ctx)
+      | Give_exact (c,t,ctx) ->
           let c' = subst_mps subst c in
-          if c==c' then data.code else Give_exact c'
-      | Res_pf_THEN_trivial_fail (c,t) ->
+	  let t' = subst_mps subst t in
+          if c==c' && t'== t then data.code else Give_exact (c',t',ctx)
+      | Res_pf_THEN_trivial_fail (c,t,ctx) ->
           let c' = subst_mps subst c in
           let t' = subst_mps subst t in
-          if c==c' && t==t' then data.code else Res_pf_THEN_trivial_fail (c',t')
+          if c==c' && t==t' then data.code else Res_pf_THEN_trivial_fail (c',t',ctx)
       | Unfold_nth ref ->
           let ref' = subst_evaluable_reference subst ref in
           if ref==ref' then data.code else Unfold_nth ref'
@@ -765,13 +829,9 @@ let add_resolves env sigma clist local dbnames =
        Lib.add_anonymous_leaf
 	 (inAutoHint
 	    (local,dbname, AddHints
-     	      (List.flatten (List.map (fun (x, hnf, path, gr) ->
-	        let c = 
-		  match gr with
-		  | IsConstr c -> c
-		  | IsGlobal gr -> constr_of_global gr
-		in
-		  make_resolves env sigma (true,hnf,Flags.is_verbose()) x ~name:path c) clist)))))
+     	      (List.flatten (List.map (fun (pri, poly, hnf, path, gr) ->
+	        make_resolves env sigma (true,hnf,Flags.is_verbose()) 
+		  pri poly ~name:path gr) clist)))))
     dbnames
 
 let add_unfolds l local dbnames =
@@ -808,14 +868,20 @@ let add_trivials env sigma l local dbnames =
     (fun dbname ->
        Lib.add_anonymous_leaf (
 	 inAutoHint(local,dbname, 
-		    AddHints (List.map (fun (name, c) -> make_trivial env sigma ~name c) l))))
+		    AddHints (List.map (fun (name, poly, c) -> make_trivial env sigma poly ~name c) l))))
     dbnames
 
 let (forward_intern_tac, extern_intern_tac) = Hook.make ()
 
+type hnf = bool
+
+let pr_hint_term = function
+  | IsConstr (c,_) -> pr_constr c
+  | IsGlobRef gr -> pr_global gr
+
 type hints_entry =
-  | HintsResolveEntry of (int option * bool * hints_path_atom * global_reference_or_constr) list
-  | HintsImmediateEntry of (hints_path_atom * global_reference_or_constr) list
+  | HintsResolveEntry of (int option * polymorphic * hnf * hints_path_atom * hint_term) list
+  | HintsImmediateEntry of (hints_path_atom * polymorphic * hint_term) list
   | HintsCutEntry of hints_path
   | HintsUnfoldEntry of evaluable_global_reference list
   | HintsTransparencyEntry of evaluable_global_reference list * bool
@@ -826,7 +892,7 @@ let h = Id.of_string "H"
 
 exception Found of constr * types
 
-let prepare_hint env (sigma,c) =
+let prepare_hint check env init (sigma,c) =
   let sigma = Typeclasses.resolve_typeclasses ~fail:false env sigma in
   (* We re-abstract over uninstantiated evars.
      It is actually a bit stupid to generalize over evars since the first
@@ -853,15 +919,16 @@ let prepare_hint env (sigma,c) =
       vars := Id.Set.add id !vars;
       subst := (evar,mkVar id)::!subst;
       mkNamedLambda id t (iter (replace_term evar (mkVar id) c)) in
-  iter c
+  let c' = iter c in
+    if check then Evarutil.check_evars (Global.env()) Evd.empty sigma c';
+    let diff = Evd.diff sigma init in
+      IsConstr (c', Evd.get_universe_context_set diff)
 
-let interp_hints =
+let interp_hints poly =
   fun h ->
   let f c =
     let evd,c = Constrintern.interp_open_constr Evd.empty (Global.env()) c in
-    let c = prepare_hint (Global.env()) (evd,c) in
-    Evarutil.check_evars (Global.env()) Evd.empty evd c;
-    c in
+      prepare_hint true (Global.env()) Evd.empty (evd,c) in
   let fr r =
     let gr = global_with_alias r in
     let r' = evaluable_of_global_reference (Global.env()) gr in
@@ -871,12 +938,17 @@ let interp_hints =
     match c with
     | HintsReference c ->
       let gr = global_with_alias c in
-	(PathHints [gr], IsGlobal gr)
-    | HintsConstr c -> (PathAny, IsConstr (f c))
+	(PathHints [gr], poly, IsGlobRef gr)
+    | HintsConstr c -> 
+      (* if poly then *)
+      (* 	errorlabstrm "Hint" (Ppconstr.pr_constr_expr c ++ spc () ++  *)
+      (* 			     str" is a term and cannot be made a polymorphic hint," ++ *)
+      (* 			     str" only global references can be polymorphic hints.") *)
+      (* else *) (PathAny, poly, f c)
   in
-  let fres (o, b, c) =
-    let path, gr = fi c in
-      (o, b, path, gr)
+  let fres (pri, b, r) =
+    let path, poly, gr = fi r in
+      (pri, poly, b, path, gr)
   in
   let fp = Constrintern.intern_constr_pattern (Global.env()) in
   match h with
@@ -888,11 +960,14 @@ let interp_hints =
   | HintsConstructors lqid ->
       let constr_hints_of_ind qid =
         let ind = global_inductive_with_alias qid in
+	let mib,_ = Global.lookup_inductive ind in
 	Dumpglob.dump_reference (fst (qualid_of_reference qid)) "<>" (string_of_reference qid) "ind";
-        List.init (nconstructors ind) (fun i -> let c = (ind,i+1) in
-				let gr = ConstructRef c in
-			 None, true, PathHints [gr], IsGlobal gr) in
-	HintsResolveEntry (List.flatten (List.map constr_hints_of_ind lqid))
+          List.init (nconstructors ind) 
+	    (fun i -> let c = (ind,i+1) in
+		      let gr = ConstructRef c in
+			None, mib.Declarations.mind_polymorphic, true, 
+			PathHints [gr], IsGlobRef gr)
+      in HintsResolveEntry (List.flatten (List.map constr_hints_of_ind lqid))
   | HintsExtern (pri, patcom, tacexp) ->
       let pat =	Option.map fp patcom in
       let l = match pat with None -> [] | Some (l, _) -> l in
@@ -922,7 +997,7 @@ let pr_autotactic =
   function
   | Res_pf (c,clenv) -> (str"apply " ++ pr_constr c)
   | ERes_pf (c,clenv) -> (str"eapply " ++ pr_constr c)
-  | Give_exact c -> (str"exact " ++ pr_constr c)
+  | Give_exact (c,clenv) -> (str"exact " ++ pr_constr c)
   | Res_pf_THEN_trivial_fail (c,clenv) ->
       (str"apply " ++ pr_constr c ++ str" ; trivial")
   | Unfold_nth c -> (str"unfold " ++  pr_evaluable_reference c)
@@ -970,11 +1045,11 @@ let pr_hint_term cl =
     let dbs = current_db () in
     let valid_dbs =
       let fn = try
-	  let (hdc,args) = head_constr_bound cl in
+	  let hdc = head_constr_bound cl in
 	  let hd = head_of_constr_reference hdc in
 	    if occur_existential cl then
 	      Hint_db.map_all hd
-	    else Hint_db.map_auto (hd, applist (hdc,args))
+	    else Hint_db.map_auto (hd, cl)
 	with Bound -> Hint_db.map_none
       in
       let fn db = List.map (fun x -> 0, x) (fn db) in
@@ -1072,40 +1147,52 @@ let auto_unif_flags = {
 
 (* Try unification with the precompiled clause, then use registered Apply *)
 
-let unify_resolve_nodelta (c,clenv) gl =
-  let clenv' = connect_clenv gl clenv in
+let unify_resolve_nodelta poly (c,clenv) gl =
+  let clenv' = if poly then fst (Clenv.refresh_undefined_univs clenv) else clenv in
+  let clenv' = connect_clenv gl clenv' in
   let clenv'' = clenv_unique_resolver ~flags:auto_unif_flags clenv' gl in
   Clenvtac.clenv_refine false clenv'' gl
 
-let unify_resolve flags (c,clenv) gl =
-  let clenv' = connect_clenv gl clenv in
+let unify_resolve poly flags (c,clenv) gl =
+  let clenv' = if poly then fst (Clenv.refresh_undefined_univs clenv) else clenv in
+  let clenv' = connect_clenv gl clenv' in
   let clenv'' = clenv_unique_resolver ~flags clenv' gl in
   Clenvtac.clenv_refine false clenv'' gl
 
-let unify_resolve_gen = function
-  | None -> unify_resolve_nodelta
-  | Some flags -> unify_resolve flags
-
+let unify_resolve_gen poly = function
+  | None -> unify_resolve_nodelta poly
+  | Some flags -> unify_resolve poly flags
+
+let exact poly (c,clenv) =
+  let c' = 
+    if poly then
+      let evd', subst = Evd.refresh_undefined_universes clenv.evd in
+	subst_univs_level_constr subst c 
+    else c
+  in exact_check c'
+    
 (* Util *)
 
-let expand_constructor_hints env lems =
-  List.map_append (fun (sigma,lem) ->
+let expand_constructor_hints env sigma lems =
+  List.map_append (fun (evd,lem) ->
     match kind_of_term lem with
-    | Ind ind ->
-	List.init (nconstructors ind) (fun i -> mkConstruct (ind,i+1))
+    | Ind (ind,u) ->
+	List.init (nconstructors ind) 
+	  (fun i -> IsConstr (mkConstructU ((ind,i+1),u), 
+			      Univ.ContextSet.empty))
     | _ ->
-	[prepare_hint env (sigma,lem)]) lems
+	[prepare_hint false env sigma (evd,lem)]) lems
 
 (* builds a hint database from a constr signature *)
 (* typically used with (lid, ltyp) = pf_hyps_types <some goal> *)
 
 let add_hint_lemmas eapply lems hint_db gl =
-  let lems = expand_constructor_hints (pf_env gl) lems in
+  let lems = expand_constructor_hints (pf_env gl) (project gl) lems in
   let hintlist' =
-    List.map_append (pf_apply make_resolves gl (eapply,true,false) None) lems in
+    List.map_append (pf_apply make_resolves gl (eapply,true,false) None true) lems in
   Hint_db.add_list hintlist' hint_db
 
-let make_local_hint_db ?ts 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") 
@@ -1115,6 +1202,15 @@ let make_local_hint_db ?ts eapply lems gl =
   add_hint_lemmas eapply lems
     (Hint_db.add_list hintlist (Hint_db.empty ts false)) gl
 
+let make_local_hint_db = 
+  if Flags.profile then
+    let key = Profile.declare_profile "make_local_hint_db" in
+      Profile.profile4 key make_local_hint_db
+  else make_local_hint_db
+
+let make_local_hint_db ?ts eapply lems gl =
+  make_local_hint_db ts eapply lems gl
+
 (* Serait-ce possible de compiler d'abord la tactique puis de faire la
    substitution sans passer par bdize dont l'objectif est de préparer un
    terme pour l'affichage ? (HH) *)
@@ -1358,15 +1454,15 @@ 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 dbg db_list local_db concl (flags, ({pat=p; code=t})) =
+and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t;poly=poly})) =
   let tactic = 
     match t with
-    | Res_pf (c,cl) -> Proofview.V82.tactic (unify_resolve_gen flags (c,cl))
+    | Res_pf (c,cl) -> Proofview.V82.tactic (unify_resolve_gen poly flags (c,cl))
     | ERes_pf _ -> Proofview.V82.tactic (fun gl -> error "eres_pf")
-    | Give_exact c  -> Proofview.V82.tactic (exact_check c)
+    | Give_exact (c, cl)  -> Proofview.V82.tactic (exact poly (c, cl))
     | Res_pf_THEN_trivial_fail (c,cl) ->
       Tacticals.New.tclTHEN
-        (Proofview.V82.tactic (unify_resolve_gen flags (c,cl)))
+        (Proofview.V82.tactic (unify_resolve_gen poly flags (c,cl)))
 	(* With "(debug) trivial", we shouldn't end here, and
 	   with "debug auto" we don't display the details of inner trivial *)
         (trivial_fail_db (no_dbg ()) (not (Option.is_empty flags)) db_list local_db)
@@ -1382,7 +1478,7 @@ and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t})) =
 and trivial_resolve dbg mod_delta db_list local_db cl =
   try
     let head =
-      try let hdconstr,_ = head_constr_bound cl in
+      try let hdconstr = head_constr_bound cl in
 	    Some (head_of_constr_reference hdconstr)
       with Bound -> None
     in
@@ -1436,7 +1532,7 @@ let h_trivial ?(debug=Off) lems l = gen_trivial ~debug lems l
 let possible_resolve dbg mod_delta db_list local_db cl =
   try
     let head =
-      try let hdconstr,_ = head_constr_bound cl in
+      try let hdconstr = head_constr_bound cl in
 	    Some (head_of_constr_reference hdconstr)
       with Bound -> None
     in
@@ -1482,7 +1578,7 @@ let search d n mod_delta db_list local_db =
 
 let default_search_depth = ref 5
 
-let delta_auto ?(debug=Off) mod_delta n lems dbnames =
+let delta_auto debug mod_delta n lems dbnames =
   Proofview.Goal.enter begin fun gl ->
   let db_list = make_db_list dbnames in
   let d = mk_auto_dbg debug in
@@ -1491,9 +1587,15 @@ let delta_auto ?(debug=Off) mod_delta n lems dbnames =
     (search d n mod_delta db_list hints)
   end
 
-let auto ?(debug=Off) n = delta_auto ~debug false n
+let delta_auto = 
+  if Flags.profile then
+    let key = Profile.declare_profile "delta_auto" in
+      Profile.profile5 key delta_auto
+  else delta_auto
+
+let auto ?(debug=Off) n = delta_auto debug false n
 
-let new_auto ?(debug=Off) n = delta_auto ~debug true n
+let new_auto ?(debug=Off) n = delta_auto debug true n
 
 let default_auto = auto !default_search_depth [] []
 
diff --git a/tactics/auto.mli b/tactics/auto.mli
index 2d2720880..b85f86ea4 100644
--- a/tactics/auto.mli
+++ b/tactics/auto.mli
@@ -21,16 +21,17 @@ open Vernacexpr
 open Mod_subst
 open Misctypes
 open Pp
+open Decl_kinds
 
 (** Auto and related automation tactics *)
 
 type 'a auto_tactic =
-  | Res_pf     of constr * 'a    (** Hint Apply *)
-  | ERes_pf    of constr * 'a    (** Hint EApply *)
-  | Give_exact of constr
-  | Res_pf_THEN_trivial_fail of constr * 'a (** Hint Immediate *)
-  | Unfold_nth of evaluable_global_reference          (** Hint Unfold *)
-  | Extern     of Tacexpr.glob_tactic_expr   (** Hint Extern *)
+  | Res_pf     of 'a (* Hint Apply *)
+  | ERes_pf    of 'a (* Hint EApply *)
+  | Give_exact of 'a
+  | Res_pf_THEN_trivial_fail of 'a (* Hint Immediate *)
+  | Unfold_nth of evaluable_global_reference       (* Hint Unfold *)
+  | Extern     of Tacexpr.glob_tactic_expr       (* Hint Extern *)
 
 type hints_path_atom = 
   | PathHints of global_reference list
@@ -38,20 +39,20 @@ type hints_path_atom =
 
 type 'a gen_auto_tactic = {
   pri   : int;            (** A number between 0 and 4, 4 = lower priority *)
+  poly  : polymorphic;    (** Is the hint polymorpic and hence should be refreshed at each application *)
   pat   : constr_pattern option; (** A pattern for the concl of the Goal *)
   name  : hints_path_atom; (** A potential name to refer to the hint *) 
   code  : 'a auto_tactic; (** the tactic to apply when the concl matches pat *)
 }
 
-type pri_auto_tactic = clausenv gen_auto_tactic
-
-type stored_data = int * clausenv gen_auto_tactic
+type pri_auto_tactic = (constr * clausenv) gen_auto_tactic
 
 type search_entry
 
 (** The head may not be bound. *)
 
-type hint_entry = global_reference option * types gen_auto_tactic
+type hint_entry = global_reference option * 
+  (constr * types * Univ.universe_context_set) gen_auto_tactic
 
 type hints_path =
   | PathAtom of hints_path_atom
@@ -94,9 +95,16 @@ type hint_db_name = string
 
 type hint_db = Hint_db.t
 
+type hnf = bool
+
+type hint_term =
+  | IsGlobRef of global_reference
+  | IsConstr of constr * Univ.universe_context_set
+
 type hints_entry =
-  | HintsResolveEntry of (int option * bool * hints_path_atom * global_reference_or_constr) list
-  | HintsImmediateEntry of (hints_path_atom * global_reference_or_constr) list
+  | HintsResolveEntry of (int option * polymorphic * hnf * hints_path_atom * 
+			  hint_term) list
+  | HintsImmediateEntry of (hints_path_atom * polymorphic * hint_term) list
   | HintsCutEntry of hints_path
   | HintsUnfoldEntry of evaluable_global_reference list
   | HintsTransparencyEntry of evaluable_global_reference list * bool
@@ -118,11 +126,12 @@ val remove_hints : bool -> hint_db_name list -> global_reference list -> unit
 
 val current_db_names : unit -> String.Set.t
 
-val interp_hints : hints_expr -> hints_entry
+val interp_hints : polymorphic -> hints_expr -> hints_entry
 
 val add_hints : locality_flag -> hint_db_name list -> hints_entry -> unit
 
-val prepare_hint : env -> open_constr -> constr
+val prepare_hint : bool (* Check no remaining evars *) -> env -> evar_map -> 
+  open_constr -> hint_term
 
 val pr_searchtable : unit -> std_ppcmds
 val pr_applicable_hint : unit -> std_ppcmds
@@ -134,7 +143,8 @@ val pr_hint_db : Hint_db.t -> std_ppcmds
    [c] is the term given as an exact proof to solve the goal;
    [ctyp] is the type of [c]. *)
 
-val make_exact_entry : evar_map -> int option -> ?name:hints_path_atom -> constr * constr -> hint_entry
+val make_exact_entry : env -> evar_map -> int option -> polymorphic -> ?name:hints_path_atom -> 
+  (constr * types * Univ.universe_context_set) -> hint_entry
 
 (** [make_apply_entry (eapply,hnf,verbose) pri (c,cty)].
    [eapply] is true if this hint will be used only with EApply;
@@ -144,8 +154,8 @@ val make_exact_entry : evar_map -> int option -> ?name:hints_path_atom -> constr
    [cty] is the type of [c]. *)
 
 val make_apply_entry :
-  env -> evar_map -> bool * bool * bool -> int option -> ?name:hints_path_atom -> 
-  constr * constr -> hint_entry
+  env -> evar_map -> bool * bool * bool -> int option -> polymorphic -> ?name:hints_path_atom -> 
+  (constr * types * Univ.universe_context_set) -> hint_entry
 
 (** A constr which is Hint'ed will be:
    - (1) used as an Exact, if it does not start with a product
@@ -155,8 +165,8 @@ val make_apply_entry :
          has missing arguments. *)
 
 val make_resolves :
-  env -> evar_map -> bool * bool * bool -> int option -> ?name:hints_path_atom -> 
-  constr -> hint_entry list
+  env -> evar_map -> bool * bool * bool -> int option -> polymorphic -> ?name:hints_path_atom -> 
+  hint_term -> hint_entry list
 
 (** [make_resolve_hyp hname htyp].
    used to add an hypothesis to the local hint database;
@@ -194,9 +204,9 @@ val default_search_depth : int ref
 val auto_unif_flags : Unification.unify_flags
 
 (** Try unification with the precompiled clause, then use registered Apply *)
-val unify_resolve_nodelta : (constr * clausenv) -> tactic
+val unify_resolve_nodelta : polymorphic -> (constr * clausenv) -> tactic
 
-val unify_resolve : Unification.unify_flags -> (constr * clausenv) -> tactic
+val unify_resolve : polymorphic -> Unification.unify_flags -> (constr * clausenv) -> tactic
 
 (** [ConclPattern concl pat tacast]:
    if the term concl matches the pattern pat, (in sense of
@@ -255,7 +265,7 @@ val full_trivial : ?debug:Tacexpr.debug ->
 val h_trivial : ?debug:Tacexpr.debug ->
   open_constr list -> hint_db_name list option -> unit Proofview.tactic
 
-val pr_autotactic : 'a auto_tactic -> Pp.std_ppcmds
+val pr_autotactic : (constr * 'a) auto_tactic -> Pp.std_ppcmds
 
 (** Hook for changing the initialization of auto *)
 
diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml
index ba3676145..0809c0500 100644
--- a/tactics/autorewrite.ml
+++ b/tactics/autorewrite.ml
@@ -23,6 +23,7 @@ open Locus
 type rew_rule = { rew_lemma: constr;
 		  rew_type: types;
 		  rew_pat: constr;
+		  rew_ctx: Univ.universe_context_set;
 		  rew_l2r: bool;
 		  rew_tac: glob_tactic_expr option }
 
@@ -85,18 +86,26 @@ let print_rewrite_hintdb bas =
 	       Pptactic.pr_glob_tactic (Global.env()) tac) (mt ()) h.rew_tac)
 	   (find_rewrites bas))
 
-type raw_rew_rule = Loc.t * constr * bool * raw_tactic_expr option
+type raw_rew_rule = Loc.t * constr Univ.in_universe_context_set * bool * raw_tactic_expr option
 
 (* Applies all the rules of one base *)
 let one_base general_rewrite_maybe_in tac_main bas =
   let lrul = find_rewrites bas in
+  let try_rewrite dir ctx c tc = Proofview.Goal.enter (fun gl ->
+    let subst, ctx' = Universes.fresh_universe_context_set_instance ctx in
+    let c' = Vars.subst_univs_level_constr subst c in
+    let sigma = Proofview.Goal.sigma gl in
+    let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx' in
+    Tacticals.New.tclTHEN (Proofview.V82.tclEVARS sigma)
+      (general_rewrite_maybe_in dir c' tc)
+  ) in
   let lrul = List.map (fun h -> 
   let tac = match h.rew_tac with None -> Proofview.tclUNIT () | Some t -> Tacinterp.eval_tactic t in
-    (h.rew_lemma,h.rew_l2r,tac)) lrul in
-    Tacticals.New.tclREPEAT_MAIN (Proofview.tclPROGRESS (List.fold_left (fun tac (csr,dir,tc) ->
+    (h.rew_ctx,h.rew_lemma,h.rew_l2r,tac)) lrul in
+    Tacticals.New.tclREPEAT_MAIN (Proofview.tclPROGRESS (List.fold_left (fun tac (ctx,csr,dir,tc) ->
       Tacticals.New.tclTHEN tac
         (Tacticals.New.tclREPEAT_MAIN
-	    (Tacticals.New.tclTHENFIRST (general_rewrite_maybe_in dir csr tc) tac_main)))
+	    (Tacticals.New.tclTHENFIRST (try_rewrite dir ctx csr tc) tac_main)))
       (Proofview.tclUNIT()) lrul))
 
 (* The AutoRewrite tactic *)
@@ -284,11 +293,11 @@ let add_rew_rules base lrul =
   let counter = ref 0 in
   let lrul =
     List.fold_left
-      (fun dn (loc,c,b,t) ->
+      (fun dn (loc,(c,ctx),b,t) ->
 	let info = find_applied_relation false loc (Global.env ()) Evd.empty c b in
 	let pat = if b then info.hyp_left else info.hyp_right in
 	let rul = { rew_lemma = c; rew_type = info.hyp_ty;
-		    rew_pat = pat; rew_l2r = b;
+		    rew_pat = pat; rew_ctx = ctx; rew_l2r = b;
 		    rew_tac = Option.map Tacintern.glob_tactic t}
 	in incr counter;
 	  HintDN.add pat (!counter, rul) dn) HintDN.empty lrul
diff --git a/tactics/autorewrite.mli b/tactics/autorewrite.mli
index 198fa36f5..046291135 100644
--- a/tactics/autorewrite.mli
+++ b/tactics/autorewrite.mli
@@ -11,7 +11,7 @@ open Tacexpr
 open Equality
 
 (** Rewriting rules before tactic interpretation *)
-type raw_rew_rule = Loc.t * Term.constr * bool * Tacexpr.raw_tactic_expr option
+type raw_rew_rule = Loc.t * Term.constr Univ.in_universe_context_set * bool * Tacexpr.raw_tactic_expr option
 
 (** To add rewriting rules to a base *)
 val add_rew_rules : string -> raw_rew_rule list -> unit
@@ -27,6 +27,7 @@ val autorewrite_in : ?conds:conditions -> Names.Id.t -> unit Proofview.tactic ->
 type rew_rule = { rew_lemma: constr;
 		  rew_type: types;
 		  rew_pat: constr;
+		  rew_ctx: Univ.universe_context_set;
 		  rew_l2r: bool;
 		  rew_tac: glob_tactic_expr option }
 
diff --git a/tactics/btermdn.ml b/tactics/btermdn.ml
index 9492ae1a0..df8e98604 100644
--- a/tactics/btermdn.ml
+++ b/tactics/btermdn.ml
@@ -48,8 +48,8 @@ let decomp =
 let constr_val_discr t =
   let c, l = decomp t in
     match kind_of_term c with
-    | Ind ind_sp -> Label(GRLabel (IndRef ind_sp),l)
-    | Construct cstr_sp -> Label(GRLabel (ConstructRef cstr_sp),l)
+    | Ind (ind_sp,u) -> Label(GRLabel (IndRef ind_sp),l)
+    | Construct (cstr_sp,u) -> Label(GRLabel (ConstructRef cstr_sp),l)
     | Var id -> Label(GRLabel (VarRef id),l)
     | Const _ -> Everything
     | _ -> Nothing
@@ -67,9 +67,9 @@ let constr_pat_discr t =
 let constr_val_discr_st (idpred,cpred) t =
   let c, l = decomp t in
     match kind_of_term c with
-    | Const c -> if Cpred.mem c cpred then Everything else Label(GRLabel (ConstRef c),l)
-    | Ind ind_sp -> Label(GRLabel (IndRef ind_sp),l)
-    | Construct cstr_sp -> Label(GRLabel (ConstructRef cstr_sp),l)
+    | Const (c,u) -> if Cpred.mem c cpred then Everything else Label(GRLabel (ConstRef c),l)
+    | Ind (ind_sp,u) -> Label(GRLabel (IndRef ind_sp),l)
+    | Construct (cstr_sp,u) -> Label(GRLabel (ConstructRef cstr_sp),l)
     | Var id when not (Id.Pred.mem id idpred) -> Label(GRLabel (VarRef id),l)
     | Prod (n, d, c) -> Label(ProdLabel, [d; c])
     | Lambda (n, d, c) -> Label(LambdaLabel, [d; c] @ l)
@@ -141,6 +141,77 @@ struct
 
   let create = Dn.create
 
+(* FIXME: MS: remove *)
+(*   let decomp = 
+    let rec decrec acc c = match kind_of_term c with
+      | App (f,l) -> decrec (Array.fold_right (fun a l -> a::l) l acc) f
+      | Proj (p,c) -> decrec (c :: acc) (mkConst p)
+      | Cast (c1,_,_) -> decrec acc c1
+      | _ -> (c,acc)
+    in 
+      decrec []
+
+  let constr_val_discr t =
+    let c, l = decomp t in
+      match kind_of_term c with
+      | Ind (ind_sp,_) -> Dn.Label(Term_dn.GRLabel (IndRef ind_sp),l)
+      | Construct (cstr_sp,_) -> Dn.Label(Term_dn.GRLabel (ConstructRef cstr_sp),l)
+      | Var id -> Dn.Label(Term_dn.GRLabel (VarRef id),l)
+      | Const _ -> Dn.Everything
+      | Proj (p, c) -> Dn.Everything
+      | _ -> Dn.Nothing
+	
+  let constr_val_discr_st (idpred,cpred) t =
+    let c, l = decomp t in
+      match kind_of_term c with
+      | Const (c,_) -> if Cpred.mem c cpred then Dn.Everything else Dn.Label(Term_dn.GRLabel (ConstRef c),l)
+      | Ind (ind_sp,_) -> Dn.Label(Term_dn.GRLabel (IndRef ind_sp),l)
+      | Construct (cstr_sp,_) -> Dn.Label(Term_dn.GRLabel (ConstructRef cstr_sp),l)
+      | Proj (p,c) ->
+        if Cpred.mem p cpred then Dn.Everything else Dn.Label(Term_dn.GRLabel (ConstRef p), c::l)
+      | Var id when not (Id.Pred.mem id idpred) -> Dn.Label(Term_dn.GRLabel (VarRef id),l)
+      | Prod (n, d, c) -> Dn.Label(Term_dn.ProdLabel, [d; c])
+      | Lambda (n, d, c) -> Dn.Label(Term_dn.LambdaLabel, [d; c] @ l)
+      | Sort _ -> Dn.Label(Term_dn.SortLabel, [])
+      | Evar _ -> Dn.Everything
+      | _ -> Dn.Nothing
+
+  let bounded_constr_pat_discr_st st (t,depth) =
+    if Int.equal depth 0 then 
+      None 
+    else
+      match Term_dn.constr_pat_discr_st st t with
+	| None -> None
+	| Some (c,l) -> Some(c,List.map (fun c -> (c,depth-1)) l)
+	    
+  let bounded_constr_val_discr_st st (t,depth) =
+    if Int.equal depth 0 then 
+      Dn.Nothing 
+    else
+      match constr_val_discr_st st t with
+	| Dn.Label (c,l) -> Dn.Label(c,List.map (fun c -> (c,depth-1)) l)
+	| Dn.Nothing -> Dn.Nothing
+	| Dn.Everything -> Dn.Everything
+
+  let bounded_constr_pat_discr (t,depth) =
+    if Int.equal depth 0 then 
+      None 
+    else
+      match Term_dn.constr_pat_discr t with
+	| None -> None
+	| Some (c,l) -> Some(c,List.map (fun c -> (c,depth-1)) l)
+	    
+  let bounded_constr_val_discr (t,depth) =
+    if Int.equal depth 0 then 
+      Dn.Nothing 
+    else
+      match constr_val_discr t with
+	| Dn.Label (c,l) -> Dn.Label(c,List.map (fun c -> (c,depth-1)) l)
+	| Dn.Nothing -> Dn.Nothing
+	| Dn.Everything -> Dn.Everything
+	    
+*)	    
+
   let add = function
     | None ->
 	(fun dn (c,v) ->
diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml
index 6d7c797af..02e671a5c 100644
--- a/tactics/class_tactics.ml
+++ b/tactics/class_tactics.ml
@@ -50,7 +50,7 @@ let evars_to_goals p evm =
 
 open Auto
 
-let e_give_exact flags c gl =
+let e_give_exact flags (c,cl) gl =
   let t1 = (pf_type_of gl c) in
     tclTHEN (Clenvtac.unify ~flags t1) (exact_no_check c) gl
 
@@ -91,15 +91,17 @@ let progress_evars t =
     in t <*> check
   end
 
-let unify_e_resolve flags (c,clenv) gls =
-  let clenv' = connect_clenv gls clenv in
+let unify_e_resolve poly flags (c,clenv) gls =
+  let clenv' = if poly then fst (Clenv.refresh_undefined_univs clenv) else clenv in
+  let clenv' = connect_clenv gls clenv' in
   let clenv' = clenv_unique_resolver ~flags clenv' gls in
     Clenvtac.clenv_refine true ~with_classes:false clenv' gls
 
-let unify_resolve flags (c,clenv) gls =
-  let clenv' = connect_clenv gls clenv in
+let unify_resolve poly flags (c,clenv) gls =
+  let clenv' = if poly then fst (Clenv.refresh_undefined_univs clenv) else clenv in
+  let clenv' = connect_clenv gls clenv' in
   let clenv' = clenv_unique_resolver ~flags clenv' gls in
-    Clenvtac.clenv_refine false ~with_classes:false clenv' gls
+    Clenvtac.clenv_refine false(*uhoh, was true*) ~with_classes:false clenv' gls
 
 let clenv_of_prods nprods (c, clenv) gls =
   if Int.equal nprods 0 then Some clenv
@@ -107,6 +109,7 @@ let clenv_of_prods nprods (c, clenv) gls =
     let ty = pf_type_of gls c in
     let diff = nb_prod ty - nprods in
       if Pervasives.(>=) diff 0 then
+        (* Was Some clenv... *)
 	Some (mk_clenv_from_n gls (Some diff) (c,ty))
       else None
 
@@ -152,14 +155,14 @@ and e_my_find_search db_list local_db hdc complete concl =
       (local_db::db_list)
   in
   let tac_of_hint =
-    fun (flags, {pri = b; pat = p; code = t; name = name}) ->
+    fun (flags, {pri = b; pat = p; poly = poly; code = t; name = name}) ->
       let tac =
 	match t with
-	  | Res_pf (term,cl) -> with_prods nprods (term,cl) (unify_resolve flags)
-	  | ERes_pf (term,cl) -> with_prods nprods (term,cl) (unify_e_resolve flags)
-	  | Give_exact (c) -> e_give_exact flags c
+	  | Res_pf (term,cl) -> with_prods nprods (term,cl) (unify_resolve poly flags)
+	  | ERes_pf (term,cl) -> with_prods nprods (term,cl) (unify_e_resolve poly flags)
+	  | Give_exact c -> e_give_exact flags c
 	  | Res_pf_THEN_trivial_fail (term,cl) ->
-              tclTHEN (with_prods nprods (term,cl) (unify_e_resolve flags))
+              tclTHEN (with_prods nprods (term,cl) (unify_e_resolve poly flags))
 	        (if complete then tclIDTAC else e_trivial_fail_db db_list local_db)
 	  | Unfold_nth c -> tclWEAK_PROGRESS (unfold_in_concl [AllOccurrences,c])
 	  | Extern tacast ->
@@ -178,13 +181,13 @@ and e_my_find_search db_list local_db hdc complete concl =
 and e_trivial_resolve db_list local_db gl =
   try
     e_my_find_search db_list local_db
-    (fst (head_constr_bound gl)) true gl
+    (head_constr_bound gl) true gl
   with Bound | Not_found -> []
 
 let e_possible_resolve db_list local_db gl =
   try
     e_my_find_search db_list local_db
-      (fst (head_constr_bound gl)) false gl
+      (head_constr_bound gl) false gl
   with Bound | Not_found -> []
 
 let catchable = function
@@ -223,8 +226,8 @@ let make_resolve_hyp env sigma st flags only_classes pri (id, _, cty) =
   let rec iscl env ty =
     let ctx, ar = decompose_prod_assum ty in
       match kind_of_term (fst (decompose_app ar)) with
-      | Const c -> is_class (ConstRef c)
-      | Ind i -> is_class (IndRef i)
+      | Const (c,_) -> is_class (ConstRef c)
+      | Ind (i,_) -> is_class (IndRef i)
       | _ ->
 	  let env' = Environ.push_rel_context ctx env in
 	  let ty' = whd_betadeltaiota env' ar in
@@ -241,13 +244,16 @@ let make_resolve_hyp env sigma st flags only_classes pri (id, _, cty) =
 	  let hints = build_subclasses ~check:false env sigma (VarRef id) None in
 	    (List.map_append
 	       (fun (path,pri, c) -> make_resolves env sigma ~name:(PathHints path)
-		  (true,false,Flags.is_verbose()) pri c)
+		  (true,false,Flags.is_verbose()) pri false
+		 (IsConstr (c,Univ.ContextSet.empty)))
 	       hints)
 	else []
       in
         (hints @ List.map_filter
-	 (fun f -> try Some (f (c, cty)) with Failure _ | UserError _ -> None)
-	 [make_exact_entry ~name sigma pri; make_apply_entry ~name env sigma flags pri])
+	 (fun f -> try Some (f (c, cty, Univ.ContextSet.empty)) 
+	   with Failure _ | UserError _ -> None)
+	 [make_exact_entry ~name env sigma pri false; 
+	  make_apply_entry ~name env sigma flags pri false])
     else []
 
 let pf_filtered_hyps gls =
@@ -266,21 +272,19 @@ let make_hints g st only_classes sign =
     (PathEmpty, []) sign
   in Hint_db.add_list hintlist (Hint_db.empty st true)
 
-let autogoal_hints_cache
-    : (bool * Environ.named_context_val * hint_db) option ref
-    = Summary.ref None ~name:"autogoal-hints-cache"
-let freeze () = !autogoal_hints_cache
-let unfreeze v = autogoal_hints_cache := v
-
 let make_autogoal_hints =
-  fun only_classes ?(st=full_transparent_state) g ->
-    let sign = pf_filtered_hyps g in
-      match freeze () with
-      | Some (onlyc, sign', hints)
-	  when (onlyc : bool) == only_classes &&
-	    Environ.eq_named_context_val sign sign' -> hints
-      | _ -> let hints = make_hints g st only_classes (Environ.named_context_of_val sign) in
-	  unfreeze (Some (only_classes, sign, hints)); hints
+  let cache = ref (true, Environ.empty_named_context_val, 
+		   Hint_db.empty full_transparent_state true) 
+  in
+    fun only_classes ?(st=full_transparent_state) g ->
+      let sign = pf_filtered_hyps g in
+      let (onlyc, sign', cached_hints) = !cache in
+	if onlyc == only_classes && 
+	  (sign == sign' || Environ.eq_named_context_val sign sign') then
+	  cached_hints
+	else
+	  let hints = make_hints g st only_classes (Environ.named_context_of_val sign) in
+	    cache := (only_classes, sign, hints); hints
 
 let lift_tactic tac (f : goal list sigma -> autoinfo -> autogoal list sigma) : 'a tac =
   { skft = fun sk fk {it = gl,hints; sigma=s;} ->
@@ -467,7 +471,8 @@ let run_on_evars ?(only_classes=true) ?(st=full_transparent_state) p evm hints t
       let res = run_list_tac tac p goals (make_autogoals ~only_classes ~st hints goals evm') in
 	match get_result res with
 	| None -> raise Not_found
-	| Some (evm', fk) -> Some (evars_reset_evd ~with_conv_pbs:true evm' evm, fk)
+	| Some (evm', fk) -> 
+	  Some (evars_reset_evd ~with_conv_pbs:true ~with_univs:false evm' evm, fk)
 
 let eauto_tac hints =
   then_tac normevars_tac (or_tac (hints_tac hints) intro_tac)
@@ -743,4 +748,4 @@ let autoapply c i gl =
   let flags = flags_of_state (Auto.Hint_db.transparent_state (Auto.searchtable_map i)) in
   let cty = pf_type_of gl c in
   let ce = mk_clenv_from gl (c,cty) in
-  unify_e_resolve flags (c,ce) gl
+  unify_e_resolve false flags (c,ce) gl
diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml
index f245247a9..faeb9fc25 100644
--- a/tactics/contradiction.ml
+++ b/tactics/contradiction.ml
@@ -34,6 +34,7 @@ let absurd c gls =
                    exact_no_check (mkApp(mkVar idna,[|mkVar ida|])) gl)));
             tclIDTAC]));
        tclIDTAC])) { gls with Evd.sigma; }
+
 let absurd c = Proofview.V82.tactic (absurd c)
 
 (* Contradiction *)
diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4
index 0ab426cd2..328d45991 100644
--- a/tactics/eauto.ml4
+++ b/tactics/eauto.ml4
@@ -32,7 +32,7 @@ let eauto_unif_flags = { auto_unif_flags with Unification.modulo_delta = full_tr
 
 let e_give_exact ?(flags=eauto_unif_flags) c gl = let t1 = (pf_type_of gl c) and t2 = pf_concl gl in
   if occur_existential t1 || occur_existential t2 then
-     tclTHEN (Clenvtac.unify ~flags t1) (exact_check c) gl
+     tclTHEN (Clenvtac.unify ~flags t1) (exact_no_check c) gl
   else exact_check c gl
 
 let assumption id = e_give_exact (mkVar id)
@@ -86,8 +86,12 @@ let rec prolog l n gl =
   let prol = (prolog l (n-1)) in
   (tclFIRST (List.map (fun t -> (tclTHEN t prol)) (one_step l gl))) gl
 
+let out_term = function
+  | IsConstr (c, _) -> c
+  | IsGlobRef gr -> fst (Universes.fresh_global_instance (Global.env ()) gr)
+
 let prolog_tac l n gl =
-  let l = List.map (prepare_hint (pf_env gl)) l in
+  let l = List.map (fun x -> out_term (pf_apply (prepare_hint false) gl x)) l in
   let n =
     match n with
       | ArgArg n -> n
@@ -110,11 +114,19 @@ open Unification
 
 let priority l = List.map snd (List.filter (fun (pr,_) -> Int.equal pr 0) l)
 
-let unify_e_resolve flags (c,clenv) gls =
-  let clenv' = connect_clenv gls clenv in
+let unify_e_resolve poly flags (c,clenv) gls =
+  let clenv', subst = if poly then Clenv.refresh_undefined_univs clenv 
+  else clenv, Univ.empty_level_subst in
+  let clenv' = connect_clenv gls clenv' in
   let _ = clenv_unique_resolver ~flags clenv' gls in
-  Tactics.Simple.eapply c gls
-
+  Tactics.Simple.eapply (Vars.subst_univs_level_constr subst c) gls
+
+let e_exact poly flags (c,clenv) =
+  let clenv', subst = 
+    if poly then Clenv.refresh_undefined_univs clenv 
+    else clenv, Univ.empty_level_subst
+  in e_give_exact ~flags (Vars.subst_univs_level_constr subst c)
+    
 let rec e_trivial_fail_db db_list local_db goal =
   let tacl =
     registered_e_assumption ::
@@ -141,15 +153,15 @@ and e_my_find_search db_list local_db hdc concl =
 	  List.map (fun x -> flags, x) (Hint_db.map_auto (hdc,concl) db)) (local_db::db_list)
   in
   let tac_of_hint =
-    fun (st, {pri=b; pat = p; code=t}) ->
+    fun (st, {pri = b; pat = p; code = t; poly = poly}) ->
       (b,
        let tac =
 	 match t with
-	   | Res_pf (term,cl) -> unify_resolve st (term,cl)
-	   | ERes_pf (term,cl) -> unify_e_resolve st (term,cl)
-	   | Give_exact (c) -> e_give_exact c
+	   | Res_pf (term,cl) -> unify_resolve poly st (term,cl)
+	   | ERes_pf (term,cl) -> unify_e_resolve poly st (term,cl)
+	   | Give_exact (c,cl) -> e_exact poly st (c,cl)
 	   | Res_pf_THEN_trivial_fail (term,cl) ->
-               tclTHEN (unify_e_resolve st (term,cl))
+               tclTHEN (unify_e_resolve poly st (term,cl))
 		 (e_trivial_fail_db db_list local_db)
 	   | Unfold_nth c -> reduce (Unfold [AllOccurrences,c]) onConcl
 	   | Extern tacast -> Proofview.V82.of_tactic (conclPattern concl p tacast)
@@ -162,13 +174,13 @@ and e_trivial_resolve db_list local_db gl =
   try
     priority
       (e_my_find_search db_list local_db
-	 (fst (head_constr_bound gl)) gl)
+	 (head_constr_bound gl) gl)
   with Bound | Not_found -> []
 
 let e_possible_resolve db_list local_db gl =
   try List.map snd
     (e_my_find_search db_list local_db
-	(fst (head_constr_bound gl)) gl)
+	(head_constr_bound gl) gl)
   with Bound | Not_found -> []
 
 let find_first_goal gls =
@@ -363,6 +375,9 @@ let e_search_auto debug (in_depth,p) lems db_list gl =
     pr_info_nop d;
     error "eauto: search failed"
 
+(* let e_search_auto_key = Profile.declare_profile "e_search_auto" *)
+(* let e_search_auto = Profile.profile5 e_search_auto_key e_search_auto *)
+
 let eauto_with_bases ?(debug=Off) np lems db_list =
   tclTRY (e_search_auto debug np lems db_list)
 
@@ -494,8 +509,8 @@ let unfold_head env (ids, csts) c =
 	(match Environ.named_body id env with
 	| Some b -> true, b
 	| None -> false, c)
-    | Const cst when Cset.mem cst csts ->
-	true, Environ.constant_value env cst
+    | Const (cst,u as c) when Cset.mem cst csts ->
+	true, Environ.constant_value_in env c
     | App (f, args) ->
 	(match aux f with
 	| true, f' -> true, Reductionops.whd_betaiota Evd.empty (mkApp (f', args))
@@ -558,7 +573,7 @@ TACTIC EXTEND autounfoldify
 | [ "autounfoldify" constr(x) ] -> [
   Proofview.V82.tactic (
     let db = match kind_of_term x with
-      | Const c -> Label.to_string (con_label c)
+      | Const (c,_) -> Label.to_string (con_label c)
       | _ -> assert false
     in autounfold ["core";db] onConcl 
   )]
diff --git a/tactics/elim.ml b/tactics/elim.ml
index 0720273bb..2a7b3bff1 100644
--- a/tactics/elim.ml
+++ b/tactics/elim.ml
@@ -104,12 +104,12 @@ let head_in indl t gl =
       if !up_to_delta
       then find_mrectype env sigma t
       else extract_mrectype t
-    in List.exists (fun i -> eq_ind i ity) indl
+    in List.exists (fun i -> eq_ind (fst i) (fst ity)) indl
   with Not_found -> false
 
 let decompose_these c l =
   Proofview.Goal.raw_enter begin fun gl ->
-  let indl = (*List.map inductive_of*) l in
+  let indl = List.map (fun x -> x, Univ.Instance.empty) l in
   general_decompose (fun (_,t) -> head_in indl t gl) c
   end
 
diff --git a/tactics/elimschemes.ml b/tactics/elimschemes.ml
index 9c020930c..617475bb7 100644
--- a/tactics/elimschemes.ml
+++ b/tactics/elimschemes.ml
@@ -23,13 +23,16 @@ open Ind_tables
 (* Induction/recursion schemes *)
 
 let optimize_non_type_induction_scheme kind dep sort ind =
+  let env = Global.env () in
+  let sigma = Evd.from_env env in
   if check_scheme kind ind then
     (* in case the inductive has a type elimination, generates only one
        induction scheme, the other ones share the same code with the
        apropriate type *)
     let cte, eff = find_scheme kind ind in
-    let c = mkConst cte in
-    let t = type_of_constant (Global.env()) cte in
+    let sigma, cte = Evd.fresh_constant_instance env sigma cte in
+    let c = mkConstU cte in
+    let t = type_of_constant_in (Global.env()) cte in
     let (mib,mip) = Global.lookup_inductive ind in
     let npars =
       (* if a constructor of [ind] contains a recursive call, the scheme
@@ -39,13 +42,29 @@ let optimize_non_type_induction_scheme kind dep sort ind =
 	mib.mind_nparams_rec
       else
 	mib.mind_nparams in
-    snd (weaken_sort_scheme (new_sort_in_family sort) npars c t), eff
+    let sigma, sort = Evd.fresh_sort_in_family env sigma sort in
+    let sigma, t', c' = weaken_sort_scheme env sigma false sort npars c t in
+    let sigma, nf = Evarutil.nf_evars_and_universes sigma in
+      (nf c', Evd.evar_universe_context sigma), eff
   else
-    build_induction_scheme (Global.env()) Evd.empty ind dep sort, Declareops.no_seff
+    let mib,mip = Inductive.lookup_mind_specif env ind in
+    let ctx = if mib.mind_polymorphic then mib.mind_universes else Univ.UContext.empty in
+    let u = Univ.UContext.instance ctx in
+    let ctxset = Univ.ContextSet.of_context ctx in
+    let sigma, c = build_induction_scheme env (Evd.from_env ~ctx:ctxset env) (ind,u) dep sort in
+      (c, Evd.evar_universe_context sigma), Declareops.no_seff
 
 let build_induction_scheme_in_type dep sort ind =
-  build_induction_scheme (Global.env()) Evd.empty ind dep sort
-
+  let env = Global.env () in
+  let ctx = 
+    let mib,mip = Inductive.lookup_mind_specif env ind in
+      Inductive.inductive_context mib
+  in
+  let u = Univ.UContext.instance ctx in
+  let ctxset = Univ.ContextSet.of_context ctx in
+  let sigma, c = build_induction_scheme env (Evd.from_env ~ctx:ctxset env) (ind,u) dep sort in
+    c, Evd.evar_universe_context sigma
+ 
 let rect_scheme_kind_from_type =
   declare_individual_scheme_object "_rect_nodep"
     (fun x -> build_induction_scheme_in_type false InType x, Declareops.no_seff)
@@ -81,7 +100,11 @@ let rec_dep_scheme_kind_from_type =
 (* Case analysis *)
 
 let build_case_analysis_scheme_in_type dep sort ind =
-  build_case_analysis_scheme (Global.env()) Evd.empty ind dep sort
+  let env = Global.env () in
+  let sigma = Evd.from_env env in
+  let sigma, indu = Evd.fresh_inductive_instance env sigma ind in
+  let sigma, c = build_case_analysis_scheme env sigma indu dep sort in 
+    c, Evd.evar_universe_context sigma
 
 let case_scheme_kind_from_type =
   declare_individual_scheme_object "_case_nodep"
diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml
index 23c4c0b2d..7909b669b 100644
--- a/tactics/eqdecide.ml
+++ b/tactics/eqdecide.ml
@@ -80,8 +80,13 @@ let solveNoteqBranch side =
 
 (* Constructs the type {c1=c2}+{~c1=c2} *)
 
+let make_eq () =
+(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq ())
+let make_eq_refl () =
+(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq_refl ())
+
 let mkDecideEqGoal eqonleft op rectype c1 c2 =
-  let equality    = mkApp(build_coq_eq(), [|rectype; c1; c2|]) in
+  let equality    = mkApp(make_eq(), [|rectype; c1; c2|]) in
   let disequality = mkApp(build_coq_not (), [|equality|]) in
   if eqonleft then mkApp(op, [|equality; disequality |])
   else mkApp(op, [|disequality; equality |])
@@ -173,7 +178,7 @@ let decideGralEquality =
         match_eqdec concl >>= fun (eqonleft,_,c1,c2,typ) ->
         let headtyp = hd_app (pf_compute gl typ) in
         begin match kind_of_term headtyp with
-        | Ind mi -> Proofview.tclUNIT mi
+        | Ind (mi,_) -> Proofview.tclUNIT mi
         | _ -> tclZEROMSG (Pp.str"This decision procedure only works for inductive objects.")
         end >>= fun rectype ->
           (tclTHEN
diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml
index 7aac37d1b..08c887b77 100644
--- a/tactics/eqschemes.ml
+++ b/tactics/eqschemes.ml
@@ -63,11 +63,13 @@ let hid = Id.of_string "H"
 let xid = Id.of_string "X"
 let default_id_of_sort = function InProp | InSet -> hid | InType -> xid
 let fresh env id = next_global_ident_away id []
+let with_context_set ctx (b, ctx') = 
+  (b, Univ.ContextSet.union ctx ctx')
 
 let build_dependent_inductive ind (mib,mip) =
   let realargs,_ = List.chop mip.mind_nrealargs_ctxt mip.mind_arity_ctxt in
   applist
-    (mkInd ind,
+    (mkIndU ind,
        extended_rel_list mip.mind_nrealargs_ctxt mib.mind_params_ctxt
        @ extended_rel_list 0 realargs)
 
@@ -76,12 +78,13 @@ let my_it_mkProd_or_LetIn s c = it_mkProd_or_LetIn c s
 let my_it_mkLambda_or_LetIn_name s c =
   it_mkLambda_or_LetIn_name (Global.env()) c s
 
-let get_coq_eq () =
+let get_coq_eq ctx =
   try
     let eq = Globnames.destIndRef Coqlib.glob_eq in
-    let _ = Global.lookup_inductive eq in
     (* Do not force the lazy if they are not defined *)
-    mkInd eq, Coqlib.build_coq_eq_refl ()
+    let eq, ctx = with_context_set ctx 
+      (Universes.fresh_inductive_instance (Global.env ()) eq) in
+      mkIndU eq, mkConstructUi (eq,1), ctx
   with Not_found ->
     error "eq not found."
 
@@ -94,12 +97,14 @@ let get_coq_eq () =
 (* in which case, a symmetry lemma is definable                       *)
 (**********************************************************************)
 
-let get_sym_eq_data env ind =
+let get_sym_eq_data env (ind,u) =
   let (mib,mip as specif) = lookup_mind_specif env ind in
   if not (Int.equal (Array.length mib.mind_packets) 1) ||
     not (Int.equal (Array.length mip.mind_nf_lc) 1) then
     error "Not an inductive type with a single constructor.";
-  let realsign,_ = List.chop mip.mind_nrealargs_ctxt mip.mind_arity_ctxt in
+  let subst = Inductive.make_inductive_subst mib u in
+  let arityctxt = Vars.subst_univs_context subst mip.mind_arity_ctxt in
+  let realsign,_ = List.chop mip.mind_nrealargs_ctxt arityctxt in
   if List.exists (fun (_,b,_) -> not (Option.is_empty b)) realsign then
     error "Inductive equalities with local definitions in arity not supported.";
   let constrsign,ccl = decompose_prod_assum mip.mind_nf_lc.(0) in
@@ -110,12 +115,13 @@ let get_sym_eq_data env ind =
   if mip.mind_nrealargs > mib.mind_nparams then
     error "Constructors arguments must repeat the parameters.";
   let _,params2 = List.chop (mib.mind_nparams-mip.mind_nrealargs) params in
+  let paramsctxt = Vars.subst_univs_context subst mib.mind_params_ctxt in
   let paramsctxt1,_ =
-    List.chop (mib.mind_nparams-mip.mind_nrealargs) mib.mind_params_ctxt in
+    List.chop (mib.mind_nparams-mip.mind_nrealargs) paramsctxt in
   if not (List.equal eq_constr params2 constrargs) then
     error "Constructors arguments must repeat the parameters.";
   (* nrealargs_ctxt and nrealargs are the same here *)
-  (specif,mip.mind_nrealargs,realsign,mib.mind_params_ctxt,paramsctxt1)
+  (specif,mip.mind_nrealargs,realsign,paramsctxt,paramsctxt1)
 
 (**********************************************************************)
 (* Check if an inductive type [ind] has the form                      *)
@@ -127,12 +133,14 @@ let get_sym_eq_data env ind =
 (* such that symmetry is a priori definable                           *)
 (**********************************************************************)
 
-let get_non_sym_eq_data env ind =
+let get_non_sym_eq_data env (ind,u) =
   let (mib,mip as specif) = lookup_mind_specif env ind in
   if not (Int.equal (Array.length mib.mind_packets) 1) ||
     not (Int.equal (Array.length mip.mind_nf_lc) 1) then
     error "Not an inductive type with a single constructor.";
-  let realsign,_ = List.chop mip.mind_nrealargs_ctxt mip.mind_arity_ctxt in
+  let subst = Inductive.make_inductive_subst mib u in
+  let arityctxt = Vars.subst_univs_context subst mip.mind_arity_ctxt in
+  let realsign,_ = List.chop mip.mind_nrealargs_ctxt arityctxt in
   if List.exists (fun (_,b,_) -> not (Option.is_empty b)) realsign then
     error "Inductive equalities with local definitions in arity not supported";
   let constrsign,ccl = decompose_prod_assum mip.mind_nf_lc.(0) in
@@ -140,7 +148,9 @@ let get_non_sym_eq_data env ind =
   if not (Int.equal (rel_context_length constrsign) (rel_context_length mib.mind_params_ctxt)) then
     error "Constructor must have no arguments";
   let _,constrargs = List.chop mib.mind_nparams constrargs in
-  (specif,constrargs,realsign,mip.mind_nrealargs)
+  let constrargs = List.map (Vars.subst_univs_constr subst) constrargs in
+  let paramsctxt = Vars.subst_univs_context subst mib.mind_params_ctxt in
+  (specif,constrargs,realsign,paramsctxt,mip.mind_nrealargs)
 
 (**********************************************************************)
 (* Build the symmetry lemma associated to an inductive type           *)
@@ -157,30 +167,35 @@ let get_non_sym_eq_data env ind =
 (**********************************************************************)
 
 let build_sym_scheme env ind =
+  let (ind,u as indu), ctx = Universes.fresh_inductive_instance env ind in
   let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 =
-    get_sym_eq_data env ind in
+    get_sym_eq_data env indu in
   let cstr n =
-    mkApp (mkConstruct(ind,1),extended_rel_vect n mib.mind_params_ctxt) in
+    mkApp (mkConstructUi(indu,1),extended_rel_vect n mib.mind_params_ctxt) in
   let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in
-  let applied_ind = build_dependent_inductive ind specif in
+  let applied_ind = build_dependent_inductive indu specif in
   let realsign_ind =
     name_context env ((Name varH,None,applied_ind)::realsign) in
   let ci = make_case_info (Global.env()) ind RegularStyle in
+  let c = 
   (my_it_mkLambda_or_LetIn mib.mind_params_ctxt
   (my_it_mkLambda_or_LetIn_name realsign_ind
   (mkCase (ci,
      my_it_mkLambda_or_LetIn_name
        (lift_rel_context (nrealargs+1) realsign_ind)
-       (mkApp (mkInd ind,Array.concat
+       (mkApp (mkIndU indu,Array.concat
 	  [extended_rel_vect (3*nrealargs+2) paramsctxt1;
 	   rel_vect 1 nrealargs;
 	   rel_vect (2*nrealargs+2) nrealargs])),
      mkRel 1 (* varH *),
        [|cstr (nrealargs+1)|]))))
+  in c, Evd.evar_universe_context_of ctx
 
 let sym_scheme_kind =
   declare_individual_scheme_object "_sym_internal"
-  (fun ind -> build_sym_scheme (Global.env() (* side-effect! *)) ind, Declareops.no_seff)
+  (fun ind -> 
+    let c, ctx = build_sym_scheme (Global.env() (* side-effect! *)) ind in
+      (c, ctx), Declareops.no_seff)
 
 (**********************************************************************)
 (* Build the involutivity of symmetry for an inductive type           *)
@@ -198,51 +213,59 @@ let sym_scheme_kind =
 (*                                                                    *)
 (**********************************************************************)
 
+let const_of_scheme kind env ind ctx = 
+  let sym_scheme, eff = (find_scheme kind ind) in
+  let sym, ctx = with_context_set ctx 
+    (Universes.fresh_constant_instance (Global.env()) sym_scheme) in
+    mkConstU sym, ctx, eff
+
 let build_sym_involutive_scheme env ind =
+  let (ind,u as indu), ctx = Universes.fresh_inductive_instance env ind in
   let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 =
-    get_sym_eq_data env ind in
-  let c, eff = find_scheme sym_scheme_kind ind in
-  let sym = mkConst c in
-  let (eq,eqrefl) = get_coq_eq () in
-  let cstr n = mkApp (mkConstruct(ind,1),extended_rel_vect n paramsctxt) in
+    get_sym_eq_data env indu in
+  let eq,eqrefl,ctx = get_coq_eq ctx in
+  let sym, ctx, eff = const_of_scheme sym_scheme_kind env ind ctx in
+  let cstr n = mkApp (mkConstructUi (indu,1),extended_rel_vect n paramsctxt) in
   let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in
-  let applied_ind = build_dependent_inductive ind specif in
+  let applied_ind = build_dependent_inductive indu specif in
   let applied_ind_C =
     mkApp
-      (mkInd ind, Array.append
+      (mkIndU indu, Array.append
          (extended_rel_vect (nrealargs+1) mib.mind_params_ctxt)
          (rel_vect (nrealargs+1) nrealargs)) in
   let realsign_ind =
     name_context env ((Name varH,None,applied_ind)::realsign) in
   let ci = make_case_info (Global.env()) ind RegularStyle in
-  (my_it_mkLambda_or_LetIn paramsctxt
-  (my_it_mkLambda_or_LetIn_name realsign_ind
-  (mkCase (ci,
-     my_it_mkLambda_or_LetIn_name
-       (lift_rel_context (nrealargs+1) realsign_ind)
-       (mkApp (eq,[|
-	 mkApp
-	   (mkInd ind, Array.concat
-	     [extended_rel_vect (3*nrealargs+2) paramsctxt1;
-	      rel_vect (2*nrealargs+2) nrealargs;
-	      rel_vect 1 nrealargs]);
-         mkApp (sym,Array.concat
-	   [extended_rel_vect (3*nrealargs+2) paramsctxt1;
-            rel_vect 1 nrealargs;
-            rel_vect (2*nrealargs+2) nrealargs;
-            [|mkApp (sym,Array.concat
-	      [extended_rel_vect (3*nrealargs+2) paramsctxt1;
-	       rel_vect (2*nrealargs+2) nrealargs;
-	       rel_vect 1 nrealargs;
-	       [|mkRel 1|]])|]]);
-	 mkRel 1|])),
-     mkRel 1 (* varH *),
-       [|mkApp(eqrefl,[|applied_ind_C;cstr (nrealargs+1)|])|])))),
-  eff
+  let c = 
+    (my_it_mkLambda_or_LetIn paramsctxt
+     (my_it_mkLambda_or_LetIn_name realsign_ind
+      (mkCase (ci,
+	       my_it_mkLambda_or_LetIn_name
+	       (lift_rel_context (nrealargs+1) realsign_ind)
+	       (mkApp (eq,[|
+	       mkApp
+	       (mkIndU indu, Array.concat
+	       [extended_rel_vect (3*nrealargs+2) paramsctxt1;
+		rel_vect (2*nrealargs+2) nrealargs;
+		rel_vect 1 nrealargs]);
+               mkApp (sym,Array.concat
+	       [extended_rel_vect (3*nrealargs+2) paramsctxt1;
+		rel_vect 1 nrealargs;
+		rel_vect (2*nrealargs+2) nrealargs;
+		[|mkApp (sym,Array.concat
+		[extended_rel_vect (3*nrealargs+2) paramsctxt1;
+		 rel_vect (2*nrealargs+2) nrealargs;
+		 rel_vect 1 nrealargs;
+		 [|mkRel 1|]])|]]);
+	       mkRel 1|])),
+	       mkRel 1 (* varH *),
+	       [|mkApp(eqrefl,[|applied_ind_C;cstr (nrealargs+1)|])|]))))
+  in (c, Evd.evar_universe_context_of ctx), eff
 
 let sym_involutive_scheme_kind =
   declare_individual_scheme_object "_sym_involutive"
-  (fun ind -> build_sym_involutive_scheme (Global.env() (* side-effect! *)) ind)
+  (fun ind -> 
+    build_sym_involutive_scheme (Global.env() (* side-effect! *)) ind)
 
 (**********************************************************************)
 (* Build the left-to-right rewriting lemma for conclusion associated  *)
@@ -305,28 +328,27 @@ let sym_involutive_scheme_kind =
 (**********************************************************************)
 
 let build_l2r_rew_scheme dep env ind kind =
+  let (ind,u as indu), ctx = Universes.fresh_inductive_instance env ind in
   let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 =
-    get_sym_eq_data env ind in
-  let c, eff = find_scheme sym_scheme_kind ind in
-  let sym = mkConst c in
-  let c, eff' = find_scheme sym_involutive_scheme_kind ind in
-  let sym_involutive = mkConst c in
-  let (eq,eqrefl) = get_coq_eq () in
+    get_sym_eq_data env indu in
+  let sym, ctx, eff = const_of_scheme sym_scheme_kind env ind ctx in
+  let sym_involutive, ctx, eff' = const_of_scheme sym_involutive_scheme_kind env ind ctx in
+  let eq,eqrefl,ctx = get_coq_eq ctx in
   let cstr n p =
-    mkApp (mkConstruct(ind,1),
+    mkApp (mkConstructUi(indu,1),
       Array.concat [extended_rel_vect n paramsctxt1;
                     rel_vect p nrealargs]) in
   let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in
   let varHC = fresh env (Id.of_string "HC") in
   let varP = fresh env (Id.of_string "P") in
-  let applied_ind = build_dependent_inductive ind specif in
+  let applied_ind = build_dependent_inductive indu specif in
   let applied_ind_P =
-    mkApp (mkInd ind, Array.concat
+    mkApp (mkIndU indu, Array.concat
        [extended_rel_vect (3*nrealargs) paramsctxt1;
         rel_vect 0 nrealargs;
         rel_vect nrealargs nrealargs]) in
   let applied_ind_G =
-    mkApp (mkInd ind, Array.concat
+    mkApp (mkIndU indu, Array.concat
        [extended_rel_vect (3*nrealargs+3) paramsctxt1;
         rel_vect (nrealargs+3) nrealargs;
         rel_vect 0 nrealargs]) in
@@ -345,9 +367,11 @@ let build_l2r_rew_scheme dep env ind kind =
                      rel_vect (nrealargs+4) nrealargs;
                      rel_vect 1 nrealargs;
 		     [|mkRel 1|]]) in
-  let s = mkSort (new_sort_in_family kind) in
+  let s, ctx' = Universes.fresh_sort_in_family (Global.env ()) kind in
+  let ctx = Univ.ContextSet.union ctx ctx' in
+  let s = mkSort s in
   let ci = make_case_info (Global.env()) ind RegularStyle in
-  let cieq = make_case_info (Global.env()) (destInd eq) RegularStyle in
+  let cieq = make_case_info (Global.env()) (fst (destInd eq)) RegularStyle in
   let applied_PC =
     mkApp (mkVar varP,Array.append (extended_rel_vect 1 realsign)
            (if dep then [|cstr (2*nrealargs+1) 1|] else [||])) in
@@ -372,6 +396,7 @@ let build_l2r_rew_scheme dep env ind kind =
       my_it_mkLambda_or_LetIn_name realsign_ind_G applied_PG,
       applied_sym_C 3,
       [|mkVar varHC|]) in
+  let c = 
   (my_it_mkLambda_or_LetIn mib.mind_params_ctxt
   (my_it_mkLambda_or_LetIn_name realsign
   (mkNamedLambda varP
@@ -388,8 +413,8 @@ let build_l2r_rew_scheme dep env ind kind =
          Array.append (extended_rel_vect 3 mip.mind_arity_ctxt) [|mkVar varH|]),
        [|main_body|])
    else
-     main_body)))))),
-  Declareops.union_side_effects eff' eff
+     main_body))))))
+  in (c, Evd.evar_universe_context_of ctx), Declareops.union_side_effects eff' eff
 
 (**********************************************************************)
 (* Build the left-to-right rewriting lemma for hypotheses associated  *)
@@ -418,23 +443,24 @@ let build_l2r_rew_scheme dep env ind kind =
 (**********************************************************************)
 
 let build_l2r_forward_rew_scheme dep env ind kind =
+  let (ind,u as indu), ctx = Universes.fresh_inductive_instance env ind in
   let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 =
-    get_sym_eq_data env ind in
+    get_sym_eq_data env indu in
   let cstr n p =
-    mkApp (mkConstruct(ind,1),
+    mkApp (mkConstructUi(indu,1),
       Array.concat [extended_rel_vect n paramsctxt1;
                     rel_vect p nrealargs]) in
   let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in
   let varHC = fresh env (Id.of_string "HC") in
   let varP = fresh env (Id.of_string "P") in
-  let applied_ind = build_dependent_inductive ind specif in
+  let applied_ind = build_dependent_inductive indu specif in
   let applied_ind_P =
-    mkApp (mkInd ind, Array.concat
+    mkApp (mkIndU indu, Array.concat
        [extended_rel_vect (4*nrealargs+2) paramsctxt1;
         rel_vect 0 nrealargs;
         rel_vect (nrealargs+1) nrealargs]) in
   let applied_ind_P' =
-    mkApp (mkInd ind, Array.concat
+    mkApp (mkIndU indu, Array.concat
        [extended_rel_vect (3*nrealargs+1) paramsctxt1;
         rel_vect 0 nrealargs;
         rel_vect (2*nrealargs+1) nrealargs]) in
@@ -443,7 +469,9 @@ let build_l2r_forward_rew_scheme dep env ind kind =
     name_context env ((Name varH,None,applied_ind)::realsign) in
   let realsign_ind_P n aP =
     name_context env ((Name varH,None,aP)::realsign_P n) in
-  let s = mkSort (new_sort_in_family kind) in
+  let s, ctx' = Universes.fresh_sort_in_family (Global.env ()) kind in
+  let ctx = Univ.ContextSet.union ctx ctx' in
+  let s = mkSort s in
   let ci = make_case_info (Global.env()) ind RegularStyle in
   let applied_PC =
     mkApp (mkVar varP,Array.append
@@ -457,6 +485,7 @@ let build_l2r_forward_rew_scheme dep env ind kind =
   let applied_PG =
     mkApp (mkVar varP,Array.append (rel_vect 3 nrealargs)
            (if dep then [|cstr (3*nrealargs+4) 3|] else [||])) in
+  let c = 
   (my_it_mkLambda_or_LetIn mib.mind_params_ctxt
   (my_it_mkLambda_or_LetIn_name realsign
   (mkNamedLambda varH applied_ind
@@ -473,6 +502,7 @@ let build_l2r_forward_rew_scheme dep env ind kind =
 	  (if dep then realsign_ind_P 1 applied_ind_P' else realsign_P 2) s)
       (mkNamedLambda varHC applied_PC'
 	(mkVar varHC))|])))))
+  in c, Evd.evar_universe_context_of ctx
 
 (**********************************************************************)
 (* Build the right-to-left rewriting lemma for hypotheses associated  *)
@@ -504,19 +534,22 @@ let build_l2r_forward_rew_scheme dep env ind kind =
 (* statement but no need for symmetry of the equality.                *)
 (**********************************************************************)
 
-let build_r2l_forward_rew_scheme dep env ind kind =
-  let ((mib,mip as specif),constrargs,realsign,nrealargs) =
-    get_non_sym_eq_data env ind in
+let build_r2l_forward_rew_scheme dep env ind kind = 
+  let (ind,u as indu), ctx = Universes.fresh_inductive_instance env ind in
+  let ((mib,mip as specif),constrargs,realsign,paramsctxt,nrealargs) =
+    get_non_sym_eq_data env indu in
   let cstr n =
-    mkApp (mkConstruct(ind,1),extended_rel_vect n mib.mind_params_ctxt) in
+    mkApp (mkConstructUi(indu,1),extended_rel_vect n mib.mind_params_ctxt) in
   let constrargs_cstr = constrargs@[cstr 0] in
   let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in
   let varHC = fresh env (Id.of_string "HC") in
   let varP = fresh env (Id.of_string "P") in
-  let applied_ind = build_dependent_inductive ind specif in
+  let applied_ind = build_dependent_inductive indu specif in
   let realsign_ind =
     name_context env ((Name varH,None,applied_ind)::realsign) in
-  let s = mkSort (new_sort_in_family kind) in
+  let s, ctx' = Universes.fresh_sort_in_family (Global.env ()) kind in
+  let ctx = Univ.ContextSet.union ctx ctx' in
+  let s = mkSort s in
   let ci = make_case_info (Global.env()) ind RegularStyle in
   let applied_PC =
     applist (mkVar varP,if dep then constrargs_cstr else constrargs) in
@@ -524,7 +557,8 @@ let build_r2l_forward_rew_scheme dep env ind kind =
     mkApp (mkVar varP,
            if dep then extended_rel_vect 0 realsign_ind
 	   else extended_rel_vect 1 realsign) in
-  (my_it_mkLambda_or_LetIn mib.mind_params_ctxt
+  let c = 
+  (my_it_mkLambda_or_LetIn paramsctxt
   (my_it_mkLambda_or_LetIn_name realsign_ind
   (mkNamedLambda varP
     (my_it_mkProd_or_LetIn (lift_rel_context (nrealargs+1)
@@ -541,6 +575,7 @@ let build_r2l_forward_rew_scheme dep env ind kind =
 	   lift (nrealargs+3) applied_PC,
 	   mkRel 1)|]),
     [|mkVar varHC|]))))))
+  in c, Evd.evar_universe_context_of ctx
 
 (**********************************************************************)
 (* This function "repairs" the non-dependent r2l forward rewriting    *)
@@ -558,11 +593,12 @@ let build_r2l_forward_rew_scheme dep env ind kind =
 (*                                                                    *)
 (**********************************************************************)
 
-let fix_r2l_forward_rew_scheme c =
+let fix_r2l_forward_rew_scheme (c, ctx') =
   let t = Retyping.get_type_of (Global.env()) Evd.empty c in
   let ctx,_ = decompose_prod_assum t in
   match ctx with
   | hp :: p :: ind :: indargs ->
+     let c' = 
       my_it_mkLambda_or_LetIn indargs
 	(mkLambda_or_LetIn (map_rel_declaration (liftn (-1) 1) p)
 	  (mkLambda_or_LetIn (map_rel_declaration (liftn (-1) 2) hp)
@@ -570,6 +606,7 @@ let fix_r2l_forward_rew_scheme c =
 	      (Reductionops.whd_beta Evd.empty
 		(applist (c,
 	          extended_rel_list 3 indargs @ [mkRel 1;mkRel 3;mkRel 2]))))))
+      in c', ctx'
   | _ -> anomaly (Pp.str "Ill-formed non-dependent left-to-right rewriting scheme")
 
 (**********************************************************************)
@@ -592,9 +629,16 @@ let fix_r2l_forward_rew_scheme c =
 (*          (H:I q1..qm a1..an),                                      *)
 (*          P b1..bn C -> P a1..an H                                  *)
 (**********************************************************************)
-
+ 
 let build_r2l_rew_scheme dep env ind k =
-  build_case_analysis_scheme env Evd.empty ind dep k
+  let sigma, indu = Evd.fresh_inductive_instance env (Evd.from_env env) ind in
+  let sigma', c = build_case_analysis_scheme env sigma indu dep k in
+    c, Evd.evar_universe_context sigma'
+
+let build_l2r_rew_scheme = build_l2r_rew_scheme
+let build_l2r_forward_rew_scheme = build_l2r_forward_rew_scheme
+let build_r2l_rew_scheme = build_r2l_rew_scheme
+let build_r2l_forward_rew_scheme = build_r2l_forward_rew_scheme
 
 (**********************************************************************)
 (* Register the rewriting schemes                                     *)
@@ -681,17 +725,22 @@ let rew_r2l_scheme_kind =
 
 (* TODO: extend it to types with more than one index *)
 
-let build_congr env (eq,refl) ind =
+let build_congr env (eq,refl,ctx) ind =
+  let (ind,u as indu), ctx = with_context_set ctx 
+    (Universes.fresh_inductive_instance env ind) in
   let (mib,mip) = lookup_mind_specif env ind in
+  let subst = Inductive.make_inductive_subst mib u in
   if not (Int.equal (Array.length mib.mind_packets) 1) || not (Int.equal (Array.length mip.mind_nf_lc) 1) then
     error "Not an inductive type with a single constructor.";
   if not (Int.equal mip.mind_nrealargs 1) then
     error "Expect an inductive type with one predicate parameter.";
   let i = 1 in
-  let realsign,_ = List.chop mip.mind_nrealargs_ctxt mip.mind_arity_ctxt in
+  let arityctxt = Vars.subst_univs_context subst mip.mind_arity_ctxt in
+  let paramsctxt = Vars.subst_univs_context subst mib.mind_params_ctxt in
+  let realsign,_ = List.chop mip.mind_nrealargs_ctxt arityctxt in
   if List.exists (fun (_,b,_) -> not (Option.is_empty b)) realsign then
     error "Inductive equalities with local definitions in arity not supported.";
-  let env_with_arity = push_rel_context mip.mind_arity_ctxt env in
+  let env_with_arity = push_rel_context arityctxt env in
   let (_,_,ty) = lookup_rel (mip.mind_nrealargs - i + 1) env_with_arity in
   let constrsign,ccl = decompose_prod_assum mip.mind_nf_lc.(0) in
   let _,constrargs = decompose_app ccl in
@@ -702,14 +751,16 @@ let build_congr env (eq,refl) ind =
   let varH = fresh env (Id.of_string "H") in
   let varf = fresh env (Id.of_string "f") in
   let ci = make_case_info (Global.env()) ind RegularStyle in
-  my_it_mkLambda_or_LetIn mib.mind_params_ctxt
-     (mkNamedLambda varB (new_Type ())
+  let uni, ctx = Universes.extend_context (Universes.new_global_univ ()) ctx in
+  let c = 
+  my_it_mkLambda_or_LetIn paramsctxt
+     (mkNamedLambda varB (mkSort (Type uni))
      (mkNamedLambda varf (mkArrow (lift 1 ty) (mkVar varB))
      (my_it_mkLambda_or_LetIn_name (lift_rel_context 2 realsign)
      (mkNamedLambda varH
         (applist
-           (mkInd ind,
-	    extended_rel_list (mip.mind_nrealargs+2) mib.mind_params_ctxt @
+           (mkIndU indu,
+	    extended_rel_list (mip.mind_nrealargs+2) paramsctxt @
 	    extended_rel_list 0 realsign))
      (mkCase (ci,
        my_it_mkLambda_or_LetIn_name
@@ -717,9 +768,9 @@ let build_congr env (eq,refl) ind =
          (mkLambda
            (Anonymous,
             applist
-             (mkInd ind,
+             (mkIndU indu,
 	        extended_rel_list (2*mip.mind_nrealargs_ctxt+3)
-		  mib.mind_params_ctxt
+		  paramsctxt
 	        @ extended_rel_list 0 realsign),
             mkApp (eq,
 	      [|mkVar varB;
@@ -729,8 +780,9 @@ let build_congr env (eq,refl) ind =
        [|mkApp (refl,
           [|mkVar varB;
 	    mkApp (mkVar varf, [|lift (mip.mind_nrealargs+3) b|])|])|]))))))
+  in c, Evd.evar_universe_context_of ctx
 
 let congr_scheme_kind = declare_individual_scheme_object "_congr"
   (fun ind ->
     (* May fail if equality is not defined *)
-          build_congr (Global.env()) (get_coq_eq ()) ind, Declareops.no_seff)
+    build_congr (Global.env()) (get_coq_eq Univ.ContextSet.empty) ind, Declareops.no_seff)
diff --git a/tactics/eqschemes.mli b/tactics/eqschemes.mli
index 72412d12d..f18991d72 100644
--- a/tactics/eqschemes.mli
+++ b/tactics/eqschemes.mli
@@ -22,24 +22,26 @@ val rew_l2r_forward_dep_scheme_kind : individual scheme_kind
 val rew_r2l_dep_scheme_kind : individual scheme_kind
 val rew_r2l_scheme_kind : individual scheme_kind
 
-val build_r2l_rew_scheme : bool -> env -> inductive -> sorts_family -> constr
-val build_l2r_rew_scheme :
-  bool -> env -> inductive -> sorts_family -> constr * Declareops.side_effects
+val build_r2l_rew_scheme : bool -> env -> inductive -> sorts_family -> 
+  constr Evd.in_evar_universe_context
+val build_l2r_rew_scheme : bool -> env -> inductive -> sorts_family -> 
+  constr Evd.in_evar_universe_context * Declareops.side_effects
 val build_r2l_forward_rew_scheme :
-  bool -> env -> inductive -> sorts_family -> constr
+  bool -> env -> inductive -> sorts_family -> constr Evd.in_evar_universe_context
 val build_l2r_forward_rew_scheme :
-  bool -> env -> inductive -> sorts_family -> constr
+  bool -> env -> inductive -> sorts_family -> constr Evd.in_evar_universe_context
 
 (** Builds a symmetry scheme for a symmetrical equality type *)
 
-val build_sym_scheme : env -> inductive -> constr
+val build_sym_scheme : env -> inductive -> constr Evd.in_evar_universe_context
 val sym_scheme_kind : individual scheme_kind
 
-val build_sym_involutive_scheme :
-  env -> inductive -> constr * Declareops.side_effects
+val build_sym_involutive_scheme : env -> inductive -> 
+  constr Evd.in_evar_universe_context * Declareops.side_effects
 val sym_involutive_scheme_kind : individual scheme_kind
 
 (** Builds a congruence scheme for an equality type *)
 
 val congr_scheme_kind : individual scheme_kind
-val build_congr : env -> constr * constr -> inductive -> constr
+val build_congr : env -> constr * constr * Univ.universe_context_set -> inductive -> 
+  constr Evd.in_evar_universe_context
diff --git a/tactics/equality.ml b/tactics/equality.ml
index b062da23e..57931f600 100644
--- a/tactics/equality.ml
+++ b/tactics/equality.ml
@@ -1,4 +1,4 @@
-(************************************************************************)
+1(************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
 (* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
 (*   \VV/  **************************************************************)
@@ -280,33 +280,32 @@ let jmeq_same_dom gl = function
 
 let find_elim hdcncl lft2rgt dep cls ot gl =
   let inccl = Option.is_empty cls in
-  let hdcncl_is u = eq_constr hdcncl (constr_of_reference u) in
-  if (hdcncl_is (Coqlib.glob_eq) ||
-      hdcncl_is (Coqlib.glob_jmeq) && jmeq_same_dom gl ot)
-     && not dep
-     || Flags.version_less_or_equal Flags.V8_2
+  if (is_global Coqlib.glob_eq hdcncl ||
+      (is_global Coqlib.glob_jmeq hdcncl &&
+	 jmeq_same_dom gl ot)) && not dep
+    || Flags.version_less_or_equal Flags.V8_2
   then
     match kind_of_term hdcncl with 
-      | Ind ind_sp -> 
+      | Ind (ind_sp,u) -> 
 	let pr1 = 
 	  lookup_eliminator ind_sp (elimination_sort_of_clause cls gl) 
 	in
         begin match lft2rgt, cls with
         | Some true, None
         | Some false, Some _ ->
-	  let c1 = destConst pr1 in 
+	  let c1 = destConstRef pr1 in 
 	  let mp,dp,l = repr_con (constant_of_kn (canonical_con c1)) in 
 	  let l' = Label.of_id (add_suffix (Label.to_id l) "_r")  in 
 	  let c1' = Global.constant_of_delta_kn (make_kn mp dp l') in
 	  begin 
 	    try 
 	      let _ = Global.lookup_constant c1' in
-              mkConst c1', Declareops.no_seff
+              c1', Declareops.no_seff
 	    with Not_found -> 
 	      let rwr_thm = Label.to_string l' in 
 	      error ("Cannot find rewrite principle "^rwr_thm^".")
 	  end
-	| _ -> pr1, Declareops.no_seff
+	| _ -> destConstRef pr1, Declareops.no_seff
         end
       | _ -> 
 	  (* cannot occur since we checked that we are in presence of 
@@ -326,9 +325,9 @@ let find_elim hdcncl lft2rgt dep cls ot gl =
     | true, _, false -> rew_r2l_forward_dep_scheme_kind
   in
   match kind_of_term hdcncl with
-  | Ind ind -> 
+  | Ind (ind,u) -> 
       let c, eff = find_scheme scheme_name ind in 
-      mkConst c , eff
+      c , eff
   | _ -> assert false
 
 let type_of_clause cls gl = match cls with
@@ -342,10 +341,13 @@ let leibniz_rewrite_ebindings_clause cls lft2rgt tac c t l with_evars frzevars d
   let type_of_cls = type_of_clause cls gl in
   let dep = dep_proof_ok && dep_fun c type_of_cls in
   let (elim,effs) = find_elim hdcncl lft2rgt dep cls (Some t) gl in
+  let tac elim =
+    general_elim_clause with_evars frzevars tac cls c t l
+      (match lft2rgt with None -> false | Some b -> b)
+      {elimindex = None; elimbody = (elim,NoBindings)}
+  in
   Proofview.tclEFFECTS effs <*>
-  general_elim_clause with_evars frzevars tac cls c t l
-    (match lft2rgt with None -> false | Some b -> b)
-    {elimindex = None; elimbody = (elim,NoBindings)}
+  pf_constr_of_global (ConstRef elim) tac
   end
 
 let adjust_rewriting_direction args lft2rgt =
@@ -534,26 +536,34 @@ let multi_replace clause c2 c1 unsafe try_prove_eq_opt =
   let get_type_of = pf_apply get_type_of gl in
   let t1 = get_type_of c1
   and t2 = get_type_of c2 in
-  let is_conv = pf_apply is_conv gl in
-  if unsafe || (is_conv t1 t2) then
+  let evd = 
+    if unsafe then Some (Proofview.Goal.sigma gl)
+    else
+      try Some (Evarconv.the_conv_x (Proofview.Goal.env gl) t1 t2 (Proofview.Goal.sigma gl))
+      with Evarconv.UnableToUnify _ -> None
+  in
+  match evd with
+  | None ->
+    tclFAIL 0 (str"Terms do not have convertible types.")
+  | Some evd ->
     let e = build_coq_eq () in
     let sym = build_coq_eq_sym () in
+    Tacticals.New.pf_constr_of_global e (fun e ->
     let eq = applist (e, [t1;c1;c2]) in
     if check_setoid clause
     then init_setoid ();
-    tclTHENS (assert_as false None eq)
-      [onLastHypId (fun id ->
-	tclTHEN
-	  (tclTRY (general_multi_rewrite false false (mkVar id,NoBindings) clause))
-	  (clear [id]));
-       tclFIRST
-	 [assumption;
-	  tclTHEN (Proofview.V82.tactic (apply sym)) assumption;
-	  try_prove_eq
-	 ]
-      ]
-  else
-    tclFAIL 0 (str"Terms do not have convertible types.")
+    Tacticals.New.pf_constr_of_global sym (fun sym ->
+      tclTHENS (assert_as false None eq)
+	[onLastHypId (fun id ->
+	  tclTHEN
+	    (tclTRY (general_multi_rewrite false false (mkVar id,NoBindings) clause))
+	    (clear [id]));
+	 tclFIRST
+	   [assumption;
+	    tclTHEN (Proofview.V82.tactic (apply sym)) assumption;
+	    try_prove_eq
+	   ]
+	]))
   end
 
 let replace c2 c1 = multi_replace onConcl c2 c1 false None
@@ -627,8 +637,7 @@ let find_positions env sigma t1 t2 =
     let hd1,args1 = whd_betadeltaiota_stack env sigma t1 in
     let hd2,args2 = whd_betadeltaiota_stack env sigma t2 in
     match (kind_of_term hd1, kind_of_term hd2) with
-
-      | Construct sp1, Construct sp2
+      | Construct (sp1,_), Construct (sp2,_)
           when Int.equal (List.length args1) (mis_constructor_nargs_env env sp1)
             ->
 	  let sorts =
@@ -636,7 +645,7 @@ let find_positions env sigma t1 t2 =
           in
           (* both sides are fully applied constructors, so either we descend,
              or we can discriminate here. *)
-	  if is_conv env sigma hd1 hd2 then
+	  if eq_constructor sp1 sp2 then
 	    let nrealargs = constructor_nrealargs env sp1 in
 	    let rargs1 = List.lastn nrealargs args1 in
 	    let rargs2 = List.lastn nrealargs args2 in
@@ -746,7 +755,7 @@ let descend_then sigma env head dirn =
     try find_rectype env sigma (get_type_of env sigma head)
     with Not_found ->
       error "Cannot project on an inductive type derived from a dependency." in
-   let ind,_ = dest_ind_family indf in
+  let (ind,_),_ = dest_ind_family indf in
   let (mib,mip) = lookup_mind_specif env ind in
   let cstr = get_constructors env indf in
   let dirn_nlams = cstr.(dirn-1).cs_nargs in
@@ -795,7 +804,7 @@ let construct_discriminator sigma env dirn c sort =
       errorlabstrm "Equality.construct_discriminator"
 	(str "Cannot discriminate on inductive constructors with \
 		 dependent types.") in
-  let (ind,_) = dest_ind_family indf in
+  let ((ind,_),_) = dest_ind_family indf in
   let (mib,mip) = lookup_mind_specif env ind in
   let (true_0,false_0,sort_0) = build_coq_True(),build_coq_False(),Prop Null in
   let deparsign = make_arity_signature env true indf in
@@ -847,22 +856,23 @@ let gen_absurdity id =
 *)
 
 let ind_scheme_of_eq lbeq =
-  let (mib,mip) = Global.lookup_inductive (destInd lbeq.eq) in
+  let (mib,mip) = Global.lookup_inductive (destIndRef lbeq.eq) in
   let kind = inductive_sort_family mip in
   (* use ind rather than case by compatibility *)
   let kind =
     if kind == InProp then Elimschemes.ind_scheme_kind_from_prop
     else Elimschemes.ind_scheme_kind_from_type in
-  let c, eff = find_scheme kind (destInd lbeq.eq) in
-  mkConst c, eff
+  let c, eff = find_scheme kind (destIndRef lbeq.eq) in
+    ConstRef c, eff
 
 
-let discrimination_pf e (t,t1,t2) discriminator lbeq =
+let discrimination_pf env sigma e (t,t1,t2) discriminator lbeq =
   let i            = build_coq_I () in
   let absurd_term  = build_coq_False () in
   let eq_elim, eff = ind_scheme_of_eq lbeq in
-  (applist (eq_elim, [t;t1;mkNamedLambda e t discriminator;i;t2]), absurd_term),
-  eff
+  let sigma, eq_elim = Evd.fresh_global env sigma eq_elim in
+    sigma, (applist (eq_elim, [t;t1;mkNamedLambda e t discriminator;i;t2]), absurd_term),
+    eff
 
 let eq_baseid = Id.of_string "e"
 
@@ -880,11 +890,12 @@ let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn sort =
   let e_env = push_named (e,None,t) env in
   let discriminator =
     build_discriminator sigma e_env dirn (mkVar e) sort cpath in
-  let (pf, absurd_term), eff =
-    discrimination_pf e (t,t1,t2) discriminator lbeq in
+  let sigma,(pf, absurd_term), eff = 
+    discrimination_pf env sigma e (t,t1,t2) discriminator lbeq in
   let pf_ty = mkArrow eqn absurd_term in
   let absurd_clause = apply_on_clause (pf,pf_ty) eq_clause in
   let pf = clenv_value_cast_meta absurd_clause in
+  Proofview.V82.tclEVARS sigma <*>
   Proofview.tclEFFECTS eff <*>
   tclTHENS (cut_intro absurd_term)
     [onLastHypId gen_absurdity; (Proofview.V82.tactic (refine pf))]
@@ -911,7 +922,7 @@ let onEquality with_evars tac (c,lbindc) =
   let eq_clause = pf_apply make_clenv_binding gl (c,t') lbindc in
   let eq_clause' = clenv_pose_dependent_evars with_evars eq_clause in
   let eqn = clenv_type eq_clause' in
-  let (eq,eq_args) = find_this_eq_data_decompose gl eqn in
+  let (eq,u,eq_args) = find_this_eq_data_decompose gl eqn in
   tclTHEN
     (Proofview.V82.tclEVARS eq_clause'.evd)
     (tac (eq,eqn,eq_args) eq_clause')
@@ -964,7 +975,7 @@ let discrHyp id = discrClause false (onHyp id)
     constructor depending on the sort *)
 (* J.F.: correction du bug #1167 en accord avec Hugo. *)
 
-let find_sigma_data s = build_sigma_type ()
+let find_sigma_data env s = build_sigma_type ()
 
 (* [make_tuple env sigma (rterm,rty) lind] assumes [lind] is the lesser
    index bound in [rty]
@@ -978,16 +989,18 @@ let find_sigma_data s = build_sigma_type ()
 
 let make_tuple env sigma (rterm,rty) lind =
   assert (dependent (mkRel lind) rty);
-  let {intro = exist_term; typ = sig_term} =
-    find_sigma_data (get_sort_of env sigma rty) in
+  let sigdata = find_sigma_data env (get_sort_of env sigma rty) in
   let a = type_of env sigma (mkRel lind) in
   let (na,_,_) = lookup_rel lind env in
   (* We move [lind] to [1] and lift other rels > [lind] by 1 *)
   let rty = lift (1-lind) (liftn lind (lind+1) rty) in
   (* Now [lind] is [mkRel 1] and we abstract on (na:a) *)
   let p = mkLambda (na, a, rty) in
-  (applist(exist_term,[a;p;(mkRel lind);rterm]),
-   applist(sig_term,[a;p]))
+  let sigma, exist_term = Evd.fresh_global env sigma sigdata.intro in
+  let sigma, sig_term = Evd.fresh_global env sigma sigdata.typ in
+    sigma,
+    (applist(exist_term,[a;p;(mkRel lind);rterm]),
+     applist(sig_term,[a;p]))
 
 (* check that the free-references of the type of [c] are contained in
    the free-references of the normal-form of that type. Strictly
@@ -1052,7 +1065,7 @@ let minimal_free_rels_rec env sigma =
  *)
 
 let sig_clausal_form env sigma sort_of_ty siglen ty dflt =
-  let { intro = exist_term } = find_sigma_data sort_of_ty in
+  let sigdata = find_sigma_data env sort_of_ty in
   let evdref = ref (Evd.create_goal_evar_defs sigma) in
   let rec sigrec_clausal_form siglen p_i =
     if Int.equal siglen 0 then
@@ -1078,13 +1091,14 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt =
 	| Some w ->
             let w_type = type_of env sigma w in
             if Evarconv.e_cumul env evdref w_type a then
+	      let exist_term = Evarutil.evd_comb1 (Evd.fresh_global env) evdref sigdata.intro in
               applist(exist_term,[w_type;p_i_minus_1;w;tuple_tail])
             else
               error "Cannot solve a unification problem."
 	| None -> anomaly (Pp.str "Not enough components to build the dependent tuple")
   in
   let scf = sigrec_clausal_form siglen ty in
-  Evarutil.nf_evar !evdref scf
+    !evdref, Evarutil.nf_evar !evdref scf
 
 (* The problem is to build a destructor (a generalization of the
    predecessor) which, when applied to a term made of constructors
@@ -1148,13 +1162,13 @@ let make_iterated_tuple env sigma dflt (z,zty) =
   let (zty,rels) = minimal_free_rels_rec env sigma (z,zty) in
   let sort_of_zty = get_sort_of env sigma zty in
   let sorted_rels = Int.Set.elements rels in
-  let (tuple,tuplety) =
-    List.fold_left (make_tuple env sigma) (z,zty) sorted_rels
+  let sigma, (tuple,tuplety) =
+    List.fold_left (fun (sigma, t) -> make_tuple env sigma t) (sigma, (z,zty)) sorted_rels
   in
   assert (closed0 tuplety);
   let n = List.length sorted_rels in
-  let dfltval = sig_clausal_form env sigma sort_of_zty n tuplety dflt in
-  (tuple,tuplety,dfltval)
+  let sigma, dfltval = sig_clausal_form env sigma sort_of_zty n tuplety dflt in
+    sigma, (tuple,tuplety,dfltval)
 
 let rec build_injrec sigma env dflt c = function
   | [] -> make_iterated_tuple env sigma dflt (c,type_of env sigma c)
@@ -1162,15 +1176,14 @@ let rec build_injrec sigma env dflt c = function
     try
       let (cnum_nlams,cnum_env,kont) = descend_then sigma env c cnum in
       let newc = mkRel(cnum_nlams-argnum) in
-      let (subval,tuplety,dfltval) = build_injrec sigma cnum_env dflt newc l in
-      (kont subval (dfltval,tuplety),
-      tuplety,dfltval)
+      let sigma, (subval,tuplety,dfltval) = build_injrec sigma cnum_env dflt newc l in
+	sigma, (kont subval (dfltval,tuplety), tuplety,dfltval)
     with
 	UserError _ -> failwith "caught"
 
 let build_injector sigma env dflt c cpath =
-  let (injcode,resty,_) = build_injrec sigma env dflt c cpath in
-  (injcode,resty)
+  let sigma, (injcode,resty,_) = build_injrec sigma env dflt c cpath in
+    sigma, (injcode,resty)
 
 (*
 let try_delta_expand env sigma t =
@@ -1199,28 +1212,32 @@ let simplify_args env sigma t =
 let inject_at_positions env sigma l2r (eq,_,(t,t1,t2)) eq_clause posns tac =
   let e = next_ident_away eq_baseid (ids_of_context env) in
   let e_env = push_named (e, None,t) env in
+  let evdref = ref sigma in
   let filter (cpath, t1', t2') =
     try
       (* arbitrarily take t1' as the injector default value *)
-      let (injbody,resty) = build_injector sigma e_env t1' (mkVar e) cpath in
+      let sigma, (injbody,resty) = build_injector !evdref e_env t1' (mkVar e) cpath in
       let injfun = mkNamedLambda e t injbody in
-      let pf = applist(eq.congr,[t;resty;injfun;t1;t2]) in
-      let pf_typ = get_type_of env sigma pf in
+      let congr = Evarutil.evd_comb1 (Evd.fresh_global env) evdref eq.congr in
+      let pf = applist(congr,[t;resty;injfun;t1;t2]) in
+      let sigma, pf_typ = Typing.e_type_of env sigma pf in
       let inj_clause = apply_on_clause (pf,pf_typ) eq_clause in
       let pf = clenv_value_cast_meta inj_clause in
       let ty = simplify_args env sigma (clenv_type inj_clause) in
-      Some (pf, ty)
+	evdref := sigma;
+	Some (pf, ty)
     with Failure _ -> None
   in
   let injectors = List.map_filter filter posns in
   if List.is_empty injectors then
     Proofview.tclZERO (Errors.UserError ("Equality.inj" , str "Failed to decompose the equality."))
   else
-    Proofview.tclBIND
+    Proofview.tclTHEN (Proofview.V82.tclEVARS !evdref)
+    (Proofview.tclBIND
       (Proofview.Monad.List.map
          (fun (pf,ty) -> tclTHENS (cut ty) [Proofview.tclUNIT (); Proofview.V82.tactic (refine pf)])
          (if l2r then List.rev injectors else injectors))
-      (fun _ -> tac (List.length injectors))
+      (fun _ -> tac (List.length injectors)))
 
 exception Not_dep_pair
 
@@ -1232,30 +1249,32 @@ let eqdep_dec = qualid_of_string "Coq.Logic.Eqdep_dec"
 let inject_if_homogenous_dependent_pair env sigma (eq,_,(t,t1,t2)) =
   Proofview.Goal.raw_enter begin fun gl ->
   (* fetch the informations of the  pair *)
-  let ceq = constr_of_global Coqlib.glob_eq in
+  let ceq = Universes.constr_of_global Coqlib.glob_eq in
   let sigTconstr () = (Coqlib.build_sigma_type()).Coqlib.typ in
   let eqTypeDest = fst (destApp t) in
   let _,ar1 = destApp t1 and
       _,ar2 = destApp t2 in
   let ind = destInd ar1.(0) in
-  (* check whether the equality deals with dep pairs or not *)
-  (* if yes, check if the user has declared the dec principle *)
-  (* and compare the fst arguments of the dep pair *)
+	(* check whether the equality deals with dep pairs or not *)
+	(* if yes, check if the user has declared the dec principle *)
+	(* and compare the fst arguments of the dep pair *)
   let new_eq_args = [|type_of env sigma ar1.(3);ar1.(3);ar2.(3)|] in
-  if (eq_constr eqTypeDest (sigTconstr())) &&
-    (Ind_tables.check_scheme (!eq_dec_scheme_kind_name()) ind) &&
+  if (Globnames.is_global (sigTconstr()) eqTypeDest) &&
+    (Ind_tables.check_scheme (!eq_dec_scheme_kind_name()) (fst ind)) &&
     (is_conv env sigma ar1.(2) ar2.(2))
   then begin
     Library.require_library [Loc.ghost,eqdep_dec] (Some false);
     let inj2 = Coqlib.coq_constant "inj_pair2_eq_dec is missing"
       ["Logic";"Eqdep_dec"] "inj_pair2_eq_dec" in
-    let c, eff = find_scheme (!eq_dec_scheme_kind_name()) ind in
+    let scheme, eff = find_scheme (!eq_dec_scheme_kind_name()) (Univ.out_punivs ind) in
       (* cut with the good equality and prove the requested goal *)
     tclTHENS (tclTHEN (Proofview.tclEFFECTS eff) (cut (mkApp (ceq,new_eq_args))))
-      [tclIDTAC; tclTHEN (Proofview.V82.tactic (apply (
-        mkApp(inj2,[|ar1.(0);mkConst c;ar1.(1);ar1.(2);ar1.(3);ar2.(3)|])
+      [tclIDTAC;
+       pf_constr_of_global (ConstRef scheme) (fun c ->
+       tclTHEN (Proofview.V82.tactic (apply (
+        mkApp(inj2,[|ar1.(0);c;ar1.(1);ar1.(2);ar1.(3);ar2.(3)|])
        ))) (Auto.trivial [] [])
-      ]
+       )]
   (* not a dep eq or no decidable type found *)
   end
   else raise Not_dep_pair
@@ -1341,29 +1360,31 @@ let swap_equality_args = function
   | HeterogenousEq (t1,e1,t2,e2) -> [t2;e2;t1;e1]
 
 let swap_equands eqn =
-  let (lbeq,eq_args) = find_eq_data eqn in
-  applist(lbeq.eq,swap_equality_args eq_args)
+  let (lbeq,u,eq_args) = find_eq_data eqn in
+  let eq = Universes.constr_of_global_univ (lbeq.eq,u) in
+  applist(eq,swap_equality_args eq_args)
 
 let swapEquandsInConcl =
   Proofview.Goal.raw_enter begin fun gl ->
-  let (lbeq,eq_args) = find_eq_data (pf_nf_concl gl) in
-  let sym_equal = lbeq.sym in
+  let (lbeq,u,eq_args) = find_eq_data (pf_nf_concl gl) in
   let args = swap_equality_args eq_args @ [Evarutil.mk_new_meta ()] in
-  Proofview.V82.tactic (fun gl -> refine (applist (sym_equal, args)) gl)
+    pf_constr_of_global lbeq.sym (fun sym_equal ->
+      Proofview.V82.tactic (refine (applist (sym_equal, args))))
   end
 
 (* Refine from [|- P e2] to [|- P e1] and [|- e1=e2:>t] (body is P (Rel 1)) *)
 
-let bareRevSubstInConcl lbeq body (t,e1,e2) =
+let bareRevSubstInConcl (lbeq,u) body (t,e1,e2) =
   Proofview.Goal.raw_enter begin fun gl ->
   (* find substitution scheme *)
-  let eq_elim, effs = find_elim lbeq.eq (Some false) false None None gl in
+  let eq = Universes.constr_of_global_univ (lbeq.eq,u) in
+  let eq_elim, effs = find_elim eq (Some false) false None None gl in
   (* build substitution predicate *)
   let p = lambda_create (Proofview.Goal.env gl) (t,body) in
   (* apply substitution scheme *)
   let args = [t; e1; p; Evarutil.mk_new_meta (); e2; Evarutil.mk_new_meta ()] in
-  let tac gl = refine (applist (eq_elim, args)) gl in
-  Proofview.V82.tactic tac
+    pf_constr_of_global (ConstRef eq_elim) (fun c ->
+      Proofview.V82.tactic (refine (applist (c, args))))
   end
 
 (* [subst_tuple_term dep_pair B]
@@ -1402,17 +1423,15 @@ let decomp_tuple_term env c t =
   let rec decomprec inner_code ex exty =
     let iterated_decomp =
     try
-      let {proj1=p1; proj2=p2},(a,p,car,cdr) = find_sigma_data_decompose ex in
-      let car_code = applist (p1,[a;p;inner_code])
-      and cdr_code = applist (p2,[a;p;inner_code]) in
+      let ({proj1=p1; proj2=p2}),(i,a,p,car,cdr) = find_sigma_data_decompose ex in
+      let car_code = applist (mkConstU (destConstRef p1,i),[a;p;inner_code])
+      and cdr_code = applist (mkConstU (destConstRef p2,i),[a;p;inner_code]) in
       let cdrtyp = beta_applist (p,[car]) in
       List.map (fun l -> ((car,a),car_code)::l) (decomprec cdr_code cdr cdrtyp)
     with ConstrMatching.PatternMatchingFailure ->
       []
-    in
-    [((ex,exty),inner_code)]::iterated_decomp
-  in
-  decomprec (mkRel 1) c t
+    in [((ex,exty),inner_code)]::iterated_decomp
+  in decomprec (mkRel 1) c t
 
 let subst_tuple_term env sigma dep_pair1 dep_pair2 b =
   let typ = get_type_of env sigma dep_pair1 in
@@ -1435,7 +1454,7 @@ let subst_tuple_term env sigma dep_pair1 dep_pair2 b =
   let expected_goal = beta_applist (abst_B,List.map fst e2_list) in
   (* Simulate now the normalisation treatment made by Logic.mk_refgoals *)
   let expected_goal = nf_betaiota sigma expected_goal in
-  pred_body,expected_goal
+    pred_body,expected_goal
 
 (* Like "replace" but decompose dependent equalities *)
 
@@ -1443,12 +1462,12 @@ exception NothingToRewrite
 
 let cutSubstInConcl_RL eqn =
   Proofview.Goal.raw_enter begin fun gl ->
-  let (lbeq,(t,e1,e2 as eq)) = find_eq_data_decompose gl eqn in
+  let (lbeq,u,(t,e1,e2 as eq)) = find_eq_data_decompose gl eqn in
   let concl = pf_nf_concl gl in
   let body,expected_goal = pf_apply subst_tuple_term gl e2 e1 concl in
   if not (dependent (mkRel 1) body) then raise NothingToRewrite;
   tclTHENFIRST
-    (bareRevSubstInConcl lbeq body eq)
+    (bareRevSubstInConcl (lbeq,u) body eq)
     (Proofview.V82.tactic (fun gl -> convert_concl expected_goal DEFAULTcast gl))
   end
 
@@ -1465,12 +1484,12 @@ let cutSubstInConcl l2r =if l2r then cutSubstInConcl_LR else cutSubstInConcl_RL
 
 let cutSubstInHyp_LR eqn id =
   Proofview.Goal.enter begin fun gl ->
-  let (lbeq,(t,e1,e2 as eq)) = find_eq_data_decompose gl eqn in
+  let (lbeq,u,(t,e1,e2 as eq)) = find_eq_data_decompose gl eqn in
   let idtyp = pf_get_hyp_typ id gl in
   let body,expected_goal = pf_apply subst_tuple_term gl e1 e2 idtyp in
   if not (dependent (mkRel 1) body) then raise NothingToRewrite;
   let refine = Proofview.V82.tactic (fun gl -> Tacmach.refine_no_check (mkVar id) gl) in
-  let subst = Proofview.V82.of_tactic (tclTHENFIRST (bareRevSubstInConcl lbeq body eq) refine) in
+  let subst = Proofview.V82.of_tactic (tclTHENFIRST (bareRevSubstInConcl (lbeq,u) body eq) refine) in
   Proofview.V82.tactic (fun gl -> cut_replacing id expected_goal subst gl)
   end
 
@@ -1555,8 +1574,8 @@ let unfold_body x =
 
 
 let restrict_to_eq_and_identity eq = (* compatibility *)
-  if not (eq_constr eq (constr_of_global glob_eq)) &&
-    not (eq_constr eq (constr_of_global glob_identity))
+  if not (is_global glob_eq eq) &&
+    not (is_global glob_identity eq) 
   then raise ConstrMatching.PatternMatchingFailure
 
 exception FoundHyp of (Id.t * constr * bool)
@@ -1565,7 +1584,7 @@ exception FoundHyp of (Id.t * constr * bool)
 let is_eq_x gl x (id,_,c) =
   try
     let c = pf_nf_evar gl c in
-    let (_,lhs,rhs) = snd (find_eq_data_decompose gl c) in
+    let (_,lhs,rhs) = pi3 (find_eq_data_decompose gl c) in
     if (eq_constr x lhs) && not (occur_term x rhs) then raise (FoundHyp (id,rhs,true));
     if (eq_constr x rhs) && not (occur_term x lhs) then raise (FoundHyp (id,lhs,false))
   with ConstrMatching.PatternMatchingFailure ->
@@ -1664,8 +1683,9 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () =
   let find_eq_data_decompose = find_eq_data_decompose gl in
   let test (_,c) =
     try
-      let lbeq,(_,x,y) = find_eq_data_decompose c in
-      if flags.only_leibniz then restrict_to_eq_and_identity lbeq.eq;
+      let lbeq,u,(_,x,y) = find_eq_data_decompose c in
+      let eq = Universes.constr_of_global_univ (lbeq.eq,u) in
+      if flags.only_leibniz then restrict_to_eq_and_identity eq;
       (* J.F.: added to prevent failure on goal containing x=x as an hyp *)
       if eq_constr x y then failwith "caught";
       match kind_of_term x with Var x -> x | _ ->
@@ -1684,19 +1704,19 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () =
 
 let cond_eq_term_left c t gl =
   try
-    let (_,x,_) = snd (find_eq_data_decompose gl t) in
+    let (_,x,_) = pi3 (find_eq_data_decompose gl t) in
     if pf_conv_x gl c x then true else failwith "not convertible"
   with ConstrMatching.PatternMatchingFailure -> failwith "not an equality"
 
 let cond_eq_term_right c t gl =
   try
-    let (_,_,x) = snd (find_eq_data_decompose gl t) in
+    let (_,_,x) = pi3 (find_eq_data_decompose gl t) in
     if pf_conv_x gl c x then false else failwith "not convertible"
   with ConstrMatching.PatternMatchingFailure -> failwith "not an equality"
 
 let cond_eq_term c t gl =
   try
-    let (_,x,y) = snd (find_eq_data_decompose gl t) in
+    let (_,x,y) = pi3 (find_eq_data_decompose gl t) in
     if pf_conv_x gl c x then true
     else if pf_conv_x gl c y then false
     else failwith "not convertible"
diff --git a/tactics/equality.mli b/tactics/equality.mli
index b59b4bbe0..82e30b940 100644
--- a/tactics/equality.mli
+++ b/tactics/equality.mli
@@ -88,7 +88,7 @@ val dEq : evars_flag -> constr with_bindings induction_arg option -> unit Proofv
 val dEqThen : evars_flag -> (constr -> int -> unit Proofview.tactic) -> constr with_bindings induction_arg option -> unit Proofview.tactic
 
 val make_iterated_tuple :
-  env -> evar_map -> constr -> (constr * types) -> constr * constr * constr
+  env -> evar_map -> constr -> (constr * types) -> evar_map * (constr * constr * constr)
 
 (* The family cutRewriteIn expect an equality statement *)
 val cutRewriteInHyp : bool -> types -> Id.t -> unit Proofview.tactic
diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4
index f8790796d..bda217566 100644
--- a/tactics/extratactics.ml4
+++ b/tactics/extratactics.ml4
@@ -252,7 +252,14 @@ TACTIC EXTEND rewrite_star
 
 let add_rewrite_hint bases ort t lcsr =
   let env = Global.env() and sigma = Evd.empty in
-  let f c = Constrexpr_ops.constr_loc c, Constrintern.interp_constr sigma env c, ort, t in
+  let poly = Flags.is_universe_polymorphism () in 
+  let f ce = 
+    let c, ctx = Constrintern.interp_constr sigma env ce in
+    let ctx =
+      if poly then ctx
+      else (Global.add_constraints (snd ctx); Univ.ContextSet.empty)
+    in
+      Constrexpr_ops.constr_loc ce, (c, ctx), ort, t in
   let eqs = List.map f lcsr in
   let add_hints base = add_rew_rules base eqs in
   List.iter add_hints bases
@@ -281,8 +288,8 @@ open Coqlib
 let project_hint pri l2r r =
   let gr = Smartlocate.global_with_alias r in
   let env = Global.env() in
-  let c = Globnames.constr_of_global gr in
-  let t = Retyping.get_type_of env Evd.empty c in
+  let c,ctx = Universes.fresh_global_instance env gr in
+  let t = Retyping.get_type_of env (Evd.from_env ~ctx env) c in
   let t =
     Tacred.reduce_to_quantified_ref env Evd.empty (Lazy.force coq_iff_ref) t in
   let sign,ccl = decompose_prod_assum t in
@@ -294,7 +301,11 @@ let project_hint pri l2r r =
   let c = Reductionops.whd_beta Evd.empty (mkApp (c,Termops.extended_rel_vect 0 sign)) in
   let c = it_mkLambda_or_LetIn
     (mkApp (p,[|mkArrow a (lift 1 b);mkArrow b (lift 1 a);c|])) sign in
-    (pri,true,Auto.PathAny, Globnames.IsConstr c)
+  let id =
+    Nameops.add_suffix (Nametab.basename_of_global gr) ("_proj_" ^ (if l2r then "l2r" else "r2l"))
+  in
+  let c = Declare.declare_definition ~internal:Declare.KernelSilent id (c,ctx) in
+    (pri,false,true,Auto.PathAny, Auto.IsGlobRef (Globnames.ConstRef c))
 
 let add_hints_iff l2r lc n bl =
   Auto.add_hints true bl
@@ -473,7 +484,7 @@ let inTransitivity : bool * constr -> obj =
 (* Main entry points *)
 
 let add_transitivity_lemma left lem =
- let lem' = Constrintern.interp_constr Evd.empty (Global.env ()) lem in
+ let lem',ctx (*FIXME*) = Constrintern.interp_constr Evd.empty (Global.env ()) lem in
   add_anonymous_leaf (inTransitivity (left,lem'))
 
 (* Vernacular syntax *)
@@ -513,8 +524,8 @@ END
 
 VERNAC COMMAND EXTEND RetroknowledgeRegister CLASSIFIED AS SIDEFF
  | [ "Register" constr(c) "as" retroknowledge_field(f) "by" constr(b)] ->
-           [ let tc = Constrintern.interp_constr Evd.empty (Global.env ()) c in
-             let tb = Constrintern.interp_constr Evd.empty (Global.env ()) b in
+           [ let tc,ctx = Constrintern.interp_constr Evd.empty (Global.env ()) c in
+             let tb,ctx(*FIXME*) = Constrintern.interp_constr Evd.empty (Global.env ()) b in
              Global.register f tc tb ]
 END
 
@@ -607,9 +618,11 @@ let hResolve id c occ t gl =
           let loc = match Loc.get_loc e with None -> Loc.ghost | Some loc -> loc in
           resolve_hole (subst_hole_with_term (fst (Loc.unloc loc)) c_raw t_hole)
   in
-  let t_constr = resolve_hole (subst_var_with_hole occ id t_raw) in
+  let t_constr,ctx = resolve_hole (subst_var_with_hole occ id t_raw) in
+  let sigma = Evd.merge_context_set Evd.univ_rigid sigma ctx in
   let t_constr_type = Retyping.get_type_of env sigma t_constr in
-  change_in_concl None (mkLetIn (Anonymous,t_constr,t_constr_type,pf_concl gl)) gl
+    tclTHEN (Refiner.tclEVARS sigma)
+     (change_in_concl None (mkLetIn (Anonymous,t_constr,t_constr_type,pf_concl gl))) gl
 
 let hResolve_auto id c t gl =
   let rec resolve_auto n = 
@@ -749,6 +762,11 @@ TACTIC EXTEND constr_eq
     if eq_constr x y then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (str "Not equal") ]
 END
 
+TACTIC EXTEND constr_eq_nounivs
+| [ "constr_eq_nounivs" constr(x) constr(y) ] -> [
+    if eq_constr_nounivs x y then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (str "Not equal") ]
+END
+
 TACTIC EXTEND is_evar
 | [ "is_evar" constr(x) ] ->
     [ match kind_of_term x with
@@ -772,6 +790,7 @@ let rec has_evar x =
       has_evar t1 || has_evar t2 || has_evar_array ts
     | Fix ((_, tr)) | CoFix ((_, tr)) ->
       has_evar_prec tr
+    | Proj (p, c) -> has_evar c
 and has_evar_array x =
   Array.exists has_evar x
 and has_evar_prec (_, ts1, ts2) =
diff --git a/tactics/g_rewrite.ml4 b/tactics/g_rewrite.ml4
index 954892e81..d00626d32 100644
--- a/tactics/g_rewrite.ml4
+++ b/tactics/g_rewrite.ml4
@@ -105,6 +105,12 @@ END
 let db_strat db = StratUnary ("topdown", StratHints (false, db))
 let cl_rewrite_clause_db db = cl_rewrite_clause_strat (strategy_of_ast (db_strat db))
 
+let cl_rewrite_clause_db = 
+  if Flags.profile then
+    let key = Profile.declare_profile "cl_rewrite_clause_db" in
+      Profile.profile3 key cl_rewrite_clause_db
+  else cl_rewrite_clause_db
+
 TACTIC EXTEND rewrite_strat
 | [ "rewrite_strat" rewstrategy(s) "in" hyp(id) ] -> [ Proofview.V82.tactic (cl_rewrite_clause_strat s (Some id)) ]
 | [ "rewrite_strat" rewstrategy(s) ] -> [ Proofview.V82.tactic (cl_rewrite_clause_strat s None) ]
@@ -140,21 +146,21 @@ TACTIC EXTEND setoid_rewrite
       [ Proofview.V82.tactic (cl_rewrite_clause c o (occurrences_of occ) (Some id))]
 END
 
-let cl_rewrite_clause_newtac_tac c o occ cl =
-  cl_rewrite_clause_newtac' c o occ cl
-
-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 AllOccurrences (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 AllOccurrences None ]
-END
+(* let cl_rewrite_clause_newtac_tac c o occ cl = *)
+(*   cl_rewrite_clause_newtac' c o occ cl *)
+
+(* 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 AllOccurrences (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 AllOccurrences None ] *)
+(* END *)
 
 VERNAC COMMAND EXTEND AddRelation CLASSIFIED AS SIDEFF
   | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1)
diff --git a/tactics/hipattern.ml4 b/tactics/hipattern.ml4
index 89aaee485..130e66720 100644
--- a/tactics/hipattern.ml4
+++ b/tactics/hipattern.ml4
@@ -47,7 +47,7 @@ let match_with_non_recursive_type t =
     | App _ ->
         let (hdapp,args) = decompose_app t in
         (match kind_of_term hdapp with
-           | Ind ind ->
+           | Ind (ind,u) ->
                if not (Global.lookup_mind (fst ind)).mind_finite then
 		 Some (hdapp,args)
 	       else
@@ -90,9 +90,9 @@ let match_with_one_constructor style onlybinary allow_rec t =
   let (hdapp,args) = decompose_app t in
   let res = match kind_of_term hdapp with
   | Ind ind ->
-      let (mib,mip) = Global.lookup_inductive ind in
+      let (mib,mip) = Global.lookup_inductive (fst ind) in
       if Int.equal (Array.length mip.mind_consnames) 1
-	&& (allow_rec || not (mis_is_recursive (ind,mib,mip)))
+	&& (allow_rec || not (mis_is_recursive (fst ind,mib,mip)))
         && (Int.equal mip.mind_nrealargs 0)
       then
 	if is_strict_conjunction style (* strict conjunction *) then
@@ -137,8 +137,8 @@ let match_with_tuple t =
   let t = match_with_one_constructor None false true t in
   Option.map (fun (hd,l) ->
     let ind = destInd hd in
-    let (mib,mip) = Global.lookup_inductive ind in
-    let isrec = mis_is_recursive (ind,mib,mip) in
+    let (mib,mip) = Global.lookup_pinductive ind in
+    let isrec = mis_is_recursive (fst ind,mib,mip) in
     (hd,l,isrec)) t
 
 let is_tuple t =
@@ -158,7 +158,7 @@ let test_strict_disjunction n lc =
 let match_with_disjunction ?(strict=false) ?(onlybinary=false) t =
   let (hdapp,args) = decompose_app t in
   let res = match kind_of_term hdapp with
-  | Ind ind  ->
+  | Ind (ind,u)  ->
       let car = mis_constr_nargs ind in
       let (mib,mip) = Global.lookup_inductive ind in
       if Array.for_all (fun ar -> Int.equal ar 1) car
@@ -193,7 +193,7 @@ let match_with_empty_type t =
   let (hdapp,args) = decompose_app t in
   match (kind_of_term hdapp) with
     | Ind ind ->
-        let (mib,mip) = Global.lookup_inductive ind in
+        let (mib,mip) = Global.lookup_pinductive ind in
         let nconstr = Array.length mip.mind_consnames in
 	if Int.equal nconstr 0 then Some hdapp else None
     | _ ->  None
@@ -207,7 +207,7 @@ let match_with_unit_or_eq_type t =
   let (hdapp,args) = decompose_app t in
   match (kind_of_term hdapp) with
     | Ind ind  ->
-        let (mib,mip) = Global.lookup_inductive ind in
+        let (mib,mip) = Global.lookup_pinductive ind in
         let constr_types = mip.mind_nf_lc in
         let nconstr = Array.length mip.mind_consnames in
         let zero_args c = Int.equal (nb_prod c) mib.mind_nparams in
@@ -249,7 +249,7 @@ let match_with_equation t =
   if not (isApp t) then raise NoEquationFound;
   let (hdapp,args) = destApp t in
   match kind_of_term hdapp with
-  | Ind ind ->
+  | Ind (ind,u) ->
       if eq_gr (IndRef ind) glob_eq then
 	Some (build_coq_eq_data()),hdapp,
 	PolymorphicLeibnizEq(args.(0),args.(1),args.(2))
@@ -282,7 +282,7 @@ let is_inductive_equality ind =
 let match_with_equality_type t =
   let (hdapp,args) = decompose_app t in
   match (kind_of_term hdapp) with
-  | Ind ind when is_inductive_equality ind -> Some (hdapp,args)
+  | Ind (ind,_) when is_inductive_equality ind -> Some (hdapp,args)
   | _ -> None
 
 let is_equality_type t = op2bool (match_with_equality_type t)
@@ -322,7 +322,7 @@ let match_with_nodep_ind t =
   let (hdapp,args) = decompose_app t in
     match (kind_of_term hdapp) with
       | Ind ind  ->
-          let (mib,mip) = Global.lookup_inductive ind in
+          let (mib,mip) = Global.lookup_pinductive ind in
 	    if Array.length (mib.mind_packets)>1 then None else
 	      let nodep_constr = has_nodep_prod_after mib.mind_nparams in
 		if Array.for_all nodep_constr mip.mind_nf_lc then
@@ -340,7 +340,7 @@ let match_with_sigma_type t=
   let (hdapp,args) = decompose_app t in
   match (kind_of_term hdapp) with
     | Ind ind  ->
-        let (mib,mip) = Global.lookup_inductive ind in
+        let (mib,mip) = Global.lookup_pinductive ind in
           if Int.equal (Array.length (mib.mind_packets)) 1 &&
 	    (Int.equal mip.mind_nrealargs 0) &&
 	    (Int.equal (Array.length mip.mind_consnames)1) &&
@@ -378,7 +378,7 @@ let match_eq eqn eq_pat =
   match Id.Map.bindings (matches pat eqn) with
     | [(m1,t);(m2,x);(m3,y)] ->
 	assert (Id.equal m1 meta1 && Id.equal m2 meta2 && Id.equal m3 meta3);
-	PolymorphicLeibnizEq (t,x,y)
+        PolymorphicLeibnizEq (t,x,y)
     | [(m1,t);(m2,x);(m3,t');(m4,x')] ->
         assert (Id.equal m1 meta1 && Id.equal m2 meta2 && Id.equal m3 meta3 && Id.equal m4 meta4);
 	HeterogenousEq (t,x,t',x')
@@ -387,13 +387,21 @@ let match_eq eqn eq_pat =
 let no_check () = true
 let check_jmeq_loaded () = Library.library_is_loaded Coqlib.jmeq_module
 
+let build_coq_jmeq_data_in env =
+  build_coq_jmeq_data (), Univ.ContextSet.empty
+
+let build_coq_identity_data_in env =
+  build_coq_identity_data (), Univ.ContextSet.empty
+
 let equalities =
   [coq_eq_pattern, no_check, build_coq_eq_data;
    coq_jmeq_pattern, check_jmeq_loaded, build_coq_jmeq_data;
    coq_identity_pattern, no_check, build_coq_identity_data]
 
 let find_eq_data eqn = (* fails with PatternMatchingFailure *)
-  first_match (match_eq eqn) equalities
+  let d,k = first_match (match_eq eqn) equalities in
+  let hd,u = destInd (fst (destApp eqn)) in
+    d,u,k
 
 let extract_eq_args gl = function
   | MonomorphicLeibnizEq (e1,e2) ->
@@ -404,11 +412,11 @@ let extract_eq_args gl = function
       else raise PatternMatchingFailure
 
 let find_eq_data_decompose gl eqn =
-  let (lbeq,eq_args) = find_eq_data eqn in
-  (lbeq,extract_eq_args gl eq_args)
+  let (lbeq,u,eq_args) = find_eq_data eqn in
+  (lbeq,u,extract_eq_args gl eq_args)
 
 let find_this_eq_data_decompose gl eqn =
-  let (lbeq,eq_args) =
+  let (lbeq,u,eq_args) =
     try (*first_match (match_eq eqn) inversible_equalities*)
       find_eq_data eqn
     with PatternMatchingFailure ->
@@ -417,7 +425,7 @@ let find_this_eq_data_decompose gl eqn =
     try extract_eq_args gl eq_args
     with PatternMatchingFailure ->
       error "Don't know what to do with JMeq on arguments not of same type." in
-  (lbeq,eq_args)
+  (lbeq,u,eq_args)
 
 let match_eq_nf gls eqn eq_pat =
   match Id.Map.bindings (pf_matches gls (Lazy.force eq_pat) eqn) with
@@ -439,18 +447,16 @@ 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 Id.Map.bindings (matches (Lazy.force ex_pat) ex) with
-    | [(m1,a);(m2,p);(m3,car);(m4,cdr)] ->
-        assert (Id.equal m1 meta1 && Id.equal m2 meta2 && Id.equal m3 meta3 && Id.equal m4 meta4);
-	(a,p,car,cdr)
-    | _ ->
-	anomaly ~label:"match_sigma" (Pp.str "a successful sigma pattern should match 4 terms")
-
+let match_sigma ex =
+  match kind_of_term ex with
+  | App (f, [| a; p; car; cdr |]) when is_global (Lazy.force coq_exist_ref) f -> 
+      build_sigma (), (snd (destConstruct f), a, p, car, cdr)
+  | App (f, [| a; p; car; cdr |]) when is_global (Lazy.force coq_existT_ref) f -> 
+    build_sigma_type (), (snd (destConstruct f), a, p, car, cdr)
+  | _ -> raise PatternMatchingFailure
+    
 let find_sigma_data_decompose ex = (* fails with PatternMatchingFailure *)
-  first_match (match_sigma ex)
-    [coq_existT_pattern, no_check, build_sigma_type;
-     coq_exist_pattern, no_check, build_sigma]
+  match_sigma ex
 
 (* Pattern "(sig ?1 ?2)" *)
 let coq_sig_pattern = lazy PATTERN [ %coq_sig_ref ?X1 ?X2 ]
@@ -495,7 +501,7 @@ let match_eqdec t =
         false,op_or,matches (Lazy.force coq_eqdec_rev_pattern) t in
   match Id.Map.bindings subst with
   | [(_,typ);(_,c1);(_,c2)] ->
-      eqonleft, Globnames.constr_of_global (Lazy.force op), c1, c2, typ
+      eqonleft, Universes.constr_of_global (Lazy.force op), c1, c2, typ
   | _ -> anomaly (Pp.str "Unexpected pattern")
 
 (* Patterns "~ ?" and "? -> False" *)
diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli
index fc87fc9ed..3637be41d 100644
--- a/tactics/hipattern.mli
+++ b/tactics/hipattern.mli
@@ -121,19 +121,19 @@ val match_with_equation:
 (** Match terms [eq A t u], [identity A t u] or [JMeq A t A u] 
    Returns associated lemmas and [A,t,u] or fails PatternMatchingFailure *)
 val find_eq_data_decompose : 'a Proofview.Goal.t -> constr ->
-      coq_eq_data * (types * constr * constr)
+      coq_eq_data * Univ.universe_instance * (types * constr * constr)
 
 (** Idem but fails with an error message instead of PatternMatchingFailure *)
 val find_this_eq_data_decompose : 'a Proofview.Goal.t -> constr ->
-      coq_eq_data * (types * constr * constr)
+      coq_eq_data * Univ.universe_instance * (types * constr * constr)
 
 (** A variant that returns more informative structure on the equality found *)
-val find_eq_data : constr -> coq_eq_data * equation_kind
+val find_eq_data : constr -> coq_eq_data * Univ.universe_instance * equation_kind
 
 (** Match a term of the form [(existT A P t p)] 
    Returns associated lemmas and [A,P,t,p] *)
 val find_sigma_data_decompose : constr ->
-  coq_sigma_data * (constr * constr * constr * constr)
+  coq_sigma_data * (Univ.universe_instance * constr * constr * constr * constr)
 
 (** Match a term of the form [{x:A|P}], returns [A] and [P] *)
 val match_sigma : constr -> constr * constr
diff --git a/tactics/inv.ml b/tactics/inv.ml
index 0c0bcc06a..0ff6b69a5 100644
--- a/tactics/inv.ml
+++ b/tactics/inv.ml
@@ -67,7 +67,7 @@ type inversion_status = Dep of constr option | NoDep
 let compute_eqn env sigma n i ai =
   (mkRel (n-i),get_type_of env sigma (mkRel (n-i)))
 
-let make_inv_predicate env sigma indf realargs id status concl =
+let make_inv_predicate env evd indf realargs id status concl =
   let nrealargs = List.length realargs in
   let (hyps,concl) =
     match status with
@@ -86,11 +86,12 @@ let make_inv_predicate env sigma indf realargs id status concl =
             match dflt_concl with
               | Some concl -> concl (*assumed it's some [x1..xn,H:I(x1..xn)]C*)
               | None ->
-		let sort = get_sort_family_of env sigma concl in
-		let p = make_arity env true indf (new_sort_in_family sort) in
-		fst (Unification.abstract_list_all env
-                       (Evd.create_evar_defs sigma)
-		       p concl (realargs@[mkVar id])) in
+		let sort = get_sort_family_of env !evd concl in
+		let sort = Evarutil.evd_comb1 (Evd.fresh_sort_in_family env) evd sort in
+		let p = make_arity env true indf sort in
+		let evd',(p,ptyp) = Unification.abstract_list_all env
+                  !evd p concl (realargs@[mkVar id])
+		in evd := evd'; p in
 	  let hyps,bodypred = decompose_lam_n_assum (nrealargs+1) pred in
 	  (* We lift to make room for the equations *)
 	  (hyps,lift nrealargs bodypred)
@@ -102,21 +103,25 @@ let make_inv_predicate env sigma indf realargs id status concl =
   (* Now, we can recurse down this list, for each ai,(mkRel k) whether to
      push <Ai>(mkRel k)=ai (when   Ai is closed).
    In any case, we carry along the rest of pairs *)
+  let eqdata = Coqlib.build_coq_eq_data () in
   let rec build_concl eqns args n = function
     | [] -> it_mkProd concl eqns, Array.rev_of_list args
     | ai :: restlist ->
         let ai = lift nhyps ai in
-        let (xi, ti) = compute_eqn env' sigma nhyps n ai in
+        let (xi, ti) = compute_eqn env' !evd nhyps n ai in
         let (lhs,eqnty,rhs) =
           if closed0 ti then
 	    (xi,ti,ai)
           else
-	    make_iterated_tuple env' sigma ai (xi,ti)
+	    let sigma, res = make_iterated_tuple env' !evd ai (xi,ti) in
+	      evd := sigma; res
 	in
-        let eq_term = Coqlib.build_coq_eq () in
-        let eqn = applist (eq_term ,[eqnty;lhs;rhs]) in
+        let eq_term = eqdata.Coqlib.eq in
+	let eq = Evarutil.evd_comb1 (Evd.fresh_global env) evd eq_term in
+        let eqn = applist (eq,[eqnty;lhs;rhs]) in
         let eqns = (Anonymous, lift n eqn) :: eqns in
-        let refl_term = Coqlib.build_coq_eq_refl () in
+        let refl_term = eqdata.Coqlib.refl in
+	let refl_term = Evarutil.evd_comb1 (Evd.fresh_global env) evd refl_term in
         let refl = mkApp (refl_term, [|eqnty; rhs|]) in
         let args = refl :: args in
         build_concl eqns args (succ n) restlist
@@ -455,8 +460,10 @@ let raw_inversion inv_kind id status names =
         Errors.errorlabstrm "" msg
     in
     let IndType (indf,realargs) = find_rectype env sigma t in
+    let evdref = ref sigma in
     let (elim_predicate, args) =
-      make_inv_predicate env sigma indf realargs id status concl in
+      make_inv_predicate env evdref indf realargs id status concl in
+    let sigma = !evdref in
     let (cut_concl,case_tac) =
       if status != NoDep && (dependent c concl) then
         Reduction.beta_appvect elim_predicate (Array.of_list (realargs@[c])),
@@ -470,12 +477,13 @@ let raw_inversion inv_kind id status names =
       Proofview.Refine.refine (fun h -> h, prf)
     in
     let neqns = List.length realargs in
-    tclTHENS
+    tclTHEN (Proofview.V82.tclEVARS sigma)
+      (tclTHENS
         (assert_tac Anonymous cut_concl)
         [case_tac names
             (introCaseAssumsThen (rewrite_equations_tac inv_kind id neqns))
             (Some elim_predicate) ind (c, t);
-        onLastHypId (fun id -> tclTHEN (refined id) reflexivity)]
+        onLastHypId (fun id -> tclTHEN (refined id) reflexivity)])
   end
 
 (* Error messages of the inversion tactics *)
@@ -486,7 +494,7 @@ let wrap_inv_error id = function
 	(strbrk "Inversion would require case analysis on sort " ++
 	pr_sort k ++
 	strbrk " which is not allowed for inductive definition " ++
-	pr_inductive (Global.env()) i ++ str ".")))
+	pr_inductive (Global.env()) (fst i) ++ str ".")))
   | e -> Proofview.tclZERO e
 
 (* The most general inversion tactic *)
diff --git a/tactics/leminv.ml b/tactics/leminv.ml
index 5e5de2589..23a7c9e53 100644
--- a/tactics/leminv.ml
+++ b/tactics/leminv.ml
@@ -194,7 +194,7 @@ 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 pf = Proof.start Evd.empty [invEnv,invGoal] in
+  let pf = Proof.start Evd.empty [invEnv,(invGoal,get_universe_context_set sigma)] in
   let pf =
     fst (Proof.run_tactic env (
       tclTHEN intro (onLastHypId inv_op)) pf)
@@ -232,6 +232,9 @@ let add_inversion_lemma name env sigma t sort dep inv_op =
     const_entry_body = Future.from_val (invProof,Declareops.no_seff);
     const_entry_secctx = None;
     const_entry_type = None;
+    const_entry_proj = None;
+    const_entry_polymorphic = true;
+    const_entry_universes = Univ.UContext.empty (*FIXME *);
     const_entry_opaque = false;
     const_entry_inline_code = false;
     const_entry_feedback = None;
@@ -244,8 +247,9 @@ let add_inversion_lemma name env sigma t sort dep inv_op =
 
 let add_inversion_lemma_exn na com comsort bool tac =
   let env = Global.env () and sigma = Evd.empty in
-  let c = Constrintern.interp_type sigma env com in
-  let sort = Pretyping.interp_sort comsort in
+  let c,ctx = Constrintern.interp_type sigma env com in
+  let sigma = Evd.merge_context_set Evd.univ_rigid sigma ctx in
+  let sigma, sort = Pretyping.interp_sort sigma comsort in
   try
     add_inversion_lemma na env sigma c sort bool tac
   with
@@ -260,7 +264,7 @@ let lemInv id c gls =
   try
     let clause = mk_clenv_type_of gls c in
     let clause = clenv_constrain_last_binding (mkVar id) clause in
-    Clenvtac.res_pf clause ~flags:Unification.elim_flags gls
+    Clenvtac.res_pf clause ~flags:(Unification.elim_flags ()) gls
   with
     | NoSuchBinding ->
 	errorlabstrm ""
diff --git a/tactics/nbtermdn.ml b/tactics/nbtermdn.ml
new file mode 100644
index 000000000..b07aff99b
--- /dev/null
+++ b/tactics/nbtermdn.ml
@@ -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        *)
+(************************************************************************)
+
+open Util
+open Names
+open Term
+open Pattern
+open Globnames
+
+(* Named, bounded-depth, term-discrimination nets.
+   Implementation:
+   Term-patterns are stored in discrimination-nets, which are
+   themselves stored in a hash-table, indexed by the first label.
+   They are also stored by name in a table on-the-side, so that we can
+   override them if needed. *)
+
+(* The former comments are from Chet.
+   See the module dn.ml for further explanations.
+   Eduardo (5/8/97) *)
+module Make = 
+  functor (Y:Map.OrderedType) ->
+struct
+  module X = struct
+    type t = constr_pattern*int
+    let compare = Pervasives.compare
+  end
+
+  module Term_dn = Termdn.Make(Y)
+  open Term_dn
+  module Z = struct 
+     type t = Term_dn.term_label
+     let compare x y =  
+       let make_name n =
+	 match n with
+	 | GRLabel(ConstRef con) -> 
+	     GRLabel(ConstRef(constant_of_kn(canonical_con con)))
+	 | GRLabel(IndRef (kn,i)) ->
+	     GRLabel(IndRef(mind_of_kn(canonical_mind kn),i))
+	 | GRLabel(ConstructRef ((kn,i),j ))->
+	     GRLabel(ConstructRef((mind_of_kn(canonical_mind kn),i),j))
+	 | k -> k
+       in
+	 Pervasives.compare (make_name x) (make_name y)
+  end
+
+  module Dn = Dn.Make(X)(Z)(Y)
+  module Bounded_net = Btermdn.Make(Y)
+
+    
+type 'na t = {
+  mutable table : ('na,constr_pattern * Y.t) Gmap.t;
+  mutable patterns : (Term_dn.term_label option,Bounded_net.t) Gmap.t }
+
+
+type 'na frozen_t = 
+    ('na,constr_pattern * Y.t) Gmap.t
+    * (Term_dn.term_label option, Bounded_net.t) Gmap.t
+
+let create () =
+  { table = Gmap.empty;
+    patterns = Gmap.empty }
+
+let get_dn dnm hkey =
+  try Gmap.find hkey dnm with Not_found -> Bounded_net.create ()
+
+let add dn (na,(pat,valu)) =
+  let hkey = Option.map fst (Term_dn.constr_pat_discr pat) in 
+  dn.table <- Gmap.add na (pat,valu) dn.table;
+  let dnm = dn.patterns in
+  dn.patterns <- Gmap.add hkey (Bounded_net.add None (get_dn dnm hkey) (pat,valu)) dnm
+
+let rmv dn na =
+  let (pat,valu) = Gmap.find na dn.table in
+  let hkey = Option.map fst (Term_dn.constr_pat_discr pat) in 
+  dn.table <- Gmap.remove na dn.table;
+  let dnm = dn.patterns in
+  dn.patterns <- Gmap.add hkey (Bounded_net.rmv None (get_dn dnm hkey) (pat,valu)) dnm
+
+let in_dn dn na = Gmap.mem na dn.table
+
+let remap ndn na (pat,valu) =
+  rmv ndn na;
+  add ndn (na,(pat,valu))
+
+let decomp = 
+  let rec decrec acc c = match kind_of_term c with
+    | App (f,l) -> decrec (Array.fold_right (fun a l -> a::l) l acc) f
+    | Cast (c1,_,_) -> decrec acc c1
+    | _ -> (c,acc)
+  in 
+  decrec []
+
+  let constr_val_discr t =
+  let c, l = decomp t in
+    match kind_of_term c with
+    | Ind (ind_sp,_) -> Dn.Label(Term_dn.GRLabel (IndRef ind_sp),l)
+    | Construct (cstr_sp,_) -> Dn.Label(Term_dn.GRLabel (ConstructRef cstr_sp),l)
+    | Var id -> Dn.Label(Term_dn.GRLabel (VarRef id),l)
+    | Const _ -> Dn.Everything
+    | _ -> Dn.Nothing
+
+let lookup dn valu =
+  let hkey =
+    match (constr_val_discr valu) with
+    | Dn.Label(l,_) -> Some l
+    | _ -> None
+  in
+  try Bounded_net.lookup None (Gmap.find hkey dn.patterns) valu with Not_found -> []
+
+let app f dn = Gmap.iter f dn.table
+
+let dnet_depth = Btermdn.dnet_depth
+
+let freeze dn = (dn.table, dn.patterns)
+
+let unfreeze (fnm,fdnm) dn =
+  dn.table <- fnm;
+  dn.patterns <- fdnm
+
+let empty dn =
+  dn.table <- Gmap.empty;
+  dn.patterns <- Gmap.empty
+
+let to2lists dn =
+  (Gmap.to_list dn.table, Gmap.to_list dn.patterns)
+end
diff --git a/tactics/rewrite.ml b/tactics/rewrite.ml
index ae73d7a41..83cb15f47 100644
--- a/tactics/rewrite.ml
+++ b/tactics/rewrite.ml
@@ -8,6 +8,8 @@
 
 (*i camlp4deps: "grammar/grammar.cma" i*)
 
+open Names
+open Pp
 open Errors
 open Util
 open Nameops
@@ -32,91 +34,86 @@ open Decl_kinds
 open Elimschemes
 open Goal
 open Environ
-open Pp
-open Names
 open Tacinterp
 open Termops
+open Genarg
+open Extraargs
+open Pcoq.Constr
 open Entries
 open Libnames
+open Evarutil
 
 (** Typeclass-based generalized rewriting. *)
 
 (** Constants used by the tactic. *)
 
 let classes_dirpath =
-  DirPath.make (List.map Id.of_string ["Classes";"Coq"])
+  Names.DirPath.make (List.map Id.of_string ["Classes";"Coq"])
 
 let init_setoid () =
   if is_dirpath_prefix_of classes_dirpath (Lib.cwd ()) then ()
   else Coqlib.check_required_library ["Coq";"Setoids";"Setoid"]
 
-let get_class str =
-  let qualid = Qualid (Loc.ghost, qualid_of_string str) in
-    lazy (class_info (Nametab.global qualid))
-
-let proper_class = get_class "Coq.Classes.Morphisms.Proper"
-let proper_proxy_class = get_class "Coq.Classes.Morphisms.ProperProxy"
-
-let proper_proj = lazy (mkConst (Option.get (pi3 (List.hd (Lazy.force proper_class).cl_projs))))
-
 let make_dir l = DirPath.make (List.rev_map Id.of_string l)
 
 let try_find_global_reference dir s =
   let sp = Libnames.make_path (make_dir ("Coq"::dir)) (Id.of_string s) in
     Nametab.global_of_path sp
 
-let try_find_reference dir s =
-  constr_of_global (try_find_global_reference dir s)
+let find_reference dir s =
+  let gr = lazy (try_find_global_reference dir s) in
+    fun () -> Lazy.force gr
 
-let gen_constant dir s = Coqlib.gen_constant "rewrite" dir s
-let coq_eq = lazy(gen_constant ["Init"; "Logic"] "eq")
-let coq_f_equal = lazy (gen_constant ["Init"; "Logic"] "f_equal")
-let coq_all = lazy (gen_constant ["Init"; "Logic"] "all")
-let coq_forall = lazy (gen_constant ["Classes"; "Morphisms"] "forall_def")
-let impl = lazy (gen_constant ["Program"; "Basics"] "impl")
-let arrow = lazy (gen_constant ["Program"; "Basics"] "arrow")
+type evars = evar_map * Evar.Set.t (* goal evars, constraint evars *)
 
-let reflexive_type = lazy (try_find_reference ["Classes"; "RelationClasses"] "Reflexive")
-let reflexive_proof = lazy (try_find_reference ["Classes"; "RelationClasses"] "reflexivity")
+let find_global dir s =
+  let gr = lazy (try_find_global_reference dir s) in
+    fun (evd,cstrs) -> 
+      let evd, c = Evarutil.new_global evd (Lazy.force gr) in
+	(evd, cstrs), c
 
-let symmetric_type = lazy (try_find_reference ["Classes"; "RelationClasses"] "Symmetric")
-let symmetric_proof = lazy (try_find_reference ["Classes"; "RelationClasses"] "symmetry")
+(** Utility for dealing with polymorphic applications *)
 
-let transitive_type = lazy (try_find_reference ["Classes"; "RelationClasses"] "Transitive")
-let transitive_proof = lazy (try_find_reference ["Classes"; "RelationClasses"] "transitivity")
+let app_poly evars f args =
+  let evars, fc = f evars in
+    evars, mkApp (fc, args)
 
-let coq_inverse = lazy (gen_constant ["Program"; "Basics"] "flip")
+let e_app_poly evars f args =
+  let evars', c = app_poly !evars f args in
+    evars := evars';
+    c
 
-let inverse car rel = mkApp (Lazy.force coq_inverse, [| car ; car; mkProp; rel |])
+(** Global constants. *)
 
-let forall_relation = lazy (gen_constant ["Classes"; "Morphisms"] "forall_relation")
-let pointwise_relation = lazy (gen_constant ["Classes"; "Morphisms"] "pointwise_relation")
-let respectful = lazy (gen_constant ["Classes"; "Morphisms"] "respectful")
-let default_relation = lazy (gen_constant ["Classes"; "SetoidTactics"] "DefaultRelation")
-let subrelation = lazy (gen_constant ["Classes"; "RelationClasses"] "subrelation")
-let do_subrelation = lazy (gen_constant ["Classes"; "Morphisms"] "do_subrelation")
-let apply_subrelation = lazy (gen_constant ["Classes"; "Morphisms"] "apply_subrelation")
-let coq_relation = lazy (gen_constant ["Relations";"Relation_Definitions"] "relation")
-let mk_relation a = mkApp (Lazy.force coq_relation, [| a |])
-let rewrite_relation_class = lazy (gen_constant ["Classes"; "RelationClasses"] "RewriteRelation")
+let gen_reference dir s = Coqlib.gen_reference "rewrite" dir s
+let coq_eq_ref = find_reference ["Init"; "Logic"] "eq"
+let coq_eq = find_global ["Init"; "Logic"] "eq"
+let coq_f_equal = find_global ["Init"; "Logic"] "f_equal"
+let coq_all = find_global ["Init"; "Logic"] "all"
+let impl = find_global ["Program"; "Basics"] "impl"
+let arrow = find_global ["Program"; "Basics"] "arrow"
+let coq_inverse = find_global ["Program"; "Basics"] "flip"
 
-let proper_type = lazy (constr_of_global (Lazy.force proper_class).cl_impl)
-let proper_proxy_type = lazy (constr_of_global (Lazy.force proper_proxy_class).cl_impl)
+(* let coq_inverse = lazy (gen_constant ["Program"; "Basics"] "flip") *)
 
-(** Utility functions *)
+(* let inverse car rel = mkApp (Lazy.force coq_inverse, [| car ; car; mkProp; rel |]) *)
 
-let split_head = function
-    hd :: tl -> hd, tl
-  | [] -> assert(false)
+(* let forall_relation = lazy (gen_constant ["Classes"; "Morphisms"] "forall_relation") *)
+(* let pointwise_relation = lazy (gen_constant ["Classes"; "Morphisms"] "pointwise_relation") *)
+(* let respectful = lazy (gen_constant ["Classes"; "Morphisms"] "respectful") *)
+(* let default_relation = lazy (gen_constant ["Classes"; "SetoidTactics"] "DefaultRelation") *)
+(* let subrelation = lazy (gen_constant ["Classes"; "RelationClasses"] "subrelation") *)
+(* let do_subrelation = lazy (gen_constant ["Classes"; "Morphisms"] "do_subrelation") *)
+(* let apply_subrelation = lazy (gen_constant ["Classes"; "Morphisms"] "apply_subrelation") *)
+(* let coq_relation = lazy (gen_constant ["Relations";"Relation_Definitions"] "relation") *)
+(* let mk_relation a = mkApp (Lazy.force coq_relation, [| a |]) *)
 
-let evd_convertible env evd x y =
-  try ignore(Evarconv.the_conv_x env x y evd); true
-  with e when Errors.noncritical e -> false
+(* let proper_type = lazy (Universes.constr_of_global (Lazy.force proper_class).cl_impl) *)
+(* let proper_proxy_type = lazy (Universes.constr_of_global (Lazy.force proper_proxy_class).cl_impl) *)
 
-let convertible env evd x y =
-  Reductionops.is_conv env evd x y
 
-(** Bookkeeping which evars are constraints so that we can
+
+(** Bookkeeping which evars are constraints so that we can 
     remove them at the end of the tactic. *)
 
 let goalevars evars = fst evars
@@ -127,10 +124,17 @@ let new_cstr_evar (evd,cstrs) env t =
     (evd', Evar.Set.add (fst (destEvar t)) cstrs), t
 
 (** Building or looking up instances. *)
+let e_new_cstr_evar evars env t =
+  let evd', t = new_cstr_evar !evars env t in evars := evd'; t
+
+let new_goal_evar (evd,cstrs) env t =
+  let evd', t = Evarutil.new_evar evd env t in
+    (evd', cstrs), t
+
+let e_new_goal_evar evars env t =
+  let evd', t = new_goal_evar !evars env t in evars := evd'; t
 
-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
+(** Building or looking up instances. *)
 
 let extends_undefined evars evars' =
   let f ev evi found = found || not (Evd.mem evars ev)
@@ -138,95 +142,328 @@ let extends_undefined evars evars' =
 
 let find_class_proof proof_type proof_method env evars carrier relation =
   try
-    let goal = mkApp (Lazy.force proof_type, [| carrier ; relation |]) in
-    let evars', c = Typeclasses.resolve_one_typeclass env evars goal in
-      if extends_undefined evars evars' then raise Not_found
-      else mkApp (Lazy.force proof_method, [| carrier; relation; c |])
+    let evars, goal = app_poly evars proof_type [| carrier ; relation |] in
+    let evars', c = Typeclasses.resolve_one_typeclass env (goalevars evars) goal in
+      if extends_undefined (goalevars evars) evars' then raise Not_found
+      else app_poly (evars',cstrevars evars) proof_method [| carrier; relation; c |]
   with e when Logic.catchable_exception e -> raise Not_found
+ 
+(** Utility functions *)
 
-let get_reflexive_proof env = find_class_proof reflexive_type reflexive_proof env
-let get_symmetric_proof env = find_class_proof symmetric_type symmetric_proof env
-let get_transitive_proof env = find_class_proof transitive_type transitive_proof env
-
-(** Build an infered signature from constraints on the arguments and expected output
-    relation *)
-
-let build_signature evars env m (cstrs : (types * types option) option list)
-    (finalcstr : (types * types option) option) =
-  let mk_relty evars newenv ty obj =
-    match obj with
+module GlobalBindings (M : sig
+  val relation_classes : string list
+  val morphisms : string list
+  val relation : string list * string
+end) = struct
+  open M
+  let relation : evars -> evars * constr = find_global (fst relation) (snd relation)
+
+  let reflexive_type = find_global relation_classes "Reflexive"
+  let reflexive_proof = find_global relation_classes "reflexivity"
+    
+  let symmetric_type = find_global relation_classes "Symmetric"
+  let symmetric_proof = find_global relation_classes "symmetry"
+
+  let transitive_type = find_global relation_classes "Transitive"
+  let transitive_proof = find_global relation_classes "transitivity"
+
+  let forall_relation = find_global morphisms "forall_relation"
+  let pointwise_relation = find_global morphisms "pointwise_relation"
+
+  let forall_relation_ref = find_reference morphisms "forall_relation"
+  let pointwise_relation_ref = find_reference morphisms "pointwise_relation"
+
+  let respectful = find_global morphisms "respectful"
+  let respectful_ref = find_reference morphisms "respectful"
+
+  let default_relation = find_global ["Classes"; "SetoidTactics"] "DefaultRelation"
+
+  let coq_forall = find_global morphisms "forall_def"
+
+  let subrelation = find_global relation_classes "subrelation"
+  let do_subrelation = find_global morphisms "do_subrelation"
+  let apply_subrelation = find_global morphisms "apply_subrelation"
+
+  let rewrite_relation_class = find_global relation_classes "RewriteRelation"
+
+  let proper_class = lazy (class_info (try_find_global_reference morphisms "Proper"))
+  let proper_proxy_class = lazy (class_info (try_find_global_reference morphisms "ProperProxy"))
+    
+  let proper_proj = lazy (mkConst (Option.get (pi3 (List.hd (Lazy.force proper_class).cl_projs))))
+    
+  let proper_type = 
+    let l = lazy (Lazy.force proper_class).cl_impl in
+      fun (evd,cstrs) -> 
+	let evd, c = Evarutil.new_global evd (Lazy.force l) in
+	  (evd, cstrs), c
+	
+  let proper_proxy_type = 
+    let l = lazy (Lazy.force proper_proxy_class).cl_impl in
+      fun (evd,cstrs) -> 
+	let evd, c = Evarutil.new_global evd (Lazy.force l) in
+	  (evd, cstrs), c
+
+  let proper_proof env evars carrier relation x =
+    let evars, goal = app_poly evars proper_proxy_type [| carrier ; relation; x |] in
+      new_cstr_evar evars env goal
+
+  let get_reflexive_proof env = find_class_proof reflexive_type reflexive_proof env
+  let get_symmetric_proof env = find_class_proof symmetric_type symmetric_proof env
+  let get_transitive_proof env = find_class_proof transitive_type transitive_proof env
+
+  let mk_relation evd a = 
+    app_poly evd relation [| a |]
+
+  (** Build an infered signature from constraints on the arguments and expected output
+      relation *)
+    
+  let build_signature evars env m (cstrs : (types * types option) option list)
+      (finalcstr : (types * types option) option) =
+    let mk_relty evars newenv ty obj =
+      match obj with
       | None | Some (_, None) ->
-	  let relty = mk_relation ty in
-	    if closed0 ty then
-	      let env' = Environ.reset_with_named_context (Environ.named_context_val env) env in
-		new_cstr_evar evars env' relty
-	    else new_cstr_evar evars newenv relty
+	let evars, relty = mk_relation evars ty in
+	  if closed0 ty then 
+	    let env' = Environ.reset_with_named_context (Environ.named_context_val env) env in
+	      new_cstr_evar evars env' relty
+	  else new_cstr_evar evars newenv relty
       | Some (x, Some rel) -> evars, rel
-  in
-  let rec aux env evars ty l =
-    let t = Reductionops.whd_betadeltaiota env (fst evars) ty in
-      match kind_of_term t, l with
-      | Prod (na, ty, b), obj :: cstrs ->
+    in
+    let rec aux env evars ty l =
+      let t = Reductionops.whd_betadeltaiota env (goalevars evars) ty in
+	match kind_of_term t, l with
+	| Prod (na, ty, b), obj :: cstrs ->
 	  if noccurn 1 b (* non-dependent product *) then
-	    let ty = Reductionops.nf_betaiota (fst evars) ty in
+	    let ty = Reductionops.nf_betaiota (goalevars evars) ty in
 	    let (evars, b', arg, cstrs) = aux env evars (subst1 mkProp b) cstrs in
 	    let evars, relty = mk_relty evars env ty obj in
-	    let newarg = mkApp (Lazy.force respectful, [| ty ; b' ; relty ; arg |]) in
+	    let evars, newarg = app_poly evars respectful [| ty ; b' ; relty ; arg |] in
 	      evars, mkProd(na, ty, b), newarg, (ty, Some relty) :: cstrs
 	  else
-	    let (evars, b, arg, cstrs) = aux (Environ.push_rel (na, None, ty) env) evars b cstrs in
-	    let ty = Reductionops.nf_betaiota (fst evars) ty in
+	    let (evars, b, arg, cstrs) = 
+	      aux (Environ.push_rel (na, None, ty) env) evars b cstrs 
+	    in
+	    let ty = Reductionops.nf_betaiota (goalevars evars) ty in
 	    let pred = mkLambda (na, ty, b) in
 	    let liftarg = mkLambda (na, ty, arg) in
-	    let arg' = mkApp (Lazy.force forall_relation, [| ty ; pred ; liftarg |]) in
+	    let evars, arg' = app_poly evars forall_relation [| ty ; pred ; liftarg |] in
 	      if Option.is_empty obj then evars, mkProd(na, ty, b), arg', (ty, None) :: cstrs
 	      else error "build_signature: no constraint can apply on a dependent argument"
-      | _, obj :: _ -> anomaly ~label:"build_signature" (Pp.str "not enough products")
-      | _, [] ->
+	| _, obj :: _ -> anomaly ~label:"build_signature" (Pp.str "not enough products")
+	| _, [] ->
 	  (match finalcstr with
 	  | None | Some (_, None) ->
-	      let t = Reductionops.nf_betaiota (fst evars) ty in
-	      let evars, rel = mk_relty evars env t None in
-		evars, t, rel, [t, Some rel]
+	    let t = Reductionops.nf_betaiota (fst evars) ty in
+	    let evars, rel = mk_relty evars env t None in
+	      evars, t, rel, [t, Some rel]
 	  | Some (t, Some rel) -> evars, t, rel, [t, Some rel])
-  in aux env evars m cstrs
+    in aux env evars m cstrs
 
-type hypinfo = {
-  cl : clausenv;
-  ext : Evar.Set.t; (* New evars in this clausenv *)
-  prf : constr;
-  car : constr;
-  rel : constr;
-  c1 : constr;
-  c2 : constr;
-  c  : (Tacinterp.interp_sign * Tacexpr.glob_constr_and_expr with_bindings) option;
-  abs : bool;
-}
+  (** Folding/unfolding of the tactic constants. *)
+
+  let unfold_impl t =
+    match kind_of_term t with
+    | App (arrow, [| a; b |])(*  when eq_constr arrow (Lazy.force impl) *) ->
+      mkProd (Anonymous, a, lift 1 b)
+    | _ -> assert false
+
+  let unfold_all t =
+    match kind_of_term t with
+    | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) ->
+      (match kind_of_term b with
+      | Lambda (n, ty, b) -> mkProd (n, ty, b)
+      | _ -> assert false)
+    | _ -> assert false
+
+  let unfold_forall t =
+    match kind_of_term t with
+    | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) ->
+      (match kind_of_term b with
+      | Lambda (n, ty, b) -> mkProd (n, ty, b)
+      | _ -> assert false)
+    | _ -> assert false
+
+  let arrow_morphism evd ta tb a b =
+    let ap = is_Prop ta and bp = is_Prop tb in
+      if ap && bp then app_poly evd impl [| a; b |], unfold_impl
+      else if ap then (* Domain in Prop, CoDomain in Type *)
+	(evd, mkProd (Anonymous, a, b)), (fun x -> x)
+      else if bp then (* Dummy forall *)
+	(app_poly evd coq_all [| a; mkLambda (Anonymous, a, b) |]), unfold_forall
+      else (* None in Prop, use arrow *)
+	(app_poly evd arrow [| a; b |]), unfold_impl
+
+  let rec decomp_pointwise n c =
+    if Int.equal n 0 then c
+    else
+      match kind_of_term c with
+      | App (f, [| a; b; relb |]) when Globnames.is_global (pointwise_relation_ref ()) f ->
+	decomp_pointwise (pred n) relb
+      | App (f, [| a; b; arelb |]) when Globnames.is_global (forall_relation_ref ()) f ->
+	decomp_pointwise (pred n) (Reductionops.beta_applist (arelb, [mkRel 1]))
+      | _ -> invalid_arg "decomp_pointwise"
+
+  let rec apply_pointwise rel = function
+    | arg :: args ->
+      (match kind_of_term rel with
+      | App (f, [| a; b; relb |]) when Globnames.is_global (pointwise_relation_ref ()) f ->
+	apply_pointwise relb args
+      | App (f, [| a; b; arelb |]) when Globnames.is_global (forall_relation_ref ()) f ->
+	apply_pointwise (Reductionops.beta_applist (arelb, [arg])) args
+      | _ -> invalid_arg "apply_pointwise")
+    | [] -> rel
+
+  let pointwise_or_dep_relation evd n t car rel =
+    if noccurn 1 car && noccurn 1 rel then
+      app_poly evd pointwise_relation [| t; lift (-1) car; lift (-1) rel |]
+    else
+      app_poly evd forall_relation
+	[| t; mkLambda (n, t, car); mkLambda (n, t, rel) |]
+
+  let lift_cstr env evars (args : constr list) c ty cstr =
+    let start evars env car =
+      match cstr with
+      | None | Some (_, None) -> 
+	let evars, rel = mk_relation evars car in
+	  new_cstr_evar evars env rel
+      | Some (ty, Some rel) -> evars, rel
+    in
+    let rec aux evars env prod n = 
+      if Int.equal n 0 then start evars env prod
+      else
+	match kind_of_term (Reduction.whd_betadeltaiota env prod) with
+	| Prod (na, ty, b) ->
+	  if noccurn 1 b then
+	    let b' = lift (-1) b in
+	    let evars, rb = aux evars env b' (pred n) in
+	      app_poly evars pointwise_relation [| ty; b'; rb |]
+	  else
+	    let evars, rb = aux evars (Environ.push_rel (na, None, ty) env) b (pred n) in
+	      app_poly evars forall_relation
+		[| ty; mkLambda (na, ty, b); mkLambda (na, ty, rb) |]
+	| _ -> raise Not_found
+    in 
+    let rec find env c ty = function
+      | [] -> None
+      | arg :: args ->
+	try let evars, found = aux evars env ty (succ (List.length args)) in
+	      Some (evars, found, c, ty, arg :: args)
+	with Not_found ->
+	  find env (mkApp (c, [| arg |])) (prod_applist ty [arg]) args
+    in find env c ty args
+
+  let unlift_cstr env sigma = function
+    | None -> None
+    | Some codom -> Some (decomp_pointwise 1 codom)
+
+end
+
+(* let my_type_of env evars c = Typing.e_type_of env evars c *)
+(* let mytypeofkey = Profile.declare_profile "my_type_of";; *)
+(* let my_type_of = Profile.profile3 mytypeofkey my_type_of *)
+
+
+let type_app_poly env evd f args =
+  let evars, c = app_poly evd f args in
+  let evd', t = Typing.e_type_of env (goalevars evars) c in
+    (evd', cstrevars evars), c
+
+module PropGlobal = struct
+  module Consts =
+  struct 
+    let relation_classes = ["Classes"; "RelationClasses"]
+    let morphisms = ["Classes"; "Morphisms"]
+    let relation = ["Relations";"Relation_Definitions"], "relation"
+  end
+
+  module G = GlobalBindings(Consts)
+
+  include G
+  include Consts
+  let inverse env evd car rel = 
+    type_app_poly env evd coq_inverse [| car ; car; mkProp; rel |]
+      (* app_poly evd coq_inverse [| car ; car; mkProp; rel |] *)
+
+end
+
+module TypeGlobal = struct
+  module Consts = 
+    struct 
+      let relation_classes = ["Classes"; "CRelationClasses"]
+      let morphisms = ["Classes"; "CMorphisms"]
+      let relation = relation_classes, "crelation"
+    end
+
+  module G = GlobalBindings(Consts)
+  include G
+
+
+  let inverse env (evd,cstrs) car rel = 
+    let evd, (sort,_) = Evarutil.new_type_evar Evd.univ_flexible evd env in
+      app_poly (evd,cstrs) coq_inverse [| car ; car; sort; rel |]
+
+end
+
+let sort_of_rel env evm rel =
+  Reductionops.sort_of_arity env evm (Retyping.get_type_of env evm rel)
 
 (** Looking up declared rewrite relations (instances of [RewriteRelation]) *)
 let is_applied_rewrite_relation env sigma rels t =
   match kind_of_term t with
   | App (c, args) when Array.length args >= 2 ->
       let head = if isApp c then fst (destApp c) else c in
-	if eq_constr (Lazy.force coq_eq) head then None
+	if Globnames.is_global (coq_eq_ref ()) head then None
 	else
 	  (try
 	      let params, args = Array.chop (Array.length args - 2) args in
 	      let env' = Environ.push_rel_context rels env in
-	      let evd, evar = Evarutil.new_evar sigma env' (new_Type ()) in
-	      let inst = mkApp (Lazy.force rewrite_relation_class, [| evar; mkApp (c, params) |]) in
-	      let _ = Typeclasses.resolve_one_typeclass env' evd inst in
+	      let evars, (evar, _) = Evarutil.new_type_evar Evd.univ_flexible sigma env' in
+	      let evars, inst = 
+		app_poly (evars,Evar.Set.empty)
+		  TypeGlobal.rewrite_relation_class [| evar; mkApp (c, params) |] in
+	      let _ = Typeclasses.resolve_one_typeclass env' (goalevars evars) inst in
 		Some (it_mkProd_or_LetIn t rels)
 	  with e when Errors.noncritical e -> None)
   | _ -> None
 
-let rec decompose_app_rel env evd t =
+(* let _ = *)
+(*   Hook.set Equality.is_applied_rewrite_relation is_applied_rewrite_relation *)
+
+let split_head = function
+    hd :: tl -> hd, tl
+  | [] -> assert(false)
+
+let evd_convertible env evd x y =
+  try ignore(Evarconv.the_conv_x env x y evd); true
+  with e when Errors.noncritical e -> false
+
+let convertible env evd x y =
+  Reductionops.is_conv env evd x y
+
+type hypinfo = {
+  cl : clausenv;
+  prf : constr;
+  car : constr;
+  rel : constr;
+  sort : bool; (* true = Prop; false = Type *)
+  l2r : bool;
+  c1 : constr;
+  c2 : constr;
+  c  : (Tacinterp.interp_sign * Tacexpr.glob_constr_and_expr with_bindings) option;
+  abs : (constr * types) option;
+  flags : Unification.unify_flags;
+}
+
+let get_symmetric_proof b = 
+  if b then PropGlobal.get_symmetric_proof else TypeGlobal.get_symmetric_proof
+
+let rec decompose_app_rel env evd t = 
   match kind_of_term t with
-  | App (f, args) ->
-      if Array.length args > 1 then
+  | App (f, args) -> 
+      if Array.length args > 1 then 
 	let fargs, args = Array.chop (Array.length args - 2) args in
 	  mkApp (f, fargs), args
-      else
+      else 
 	let (f', args) = decompose_app_rel env evd args.(0) in
 	let ty = Typing.type_of env evd args.(0) in
 	let f'' = mkLambda (Name (Id.of_string "x"), ty,
@@ -235,37 +472,46 @@ 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 orig (c,l) =
-  let ctype = Typing.type_of env sigma c in
+let decompose_applied_relation env origsigma sigma flags orig (c,l) left2right =
+  let c' = c in
+  let ctype = Typing.type_of env sigma c' in
   let find_rel ty =
-    let eqclause = Clenv.make_clenv_binding_env_apply env sigma None (c, ty) l in
+    let eqclause = Clenv.make_clenv_binding_env_apply env sigma None (c',ty) l in
     let (equiv, args) = decompose_app_rel env eqclause.evd (Clenv.clenv_type eqclause) in
-    let c1 = args.(0) and c2 = args.(1) in
+    let c1 = args.(0) and c2 = args.(1) in 
     let ty1, ty2 =
       Typing.type_of env eqclause.evd c1, Typing.type_of env eqclause.evd c2
     in
       if not (evd_convertible env eqclause.evd ty1 ty2) then None
       else
+	let sort = sort_of_rel env eqclause.evd equiv in
 	let value = Clenv.clenv_value eqclause in
-	let ext = Evarutil.evars_of_term value in
-	  Some { cl=eqclause; ext=ext; prf=value;
-		 car=ty1; rel = equiv; c1=c1; c2=c2; c=orig; abs=false; }
+	let eqclause = { eqclause with evd = Evd.diff eqclause.evd origsigma } in
+	  Some { cl=eqclause; prf=value;
+		 car=ty1; rel = equiv; sort = Sorts.is_prop sort;
+		 l2r=left2right; c1=c1; c2=c2; c=orig; abs=None;
+		 flags = flags }
   in
     match find_rel ctype with
     | Some c -> c
     | None ->
-	let ctx,t' = Reductionops.splay_prod_assum env sigma ctype in (* Search for underlying eq *)
-	match find_rel (it_mkProd_or_LetIn t' ctx) with
+	let ctx,t' = Reductionops.splay_prod env sigma ctype in (* Search for underlying eq *)
+	match find_rel (it_mkProd_or_LetIn t' (List.map (fun (n,t) -> n, None, t) ctx)) with
 	| Some c -> c
 	| None -> error "The term does not end with an applied homogeneous relation."
 
-let decompose_applied_relation_expr env sigma (is, (c,l)) =
-  let sigma, cbl = Tacinterp.interp_open_constr_with_bindings is env sigma (c,l) in
-  decompose_applied_relation env sigma (Some (is, (c,l))) cbl
+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 sigma' flags (Some (is, (c,l))) cbl left2right
+
+let rewrite_db = "rewrite"
 
-(** Hint database named "rewrite", now created directly in Auto *)
+let conv_transparent_state = (Id.Pred.empty, Cpred.full)
 
-let rewrite_db = Auto.rewrite_db
+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)
@@ -288,10 +534,10 @@ let rewrite_unif_flags = {
 }
 
 let rewrite2_unif_flags =
-  {  Unification.modulo_conv_on_closed_terms = Some cst_full_transparent_state;
+  {  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 = cst_full_transparent_state;
+     Unification.modulo_delta_types = conv_transparent_state;
      Unification.modulo_delta_in_merge = None;
      Unification.check_applied_meta_types = true;
      Unification.resolve_evars = false;
@@ -304,7 +550,7 @@ let rewrite2_unif_flags =
      Unification.allow_K_in_toplevel_higher_order_unification = true
   }
 
-let general_rewrite_unif_flags () =
+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;
@@ -322,13 +568,14 @@ let general_rewrite_unif_flags () =
        Unification.allow_K_in_toplevel_higher_order_unification = true }
 
 let refresh_hypinfo env sigma hypinfo =
-    let {c=c} = hypinfo in
+  if Option.is_empty hypinfo.abs then
+    let {l2r=l2r; c=c;cl=cl;flags=flags} = hypinfo in
       match c with
 	| Some c ->
 	    (* Refresh the clausenv to not get the same meta twice in the goal. *)
-	    decompose_applied_relation_expr env sigma c
+	    decompose_applied_relation_expr env sigma flags c l2r;
 	| _ -> hypinfo
-
+  else hypinfo
 
 let solve_remaining_by by env prf =
   match by with
@@ -336,10 +583,10 @@ let solve_remaining_by by env prf =
   | Some tac ->
     let indep = clenv_independent env in
     let tac = eval_tactic tac in
-    let evd' =
+    let evd' = 
       List.fold_right (fun mv evd ->
         let ty = Clenv.clenv_nf_meta env (meta_type evd mv) in
-	let c,_ = Pfedit.build_by_tactic env.env ty (Tacticals.New.tclCOMPLETE tac) in
+	let c,_,_ = Pfedit.build_by_tactic env.env (ty,Univ.ContextSet.empty) (Tacticals.New.tclCOMPLETE tac) in
 	  meta_assign mv (c, (Conv,TypeNotProcessed)) evd)
       indep env.evd
     in { env with evd = evd' }, prf
@@ -352,35 +599,32 @@ let extend_evd sigma ext sigma' =
 let shrink_evd sigma ext =
   Evar.Set.fold (fun i acc -> Evd.remove acc i) ext sigma
 
-let no_constraints cstrs =
+let no_constraints cstrs = 
   fun ev _ -> not (Evar.Set.mem ev cstrs)
 
-let eq_env x y = x == y
+let poly_inverse sort =
+  if sort then PropGlobal.inverse else TypeGlobal.inverse
 
-let unify_eqn l2r flags env (sigma, cstrs) hypinfo by t =
+let unify_eqn env (sigma, cstrs) hypinfo by t =
   if isEvar t then None
   else try
-    let hypinfo =
-      if hypinfo.abs || eq_env hypinfo.cl.env env then hypinfo
-      else refresh_hypinfo env sigma hypinfo
-    in
-    let {cl=cl; ext=ext; prf=prf; car=car; rel=rel; c1=c1; c2=c2; abs=abs} =
-      hypinfo in
+    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' = Evd.evars_reset_evd ~with_conv_pbs:true sigma cl.evd in
-    let evd'' = extend_evd evd' ext cl.evd in
-    let cl = { cl with evd = evd'' } in
-    let hypinfo, evd', prf, c1, c2, car, rel =
-      if abs then
+    let evd' = Evd.merge sigma cl.evd in
+    let cl = { cl with evd = evd' } in
+    let evd', prf, c1, c2, car, rel =
+      match abs with
+      | Some (absprf, absprfty) ->
 	  let env' = clenv_unify ~flags:rewrite_unif_flags CONV left t cl in
-	    hypinfo, env'.evd, prf, c1, c2, car, rel
-      else
-	  let env' = clenv_unify ~flags CONV left t cl in
+	    env'.evd, prf, c1, c2, car, rel
+      | None ->
+	  let env' = clenv_unify ~flags:!hypinfo.flags CONV left t cl in
 	  let env' = Clenvtac.clenv_pose_dependent_evars true env' in
 	  let evd' = Typeclasses.resolve_typeclasses ~filter:(no_constraints cstrs)
 	    ~fail:true env'.env env'.evd in
 	  let env' = { env' with evd = evd' } in
-	  let env', prf = solve_remaining_by by env' (Clenv.clenv_value env') in
+	  let env', prf = solve_remaining_by by env' (Clenv.clenv_value env') in	   
 	  let nf c = Evarutil.nf_evar env'.evd (Clenv.clenv_nf_meta env' c) in
 	  let c1 = nf c1 and c2 = nf c2
 	  and car = nf car and rel = nf rel
@@ -388,131 +632,41 @@ let unify_eqn l2r flags env (sigma, cstrs) hypinfo by t =
 	  let ty1 = Typing.type_of env'.env env'.evd c1
 	  and ty2 = Typing.type_of env'.env env'.evd c2
 	  in
-	    if convertible env env'.evd ty1 ty2 then
+	    if convertible env env'.evd ty1 ty2 then 
 	      (if occur_meta_or_existential prf then
-		let hypinfo = refresh_hypinfo env env'.evd hypinfo in
-		 (hypinfo, env'.evd, prf, c1, c2, car, rel)
+		(hypinfo := refresh_hypinfo env env'.evd !hypinfo;
+		 env'.evd, prf, c1, c2, car, rel)
 	       else (** Evars have been solved, we can go back to the initial evd,
 			but keep the potential refinement of existing evars. *)
-		let evd' = shrink_evd env'.evd ext in
-		  (hypinfo, evd', prf, c1, c2, car, rel))
+		  env'.evd, prf, c1, c2, car, rel)
 	    else raise Reduction.NotConvertible
     in
-    let res =
-      if l2r then (prf, (car, rel, c1, c2))
+    let evars = evd', Evar.Set.empty in
+    let evd, res =
+      if l2r then evars, (prf, (car, rel, c1, c2))
       else
-	try (mkApp (get_symmetric_proof env evd' car rel,
-		   [| c1 ; c2 ; prf |]),
-	    (car, rel, c2, c1))
+	try
+	  let evars, symprf = get_symmetric_proof !hypinfo.sort env evars car rel in
+	    evars, (mkApp (symprf, [| c1 ; c2 ; prf |]),
+		    (car, rel, c2, c1))
 	with Not_found ->
-	  (prf, (car, inverse car rel, c2, c1))
-    in Some (hypinfo, evd', res)
+	  let evars, rel' = poly_inverse !hypinfo.sort env evars car rel in
+	    evars, (prf, (car, rel', c2, c1))
+    in Some (evd, res)
   with e when Class_tactics.catchable e -> None
 
-let unfold_impl t =
-  match kind_of_term t with
-    | App (arrow, [| a; b |])(*  when eq_constr arrow (Lazy.force impl) *) ->
-	mkProd (Anonymous, a, lift 1 b)
-    | _ -> assert false
-
-let unfold_all t =
-  match kind_of_term t with
-    | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) ->
-	(match kind_of_term b with
-	  | Lambda (n, ty, b) -> mkProd (n, ty, b)
-	  | _ -> assert false)
-    | _ -> assert false
-
-let unfold_forall t =
-  match kind_of_term t with
-    | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) ->
-	(match kind_of_term b with
-	  | Lambda (n, ty, b) -> mkProd (n, ty, b)
-	  | _ -> assert false)
-    | _ -> assert false
-
-let arrow_morphism ta tb a b =
-  let ap = is_Prop ta and bp = is_Prop tb in
-    if ap && bp then mkApp (Lazy.force impl, [| a; b |]), unfold_impl
-    else if ap then (* Domain in Prop, CoDomain in Type *)
-      mkProd (Anonymous, a, b), (fun x -> x)
-    else if bp then (* Dummy forall *)
-      mkApp (Lazy.force coq_all, [| a; mkLambda (Anonymous, a, b) |]), unfold_forall
-    else (* None in Prop, use arrow *)
-      mkApp (Lazy.force arrow, [| a; b |]), unfold_impl
-
-let rec decomp_pointwise n c =
-  if Int.equal n 0 then c
-  else
-    match kind_of_term c with
-    | App (f, [| a; b; relb |]) when eq_constr f (Lazy.force pointwise_relation) ->
-	decomp_pointwise (pred n) relb
-    | App (f, [| a; b; arelb |]) when eq_constr f (Lazy.force forall_relation) ->
-	decomp_pointwise (pred n) (Reductionops.beta_applist (arelb, [mkRel 1]))
-    | _ -> invalid_arg "decomp_pointwise"
-
-let rec apply_pointwise rel = function
-  | arg :: args ->
-      (match kind_of_term rel with
-      | App (f, [| a; b; relb |]) when eq_constr f (Lazy.force pointwise_relation) ->
-	  apply_pointwise relb args
-      | App (f, [| a; b; arelb |]) when eq_constr f (Lazy.force forall_relation) ->
-	  apply_pointwise (Reductionops.beta_applist (arelb, [arg])) args
-      | _ -> invalid_arg "apply_pointwise")
-  | [] -> rel
-
-let pointwise_or_dep_relation n t car rel =
-  if noccurn 1 car && noccurn 1 rel then
-    mkApp (Lazy.force pointwise_relation, [| t; lift (-1) car; lift (-1) rel |])
-  else
-    mkApp (Lazy.force forall_relation,
-	  [| t; mkLambda (n, t, car); mkLambda (n, t, rel) |])
-
-let lift_cstr env evars (args : constr list) c ty cstr =
-  let start evars env car =
-    match cstr with
-    | None | Some (_, None) ->
-      new_cstr_evar evars env (mk_relation car)
-    | Some (ty, Some rel) -> evars, rel
-  in
-  let rec aux evars env prod n =
-    if Int.equal n 0 then start evars env prod
-    else
-      match kind_of_term (Reduction.whd_betadeltaiota env prod) with
-      | Prod (na, ty, b) ->
-	  if noccurn 1 b then
-	    let b' = lift (-1) b in
-	    let evars, rb = aux evars env b' (pred n) in
-	      evars, mkApp (Lazy.force pointwise_relation, [| ty; b'; rb |])
-	  else
-	    let evars, rb = aux evars (Environ.push_rel (na, None, ty) env) b (pred n) in
-	      evars, 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 let evars, found = aux evars env ty (succ (List.length args)) in
-	      Some (evars, found, c, ty, arg :: args)
-	with Not_found ->
-	  find env (mkApp (c, [| arg |])) (prod_applist ty [arg]) args
-  in find env c ty args
-
-let unlift_cstr env sigma = function
-  | None -> None
-  | Some codom -> Some (decomp_pointwise 1 codom)
-
 type rewrite_flags = { under_lambdas : bool; on_morphisms : bool }
 
 let default_flags = { under_lambdas = true; on_morphisms = true; }
 
-type evars = evar_map * Evar.Set.t (* goal evars, constraint evars *)
-
-type rewrite_proof =
+type rewrite_proof = 
   | RewPrf of constr * constr
   | RewCast of cast_kind
 
+let map_rewprf f p = match p with
+  | RewPrf (x, y) -> RewPrf (f x, f y)
+  | RewCast _ -> p
+
 let get_opt_rew_rel = function RewPrf (rel, prf) -> Some rel | _ -> None
 
 type rewrite_result_info = {
@@ -523,34 +677,41 @@ type rewrite_result_info = {
   rew_evars : evars;
 }
 
-type 'a rewrite_result =
-| Fail
-| Same
-| Info of 'a
+type rewrite_result = rewrite_result_info option
 
-type 'a pure_strategy = 'a -> Environ.env -> Id.t list -> constr -> types ->
-  constr option -> evars -> 'a * rewrite_result_info rewrite_result
+type strategy = Environ.env -> Id.t list -> constr -> types ->
+  (bool (* prop *) * constr option) -> evars -> rewrite_result option
 
-type strategy = unit pure_strategy
+let make_eq () =
+(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq ())
+let make_eq_refl () =
+(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq_refl ())
+
+let get_rew_rel r = match r.rew_prf with
+  | RewPrf (rel, prf) -> rel
+  | RewCast c -> mkApp (make_eq (),[| r.rew_car; r.rew_from; r.rew_to |])
 
 let get_rew_prf r = match r.rew_prf with
-  | RewPrf (rel, prf) -> rel, prf
+  | RewPrf (rel, prf) -> rel, prf 
   | RewCast c ->
-    let rel = mkApp (Coqlib.build_coq_eq (), [| r.rew_car |]) in
-      rel, mkCast (mkApp (Coqlib.build_coq_eq_refl (), [| r.rew_car; r.rew_from |]),
+    let rel = mkApp (make_eq (), [| r.rew_car |]) in
+      rel, mkCast (mkApp (make_eq_refl (), [| r.rew_car; r.rew_from |]),
 		   c, mkApp (rel, [| r.rew_from; r.rew_to |]))
 
-let resolve_subrelation env avoid car rel prf rel' res =
+let poly_subrelation sort = 
+  if sort then PropGlobal.subrelation else TypeGlobal.subrelation
+
+let resolve_subrelation env avoid car rel sort prf rel' res =
   if eq_constr rel rel' then res
   else
-    let app = mkApp (Lazy.force subrelation, [|car; rel; rel'|]) in
-    let evars, subrel = new_cstr_evar res.rew_evars env app in
+    let evars, app = app_poly res.rew_evars (poly_subrelation sort) [|car; rel; rel'|] in
+    let evars, subrel = new_cstr_evar evars env app in
     let appsub = mkApp (subrel, [| res.rew_from ; res.rew_to ; prf |]) in
       { res with
 	rew_prf = RewPrf (rel', appsub);
 	rew_evars = evars }
 
-let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' cstr evars =
+let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' (b,cstr) evars =
   let evars, morph_instance, proj, sigargs, m', args, args' =
     let first = match (Array.findi (fun _ b -> not (Option.is_empty b)) args') with
     | Some i -> i
@@ -559,21 +720,23 @@ let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' cstr evars
     let morphargs', morphobjs' = Array.chop first args' in
     let appm = mkApp(m, morphargs) in
     let appmtype = Typing.type_of env (goalevars evars) appm in
-    let cstrs = List.map
-      (Option.map (fun r -> r.rew_car, get_opt_rew_rel r.rew_prf))
-      (Array.to_list morphobjs')
+    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
+    let evars, appmtype', signature, sigargs = 
+      if b then PropGlobal.build_signature evars env appmtype cstrs cstr
+      else TypeGlobal.build_signature evars env appmtype cstrs cstr
     in
       (* Actual signature found *)
     let cl_args = [| appmtype' ; signature ; appm |] in
-    let app = mkApp (Lazy.force proper_type, cl_args) in
+    let evars, app = app_poly evars (if b then PropGlobal.proper_type else TypeGlobal.proper_type)
+      cl_args in
     let env' = Environ.push_named
-      (Id.of_string "do_subrelation",
-       Some (Lazy.force do_subrelation),
-       Lazy.force apply_subrelation)
+      (Id.of_string "do_subrelation", 
+       Some (snd (app_poly evars PropGlobal.do_subrelation [||])), 
+       snd (app_poly evars PropGlobal.apply_subrelation [||]))
       env
     in
     let evars, morph = new_cstr_evar evars env' app in
@@ -589,13 +752,15 @@ let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' cstr evars
 	      and relation = substl subst relation in
 	      (match y with
 	      | None ->
-		  let evars, proof = proper_proof env evars carrier relation x in
+		  let evars, proof = 
+		    (if b then PropGlobal.proper_proof else TypeGlobal.proper_proof) 
+		      env evars carrier relation x in
 		    [ proof ; x ; x ] @ acc, subst, evars, sigargs, x :: typeargs'
 	      | Some r ->
-		  [ snd (get_rew_prf r); r.rew_to; x ] @ acc, subst, evars,
+		  [ snd (get_rew_prf r); r.rew_to; x ] @ acc, subst, evars, 
 	      sigargs, r.rew_to :: typeargs')
 	  | None ->
-	      if not (Option.is_empty y) then
+	      if not (Option.is_empty y) then 
 		error "Cannot rewrite the argument of a dependent function";
 	      x :: acc, x :: subst, evars, sigargs, x :: typeargs')
       ([], [], evars, sigargs, []) args args'
@@ -607,66 +772,68 @@ let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' cstr evars
       | _ -> assert(false)
 
 let apply_constraint env avoid car rel prf cstr res =
-  match cstr with
+  match snd cstr with
   | None -> res
-  | Some r -> resolve_subrelation env avoid car rel prf r res
+  | Some r -> resolve_subrelation env avoid car rel (fst cstr) prf r res
+
+let eq_env x y = x == y
 
-let apply_rule l2r flags by loccs : (hypinfo * int) pure_strategy =
+let apply_rule hypinfo by loccs : strategy =
   let (nowhere_except_in,occs) = convert_occs loccs in
   let is_occ occ =
-    if nowhere_except_in
-    then Int.List.mem occ occs
-    else not (Int.List.mem occ occs)
-  in
-  fun (hypinfo, occ) env avoid t ty cstr evars ->
-    let unif = unify_eqn l2r flags env evars hypinfo by t in
-    match unif with
-    | None -> ((hypinfo, occ), Fail)
-    | Some (hypinfo, evd', (prf, (car, rel, c1, c2))) ->
-      let occ = succ occ in
-      let res =
-        if not (is_occ occ) then Fail
-        else if eq_constr t c2 then Same
-        else
-          let res = { rew_car = ty; rew_from = c1;
-                      rew_to = c2; rew_prf = RewPrf (rel, prf);
-                      rew_evars = evd', cstrevars evars }
-          in Info (apply_constraint env avoid car rel prf cstr res)
-      in
-      ((hypinfo, occ), res)
-
-let apply_lemma l2r flags c by loccs : strategy =
-  fun () env avoid t ty cstr evars ->
-    let hypinfo =
-      decompose_applied_relation env (goalevars evars) None c
+    if nowhere_except_in then List.mem occ occs else not (List.mem occ occs) in
+  let occ = ref 0 in
+    fun env avoid t ty cstr evars ->
+      if not (eq_env !hypinfo.cl.env env) then
+	hypinfo := refresh_hypinfo env (goalevars evars) !hypinfo;
+      let unif = unify_eqn env evars hypinfo by t in
+	if not (Option.is_empty unif) then incr occ;
+	match unif with
+	| Some (evars', (prf, (car, rel, c1, c2))) when is_occ !occ ->
+	    begin
+	      if eq_constr t c2 then Some None
+	      else
+		let res = { rew_car = ty; rew_from = c1;
+			    rew_to = c2; rew_prf = RewPrf (rel, prf); 
+			    rew_evars = evars' }
+		in Some (Some (apply_constraint env avoid car rel prf cstr res))
+	    end
+	| _ -> None
+
+let apply_lemma flags (evm,c) left2right by loccs : strategy =
+  fun env avoid t ty cstr evars ->
+    let hypinfo = 
+      let evars' = Evd.merge (goalevars evars) evm in
+	ref (decompose_applied_relation env (goalevars evars) evars'
+	       flags None c left2right)
     in
-    let _, res = apply_rule l2r flags by loccs (hypinfo, 0) env avoid t ty cstr evars in
-    (), res
+      apply_rule hypinfo by loccs env avoid t ty cstr evars
 
 let make_leibniz_proof c ty r =
-  let prf =
+  let evars = ref r.rew_evars in
+  let prf = 
     match r.rew_prf with
-    | RewPrf (rel, prf) ->
-	let rel = mkApp (Lazy.force coq_eq, [| ty |]) in
+    | RewPrf (rel, prf) -> 
+	let rel = e_app_poly evars coq_eq [| ty |] in
 	let prf =
-	  mkApp (Lazy.force coq_f_equal,
+	  e_app_poly evars coq_f_equal
 		[| r.rew_car; ty;
 		   mkLambda (Anonymous, r.rew_car, c);
-		   r.rew_from; r.rew_to; prf |])
+		   r.rew_from; r.rew_to; prf |]
 	in RewPrf (rel, prf)
     | RewCast k -> r.rew_prf
   in
-    { r with rew_car = ty;
+    { rew_car = ty; rew_evars = !evars;
       rew_from = subst1 r.rew_from c; rew_to = subst1 r.rew_to c; rew_prf = prf }
 
 let reset_env env =
   let env' = Global.env_of_context (Environ.named_context_val env) in
     Environ.push_rel_context (Environ.rel_context env) env'
-
+      
 let fold_match ?(force=false) env sigma c =
   let (ci, p, c, brs) = destCase c in
   let cty = Retyping.get_type_of env sigma c in
-  let dep, pred, exists, (sk, eff) =
+  let dep, pred, exists, (sk,eff) = 
     let env', ctx, body =
       let ctx, pred = decompose_lam_assum p in
       let env' = Environ.push_rel_context ctx env in
@@ -678,7 +845,7 @@ let fold_match ?(force=false) env sigma c =
     let pred = if dep then p else
 	it_mkProd_or_LetIn (subst1 mkProp body) (List.tl ctx)
     in
-    let sk =
+    let sk = 
       if sortp == InProp then
 	if sortc == InProp then
 	  if dep then case_dep_scheme_kind_from_prop
@@ -691,7 +858,7 @@ let fold_match ?(force=false) env sigma c =
 	if dep
 	then case_dep_scheme_kind_from_type
 	else case_scheme_kind_from_type)
-    in
+    in 
     let exists = Ind_tables.check_scheme sk ci.ci_ind in
       if exists || force then
 	dep, pred, exists, Ind_tables.find_scheme sk ci.ci_ind
@@ -702,108 +869,121 @@ let fold_match ?(force=false) env sigma c =
     let pars, args = List.chop ci.ci_npar args in
     let meths = List.map (fun br -> br) (Array.to_list brs) in
       applist (mkConst sk, pars @ [pred] @ meths @ args @ [c])
-  in
+  in 
     sk, (if exists then env else reset_env env), app, eff
 
 let unfold_match env sigma sk app =
   match kind_of_term app with
-  | App (f', args) when eq_constr f' (mkConst sk) ->
-      let v = Environ.constant_value (Global.env ()) sk in
+  | App (f', args) when eq_constant (fst (destConst f')) sk ->
+      let v = Environ.constant_value_in (Global.env ()) (sk,Univ.Instance.empty)(*FIXME*) in
 	Reductionops.whd_beta sigma (mkApp (v, args))
   | _ -> app
 
 let is_rew_cast = function RewCast _ -> true | _ -> false
 
-let coerce env avoid cstr res =
+let coerce env avoid cstr res = 
   let rel, prf = get_rew_prf res in
     apply_constraint env avoid res.rew_car rel prf cstr res
 
-let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy =
-  let rec aux state env avoid t ty cstr evars =
+let subterm all flags (s : strategy) : strategy =
+  let rec aux env avoid t ty (prop, cstr) evars =
     let cstr' = Option.map (fun c -> (ty, Some c)) cstr in
       match kind_of_term t with
       | App (m, args) ->
-	  let rewrite_args state success =
-	    let state, args', evars', progress =
+	  let rewrite_args success =
+	    let args', evars', progress =
 	      Array.fold_left
-		(fun (state, acc, evars, progress) arg ->
-		  if not (Option.is_empty progress) && not all then (state, None :: acc, evars, progress)
+		(fun (acc, evars, progress) arg ->
+		  if not (Option.is_empty progress) && not all then (None :: acc, evars, progress)
 		  else
-		    let state, res = s state env avoid arg (Typing.type_of env (goalevars evars) arg) None evars in
+		    let argty = Typing.type_of env (goalevars evars) arg in
+		    let res = s env avoid arg argty (prop,None) evars in
 		      match res with
-		      | Same -> (state, None :: acc, evars, if Option.is_empty progress then Some false else progress)
-		      | Info r -> (state, Some r :: acc, r.rew_evars, Some true)
-		      | Fail -> (state, None :: acc, evars, progress))
-		(state, [], evars, success) args
+		      | Some None -> (None :: acc, evars, 
+				      if Option.is_empty progress then Some false else progress)
+		      | Some (Some r) -> 
+			(Some r :: acc, r.rew_evars, Some true)
+		      | None -> (None :: acc, evars, progress))
+		([], evars, success) args
 	    in
-	      state, match progress with
-	      | None -> Fail
-	      | Some false -> Same
+	      match progress with
+	      | None -> None
+	      | Some false -> Some None
 	      | Some true ->
 		  let args' = Array.of_list (List.rev args') in
 		    if Array.exists
-		      (function
-			 | None -> false
+		      (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 evars', prf, car, rel, c1, c2 = 
+			resolve_morphism env avoid t m args args' (prop, cstr') evars' 
+		      in
 		      let res = { rew_car = ty; rew_from = c1;
 				  rew_to = c2; rew_prf = RewPrf (rel, prf);
-				  rew_evars = evars' }
-		      in Info res
-		    else
+				  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'
+			   | 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 Info res
+		      in Some (Some res)
 
 	  in
 	    if flags.on_morphisms then
 	      let mty = Typing.type_of env (goalevars evars) m in
-	      let evars, cstr', m, mty, argsl, args =
+	      let evars, cstr', m, mty, argsl, args = 
 		let argsl = Array.to_list args in
-		  match lift_cstr env evars argsl m mty None with
-		  | Some (evars, cstr', m, mty, args) ->
+		let lift = if prop then PropGlobal.lift_cstr else TypeGlobal.lift_cstr in
+		  match lift env evars argsl m mty None with
+		  | Some (evars, cstr', m, mty, args) -> 
 		    evars, Some cstr', m, mty, args, Array.of_list args
 		  | None -> evars, None, m, mty, argsl, args
 	      in
-	      let state, m' = s state env avoid m mty cstr' evars in
+	      let m' = s env avoid m mty (prop, cstr') evars in
 		match m' with
-		| Fail -> rewrite_args state None (* Standard path, try rewrite on arguments *)
-		| Same -> rewrite_args state (Some false)
-		| Info r ->
+		| None -> rewrite_args None (* Standard path, try rewrite on arguments *)
+		| Some None -> rewrite_args (Some false)
+		| Some (Some r) ->
 		    (* We rewrote the function and get a proof of pointwise rel for the arguments.
 		       We just apply it. *)
 		    let prf = match r.rew_prf with
 		      | RewPrf (rel, prf) ->
-			  RewPrf (apply_pointwise rel argsl, mkApp (prf, args))
+			let app = if prop then PropGlobal.apply_pointwise 
+			  else TypeGlobal.apply_pointwise 
+			in
+			  RewPrf (app rel argsl, mkApp (prf, args))
 		      | x -> x
 		    in
 		    let res =
 		      { rew_car = prod_appvect r.rew_car args;
 			rew_from = mkApp(r.rew_from, args); rew_to = mkApp(r.rew_to, args);
-			rew_prf = prf;
-			rew_evars = r.rew_evars }
-		    in
-		      state, match prf with
+			rew_prf = prf; rew_evars = r.rew_evars }
+		    in 
+		      match prf with
 		      | RewPrf (rel, prf) ->
-			Info (apply_constraint env avoid res.rew_car rel prf cstr res)
-		      | RewCast _ -> Info res
-	    else rewrite_args state None
-
+			Some (Some (apply_constraint env avoid res.rew_car
+				      rel prf (prop,cstr) res))
+		      | _ -> Some (Some res)
+	    else rewrite_args None
+	      
       | Prod (n, x, b) when noccurn 1 b ->
 	  let b = subst1 mkProp b in
-	  let tx = Typing.type_of env (goalevars evars) x and tb = Typing.type_of env (goalevars evars) b in
-	  let mor, unfold = arrow_morphism tx tb x b in
-	  let state, res = aux state env avoid mor ty cstr evars in
-	    state, (match res with
-	    | Info r -> Info { r with rew_to = unfold r.rew_to }
-	    | Fail | Same -> res)
+	  let tx = Typing.type_of env (goalevars evars) x 
+	  and tb = Typing.type_of env (goalevars evars) b in
+	  let arr = if prop then PropGlobal.arrow_morphism 
+	    else TypeGlobal.arrow_morphism 
+	  in
+	  let (evars', mor), unfold = arr evars tx tb x b in
+	  let res = aux env avoid mor ty (prop,cstr) evars' in
+	    (match res with
+	    | Some (Some r) -> Some (Some { r with rew_to = unfold r.rew_to })
+	    | _ -> res)
 
       (* 		if x' = None && flags.under_lambdas then *)
       (* 		  let lam = mkLambda (n, x, b) in *)
@@ -821,80 +1001,116 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy =
 
       | Prod (n, dom, codom) ->
 	  let lam = mkLambda (n, dom, codom) in
-	  let app, unfold =
+	  let (evars', 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
+	      (app_poly evars coq_all [| dom; lam |]), TypeGlobal.unfold_all
+	    else 
+	      let forall = if prop then PropGlobal.coq_forall else TypeGlobal.coq_forall in
+		(app_poly evars forall [| dom; lam |]), TypeGlobal.unfold_forall
 	  in
-	  let state, res = aux state env avoid app ty cstr evars in
-	    state, (match res with
-	     | Info r -> Info { r with rew_to = unfold r.rew_to }
-	     | Fail | Same -> res)
+	  let res = aux env avoid app ty (prop,cstr) evars' in
+	    (match res with
+	     | Some (Some r) -> Some (Some { r with rew_to = unfold r.rew_to })
+	     | _ -> res)
+
+(* TODO: real rewriting under binders: introduce x x' (H : R x x') and rewrite with 
+   H at any occurrence of x. Ask for (R ==> R') for the lambda. Formalize this.
+   B. Barras' idea is to have a context of relations, of length 1, with Σ for gluing
+   dependent relations and using projections to get them out.
+ *)
+      (* | Lambda (n, t, b) when flags.under_lambdas -> *)
+      (* 	  let n' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n in *)
+      (* 	  let n'' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n' in *)
+      (* 	  let n''' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n'' in *)
+      (* 	  let rel = new_cstr_evar cstr env (mkApp (Lazy.force coq_relation, [|t|])) in *)
+      (* 	  let env' = Environ.push_rel_context [(n'',None,lift 2 rel);(n'',None,lift 1 t);(n', None, t)] env in *)
+      (* 	  let b' = s env' avoid b (Typing.type_of env' (goalevars evars) (lift 2 b)) (unlift_cstr env (goalevars evars) cstr) evars in *)
+      (* 	    (match b' with *)
+      (* 	    | Some (Some r) -> *)
+      (* 		let prf = match r.rew_prf with *)
+      (* 		  | RewPrf (rel, prf) -> *)
+      (* 		      let rel = pointwise_or_dep_relation n' t r.rew_car rel in *)
+      (* 		      let prf = mkLambda (n', t, prf) in *)
+      (* 			RewPrf (rel, prf) *)
+      (* 		  | x -> x *)
+      (* 		in *)
+      (* 		  Some (Some { r with *)
+      (* 		    rew_prf = prf; *)
+      (* 		    rew_car = mkProd (n, t, r.rew_car); *)
+      (* 		    rew_from = mkLambda(n, t, r.rew_from); *)
+      (* 		    rew_to = mkLambda (n, t, r.rew_to) }) *)
+      (* 	    | _ -> b') *)
 
       | Lambda (n, t, b) when flags.under_lambdas ->
-	  let n' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n in
-	  let env' = Environ.push_rel (n', None, t) env in
-	  let state, b' = s state env' avoid b (Typing.type_of env' (goalevars evars) b) (unlift_cstr env (goalevars evars) cstr) evars in
-	    state, (match b' with
-	    | Info r ->
-		let prf = match r.rew_prf with
-		  | RewPrf (rel, prf) ->
-		      let rel = pointwise_or_dep_relation n' t r.rew_car rel in
-		      let prf = mkLambda (n', t, prf) in
-			RewPrf (rel, prf)
-		  | x -> x
+	let n' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n in
+	let env' = Environ.push_rel (n', None, t) env in
+	let bty = Typing.type_of env' (goalevars evars) b in
+	let unlift = if prop then PropGlobal.unlift_cstr else TypeGlobal.unlift_cstr in
+	let b' = s env' avoid b bty (prop, unlift env evars cstr) evars in
+	  (match b' with
+	  | Some (Some r) ->
+	    let r = match r.rew_prf with
+	      | RewPrf (rel, prf) ->
+		let point = if prop then PropGlobal.pointwise_or_dep_relation else
+		    TypeGlobal.pointwise_or_dep_relation
 		in
-		  Info { r with
-		    rew_prf = prf;
-		    rew_car = mkProd (n, t, r.rew_car);
-		    rew_from = mkLambda(n, t, r.rew_from);
-		    rew_to = mkLambda (n, t, r.rew_to) }
-	    | Fail | Same -> b')
-
+		let evars, rel = point r.rew_evars n' t r.rew_car rel in
+		let prf = mkLambda (n', t, prf) in
+		  { r with rew_prf = RewPrf (rel, prf); rew_evars = evars }
+	      | x -> r
+	    in
+	      Some (Some { r with
+		rew_car = mkProd (n, t, r.rew_car);
+		rew_from = mkLambda(n, t, r.rew_from);
+		rew_to = mkLambda (n, t, r.rew_to) })
+	  | _ -> b')
+	    
       | Case (ci, p, c, brs) ->
-	  let cty = Typing.type_of env (goalevars evars) c in
-	  let cstr' = Some (mkApp (Lazy.force coq_eq, [| cty |])) in
-	  let state, c' = s state env avoid c cty cstr' evars in
-	  let state, res =
-	    match c' with
-	    | Info r ->
-		let res = make_leibniz_proof (mkCase (ci, lift 1 p, mkRel 1, Array.map (lift 1) brs)) ty r in
-		  state, Info (coerce env avoid cstr res)
-	    | Same | Fail ->
-	      if Array.for_all (Int.equal 0) ci.ci_cstr_ndecls then
-		let cstr = Some (mkApp (Lazy.force coq_eq, [| ty |])) in
-		let state, found, brs' = Array.fold_left
-		  (fun (state, found, acc) br ->
-		   if not (Option.is_empty found) then (state, found, fun x -> lift 1 br :: acc x)
-		   else
-                     let state, res = s state env avoid br ty cstr evars in
-		     match res with
-		     | Info r -> (state, Some r, fun x -> mkRel 1 :: acc x)
-		     | Fail | Same -> (state, None, fun x -> lift 1 br :: acc x))
-		  (state, None, fun x -> []) brs
-		in
-		  state, match found with
-		  | Some r ->
-		    let ctxc = mkCase (ci, lift 1 p, lift 1 c, Array.of_list (List.rev (brs' c'))) in
-		      Info (make_leibniz_proof ctxc ty r)
-		  | None -> c'
-	      else
-		match try Some (fold_match env (goalevars evars) t) with Not_found -> None with
-		| None -> state, c'
-		| Some (cst, _, t',_) -> (* eff XXX *)
-                  let state, res = aux state env avoid t' ty cstr evars in
-		  state, match res with
-		  | Info prf ->
-		    Info { prf with
-				 rew_from = t; rew_to = unfold_match env (goalevars evars) cst prf.rew_to }
-		  | x' -> c'
-	  in
-	    state, (match res with
-	     | Info r ->
-	       let rel, prf = get_rew_prf r in
-		 Info (apply_constraint env avoid r.rew_car rel prf cstr r)
-	     | x -> x)
-      | _ -> state, Fail
+	let cty = Typing.type_of env (goalevars evars) c in
+	let evars', eqty = app_poly evars coq_eq [| cty |] in
+	let cstr' = Some eqty in
+	let c' = s env avoid c cty (prop, cstr') evars' in
+	let res = 
+	  match c' with
+	  | Some (Some r) ->
+	    let case = mkCase (ci, lift 1 p, mkRel 1, Array.map (lift 1) brs) in
+	    let res = make_leibniz_proof case ty r in
+	      Some (Some (coerce env avoid (prop,cstr) res))
+	  | x ->
+	    if Array.for_all (Int.equal 0) ci.ci_cstr_ndecls then
+	      let evars', eqty = app_poly evars coq_eq [| ty |] in
+	      let cstr = Some eqty in
+	      let found, brs' = Array.fold_left 
+		(fun (found, acc) br ->
+		  if not (Option.is_empty found) then (found, fun x -> lift 1 br :: acc x)
+		  else
+		    match s env avoid br ty (prop,cstr) evars with
+		    | Some (Some r) -> (Some r, fun x -> mkRel 1 :: acc x)
+		    | _ -> (None, fun x -> lift 1 br :: acc x))
+		(None, fun x -> []) brs
+	      in
+		match found with
+		| Some r ->
+		  let ctxc = mkCase (ci, lift 1 p, lift 1 c, Array.of_list (List.rev (brs' x))) in
+		    Some (Some (make_leibniz_proof ctxc ty r))
+		| None -> x
+	    else
+	      match try Some (fold_match env (goalevars evars) t) with Not_found -> None with
+	      | None -> x
+	      | Some (cst, _, t', eff (*FIXME*)) ->
+		match aux env avoid t' ty (prop,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 (prop,cstr) r))
+	  | x -> x)
+      | _ -> None
   in aux
 
 let all_subterms = subterm true default_flags
@@ -903,25 +1119,35 @@ let one_subterm = subterm false default_flags
 (** Requires transitivity of the rewrite step, if not a reduction.
     Not tail-recursive. *)
 
-let transitivity state env avoid (res : rewrite_result_info) (next : 'a pure_strategy) : 'a * rewrite_result_info rewrite_result =
-  let state, res' = next state env avoid res.rew_to res.rew_car (get_opt_rew_rel res.rew_prf) res.rew_evars in
-  state, match res' with
-  | Fail -> Fail
-  | Same -> Info res
-  | Info res' ->
+let transitivity env avoid prop (res : rewrite_result_info) (next : strategy) : 
+    rewrite_result option =
+  let nextres =
+    next env avoid res.rew_to res.rew_car
+      (prop, get_opt_rew_rel res.rew_prf) res.rew_evars 
+  in 
+  match nextres with
+  | None -> None
+  | Some None -> Some (Some res)
+  | Some (Some res') ->
       match res.rew_prf with
-      | RewCast c -> Info { res' with rew_from = res.rew_from }
+      | RewCast c -> Some (Some { res' with rew_from = res.rew_from })
       | RewPrf (rew_rel, rew_prf) ->
 	  match res'.rew_prf with
-	  | RewCast _ -> Info { res with rew_to = res'.rew_to }
+	  | RewCast _ -> Some (Some ({ res with rew_to = res'.rew_to }))
 	  | RewPrf (res'_rel, res'_prf) ->
-	      let prfty = mkApp (Lazy.force transitive_type, [| res.rew_car; rew_rel |]) in
-	      let evars, prf = new_cstr_evar res'.rew_evars env prfty in
-	      let prf = mkApp (prf, [|res.rew_from; res'.rew_from; res'.rew_to;
-				      rew_prf; res'_prf |])
-	      in Info { res' with rew_from = res.rew_from;
-		rew_evars = evars; rew_prf = RewPrf (res'_rel, prf) }
-
+	    let trans = 
+	      if prop then PropGlobal.transitive_type 
+	      else TypeGlobal.transitive_type
+	    in
+	    let evars, prfty = 
+	      app_poly res'.rew_evars trans [| res.rew_car; rew_rel |] 
+	    in
+	    let evars, prf = new_cstr_evar evars env prfty in
+	    let prf = mkApp (prf, [|res.rew_from; res'.rew_from; res'.rew_to;
+				    rew_prf; res'_prf |])
+	    in Some (Some { res' with rew_from = res.rew_from; 
+	      rew_evars = evars; rew_prf = RewPrf (res'_rel, prf) })
+		
 (** Rewriting strategies.
 
     Inspired by ELAN's rewriting strategies:
@@ -931,103 +1157,129 @@ let transitivity state env avoid (res : rewrite_result_info) (next : 'a pure_str
 module Strategies =
   struct
 
-    let fail : 'a pure_strategy =
-      fun s env avoid t ty cstr evars -> (s, Fail)
+    let fail : strategy =
+      fun env avoid t ty cstr evars -> None
 
-    let id : 'a pure_strategy =
-      fun s env avoid t ty cstr evars -> (s, Same)
+    let id : strategy =
+      fun env avoid t ty cstr evars -> Some None
 
-    let refl : 'a pure_strategy =
-      fun s env avoid t ty cstr evars ->
+    let refl : strategy =
+      fun env avoid t ty (prop,cstr) evars ->
 	let evars, rel = match cstr with
-	  | None -> new_cstr_evar evars env (mk_relation ty)
+	  | None -> 
+	    let mkr = if prop then PropGlobal.mk_relation else TypeGlobal.mk_relation in
+	    let evars, rty = mkr evars ty in
+	      new_cstr_evar evars env rty
 	  | Some r -> evars, r
 	in
 	let evars, proof =
-	  let mty = mkApp (Lazy.force proper_proxy_type, [| ty ; rel; t |]) in
+	  let proxy = 
+	    if prop then PropGlobal.proper_proxy_type 
+	    else TypeGlobal.proper_proxy_type
+	  in
+	  let evars, mty = app_poly evars proxy [| ty ; rel; t |] in
 	    new_cstr_evar evars env mty
 	in
-	  s, Info { rew_car = ty; rew_from = t; rew_to = t;
-		       rew_prf = RewPrf (rel, proof); rew_evars = evars }
-
-    let progress (s : 'a pure_strategy) : 'a pure_strategy =
-      fun state env avoid t ty cstr evars ->
-        let state, res = s state env avoid t ty cstr evars in
-	state, match res with
-	| Fail -> Fail
-	| Same -> Fail
-	| Info _ -> res
-
-    let seq (fst : 'a pure_strategy) (snd : 'a pure_strategy) : 'a pure_strategy =
-      fun state env avoid t ty cstr evars ->
-        let state, res = fst state env avoid t ty cstr evars in
-	match res with
-	| Fail -> state, Fail
-	| Same -> snd state env avoid t ty cstr evars
-	| Info res -> transitivity state env avoid res snd
-
-    let choice fst snd : 'a pure_strategy =
-      fun state env avoid t ty cstr evars ->
-        let state, res = fst state env avoid t ty cstr evars in
-	match res with
-	| Fail -> snd state env avoid t ty cstr evars
-	| Same | Info _ -> state, res
-
-    let try_ str : 'a pure_strategy = choice str id
-
-    let fix (f : 'a pure_strategy -> 'a pure_strategy) : 'a pure_strategy =
-      let rec aux state env avoid t ty cstr evars =
-        f aux state env avoid t ty cstr evars
-      in aux
-
-    let any (s : 'a pure_strategy) : 'a pure_strategy =
+	  Some (Some { rew_car = ty; rew_from = t; rew_to = t;
+		       rew_prf = RewPrf (rel, proof); rew_evars = evars })
+
+    let progress (s : strategy) : strategy =
+      fun env avoid t ty cstr evars ->
+	match s env avoid t ty cstr evars with
+	| None -> None
+	| Some None -> None
+	| r -> r
+
+    let seq first snd : strategy =
+      fun env avoid t ty cstr evars ->
+	match first env avoid t ty cstr evars with
+	| None -> None
+	| Some None -> snd env avoid t ty cstr evars
+	| Some (Some res) -> transitivity env avoid (fst cstr) res snd
+
+    let choice fst snd : strategy =
+      fun env avoid t ty cstr evars ->
+	match fst env avoid t ty cstr evars with
+	| None -> snd env avoid t ty cstr evars
+	| res -> res
+
+    let try_ str : strategy = choice str id
+
+    let fix (f : strategy -> strategy) : strategy =
+      let rec aux env = f (fun env -> aux env) env in aux
+
+    let any (s : strategy) : strategy =
       fix (fun any -> try_ (seq s any))
 
-    let repeat (s : 'a pure_strategy) : 'a pure_strategy =
+    let repeat (s : strategy) : strategy =
       seq s (any s)
 
-    let bu (s : 'a pure_strategy) : 'a pure_strategy =
+    let bu (s : strategy) : strategy =
       fix (fun s' -> seq (choice (progress (all_subterms s')) s) (try_ s'))
 
-    let td (s : 'a pure_strategy) : 'a pure_strategy =
+    let td (s : strategy) : strategy =
       fix (fun s' -> seq (choice s (progress (all_subterms s'))) (try_ s'))
 
-    let innermost (s : 'a pure_strategy) : 'a pure_strategy =
+    let innermost (s : strategy) : strategy =
       fix (fun ins -> choice (one_subterm ins) s)
 
-    let outermost (s : 'a pure_strategy) : 'a pure_strategy =
+    let outermost (s : strategy) : strategy =
       fix (fun out -> choice s (one_subterm out))
 
-    let lemmas flags cs : 'a pure_strategy =
+    let lemmas flags cs : strategy =
       List.fold_left (fun tac (l,l2r,by) ->
-	choice tac (apply_lemma l2r flags l by AllOccurrences))
+	choice tac (apply_lemma flags l l2r by AllOccurrences))
 	fail cs
 
-    let old_hints (db : string) : 'a pure_strategy =
+    let inj_open hint =
+      (Evd.from_env ~ctx:hint.Autorewrite.rew_ctx (Global.env()),
+       (hint.Autorewrite.rew_lemma, NoBindings))
+
+    let old_hints (db : string) : strategy =
       let rules = Autorewrite.find_rewrites db in
 	lemmas rewrite_unif_flags
-	  (List.map (fun hint -> ((hint.Autorewrite.rew_lemma, NoBindings), hint.Autorewrite.rew_l2r, hint.Autorewrite.rew_tac)) rules)
+	  (List.map (fun hint -> (inj_open hint, hint.Autorewrite.rew_l2r,
+				  hint.Autorewrite.rew_tac)) rules)
 
-    let hints (db : string) : 'a pure_strategy =
-      fun state env avoid t ty cstr evars ->
+    let hints (db : string) : strategy =
+      fun env avoid t ty cstr evars ->
       let rules = Autorewrite.find_matches db t in
-      let lemma hint = ((hint.Autorewrite.rew_lemma, NoBindings), hint.Autorewrite.rew_l2r,
+      let lemma hint = (inj_open hint, hint.Autorewrite.rew_l2r,
 			hint.Autorewrite.rew_tac) in
       let lems = List.map lemma rules in
-	lemmas rewrite_unif_flags lems state env avoid t ty cstr evars
+	lemmas rewrite_unif_flags lems env avoid t ty cstr evars
 
-    let reduce (r : Redexpr.red_expr) : 'a pure_strategy =
-      fun state env avoid t ty cstr evars ->
-        let rfn, ckind = Redexpr.reduction_of_red_expr env r in
+    let reduce (r : Redexpr.red_expr) : strategy =
+	fun env avoid t ty cstr evars ->
+          let rfn, ckind = Redexpr.reduction_of_red_expr env r in
 	  let t' = rfn env (goalevars evars) t in
 	    if eq_constr t' t then
-	      state, Same
+	      Some None
 	    else
-	      state, Info { rew_car = ty; rew_from = t; rew_to = t';
-			   rew_prf = RewCast ckind; rew_evars = evars }
+	      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, snd evars) })
+	  with e when Errors.noncritical e -> None
 
-    let fold_glob c : 'a pure_strategy =
-      fun state env avoid t ty cstr evars ->
+
+    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.understand_tcc (goalevars evars) env c in
 	let unfolded =
@@ -1036,120 +1288,133 @@ module Strategies =
             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 sigma = Unification.w_unify env sigma CONV ~flags:(Unification.elim_flags ()) unfolded t in
 	    let c' = Evarutil.nf_evar sigma c in
-	      state, Info { rew_car = ty; rew_from = t; rew_to = c';
+	      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 -> state, Fail
-
+			   rew_evars = (sigma, snd evars) })
+	  with e when Errors.noncritical e -> None
+  
 
 end
 
 (** The strategy for a single rewrite, dealing with occurences. *)
 
-let rewrite_with l2r flags c occs : strategy =
-  fun () env avoid t ty cstr evars ->
+let rewrite_strat flags occs hyp =
+  let app = apply_rule hyp None occs in
+  let rec aux () =
+    Strategies.choice app (subterm true flags (fun env -> aux () env))
+  in aux ()
+
+let get_hypinfo_ids {c = opt} =
+  match opt with
+  | None -> []
+  | Some (is, gc) ->
+    let avoid = Option.default [] (TacStore.get is.extra f_avoid_ids) in
+      Id.Map.fold (fun id _ accu -> id :: accu) is.lfun avoid
+      
+let rewrite_with flags c left2right loccs : strategy =
+  fun env avoid t ty cstr evars ->
     let gevars = goalevars evars in
-    let hypinfo = decompose_applied_relation_expr env gevars c in
-    let (is, _) = c in
-    let avoid = match TacStore.get is.extra f_avoid_ids with
-    | None -> avoid
-    | Some l -> l @ avoid
-    in
-    let avoid = Id.Map.fold (fun id _ accu -> id :: accu) is.lfun avoid in
-    let app = apply_rule l2r flags None occs in
-    let strat = Strategies.fix (fun aux -> Strategies.choice app (subterm true default_flags aux)) in
-    let _, res = strat (hypinfo, 0) env avoid t ty cstr (gevars, cstrevars evars) in
-    ((), res)
-
-let apply_strategy (s : strategy) env avoid concl cstr evars =
-  let _, res =
-    s () env avoid concl (Typing.type_of env (goalevars evars) concl)
-      (Option.map snd cstr) evars
+    let hypinfo = ref (decompose_applied_relation_expr env gevars flags c left2right) in
+    let avoid = get_hypinfo_ids !hypinfo @ avoid in
+      rewrite_strat default_flags loccs hypinfo env avoid t ty cstr (gevars, cstrevars evars)
+
+let apply_strategy (s : strategy) env avoid concl (prop, cstr) evars =
+  let res =
+    s env avoid concl (Typing.type_of env (goalevars evars) concl)
+      (prop, Some cstr) evars
   in
     match res with
-    | Fail -> Fail
-    | Same -> Same
-    | Info res ->
-	Info (res.rew_prf, res.rew_evars, res.rew_car, res.rew_from, res.rew_to)
+    | None -> None
+    | Some None -> Some None
+    | Some (Some res) ->
+	Some (Some (res.rew_prf, res.rew_evars, res.rew_car, res.rew_from, res.rew_to))
 
-let solve_constraints env evars =
+let solve_constraints env (evars,cstrs) =
   Typeclasses.resolve_typeclasses env ~split:false ~fail:true evars
 
 let nf_zeta =
   Reductionops.clos_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA])
 
-exception RewriteFailure of std_ppcmds
+exception RewriteFailure of Pp.std_ppcmds
 
-type result = (evar_map * constr option * types) rewrite_result
+type result = (evar_map * constr option * types) option option
 
 let cl_rewrite_clause_aux ?(abs=None) strat env avoid sigma concl is_hyp : result =
-  let cstr =
-    let sort = mkProp in
-    let impl = Lazy.force impl in
+  let evars = (sigma, Evar.Set.empty) in
+  let evars, cstr =
+    let sort = Typing.sort_of env (goalevars evars) concl in
+    let prop, (evars, arrow) = 
+      if is_prop_sort sort then true, app_poly evars impl [||]
+      else false, app_poly evars arrow [||]
+    in
       match is_hyp with
-      | None -> (sort, inverse sort impl)
-      | Some _ -> (sort, impl)
+      | None -> 
+	let evars, t = poly_inverse prop env evars (mkSort sort) arrow in 
+	  evars, (prop, t)
+      | Some _ -> evars, (prop, arrow)
   in
-  let evars = (sigma, Evar.Set.empty) in
-  let eq = apply_strategy strat env avoid concl (Some cstr) evars in
+  let eq = apply_strategy strat env avoid concl cstr evars in
     match eq with
-    | Fail -> Fail
-    | Same -> Same
-    | Info (p, (evars, cstrs), car, oldt, newt) ->
-	let evars' = solve_constraints env evars in
+    | Some (Some (p, (evars, cstrs), car, oldt, newt)) ->
+	let evars' = solve_constraints env (evars, cstrs) 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. *)
-	  Evd.fold (fun ev evi acc ->
-	    if Evar.Set.mem ev cstrs then Evd.remove acc ev
-	    else acc) evars' evars'
+	  Evar.Set.fold (fun ev acc -> Evd.remove acc ev) cstrs evars'
 	in
-        match p with
-        | RewCast c -> Info (evars, None, newt)
-        | RewPrf (_, p) ->
-          let p = nf_zeta env evars' (Evarutil.nf_evar evars' p) in
-          let term = match abs with
-          | None -> p
-          | Some (t, ty) ->
-            let t = Evarutil.nf_evar evars' t in
-            let ty = Evarutil.nf_evar evars' ty in
-            mkApp (mkLambda (Name (Id.of_string "lemma"), ty, p), [| t |])
-          in
-          let proof = match is_hyp with
-          | None -> term
-          | Some id -> mkApp (term, [| mkVar id |])
-          in
-          Info (evars, Some proof, newt)
-
-(** ppedrot: this is a workaround. The current implementation of rewrite leaks
-    evar maps. We know that we should not produce effects in here, so we reput
-    them after computing... *)
-let tclEFFECT (tac : tactic) : tactic = fun gl ->
-  let eff = Evd.eval_side_effects gl.sigma in
-  let gls = tac gl in
-  let sigma = Evd.emit_side_effects eff (Evd.drop_side_effects gls.sigma) in
-  { gls with sigma; }
-
-let cl_rewrite_clause_tac ?abs strat clause gl =
-  let evartac evd = Refiner.tclEVARS evd 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.clear_metas evd) in
   let treat res =
     match res with
-    | Fail -> tclFAIL 0 (str "Nothing to rewrite")
-    | Same ->
-	tclFAIL 0 (str"No progress made")
-    | Info (undef, p, newt) ->
-	let tac =
+    | None -> tclFAIL 0 (str "Nothing to rewrite")
+    | Some None -> tclIDTAC
+    | 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 ->
+	  | 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)
+		  (Tacmach.internal_cut false name newt)
 		  (tclTHEN (Tactics.revert [name]) (Tacmach.refine p))
 	  | None, None -> change_in_concl None newt
 	in tclTHEN (evartac undef) tac
@@ -1162,7 +1427,7 @@ let cl_rewrite_clause_tac ?abs strat clause gl =
 	| None -> pf_concl gl, None
       in
       let sigma = project gl in
-      let concl = Evarutil.nf_evar sigma concl 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
@@ -1170,35 +1435,35 @@ let cl_rewrite_clause_tac ?abs strat clause gl =
 	Refiner.tclFAIL 0
 	  (str"Unable to satisfy the rewriting constraints."
 	   ++ fnl () ++ Himsg.explain_typeclass_error env e)
-  in tclEFFECT tac gl
+  in tac gl
 
 
 let bind_gl_info f =
-  bind concl (fun c -> bind env (fun v -> bind defs (fun ev -> f c v ev)))
+  bind concl (fun c -> bind env (fun v -> bind defs (fun ev -> f c v ev))) 
 
 let new_refine c : Goal.subgoals Goal.sensitive =
   let refable = Goal.Refinable.make
-    (fun handle -> Goal.Refinable.constr_of_open_constr handle true c)
+    (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
+let assert_replacing id newt tac = 
+  let sens = bind_gl_info 
     (fun concl env sigma ->
-       let nc' =
+       let nc' = 
 	 Environ.fold_named_context
 	   (fun _ (n, b, t as decl) nc' ->
 	      if Id.equal n id then (n, b, newt) :: nc'
 	      else decl :: nc')
 	   env ~init:[]
        in
-       let reft = Refinable.make
-	 (fun h ->
+       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 ->
+	      (fun ev -> 
 		 Goal.bind (Refinable.mkEvar h env newt)
 		   (fun ev' ->
-		      let inst =
+		      let inst = 
 			fold_named_context
 			  (fun _ (n, b, t) inst ->
 			     if Id.equal n id then ev' :: inst
@@ -1206,34 +1471,32 @@ let assert_replacing id newt tac =
 			  env ~init:[]
 		      in
 		      let (e, args) = destEvar ev in
-			Goal.return
-                         (mkEvar (e, Array.of_list inst)))))
+			Goal.return (mkEvar (e, Array.of_list inst)))))
        in Goal.bind reft Goal.refine)
-  in Tacticals.New.tclTHEN (Proofview.tclSENSITIVE sens)
+  in Proofview.tclTHEN (Proofview.tclSENSITIVE sens) 
        (Proofview.tclFOCUS 2 2 tac)
 
-let newfail n s =
+let newfail n s = 
   Proofview.tclZERO (Refiner.FailError (n, lazy s))
 
 let cl_rewrite_clause_newtac ?abs strat clause =
-  let treat (res, is_hyp) =
+  let treat (res, is_hyp) = 
     match res with
-    | Fail -> newfail 0 (str "Nothing to rewrite")
-    | Same ->
-	newfail 0 (str"No progress made")
-    | Info res ->
+    | None -> newfail 0 (str "Nothing to rewrite")
+    | Some None -> Proofview.tclUNIT ()
+    | 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) ->
+	| 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 ->
+	      (fun handle -> 
 		 Goal.bind env
 		   (fun env -> Goal.bind (Refinable.mkEvar handle env newt)
 		      (fun ev ->
-			 Goal.Refinable.constr_of_open_constr handle true
+			 Goal.Refinable.constr_of_open_constr handle true 
 			   (undef, mkApp (p, [| ev |])))))
 	    in
 	      Proofview.tclSENSITIVE (Goal.bind refable Goal.refine)
@@ -1248,9 +1511,9 @@ let cl_rewrite_clause_newtac ?abs strat clause =
 	   | Some id -> Environ.named_type id env, Some id
 	   | None -> concl, None
 	 in
-	   try
-	     let res =
-	       cl_rewrite_clause_aux ?abs strat env [] sigma ty is_hyp
+	   try 
+	     let res = 
+	       cl_rewrite_clause_aux ?abs strat env [] sigma ty is_hyp 
 	     in return (res, is_hyp)
 	   with
 	   | TypeClassError (env, (UnsatisfiableConstraints _ as e)) ->
@@ -1262,52 +1525,73 @@ let newtactic_init_setoid () =
   try init_setoid (); Proofview.tclUNIT ()
   with e when Errors.noncritical e -> Proofview.tclZERO e
 
-let tactic_init_setoid () =
+let tactic_init_setoid () = 
   init_setoid (); tclIDTAC
-
+  
 let cl_rewrite_clause_new_strat ?abs strat clause =
-  Tacticals.New.tclTHEN (newtactic_init_setoid ())
+  Proofview.tclTHEN (newtactic_init_setoid ())
   (try cl_rewrite_clause_newtac ?abs strat clause
    with RewriteFailure s ->
    newfail 0 (str"setoid rewrite failed: " ++ s))
 
-let cl_rewrite_clause_newtac' l left2right occs clause =
-  Proofview.tclFOCUS 1 1
-       (cl_rewrite_clause_new_strat (rewrite_with left2right rewrite_unif_flags l occs) 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 cl_rewrite_clause_strat strat clause =
   tclTHEN (tactic_init_setoid ())
-  (fun gl ->
+  (fun gl -> 
+   let meta = Evarutil.new_meta() in
      (*     let gl = { gl with sigma = Typeclasses.mark_unresolvables gl.sigma } in *)
-     try cl_rewrite_clause_tac strat clause gl
+     try cl_rewrite_clause_tac strat (mkMeta meta) clause gl
      with RewriteFailure e ->
        tclFAIL 0 (str"setoid rewrite failed: " ++ e) gl
-     | Refiner.FailError (n, pp) ->
+     | 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 left2right (general_rewrite_unif_flags ()) l occs) clause gl
+  cl_rewrite_clause_strat (rewrite_with (general_rewrite_unif_flags ()) l left2right occs) clause gl
+
+let occurrences_of = function
+  | n::_ as nl when n < 0 -> (false,List.map abs nl)
+  | nl ->
+      if List.exists (fun n -> n < 0) nl then
+	error "Illegal negative occurrence number.";
+      (true,nl)
+
+open Extraargs
+
+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.empty, (c, NoBindings)) 
+      l2r None occs env avoid t ty cstr (evd, cstrevars evars)
 
-let apply_glob_constr c l2r occs = fun () env avoid t ty cstr evars ->
+let apply_glob_constr c l2r occs = fun env avoid t ty cstr evars ->
   let evd, c = (Pretyping.understand_tcc (goalevars evars) env c) in
-    apply_lemma l2r (general_rewrite_unif_flags ()) (c, NoBindings)
-      None occs () env avoid t ty cstr (evd, cstrevars evars)
+    apply_lemma (general_rewrite_unif_flags ()) (Evd.empty, (c, NoBindings)) 
+      l2r None occs env avoid t ty cstr (evd, cstrevars evars)
 
-let interp_glob_constr_list env sigma cl =
-  let understand sigma (c, _) =
-    let sigma, c = Pretyping.understand_tcc sigma env c in
-    (sigma, ((c, NoBindings), true, None))
-  in
-  List.fold_map understand sigma cl
+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, None)
+
+let interp_glob_constr_list env sigma =
+  List.map (fun c -> 
+	      let evd, c = Pretyping.understand_tcc sigma env c in
+		(evd, (c, NoBindings)), true, None)
 
-type ('constr,'redexpr) strategy_ast =
+(* Syntax for rewriting with strategies *)
+
+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
+  | 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
@@ -1324,7 +1608,7 @@ let rec strategy_of_ast = function
   | StratId -> Strategies.id
   | StratFail -> Strategies.fail
   | StratRefl -> Strategies.refl
-  | StratUnary (f, s) ->
+  | StratUnary (f, s) -> 
     let s' = strategy_of_ast s in
     let f' = match f with
       | "subterms" -> all_subterms
@@ -1349,28 +1633,31 @@ let rec strategy_of_ast = function
     in f' s' t'
   | StratConstr (c, b) -> apply_glob_constr (fst c) b AllOccurrences
   | StratHints (old, id) -> if old then Strategies.old_hints id else Strategies.hints id
-  | StratTerms l ->
-    (fun () env avoid t ty cstr (evars, cstrs) ->
-     let evars, cl = interp_glob_constr_list env evars l in
-       Strategies.lemmas rewrite_unif_flags cl () env avoid t ty cstr (evars, cstrs))
-  | StratEval r ->
-    (fun () env avoid t ty cstr evars ->
+  | 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))
+       Strategies.reduce r_interp env avoid t ty cstr (sigma,cstrevars evars))
   | StratFold c -> Strategies.fold_glob (fst c)
 
 
-let mkappc s l = CAppExpl (Loc.ghost,(None,(Libnames.Ident (Loc.ghost,Id.of_string s))),l)
+(* By default the strategy for "rewrite_db" is top-down *)
+
+let mkappc s l = CAppExpl (Loc.ghost,(None,(Libnames.Ident (Loc.ghost,Id.of_string s)),None),l)
 
 let declare_an_instance n s args =
   ((Loc.ghost,Name n), Explicit,
-  CAppExpl (Loc.ghost, (None, Qualid (Loc.ghost, qualid_of_string s)),
+  CAppExpl (Loc.ghost, (None, Qualid (Loc.ghost, qualid_of_string s),None),
 	   args))
 
 let declare_instance a aeq n s = declare_an_instance n s [a;aeq]
 
 let anew_instance global binders instance fields =
-  new_instance binders instance (Some (CRecord (Loc.ghost,None,fields)))
+  new_instance (Flags.is_universe_polymorphism ()) 
+    binders instance (Some (CRecord (Loc.ghost,None,fields)))
     ~global ~generalize:false None
 
 let declare_instance_refl global binders a aeq n lemma =
@@ -1437,51 +1724,49 @@ let proper_projection r ty =
   let ctx, inst = decompose_prod_assum ty in
   let mor, args = destApp inst in
   let instarg = mkApp (r, rel_vect 0 (List.length ctx)) in
-  let app = mkApp (Lazy.force proper_proj,
+  let app = mkApp (Lazy.force PropGlobal.proper_proj,
 		  Array.append args [| instarg |]) in
     it_mkLambda_or_LetIn app ctx
 
 let declare_projection n instance_id r =
-  let ty = Global.type_of_global r in
-  let c = constr_of_global r in
+  let c,uctx = Universes.fresh_global_instance (Global.env()) r in
+  let poly = Global.is_polymorphic r in
+  let ty = Retyping.get_type_of (Global.env ()) Evd.empty c in
   let term = proper_projection c ty in
-  let env = Global.env() in
-  let typ = Typing.type_of env Evd.empty term in
+  let typ = Typing.type_of (Global.env ()) Evd.empty term in
   let ctx, typ = decompose_prod_assum typ in
   let typ =
     let n =
       let rec aux t =
 	match kind_of_term t with
-	    App (f, [| a ; a' ; rel; rel' |]) when eq_constr f (Lazy.force respectful) ->
-	      succ (aux rel')
-	  | _ -> 0
+	| App (f, [| a ; a' ; rel; rel' |]) 
+	    when Globnames.is_global (PropGlobal.respectful_ref ()) f ->
+	  succ (aux rel')
+	| _ -> 0
       in
       let init =
 	match kind_of_term typ with
-	    App (f, args) when eq_constr f (Lazy.force respectful) ->
+	    App (f, args) when Globnames.is_global (PropGlobal.respectful_ref ()) f  ->
 	      mkApp (f, fst (Array.chop (Array.length args - 2) args))
 	  | _ -> typ
       in aux init
     in
-    let ctx,ccl = Reductionops.splay_prod_n env Evd.empty (3 * n) typ
+    let ctx,ccl = Reductionops.splay_prod_n (Global.env()) Evd.empty (3 * n) typ
     in it_mkProd_or_LetIn ccl ctx
   in
   let typ = it_mkProd_or_LetIn typ ctx in
-  let cst =
-    { const_entry_body = Future.from_val (term,Declareops.no_seff);
-      const_entry_secctx = None;
-      const_entry_type = Some typ;
-      const_entry_opaque = false;
-      const_entry_inline_code = false;
-      const_entry_feedback = None;
-  } in
-    ignore(Declare.declare_constant n (Entries.DefinitionEntry cst, Decl_kinds.IsDefinition Decl_kinds.Definition))
+  let cst = 
+    Declare.definition_entry ~types:typ ~poly ~univs:(Univ.ContextSet.to_context uctx) 
+      term 
+  in
+    ignore(Declare.declare_constant n 
+	   (Entries.DefinitionEntry cst, Decl_kinds.IsDefinition Decl_kinds.Definition))
 
 let build_morphism_signature m =
   let env = Global.env () in
-  let m = Constrintern.interp_constr Evd.empty env m in
-  let t = Typing.type_of env Evd.empty m in
-  let evdref = ref (Evd.empty, Evar.Set.empty) in
+  let m,ctx = Constrintern.interp_constr Evd.empty env m in
+  let sigma = Evd.from_env ~ctx env in
+  let t = Typing.type_of env sigma m in
   let cstrs =
     let rec aux t =
       match kind_of_term t with
@@ -1490,21 +1775,19 @@ let build_morphism_signature m =
 	| _ -> []
     in aux t
   in
-  let evars, t', sig_, cstrs = build_signature !evdref env t cstrs None in
-  let _ = evdref := evars in
+  let evars, t', sig_, cstrs = 
+    PropGlobal.build_signature (Evd.empty, Evar.Set.empty) env t cstrs None in
+  let evd = ref evars in
   let _ = List.iter
     (fun (ty, rel) ->
       Option.iter (fun rel ->
-	let default = mkApp (Lazy.force default_relation, [| ty; rel |]) in
-	let evars,c = new_cstr_evar !evdref env default in
-	  evdref := evars)
+	let default = e_app_poly evd PropGlobal.default_relation [| ty; rel |] in
+	  ignore(e_new_cstr_evar evd env default))
 	rel)
     cstrs
   in
-  let morph =
-    mkApp (Lazy.force proper_type, [| t; sig_; m |])
-  in
-  let evd = solve_constraints env (goalevars !evdref) in
+  let morph = e_app_poly evd PropGlobal.proper_type [| t; sig_; m |] in
+  let evd = solve_constraints env !evd in
   let m = Evarutil.nf_evar evd morph in
     Evarutil.check_evars env Evd.empty evd m; m
 
@@ -1512,12 +1795,10 @@ let default_morphism sign m =
   let env = Global.env () in
   let t = Typing.type_of env Evd.empty m in
   let evars, _, sign, cstrs =
-    build_signature (Evd.empty, Evar.Set.empty) env t (fst sign) (snd sign)
+    PropGlobal.build_signature (Evd.empty, Evar.Set.empty) env t (fst sign) (snd sign)
   in
-  let morph =
-    mkApp (Lazy.force proper_type, [| t; sign; m |])
-  in
-  let evars, mor = resolve_one_typeclass env (fst evars) morph in
+  let evars, morph = app_poly evars PropGlobal.proper_type [| t; sign; m |] in
+  let evars, mor = resolve_one_typeclass env (goalevars evars) morph in
     mor, proper_projection mor morph
 
 let add_setoid global binders a aeq t n =
@@ -1532,6 +1813,7 @@ let add_setoid global binders a aeq t n =
        (Ident (Loc.ghost,Id.of_string "Equivalence_Symmetric"), mkappc "Seq_sym" [a;aeq;t]);
        (Ident (Loc.ghost,Id.of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])])
 
+
 let make_tactic name =
   let open Tacexpr in
   let loc = Loc.ghost in
@@ -1541,39 +1823,50 @@ let make_tactic name =
 
 let add_morphism_infer glob m n =
   init_setoid ();
+  let poly = Flags.is_universe_polymorphism () in
   let instance_id = add_suffix n "_Proper" in
   let instance = build_morphism_signature m in
+  let ctx = Univ.ContextSet.empty (*FIXME *) in
     if Lib.is_modtype () then
       let cst = Declare.declare_constant ~internal:Declare.KernelSilent instance_id
-				(Entries.ParameterEntry (None,instance,None), Decl_kinds.IsAssumption Decl_kinds.Logical)
+				(Entries.ParameterEntry 
+				 (None,poly,(instance,Univ.UContext.empty),None), 
+				 Decl_kinds.IsAssumption Decl_kinds.Logical)
       in
-	add_instance (Typeclasses.new_instance (Lazy.force proper_class) None glob (ConstRef cst));
+	add_instance (Typeclasses.new_instance 
+			(Lazy.force PropGlobal.proper_class) None glob 
+			poly (ConstRef cst));
 	declare_projection n instance_id (ConstRef cst)
     else
-      let kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Instance in
+      let kind = Decl_kinds.Global, poly, 
+	Decl_kinds.DefinitionBody Decl_kinds.Instance 
+      in
       let tac = make_tactic "Coq.Classes.SetoidTactics.add_morphism_tactic" in
+      let hook _ = function
+	| Globnames.ConstRef cst ->
+	  add_instance (Typeclasses.new_instance 
+			  (Lazy.force PropGlobal.proper_class) None
+			  glob poly (ConstRef cst));
+	  declare_projection n instance_id (ConstRef cst)
+	| _ -> assert false
+      in
 	Flags.silently
 	  (fun () ->
-	    Lemmas.start_proof instance_id kind instance
-	      (fun _ -> function
-		Globnames.ConstRef cst ->
-		  add_instance (Typeclasses.new_instance (Lazy.force proper_class) None
-				   glob (ConstRef cst));
-		  declare_projection n instance_id (ConstRef cst)
-		| _ -> assert false);
+	    Lemmas.start_proof instance_id kind (instance, ctx) hook;
 	    ignore (Pfedit.by (Tacinterp.interp tac))) ()
 
 let add_morphism glob binders m s n =
   init_setoid ();
+  let poly = Flags.is_universe_polymorphism () in
   let instance_id = add_suffix n "_Proper" in
   let instance =
     ((Loc.ghost,Name instance_id), Explicit,
     CAppExpl (Loc.ghost,
-	     (None, Qualid (Loc.ghost, Libnames.qualid_of_string "Coq.Classes.Morphisms.Proper")),
+	     (None, Qualid (Loc.ghost, Libnames.qualid_of_string "Coq.Classes.Morphisms.Proper"),None),
 	     [cHole; s; m]))
   in
   let tac = Tacinterp.interp (make_tactic "add_morphism_tactic") in
-    ignore(new_instance ~global:glob binders instance (Some (CRecord (Loc.ghost,None,[])))
+    ignore(new_instance ~global:glob poly binders instance (Some (CRecord (Loc.ghost,None,[])))
 	      ~generalize:false ~tac ~hook:(declare_projection n instance_id) None)
 
 (** Bind to "rewrite" too *)
@@ -1601,22 +1894,24 @@ 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 env =
+let unification_rewrite flags l2r c1 c2 cl car rel but gl =
+  let env = pf_env gl in
+  let evd = Evd.merge (project gl) cl.evd 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
+      Unification.w_unify_to_subterm 
        ~flags:{ rewrite_unif_flags with Unification.resolve_evars = true } env
-        cl.evd ((if l2r then c1 else c2),but)
+        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 with Unification.resolve_evars = true }
-	    env cl.evd ((if l2r then c1 else c2),but)
+	  Unification.w_unify_to_subterm 
+	  ~flags:{ flags with Unification.resolve_evars = true }
+	    env evd ((if l2r then c1 else c2),but)
   in
   let cl' = {cl with evd = evd'} in
   let cl' = Clenvtac.clenv_pose_dependent_evars true cl' in
@@ -1626,51 +1921,60 @@ let unification_rewrite l2r c1 c2 cl car rel but env =
   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
-  let abs = (prf, prfty) in
-  abs, {cl=cl'; ext=Evar.Set.empty; prf=(mkRel 1); car=car; rel=rel;
-     c1=c1; c2=c2; c=None; abs=true; }
+  let sort = sort_of_rel env evd' (pf_concl gl) in
+  let cl' = { cl' with templval = mk_freelisted prf ; templtyp = mk_freelisted prfty;
+    evd = Evd.diff cl'.evd (project gl) } 
+  in
+    {cl=cl'; prf=(mkRel 1); car=car; rel=rel; l2r=l2r; 
+     c1=c1; c2=c2; c=None; abs=Some (prf, prfty); sort = Sorts.is_prop sort; flags = flags}
 
 let get_hyp gl evars (c,l) clause l2r =
-  let env = pf_env gl in
-  let hi = decompose_applied_relation env evars None (c,l) in
+  let flags = rewrite2_unif_flags in
+  let hi = decompose_applied_relation (pf_env gl) evars evars flags None (c,l) l2r in
   let but = match clause with
-    | Some id -> pf_get_hyp_typ gl id
+    | Some id -> pf_get_hyp_typ gl id 
     | None -> Evarutil.nf_evar evars (pf_concl gl)
   in
-  unification_rewrite l2r hi.c1 hi.c2 hi.cl hi.car hi.rel but env
+  let unif = unification_rewrite flags hi.l2r hi.c1 hi.c2 hi.cl hi.car hi.rel but gl in
+    { unif with flags = rewrite_unif_flags }
 
 let general_rewrite_flags = { under_lambdas = false; on_morphisms = true }
 
+let apply_lemma gl (c,l) cl l2r occs =
+  let sigma = project gl in
+  let hypinfo = ref (get_hyp gl sigma (c,l) cl l2r) in
+  let app = apply_rule hypinfo None occs in
+  let rec aux () =
+    Strategies.choice app (subterm true general_rewrite_flags (fun env -> aux () env))
+  in !hypinfo, aux ()
+
+
+let cl_rewrite_clause_tac abs strat meta cl gl =
+  cl_rewrite_clause_tac ~abs strat meta cl gl
+
+(* let rewriteclaustac_key = Profile.declare_profile "cl_rewrite_clause_tac";; *)
+(* let cl_rewrite_clause_tac = Profile.profile5 rewriteclaustac_key cl_rewrite_clause_tac *)
+
 let general_s_rewrite cl l2r occs (c,l) ~new_goals gl =
-  let app = apply_rule l2r rewrite_unif_flags None occs in
-  let recstrat aux = Strategies.choice app (subterm true general_rewrite_flags aux) in
-  let substrat = Strategies.fix recstrat in
-  let abs, hypinfo = get_hyp gl (project gl) (c,l) cl l2r in
-  let strat () env avoid t ty cstr evars =
-    let _, res = substrat (hypinfo, 0) env avoid t ty cstr evars in
-    (), res
-  in
+  let meta = Evarutil.new_meta() in
+  let hypinfo, strat = apply_lemma gl (c,l) cl l2r occs in
     try
-      (tclWEAK_PROGRESS
+      tclWEAK_PROGRESS 
 	(tclTHEN
-           (Refiner.tclEVARS hypinfo.cl.evd)
-	   (cl_rewrite_clause_tac ~abs:(Some abs) strat cl))) gl
+           (Refiner.tclEVARS (Evd.merge (project gl) hypinfo.cl.evd))
+	   (cl_rewrite_clause_tac hypinfo.abs strat (mkMeta meta) cl)) gl
     with RewriteFailure e ->
-      let {c1=x; c2=y} = hypinfo in
+      let {l2r=l2r; c1=x; c2=y} = hypinfo in
 	raise (Pretype_errors.PretypeError
 		  (pf_env gl,project gl,
 		  Pretype_errors.NoOccurrenceFound ((if l2r then x else y), cl)))
 
-open Proofview.Notations
-
 let general_s_rewrite_clause x =
+  init_setoid ();
+  fun b occs cl ~new_goals ->
   match x with
-    | None -> general_s_rewrite None
-    | Some id -> general_s_rewrite (Some id)
-let general_s_rewrite_clause x y z w ~new_goals =
-  newtactic_init_setoid () <*>
-  Proofview.V82.tactic (general_s_rewrite_clause x y z w ~new_goals)
+    | None -> Proofview.V82.tactic (general_s_rewrite None b occs cl ~new_goals)
+    | Some id -> Proofview.V82.tactic (general_s_rewrite (Some id) b occs cl ~new_goals)
 
 let _ = Hook.set Equality.general_rewrite_clause general_s_rewrite_clause
 
@@ -1682,63 +1986,61 @@ let not_declared env ty rel =
 
 let setoid_proof ty fn fallback =
   Proofview.Goal.enter begin fun gl ->
-    let sigma = Proofview.Goal.sigma gl in
     let env = Proofview.Goal.env gl in
+    let sigma = Proofview.Goal.sigma gl in
     let concl = Proofview.Goal.concl gl in
-    Proofview.tclORELSE
-      begin
-        try
-          let rel, args = decompose_app_rel env sigma concl in
-          let evm = sigma in
-          let car = pi3 (List.hd (fst (Reduction.dest_prod env (Typing.type_of env evm rel)))) in
-          fn env evm car rel
-        with e -> Proofview.tclZERO e
-      end
-      begin function
-        | e ->
-            Proofview.tclORELSE
-              fallback
-              begin function
-                | Hipattern.NoEquationFound ->
-                (* spiwack: [Errors.push] here is unlikely to do what
-                   it's intended to, or anything meaningful for that
-                   matter. *)
-                    let e = Errors.push e in
-	            begin match e with
-	            | Not_found ->
-	                let rel, args = decompose_app_rel env sigma concl in
-		        not_declared env ty rel
-	            | _ -> Proofview.tclZERO e
-                    end
-                | e' -> Proofview.tclZERO e'
-              end
-      end
+    try
+      let rel, args = decompose_app_rel env sigma concl in
+      let car = pi3 (List.hd (fst (Reduction.dest_prod env (Typing.type_of env sigma rel)))) in
+      Proofview.V82.tactic (fn env sigma car rel)
+    with e when Errors.noncritical e ->
+      Proofview.tclORELSE fallback (function
+      | Hipattern.NoEquationFound ->
+          let e = Errors.push e in
+	  begin match e with
+	  | Not_found ->
+	      let rel, args = decompose_app_rel env sigma concl in
+		not_declared env ty rel
+	  | _ -> raise e
+          end
+      | e -> Proofview.tclZERO e)
   end
 
+let tac_open ((evm,_), c) tac = 
+  tclTHEN (Refiner.tclEVARS evm) (tac c)
+
+let poly_proof getp gett env evm car rel =
+  if Sorts.is_prop (sort_of_rel env evm rel) then
+    getp env (evm,Evar.Set.empty) car rel
+  else gett env (evm,Evar.Set.empty) car rel
+
 let setoid_reflexivity =
   setoid_proof "reflexive"
-    (fun env evm car rel -> Proofview.V82.tactic (apply (get_reflexive_proof env evm car rel)))
+    (fun env evm car rel -> 
+      tac_open (poly_proof PropGlobal.get_reflexive_proof TypeGlobal.get_reflexive_proof
+		  env evm car rel) apply)
     (reflexivity_red true)
 
 let setoid_symmetry =
   setoid_proof "symmetric"
-    (fun env evm car rel -> Proofview.V82.tactic (apply (get_symmetric_proof env evm car rel)))
+    (fun env evm car rel -> 
+      tac_open (poly_proof PropGlobal.get_symmetric_proof TypeGlobal.get_symmetric_proof
+		  env evm car rel) apply)
     (symmetry_red true)
 
 let setoid_transitivity c =
   setoid_proof "transitive"
     (fun env evm car rel ->
-      Proofview.V82.tactic begin
-        let proof = get_transitive_proof env evm car rel in
-        match c with
-        | None -> eapply proof
-        | Some c -> apply_with_bindings (proof,ImplicitBindings [ c ])
-      end)
+      let proof = poly_proof PropGlobal.get_transitive_proof TypeGlobal.get_transitive_proof
+	env evm car rel in
+	match c with
+	| None -> tac_open proof eapply
+	| Some c -> tac_open proof (fun t -> apply_with_bindings (t,ImplicitBindings [ c ])))
     (transitivity_red true c)
-
+    
 let setoid_symmetry_in id =
-  Proofview.Goal.enter begin fun gl ->
-  let ctype = Tacmach.New.of_old (fun gl -> pf_type_of gl (mkVar id)) gl in
+  Proofview.V82.tactic (fun gl ->
+  let ctype = pf_type_of gl (mkVar id) in
   let binders,concl = decompose_prod_assum ctype in
   let (equiv, args) = decompose_app concl in
   let rec split_last_two = function
@@ -1750,12 +2052,81 @@ let setoid_symmetry_in id =
   let he,c1,c2 =  mkApp (equiv, Array.of_list others),c1,c2 in
   let new_hyp' =  mkApp (he, [| c2 ; c1 |]) in
   let new_hyp = it_mkProd_or_LetIn new_hyp'  binders in
-    Tacticals.New.tclTHENS (Tactics.cut new_hyp)
-      [ Proofview.V82.tactic (intro_replacing id);
-	Tacticals.New.tclTHENLIST [ intros; setoid_symmetry; Proofview.V82.tactic (apply (mkVar id)); Tactics.assumption ] ]
-  end
+    tclTHENS (Proofview.V82.of_tactic (Tactics.cut new_hyp))
+      [ intro_replacing id;
+	tclTHENLIST [ Proofview.V82.of_tactic intros; Proofview.V82.of_tactic setoid_symmetry; apply (mkVar id); Proofview.V82.of_tactic Tactics.assumption ] ]
+      gl)
 
 let _ = Hook.set Tactics.setoid_reflexivity setoid_reflexivity
 let _ = Hook.set Tactics.setoid_symmetry setoid_symmetry
 let _ = Hook.set Tactics.setoid_symmetry_in setoid_symmetry_in
 let _ = Hook.set Tactics.setoid_transitivity setoid_transitivity
+
+let implify id gl =
+  let (_, b, ctype) = pf_get_hyp gl id in
+  let binders,concl = decompose_prod_assum ctype in
+  let evm, ctype' =
+    match binders with
+    | (_, None, ty as hd) :: tl when noccurn 1 concl ->
+	let env = Environ.push_rel_context tl (pf_env gl) in
+	let sigma = project gl in
+	let tyhd = Typing.type_of env sigma ty
+	and tyconcl = Typing.type_of (Environ.push_rel hd env) sigma concl in
+	let ((sigma,_), app), unfold = 
+	  PropGlobal.arrow_morphism (sigma, Evar.Set.empty) tyhd 
+	    (subst1 mkProp tyconcl) ty (subst1 mkProp concl) 
+	in
+	  sigma, it_mkProd_or_LetIn app tl
+    | _ -> project gl, ctype
+  in tclTHEN (Refiner.tclEVARS evm) (Tacmach.convert_hyp (id, b, ctype')) gl
+
+let rec fold_matches env sigma c =
+  map_constr_with_full_binders Environ.push_rel 
+    (fun env c ->
+      match kind_of_term c with
+      | Case _ ->
+          let cst, env, c', _eff = fold_match ~force:true env sigma c in
+	    fold_matches env sigma c'
+      | _ -> fold_matches env sigma c)
+    env c
+
+let fold_match_tac c gl =
+  let _, _, c', eff = fold_match ~force:true (pf_env gl) (project gl) c in
+  let gl = { gl with sigma = Evd.emit_side_effects eff gl.sigma } in
+    change (Some (snd (Patternops.pattern_of_constr (project gl) c))) c' onConcl gl
+
+let fold_matches_tac c gl =
+  let c' = fold_matches (pf_env gl) (project gl) c in
+  (* let gl = { gl with sigma = Evd.emit_side_effects eff gl.sigma } in *)
+    change (Some (snd (Patternops.pattern_of_constr (project gl) c))) c' onConcl gl
+
+let myapply id l gl =
+  let gr = id in
+  let _, impls = List.hd (Impargs.implicits_of_global gr) in
+  let env = pf_env gl in
+  let evars = ref (project gl) in
+  let evd, ty = fresh_global env !evars gr in
+  let _ = evars := evd 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 (Universes.constr_of_global gr, Array.of_list (List.rev args'))
+    in aux ty impls l []
+  in
+    tclTHEN (Refiner.tclEVARS !evars) (apply app) gl
+
diff --git a/tactics/rewrite.mli b/tactics/rewrite.mli
index e2d9a41d8..9bdfc08d2 100644
--- a/tactics/rewrite.mli
+++ b/tactics/rewrite.mli
@@ -41,10 +41,6 @@ val cl_rewrite_clause :
   interp_sign * (glob_constr_and_expr * glob_constr_and_expr bindings) ->
   bool -> Locus.occurrences -> Id.t option -> tactic
 
-val cl_rewrite_clause_newtac' :
-  interp_sign * (glob_constr_and_expr * glob_constr_and_expr bindings) ->
-  bool -> Locus.occurrences -> Id.t option -> unit Proofview.tactic
-
 val is_applied_rewrite_relation :
   env -> evar_map -> Context.rel_context -> constr -> types option
 
@@ -61,12 +57,6 @@ val add_morphism_infer : bool -> constr_expr -> Id.t -> unit
 val add_morphism :
   bool -> local_binder list -> constr_expr -> constr_expr -> Id.t -> unit
 
-val get_reflexive_proof : env -> evar_map -> constr -> constr -> constr
-
-val get_symmetric_proof : env -> evar_map -> constr -> constr -> constr
-
-val get_transitive_proof : env -> evar_map -> constr -> constr -> constr
-
 val default_morphism :
   (types * constr option) option list * (types * types option) option ->
   constr -> constr * constr
diff --git a/tactics/taccoerce.ml b/tactics/taccoerce.ml
index 2c1de14ea..95c6b6bfb 100644
--- a/tactics/taccoerce.ml
+++ b/tactics/taccoerce.ml
@@ -157,7 +157,7 @@ let coerce_to_evaluable_ref env v =
     else fail ()
   else
     let ev = match Value.to_constr v with
-    | Some c when isConst c -> EvalConstRef (destConst c)
+    | Some c when isConst c -> EvalConstRef (Univ.out_punivs (destConst c))
     | Some c when isVar c -> EvalVarRef (destVar c)
     | _ -> fail ()
     in
@@ -213,7 +213,7 @@ let coerce_to_reference env v =
 
 let coerce_to_inductive v =
   match Value.to_constr v with
-  | Some c when isInd c -> destInd c
+  | Some c when isInd c -> Univ.out_punivs (destInd c)
   | _ -> raise (CannotCoerceTo "an inductive type")
 
 (* Quantified named or numbered hypothesis or hypothesis in context *)
diff --git a/tactics/tacintern.ml b/tactics/tacintern.ml
index cd2319c01..fa76b2a94 100644
--- a/tactics/tacintern.ml
+++ b/tactics/tacintern.ml
@@ -138,12 +138,13 @@ let intern_ltac_variable ist = function
 
 let intern_constr_reference strict ist = function
   | Ident (_,id) as r when not strict && find_hyp id ist ->
-      GVar (dloc,id), Some (CRef r)
+      GVar (dloc,id), Some (CRef (r,None))
   | Ident (_,id) as r when find_ctxvar id ist ->
-      GVar (dloc,id), if strict then None else Some (CRef r)
+      GVar (dloc,id), if strict then None else Some (CRef (r,None))
   | r ->
       let loc,_ as lqid = qualid_of_reference r in
-      GRef (loc,locate_global_with_alias lqid), if strict then None else Some (CRef r)
+      GRef (loc,locate_global_with_alias lqid,None), 
+	if strict then None else Some (CRef (r,None))
 
 let intern_move_location ist = function
   | MoveAfter id -> MoveAfter (intern_hyp_or_metaid ist id)
@@ -278,7 +279,7 @@ let intern_induction_arg ist = function
   | ElimOnIdent (loc,id) ->
       if !strict_check then
 	(* If in a defined tactic, no intros-until *)
-	match intern_constr ist (CRef (Ident (dloc,id))) with
+	match intern_constr ist (CRef (Ident (dloc,id), None)) with
 	| GVar (loc,id),_ -> ElimOnIdent (loc,id)
 	| c -> ElimOnConstr (c,NoBindings)
       else
diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml
index ecd7fce31..128d8ea87 100644
--- a/tactics/tacinterp.ml
+++ b/tactics/tacinterp.ml
@@ -295,6 +295,9 @@ let interp_ident = interp_ident_gen false
 let interp_fresh_ident = interp_ident_gen true
 let pf_interp_ident id gl = interp_ident_gen false id (pf_env gl)
 
+let interp_global ist gl gr = 
+  Evd.fresh_global (pf_env gl) (project gl) gr
+
 (* Interprets an optional identifier which must be fresh *)
 let interp_fresh_name ist env = function
   | Anonymous -> Anonymous
@@ -842,7 +845,7 @@ let interp_induction_arg ist gl arg =
 	if Tactics.is_quantified_hypothesis id gl then
           ElimOnIdent (loc,id)
 	else
-          let c = (GVar (loc,id),Some (CRef (Ident (loc,id)))) in
+          let c = (GVar (loc,id),Some (CRef (Ident (loc,id),None))) in
           let (sigma,c) = interp_constr ist env sigma c in
           ElimOnConstr (sigma,(c,NoBindings))
 
@@ -2104,8 +2107,7 @@ let () =
   Geninterp.register_interp0 wit_intro_pattern interp;
   let interp ist gl pat = (project gl, interp_clause ist (pf_env gl) pat) in
   Geninterp.register_interp0 wit_clause_dft_concl interp;
-
-  let interp ist gl s = (project gl, interp_sort s) in
+  let interp ist gl s = interp_sort (project gl) s in
   Geninterp.register_interp0 wit_sort interp
 
 let () =
@@ -2143,7 +2145,8 @@ let _ =
     if has_type arg (glbwit wit_tactic) then
       let tac = out_gen (glbwit wit_tactic) arg in
       let tac = interp_tactic ist tac in
-      let prf = Proof.start sigma [env, ty] in
+      let ctx = Evd.get_universe_context_set sigma in
+      let prf = Proof.start sigma [env, (ty, ctx)] in
       let (prf, _) =
         try Proof.run_tactic env tac prf
         with Proof_errors.TacticFailure e as src ->
diff --git a/tactics/tacsubst.ml b/tactics/tacsubst.ml
index 997975196..47fa4f942 100644
--- a/tactics/tacsubst.ml
+++ b/tactics/tacsubst.ml
@@ -74,7 +74,7 @@ open Printer
 let subst_global_reference subst =
  let subst_global ref =
   let ref',t' = subst_global subst ref in
-   if not (eq_constr (constr_of_global ref') t') then
+   if not (eq_constr (Universes.constr_of_global ref') t') then
     msg_warning (strbrk "The reference " ++ pr_global ref ++ str " is not " ++
           str " expanded to \"" ++ pr_lconstr t' ++ str "\", but to " ++
           pr_global ref') ;
@@ -175,7 +175,7 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with
   | 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
+      let l = List.map (subst_or_var (subst_ind subst)) l in
       TacDecompose (l,subst_glob_constr subst c)
   | TacSpecialize (n,l) -> TacSpecialize (n,subst_glob_with_bindings subst l)
   | TacLApply c -> TacLApply (subst_glob_constr subst c)
diff --git a/tactics/tacticMatching.ml b/tactics/tacticMatching.ml
index b11841a65..cb54263bb 100644
--- a/tactics/tacticMatching.ml
+++ b/tactics/tacticMatching.ml
@@ -232,7 +232,7 @@ module PatternMatching (E:StaticEnvironment) = struct
       matchings of [term] with the pattern [pat => lhs]. If refresh is
       true, refreshes the universes of [term]. *)
   let pattern_match_term refresh pat term lhs = 
-    let term = if refresh then Termops.refresh_universes_strict term else term in
+(*     let term = if refresh then Termops.refresh_universes_strict term else term in *)
     match pat with
     | Term p ->
         begin 
diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml
index bd33e5146..f647ac510 100644
--- a/tactics/tacticals.ml
+++ b/tactics/tacticals.ml
@@ -145,7 +145,7 @@ let ifOnHyp pred tac1 tac2 id gl =
   the elimination. *)
 
 type branch_args = {
-  ity        : inductive;   (* the type we were eliminating on *)
+  ity        : pinductive;   (* the type we were eliminating on *)
   largs      : constr list; (* its arguments *)
   branchnum  : int;         (* the branch number *)
   pred       : constr;      (* the predicate we used *)
@@ -185,7 +185,7 @@ let compute_induction_names n = function
   | Some (loc,_) ->
       user_err_loc (loc,"",str "Disjunctive/conjunctive introduction pattern expected.")
 
-let compute_construtor_signatures isrec (_,k as ity) =
+let compute_construtor_signatures isrec ((_,k as ity),u) =
   let rec analrec c recargs =
     match kind_of_term c, recargs with
     | Prod (_,_,c), recarg::rest ->
@@ -214,10 +214,19 @@ let elimination_sort_of_clause = function
   | None -> elimination_sort_of_goal
   | Some id -> elimination_sort_of_hyp id
 
+
+let pf_with_evars glsev k gls = 
+  let evd, a = glsev gls in
+    tclTHEN (Refiner.tclEVARS evd) (k a) gls
+
+let pf_constr_of_global gr k =
+  pf_with_evars (fun gls -> pf_apply Evd.fresh_global gls gr) k
+
 (* computing the case/elim combinators *)
 
 let gl_make_elim ind gl =
-  Indrec.lookup_eliminator ind (elimination_sort_of_goal gl)
+  let gr = Indrec.lookup_eliminator (fst ind) (elimination_sort_of_goal gl) in
+    pf_apply Evd.fresh_global gl gr
 
 let gl_make_case_dep ind gl =
   pf_apply Indrec.build_case_analysis_scheme gl ind true
@@ -535,7 +544,8 @@ module New = struct
       isrec allnames tac predicate ind (c, t) =
     Proofview.Goal.enter begin fun gl ->
     let indclause = Tacmach.New.of_old (fun gl -> mk_clenv_from gl (c, t)) gl in
-    let elim = Tacmach.New.of_old (mk_elim ind) gl in
+    (** FIXME: evar leak. *)
+    let sigma, elim = Tacmach.New.of_old (mk_elim ind) gl in
     (* applying elimination_scheme just a little modified *)
     let elimclause = Tacmach.New.of_old (fun gls -> mk_clenv_from gls (elim,Tacmach.New.pf_type_of gl elim)) gl in
     let indmv =
@@ -550,7 +560,7 @@ module New = struct
       | _ ->
 	  let name_elim =
 	    match kind_of_term elim with
-	    | Const kn -> string_of_con kn
+	    | Const (kn, _) -> string_of_con kn
 	    | Var id -> string_of_id id
 	    | _ -> "\b"
 	  in
@@ -559,7 +569,7 @@ module New = struct
     let elimclause' = clenv_fchain indmv elimclause indclause in
     let branchsigns = compute_construtor_signatures isrec ind in
     let brnames = compute_induction_names (Array.length branchsigns) allnames in
-    let flags = Unification.elim_flags in
+    let flags = Unification.elim_flags () in
     let elimclause' =
       match predicate with
       | None   -> elimclause'
@@ -591,9 +601,9 @@ module New = struct
     Proofview.Goal.enter begin fun gl ->
     let (ind,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in
     let isrec,mkelim =
-      if (Global.lookup_mind (fst ind)).mind_record
-      then false,gl_make_case_dep
-      else true,gl_make_elim
+      match (Global.lookup_mind (fst (fst ind))).mind_record with
+      | None -> true,gl_make_elim
+      | Some _ -> false,gl_make_case_dep
     in
     general_elim_then_using mkelim isrec None tac None ind (c, t)
     end
@@ -630,4 +640,12 @@ module New = struct
   | None -> elimination_sort_of_goal gl
   | Some id -> elimination_sort_of_hyp id gl
 
+  let pf_constr_of_global ref tac =
+    Proofview.Goal.enter begin fun gl ->
+      let env = Proofview.Goal.env gl in
+      let sigma = Proofview.Goal.sigma gl in
+      let (sigma, c) = Evd.fresh_global env sigma ref in
+      Proofview.V82.tclEVARS sigma <*> (tac c)
+    end
+
 end
diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli
index fcc23df22..cc1528797 100644
--- a/tactics/tacticals.mli
+++ b/tactics/tacticals.mli
@@ -101,7 +101,7 @@ val onClauseLR : (Id.t option -> tactic) -> clause -> tactic
 (** {6 Elimination tacticals. } *)
 
 type branch_args = {
-  ity        : inductive;   (** the type we were eliminating on *)
+  ity        : pinductive;   (** the type we were eliminating on *)
   largs      : constr list; (** its arguments *)
   branchnum  : int;         (** the branch number *)
   pred       : constr;      (** the predicate we used *)
@@ -132,6 +132,9 @@ val elimination_sort_of_goal : goal sigma -> sorts_family
 val elimination_sort_of_hyp  : Id.t -> goal sigma -> sorts_family
 val elimination_sort_of_clause : Id.t option -> goal sigma -> sorts_family
 
+val pf_with_evars :  (goal sigma -> Evd.evar_map * 'a) -> ('a -> tactic) -> tactic
+val pf_constr_of_global : Globnames.global_reference -> (constr -> tactic) -> tactic
+
 val elim_on_ba : (branch_assumptions -> tactic) -> branch_args  -> tactic
 val case_on_ba : (branch_assumptions -> tactic) -> branch_args  -> tactic
 
@@ -237,12 +240,14 @@ module New : sig
 
   val case_then_using :
     intro_pattern_expr located option -> (branch_args -> unit Proofview.tactic) ->
-    constr option -> inductive -> Term.constr * Term.types -> unit Proofview.tactic
+    constr option -> pinductive -> Term.constr * Term.types -> unit Proofview.tactic
 
   val case_nodep_then_using :
     intro_pattern_expr located option -> (branch_args -> unit Proofview.tactic) ->
-    constr option -> inductive -> Term.constr * Term.types -> unit Proofview.tactic
+    constr option -> pinductive -> Term.constr * Term.types -> unit Proofview.tactic
 
   val elim_on_ba : (branch_assumptions -> unit Proofview.tactic) -> branch_args  -> unit Proofview.tactic
   val case_on_ba : (branch_assumptions -> unit Proofview.tactic) -> branch_args  -> unit Proofview.tactic
+
+  val pf_constr_of_global : Globnames.global_reference -> (constr -> unit Proofview.tactic) -> unit Proofview.tactic
 end
diff --git a/tactics/tactics.ml b/tactics/tactics.ml
index 151c5b2ce..280950600 100644
--- a/tactics/tactics.ml
+++ b/tactics/tactics.ml
@@ -97,7 +97,7 @@ let tactic_infer_flags = {
 let finish_evar_resolution env initial_sigma (sigma,c) =
   let sigma =
     Pretyping.solve_remaining_evars tactic_infer_flags env initial_sigma sigma
-  in nf_evar sigma c
+  in Evd.evar_universe_context sigma, nf_evar sigma c
 
 (*********************************************)
 (*                 Tactics                   *)
@@ -112,7 +112,8 @@ let head_constr_bound t =
   let _,ccl = decompose_prod_assum t in
   let hd,args = decompose_app ccl in
   match kind_of_term hd with
-    | Const _ | Ind _ | Construct _ | Var _ -> (hd,args)
+    | Const _ | Ind _ | Construct _ | Var _ -> hd
+    | Proj (p, _) -> mkConst p
     | _ -> raise Bound
 
 let head_constr c =
@@ -128,6 +129,19 @@ let convert_concl   = Tacmach.convert_concl
 let convert_hyp     = Tacmach.convert_hyp
 let thin_body       = Tacmach.thin_body
 
+let convert_gen pb x y gl =
+  try tclEVARS (pf_apply Evd.conversion gl pb x y) gl
+  with Reduction.NotConvertible ->
+    tclFAIL_lazy 0 (lazy (str"Not convertible"))
+ (* Adding more information in this message, even under the lazy, can result in huge *)
+ (* blowups, time and spacewise... (see autos used in DoubleCyclic.) 2.3s against 15s. *)
+ (* 			    ++ Printer.pr_constr_env env x ++  *)
+ (* 			    str" and " ++ Printer.pr_constr_env env y)) *)
+        gl
+
+let convert = convert_gen Reduction.CONV
+let convert_leq = convert_gen Reduction.CUMUL
+
 let error_clear_dependency env id = function
   | Evarutil.OccurHypInSimpleClause None ->
       errorlabstrm "" (pr_id id ++ str " is used in conclusion.")
@@ -302,25 +316,54 @@ let reduct_option redfun = function
   | Some id -> reduct_in_hyp (fst redfun) id
   | None    -> reduct_in_concl (revert_cast redfun)
 
+(** Versions with evars to maintain the unification of universes resulting
+    from conversions. *)
+
+let tclWITHEVARS f k gl =
+  let evm, c' = pf_apply f gl in
+    tclTHEN (tclEVARS evm) (k c') gl
+
+let e_reduct_in_concl (redfun,sty) gl =
+  tclWITHEVARS 
+    (fun env sigma -> redfun env sigma (pf_concl gl))
+    (fun c -> convert_concl_no_check c sty) gl
+
+let e_pf_reduce_decl (redfun : e_reduction_function) where (id,c,ty) env sigma =
+  match c with
+  | None ->
+      if where == InHypValueOnly then
+	errorlabstrm "" (pr_id id ++ str "has no value.");
+    let sigma',ty' = redfun env sigma ty in
+      sigma', (id,None,ty')
+  | Some b ->
+      let sigma',b' = if where != InHypTypeOnly then redfun env sigma b else sigma, b in
+      let sigma',ty' = if where != InHypValueOnly then redfun env sigma ty else sigma', ty in
+	sigma', (id,Some b',ty')
+    
+let e_reduct_in_hyp redfun (id,where) gl =
+  tclWITHEVARS
+    (e_pf_reduce_decl redfun where (pf_get_hyp gl id))
+    convert_hyp_no_check gl
+
 (* Now we introduce different instances of the previous tacticals *)
 let change_and_check cv_pb t env sigma c =
-  if is_fconv cv_pb env sigma t c then
-    t
-  else
-    errorlabstrm "convert-check-hyp" (str "Not convertible.")
+  let evd, b = infer_conv ~pb:cv_pb env sigma t c in
+    if b then evd, t
+    else
+      errorlabstrm "convert-check-hyp" (str "Not convertible.")
 
 (* Use cumulativity only if changing the conclusion not a subterm *)
 let change_on_subterm cv_pb t = function
   | None -> change_and_check cv_pb t
   | Some occl ->
-      contextually false occl
+      e_contextually false occl
         (fun subst -> change_and_check Reduction.CONV (replace_vars (Id.Map.bindings subst) t))
 
 let change_in_concl occl t =
-  reduct_in_concl ((change_on_subterm Reduction.CUMUL t occl),DEFAULTcast)
+  e_reduct_in_concl ((change_on_subterm Reduction.CUMUL t occl),DEFAULTcast)
 
 let change_in_hyp occl t id  =
-  with_check (reduct_in_hyp (change_on_subterm Reduction.CONV t occl) id)
+  with_check (e_reduct_in_hyp (change_on_subterm Reduction.CONV t occl) id)
 
 let change_option occl t = function
   | Some id -> change_in_hyp occl t id
@@ -785,7 +828,7 @@ let index_of_ind_arg t =
       | None -> error "Could not find inductive argument of elimination scheme."
   in aux None 0 t
 
-let elimination_clause_scheme with_evars ?(flags=elim_flags) i elimclause indclause gl =
+let 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
@@ -830,13 +873,14 @@ let general_elim with_evars c e =
 let general_case_analysis_in_context with_evars (c,lbindc) gl =
   let (mind,_) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in
   let sort = elimination_sort_of_goal gl in
-  let elim =
+  let sigma, elim =
     if occur_term c (pf_concl gl) then
       pf_apply build_case_analysis_scheme gl mind true sort
     else
       pf_apply build_case_analysis_scheme_default gl mind sort in
-  general_elim with_evars (c,lbindc)
-    {elimindex = None; elimbody = (elim,NoBindings)} gl
+  tclTHEN (tclEVARS sigma)
+  (general_elim with_evars (c,lbindc)
+   {elimindex = None; elimbody = (elim,NoBindings)}) gl
 
 let general_case_analysis with_evars (c,lbindc as cx) =
   match kind_of_term c with
@@ -855,17 +899,22 @@ exception IsRecord
 
 let is_record mind = (Global.lookup_mind (fst mind)).mind_record
 
+let find_ind_eliminator ind s gl =
+  let gr = lookup_eliminator ind s in
+  let evd, c = pf_apply Evd.fresh_global gl gr in
+    evd, c
+
 let find_eliminator c gl =
-  let (ind,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in
-  if is_record ind then raise IsRecord;
-  let c = lookup_eliminator ind (elimination_sort_of_goal gl) in
-  {elimindex = None; elimbody = (c,NoBindings)}
+  let ((ind,u),t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in
+  if is_record ind <> None then raise IsRecord;
+  let evd, c = find_ind_eliminator ind (elimination_sort_of_goal gl) gl in
+    evd, {elimindex = None; elimbody = (c,NoBindings)}
 
 let default_elim with_evars (c,_ as cx) =
   Proofview.tclORELSE
     (Proofview.Goal.enter begin fun gl ->
-      let elim = Tacmach.New.of_old (find_eliminator c) gl in
-      Proofview.V82.tactic (general_elim with_evars cx elim)
+      let evd, elim = Tacmach.New.of_old (find_eliminator c) gl in
+      Proofview.V82.tactic (tclTHEN (tclEVARS evd) (general_elim with_evars cx elim))
     end)
     begin function
       | IsRecord ->
@@ -902,13 +951,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 ?(flags=elim_flags) mv elimclause hypclause =
+let clenv_fchain_in id ?(flags=elim_flags ()) mv elimclause hypclause =
   try clenv_fchain ~flags mv elimclause hypclause
   with PretypeError (env,evd,NoOccurrenceFound (op,_)) ->
     (* Set the hypothesis name in the message *)
     raise (PretypeError (env,evd,NoOccurrenceFound (op,Some id)))
 
-let elimination_in_clause_scheme with_evars ?(flags=elim_flags) id i elimclause indclause gl =
+let elimination_in_clause_scheme with_evars ?(flags=elim_flags ()) id i elimclause indclause gl =
   let indmv = destMeta (nth_arg i elimclause.templval.rebus) in
   let hypmv =
     try match List.remove Int.equal indmv (clenv_independent elimclause) with
@@ -933,7 +982,7 @@ type conjunction_status =
   | DefinedRecord of constant option list
   | NotADefinedRecordUseScheme of constr
 
-let make_projection sigma params cstr sign elim i n c =
+let make_projection env sigma params cstr sign elim i n c u =
   let elim = match elim with
   | NotADefinedRecordUseScheme elim ->
       (* bugs: goes from right to left when i increases! *)
@@ -947,24 +996,32 @@ let make_projection sigma params cstr sign elim i n c =
 	&& not (isEvar (fst (whd_betaiota_stack sigma t)))
       then
         let t = lift (i+1-n) t in
-	Some (beta_applist (elim,params@[t;branch]),t)
+	let abselim = beta_applist (elim,params@[t;branch]) in
+	let c = beta_applist (abselim, [mkApp (c, extended_rel_vect 0 sign)]) in
+	  Some (it_mkLambda_or_LetIn c sign, it_mkProd_or_LetIn t sign)
       else
 	None
   | DefinedRecord l ->
       (* goes from left to right when i increases! *)
       match List.nth l i with
       | Some proj ->
-	  let t = Typeops.type_of_constant (Global.env()) proj in
 	  let args = extended_rel_vect 0 sign in
-	  Some (beta_applist (mkConst proj,params),prod_applist t (params@[mkApp (c,args)]))
+	  let proj = 
+	    if Environ.is_projection proj env then
+	      mkProj (proj, mkApp (c, args)) 
+	    else 
+	      mkApp (mkConstU (proj,u), Array.append (Array.of_list params)
+		[|mkApp (c, args)|])
+	  in
+	  let app = it_mkLambda_or_LetIn proj sign in
+	  let t = Retyping.get_type_of env sigma app in
+	    Some (app, t)
       | None -> None
-  in Option.map (fun (abselim,elimt) -> 
-    let c = beta_applist (abselim,[mkApp (c,extended_rel_vect 0 sign)]) in
-    (it_mkLambda_or_LetIn c sign, it_mkProd_or_LetIn elimt sign)) elim
+  in elim
 
 let descend_in_conjunctions tac exit c gl =
   try
-    let (ind,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in
+    let ((ind,u),t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in
     let sign,ccl = decompose_prod_assum t in
     match match_with_tuple ccl with
     | Some (_,_,isrec) ->
@@ -972,18 +1029,18 @@ let descend_in_conjunctions tac exit c gl =
 	let sort = elimination_sort_of_goal gl in
 	let id = fresh_id [] (Id.of_string "H") gl in
 	let IndType (indf,_) = pf_apply find_rectype gl ccl in
-	let params = snd (dest_ind_family indf) in
+	let (_,inst), params = dest_ind_family indf in
 	let cstr = (get_constructors (pf_env gl) indf).(0) in
 	let elim =
 	  try DefinedRecord (Recordops.lookup_projections ind)
 	  with Not_found ->
-	    let elim = pf_apply build_case_analysis_scheme gl ind false sort in
-	    NotADefinedRecordUseScheme elim in
+	    let elim = pf_apply build_case_analysis_scheme gl (ind,u) false sort in
+	    NotADefinedRecordUseScheme (snd elim) in
 	tclFIRST
 	  (List.init n (fun i gl ->
-	    match make_projection (project gl) params cstr sign elim i n c with
+	    match pf_apply make_projection gl params cstr sign elim i n c u with
 	    | None -> tclFAIL 0 (mt()) gl
-	    | Some (p,pt) ->
+	    | Some (p,pt) -> 
 	    tclTHENS
 	      (internal_cut id pt)
 	      [refine p; (* Might be ill-typed due to forbidden elimination. *)
@@ -999,7 +1056,7 @@ let descend_in_conjunctions tac exit c gl =
 
 let general_apply with_delta with_destruct with_evars (loc,(c,lbind)) gl0 =
   let flags =
-    if with_delta then default_unify_flags else default_no_delta_unify_flags in
+    if with_delta then default_unify_flags () else default_no_delta_unify_flags () in
   (* The actual type of the theorem. It will be matched against the
   goal. If this fails, then the head constant will be unfolded step by
   step. *)
@@ -1094,7 +1151,7 @@ let apply_in_once_main flags innerclause (d,lbind) gl =
 
 let apply_in_once sidecond_first with_delta with_destruct with_evars id
   (loc,(d,lbind)) gl0 =
-  let flags = if with_delta then elim_flags else elim_no_delta_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 =
@@ -1144,13 +1201,17 @@ let cut_and_apply c =
 (*               Exact tactics                                      *)
 (********************************************************************)
 
+(* let convert_leqkey = Profile.declare_profile "convert_leq";; *)
+(* let convert_leq = Profile.profile3 convert_leqkey convert_leq *)
+
+(* let refine_no_checkkey = Profile.declare_profile "refine_no_check";; *)
+(* let refine_no_check = Profile.profile2 refine_no_checkkey refine_no_check *)
+
 let exact_check c gl =
   let concl = (pf_concl gl) in
   let ct = pf_type_of gl c in
-  if pf_conv_x_leq gl ct concl then
-    refine_no_check c gl
-  else
-    error "Not an exact proof."
+    try tclTHEN (convert_leq ct concl) (refine_no_check c) gl
+    with _ -> error "Not an exact proof." (*FIXME error handling here not the best *)
 
 let exact_no_check = refine_no_check
 let new_exact_no_check c =
@@ -1162,8 +1223,8 @@ let vm_cast_no_check c gl =
 
 
 let exact_proof c gl =
-  let c = Constrintern.interp_casted_constr (project gl) (pf_env gl) c (pf_concl gl)
-  in refine_no_check c gl
+  let c,ctx = Constrintern.interp_casted_constr (project gl) (pf_env gl) c (pf_concl gl)
+  in tclPUSHCONTEXT Evd.univ_flexible ctx (refine_no_check c) gl
 
 let assumption =
   let rec arec gl only_eq = function
@@ -1174,12 +1235,12 @@ let assumption =
     else Tacticals.New.tclZEROMSG (str "No such assumption.")
   | (id, c, t)::rest ->
     let concl = Proofview.Goal.concl gl in
-    let is_same_type =
-      if only_eq then eq_constr t concl
+    let sigma = Proofview.Goal.sigma gl in
+    let (sigma, is_same_type) =
+      if only_eq then (sigma, eq_constr t concl)
       else
-        let sigma = Proofview.Goal.sigma gl in
         let env = Proofview.Goal.env gl in
-        is_conv_leq env sigma t concl
+        infer_conv env sigma t concl
     in
     if is_same_type then Proofview.Refine.refine (fun h -> (h, mkVar id))
     else arec gl only_eq rest
@@ -1233,7 +1294,7 @@ let specialize mopt (c,lbind) g =
 	tclEVARS evd, nf_evar evd c
     else
       let clause = pf_apply make_clenv_binding g (c,pf_type_of g c) lbind in
-      let flags = { default_unify_flags with resolve_evars = true } in
+      let flags = { (default_unify_flags ()) with resolve_evars = true } in
       let clause = clenv_unify_meta_types ~flags clause in
       let (thd,tstack) = whd_nored_stack clause.evd (clenv_value clause) in
       let nargs = List.length tstack in
@@ -1299,14 +1360,20 @@ let constructor_tac with_evars expctdnumopt i lbind =
     let reduce_to_quantified_ind =
       Tacmach.New.pf_apply Tacred.reduce_to_quantified_ind gl
     in
-    let (mind,redcl) = reduce_to_quantified_ind cl in
-    let nconstr =
-      Array.length (snd (Global.lookup_inductive mind)).mind_consnames in
-    check_number_of_constructors expctdnumopt i nconstr;
-    let cons = mkConstruct (ith_constructor_of_inductive mind i) in
-    let apply_tac = Proofview.V82.tactic (general_apply true false with_evars (dloc,(cons,lbind))) in
-    (Tacticals.New.tclTHENLIST
-        [Proofview.V82.tactic (convert_concl_no_check redcl DEFAULTcast); intros; apply_tac])
+      try (* reduce_to_quantified_ind can raise an exception *)
+	let (mind,redcl) = reduce_to_quantified_ind cl in
+	let nconstr =
+	  Array.length (snd (Global.lookup_inductive (fst mind))).mind_consnames in
+	  check_number_of_constructors expctdnumopt i nconstr;
+	  
+	  let sigma, cons = Evd.fresh_constructor_instance 
+	    (Proofview.Goal.env gl) (Proofview.Goal.sigma gl) (fst mind, i) in
+	  let cons = mkConstructU cons in
+	    
+	  let apply_tac = Proofview.V82.tactic (general_apply true false with_evars (dloc,(cons,lbind))) in
+	    (Tacticals.New.tclTHENLIST
+               [Proofview.V82.tactic (tclTHEN (tclEVARS sigma) (convert_concl_no_check redcl DEFAULTcast)); intros; apply_tac])
+      with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e
   end
 
 let one_constructor i lbind = constructor_tac false None i lbind
@@ -1331,7 +1398,7 @@ let any_constructor with_evars tacopt =
     in
     let mind = fst (reduce_to_quantified_ind cl) in
     let nconstr =
-      Array.length (snd (Global.lookup_inductive mind)).mind_consnames in
+      Array.length (snd (Global.lookup_inductive (fst mind))).mind_consnames in
     if Int.equal nconstr 0 then error "The type has no constructors.";
     tclANY tac (List.interval 1 nconstr)
  end
@@ -1395,7 +1462,7 @@ let intro_decomp_eq loc b l l' thin tac id =
   let c = mkVar id in
   let t = Tacmach.New.pf_type_of gl c in
   let _,t = Tacmach.New.pf_reduce_to_quantified_ind gl t in
-  let eq,eq_args = my_find_eq_data_decompose gl t in
+  let eq,u,eq_args = my_find_eq_data_decompose gl t in
   let eq_clause = Tacmach.New.pf_apply make_clenv_binding gl (c,t) NoBindings in
   !intro_decomp_eq_function
     (fun n -> tac ((dloc,id)::thin) (adjust_intro_patterns n l @ l'))
@@ -1406,7 +1473,7 @@ let intro_or_and_pattern loc b ll l' thin tac id =
   Proofview.Goal.raw_enter begin fun gl ->
   let c = mkVar id in
   let t = Tacmach.New.pf_type_of gl c in
-  let (ind,t) = Tacmach.New.pf_reduce_to_quantified_ind gl t in
+  let ((ind,u),t) = Tacmach.New.pf_reduce_to_quantified_ind gl t in
   let nv = mis_constr_nargs ind in
   let bracketed = b || not (List.is_empty l') in
   let adjust n l = if bracketed then adjust_intro_patterns n l else l in
@@ -1660,14 +1727,14 @@ let generalized_name c t ids cl = function
                constante dont on aurait pu prendre directement le nom *)
 	    named_hd (Global.env()) t Anonymous
 
-let generalize_goal gl i ((occs,c,b),na) cl =
+let generalize_goal gl i ((occs,c,b),na) (cl,evd) =
   let t = pf_type_of gl c in
   let decls,cl = decompose_prod_n_assum i cl in
   let dummy_prod = it_mkProd_or_LetIn mkProp decls in
-  let newdecls,_ = decompose_prod_n_assum i (subst_term c dummy_prod) in
-  let cl' = subst_closed_term_occ occs c (it_mkProd_or_LetIn cl newdecls) in
+  let newdecls,_ = decompose_prod_n_assum i (subst_term_gen eq_constr_nounivs c dummy_prod) in
+  let cl',evd' = subst_closed_term_univs_occ evd 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'
+    mkProd_or_LetIn (na,b,t) cl', evd
 
 let generalize_dep ?(with_let=false) c gl =
   let env = pf_env gl in
@@ -1697,18 +1764,23 @@ let generalize_dep ?(with_let=false) c gl =
       | _ -> None
     else None
   in
-  let cl'' = generalize_goal gl 0 ((AllOccurrences,c,body),Anonymous) cl' in
+  let cl'',evd = generalize_goal gl 0 ((AllOccurrences,c,body),Anonymous) 
+    (cl',project gl) in
   let args = instance_from_named_context to_quantify_rev in
-  tclTHEN
-    (apply_type cl'' (if Option.is_empty body then c::args else args))
-    (thin (List.rev tothin'))
+  tclTHENLIST
+    [tclPUSHEVARUNIVCONTEXT (Evd.evar_universe_context evd);
+     apply_type cl'' (if Option.is_empty body then c::args else args);
+     thin (List.rev tothin')]
     gl
 
 let generalize_gen_let lconstr gl =
-  let newcl =
-    List.fold_right_i (generalize_goal gl) 0 lconstr (pf_concl gl) in
-  apply_type newcl (List.map_filter (fun ((_,c,b),_) -> 
-    if Option.is_empty b then Some c else None) lconstr) gl
+  let newcl, evd =
+    List.fold_right_i (generalize_goal gl) 0 lconstr 
+      (pf_concl gl,project gl) 
+  in
+  tclTHEN (tclPUSHEVARUNIVCONTEXT (Evd.evar_universe_context evd))
+    (apply_type newcl (List.map_filter (fun ((_,c,b),_) -> 
+      if Option.is_empty b then Some c else None) lconstr)) gl
 
 let generalize_gen lconstr =
   generalize_gen_let (List.map (fun ((occs,c),na) ->
@@ -1804,19 +1876,30 @@ let default_matching_flags sigma = {
 
 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)
+  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
+    | Some (evd,c1), Some (_,c2) -> 
+      (try let evd = w_unify env evd Reduction.CONV ~flags c1 c2 in
+	     Some (evd, c1) 
+       with e when Errors.noncritical e -> raise NotUnifiable)
+    | Some _, None -> c1
+    | None, Some _ -> c2
+    | None, None -> None 
+  in
   { match_fun = matching_fun; merge_fun = merge_fun; 
     testing_state = None; last_found = None },
   (fun test -> match test.testing_state with
-   | None -> finish_evar_resolution env sigma0 (sigma,c)
-   | Some (sigma,_) -> nf_evar sigma c)
+  | None -> 
+    let ctx, c = finish_evar_resolution env sigma0 (sigma,c) in
+      Proofview.V82.tactic (tclPUSHEVARUNIVCONTEXT ctx), c
+  | Some (sigma,_) -> 
+     let univs, subst = nf_univ_variables sigma in
+       Proofview.V82.tactic (tclPUSHEVARUNIVCONTEXT (Evd.evar_universe_context univs)),
+       subst_univs_constr subst (nf_evar sigma c))
 
 let letin_abstract id c (test,out) (occs,check_occs) gl =
   let env = pf_env gl in
@@ -1854,13 +1937,13 @@ let letin_tac_gen with_eq name (sigmac,c) test ty occs =
           if not (mem_named_context x hyps) then x else
 	    error ("The variable "^(Id.to_string x)^" is already declared.")
     in
-    let (depdecls,lastlhyp,ccl,c) =
+    let (depdecls,lastlhyp,ccl,(tac,c)) =
       Tacmach.New.of_old (letin_abstract id c test occs) gl
     in
     let t =
       match ty with Some t -> t | None -> Tacmach.New.pf_apply (fun e s -> typ_of e s c) gl
     in
-    let (newcl,eq_tac) = match with_eq with
+    let (sigma,newcl,eq_tac) = match with_eq with
       | Some (lr,(loc,ido)) ->
           let heq = match ido with
             | IntroAnonymous -> new_fresh_id [id] (add_prefix "Heq" id) gl
@@ -1869,26 +1952,34 @@ let letin_tac_gen with_eq name (sigmac,c) test ty occs =
 	    | _ -> Errors.error "Expect an introduction pattern naming one hypothesis." in
             let eqdata = build_coq_eq_data () in
             let args = if lr then [t;mkVar id;c] else [t;c;mkVar id]in
-            let eq = applist (eqdata.eq,args) in
-            let refl = applist (eqdata.refl, [t;mkVar id]) in
+            let sigma, eq = Evd.fresh_global env (Proofview.Goal.sigma gl) eqdata.eq in
+            let sigma, refl = Evd.fresh_global env sigma eqdata.refl in
+            let eq = applist (eq,args) in
+            let refl = applist (refl, [t;mkVar id]) in
+              sigma,
               mkNamedLetIn id c t (mkLetIn (Name heq, refl, eq, ccl)),
               Tacticals.New.tclTHEN
 	        (intro_gen loc (IntroMustBe heq) lastlhyp true false)
 	        (Proofview.V82.tactic (thin_body [heq;id]))
       | None ->
-	  (mkNamedLetIn id c t ccl, Proofview.tclUNIT ()) in
+	  (Proofview.Goal.sigma gl, mkNamedLetIn id c t ccl, Proofview.tclUNIT ()) in
     Tacticals.New.tclTHENLIST
-      [ Proofview.V82.tactic (convert_concl_no_check newcl DEFAULTcast);
+      [ Proofview.V82.tclEVARS sigma; tac; Proofview.V82.tactic (convert_concl_no_check newcl DEFAULTcast);
         intro_gen dloc (IntroMustBe id) lastlhyp true false;
         Proofview.V82.tactic (tclMAP convert_hyp_no_check depdecls);
         eq_tac ]
   end
 
-let make_eq_test c = (make_eq_test c,fun _ -> c)
+let make_eq_test evd c = 
+  let out cstr = 
+    let tac = tclPUSHEVARUNIVCONTEXT (Evd.evar_universe_context cstr.testing_state) in
+      Proofview.V82.tactic tac, c
+  in
+    (Tacred.make_eq_univs_test Evd.empty c, out)
 
 let letin_tac with_eq name c ty occs =
   Proofview.tclEVARMAP >>= fun sigma ->
-  letin_tac_gen with_eq name (sigma,c) (make_eq_test c) ty (occs,true)
+  letin_tac_gen with_eq name (sigma,c) (make_eq_test sigma c) ty (occs,true)
 
 let letin_pat_tac with_eq name c ty occs =
   Proofview.Goal.raw_enter begin fun gl ->
@@ -2401,25 +2492,28 @@ let error_ind_scheme s =
   let s = if not (String.is_empty s) then s^" " else s in
   error ("Cannot recognize "^s^"an induction scheme.")
 
-let coq_eq = Lazy.lazy_from_fun Coqlib.build_coq_eq
-let coq_eq_refl = lazy ((Coqlib.build_coq_eq_data ()).Coqlib.refl)
+let glob = Universes.constr_of_global
+
+let coq_eq = lazy (glob (Coqlib.build_coq_eq ()))
+let coq_eq_refl = lazy (glob (Coqlib.build_coq_eq_refl ()))
 
 let coq_heq = lazy (Coqlib.coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq")
 let coq_heq_refl = lazy (Coqlib.coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq_refl")
 
+
 let mkEq t x y = 
-  mkApp (Lazy.force coq_eq, [| refresh_universes_strict t; x; y |])
+  mkApp (Lazy.force coq_eq, [| t; x; y |])
     
 let mkRefl t x = 
-  mkApp (Lazy.force coq_eq_refl, [| refresh_universes_strict t; x |])
+  mkApp (Lazy.force coq_eq_refl, [| t; x |])
 
 let mkHEq t x u y =
   mkApp (Lazy.force coq_heq,
-	[| refresh_universes_strict t; x; refresh_universes_strict u; y |])
+	[| t; x; u; y |])
     
 let mkHRefl t x =
   mkApp (Lazy.force coq_heq_refl,
-	[| refresh_universes_strict t; x |])
+	[| t; x |])
 
 let lift_togethern n l =
   let l', _ =
@@ -2437,8 +2531,8 @@ let ids_of_constr ?(all=false) vars c =
     | Var id -> Id.Set.add id vars
     | App (f, args) -> 
 	(match kind_of_term f with
-	| Construct (ind,_)
-	| Ind ind ->
+	| Construct ((ind,_),_)
+	| Ind (ind,_) ->
             let (mib,mip) = Global.lookup_inductive ind in
 	      Array.fold_left_from
 		(if all then 0 else mib.Declarations.mind_nparams)
@@ -2449,8 +2543,8 @@ let ids_of_constr ?(all=false) vars c =
     
 let decompose_indapp f args =
   match kind_of_term f with
-  | Construct (ind,_) 
-  | Ind ind ->
+  | Construct ((ind,_),_)
+  | Ind (ind,_) ->
       let (mib,mip) = Global.lookup_inductive ind in
       let first = mib.Declarations.mind_nparams_rec in
       let pars, args = Array.chop first args in
@@ -2552,8 +2646,7 @@ let abstract_args gl generalize_vars dep id defined f args =
 	List.hd rel, c
     in
     let argty = pf_type_of gl arg in
-    let argty = refresh_universes_strict argty in 
-    let ty = refresh_universes_strict ty in
+    let ty = (* refresh_universes_strict *) ty in
     let lenctx = List.length ctx in
     let liftargty = lift lenctx argty in
     let leq = constr_cmp Reduction.CUMUL liftargty ty in
@@ -2656,7 +2749,7 @@ let specialize_eqs id gl =
     match kind_of_term ty with
     | Prod (na, t, b) -> 
 	(match kind_of_term t with
-	| App (eq, [| eqty; x; y |]) when eq_constr eq (Lazy.force coq_eq) ->
+	| App (eq, [| eqty; x; y |]) when eq_constr (Lazy.force coq_eq) eq ->
 	    let c = if noccur_between 1 (List.length ctx) x then y else x in
 	    let pt = mkApp (Lazy.force coq_eq, [| eqty; c; c |]) in
 	    let p = mkApp (Lazy.force coq_eq_refl, [| eqty; c |]) in
@@ -2691,7 +2784,7 @@ let specialize_eqs id gl =
   let ty' = Evarutil.nf_evar !evars ty' in
     if worked then
       tclTHENFIRST (Tacmach.internal_cut true id ty')
-	(exact_no_check (refresh_universes_strict acc')) gl
+	(exact_no_check ((* refresh_universes_strict *) acc')) gl
     else tclFAIL 0 (str "Nothing to do in hypothesis " ++ pr_id id) gl
       
 
@@ -2912,7 +3005,7 @@ let compute_scheme_signature scheme names_info ind_type_guess =
    extra final argument of the form (f x y ...) in the conclusion. In
    the non standard case, naming of generated hypos is slightly
    different. *)
-let compute_elim_signature ((elimc,elimt),ind_type_guess) names_info =
+let compute_elim_signature (evd,(elimc,elimt),ind_type_guess) names_info =
   let scheme = compute_elim_sig ~elimc:elimc elimt in
   compute_scheme_signature scheme names_info ind_type_guess, scheme
 
@@ -2920,8 +3013,8 @@ let guess_elim isrec hyp0 gl =
   let tmptyp0 =	pf_get_hyp_typ gl hyp0 in
   let mind,_ = pf_reduce_to_quantified_ind gl tmptyp0 in
   let s = elimination_sort_of_goal gl in
-  let elimc =
-    if isrec && not (is_record mind) then lookup_eliminator mind s
+  let evd, elimc =
+    if isrec && not (is_record (fst mind) <> None) then find_ind_eliminator (fst mind) s gl
     else
       if use_dependent_propositions_elimination () &&
 	dependent_no_evar (mkVar hyp0) (pf_concl gl)
@@ -2930,12 +3023,12 @@ let guess_elim isrec hyp0 gl =
       else
 	pf_apply build_case_analysis_scheme_default gl mind s in
   let elimt = pf_type_of gl elimc in
-  ((elimc, NoBindings), elimt), mkInd mind
+    evd, ((elimc, NoBindings), elimt), mkIndU mind
 
 let given_elim hyp0 (elimc,lbind as e) gl =
   let tmptyp0 = pf_get_hyp_typ gl hyp0 in
   let ind_type_guess,_ = decompose_app ((strip_prod tmptyp0)) in
-  (e, pf_type_of gl elimc), ind_type_guess
+  project gl, (e, pf_type_of gl elimc), ind_type_guess
 
 let find_elim isrec elim hyp0 gl =
   match elim with
@@ -2950,21 +3043,21 @@ type eliminator_source =
   | ElimOver of bool * Id.t
 
 let find_induction_type isrec elim hyp0 gl =
-  let scheme,elim =
+  let evd,scheme,elim =
     match elim with
     | None ->
-	let (elimc,elimt),_ = guess_elim isrec hyp0 gl in
+	let evd, (elimc,elimt),_ = guess_elim isrec hyp0 gl in
 	let scheme = compute_elim_sig ~elimc elimt in
 	(* We drop the scheme waiting to know if it is dependent *)
-	scheme, ElimOver (isrec,hyp0)
+	project gl, scheme, ElimOver (isrec,hyp0)
     | Some e ->
-	let (elimc,elimt),ind_guess = given_elim hyp0 e gl in
+	let evd, (elimc,elimt),ind_guess = given_elim hyp0 e gl in
 	let scheme = compute_elim_sig ~elimc elimt in
 	if Option.is_empty scheme.indarg then error "Cannot find induction type";
 	let indsign = compute_scheme_signature scheme hyp0 ind_guess in
 	let elim = ({elimindex = Some(-1); elimbody = elimc},elimt) in
-	scheme, ElimUsing (elim,indsign) in
-  Option.get scheme.indref,scheme.nparams, elim
+	evd, scheme, ElimUsing (elim,indsign) in
+  evd,(Option.get scheme.indref,scheme.nparams, elim)
 
 let find_elim_signature isrec elim hyp0 gl =
   compute_elim_signature (find_elim isrec elim hyp0 gl) hyp0
@@ -2984,10 +3077,10 @@ let is_functional_induction elim gl =
 
 let get_eliminator elim gl = match elim with
   | ElimUsing (elim,indsign) ->
-      (* bugged, should be computed *) true, elim, indsign
+      Proofview.Goal.sigma gl, (* bugged, should be computed *) true, elim, indsign
   | ElimOver (isrec,id) ->
-      let (elimc,elimt),_ as elims = Tacmach.New.of_old (guess_elim isrec id) gl in
-      isrec, ({elimindex = None; elimbody = elimc}, elimt),
+      let evd, (elimc,elimt),_ as elims = Tacmach.New.of_old (guess_elim isrec id) gl in
+      evd, isrec, ({elimindex = None; elimbody = elimc}, elimt),
       fst (compute_elim_signature elims id)
 
 (* Instantiate all meta variables of elimclause using lid, some elts
@@ -3041,7 +3134,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 ~flags:elim_flags 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
@@ -3049,13 +3142,14 @@ let induction_tac_felim with_evars indvars nparams elim gl =
 
 let apply_induction_with_discharge induct_tac elim indhyps destopt avoid names tac =
   Proofview.Goal.enter begin fun gl ->
-  let (isrec, elim, indsign) = get_eliminator elim gl in
+  let (sigma, isrec, elim, indsign) = get_eliminator elim gl in
   let names = compute_induction_names (Array.length indsign) names in
-  (if isrec then Tacticals.New.tclTHENFIRSTn else Tacticals.New.tclTHENLASTn)
+  Tacticals.New.tclTHEN (Proofview.V82.tclEVARS sigma)
+  ((if isrec then Tacticals.New.tclTHENFIRSTn else Tacticals.New.tclTHENLASTn)
     (Tacticals.New.tclTHEN
        (induct_tac elim)
        (Proofview.V82.tactic (tclMAP (fun id -> tclTRY (expand_hyp id)) (List.rev indhyps))))
-    (Array.map2 (induct_discharge destopt avoid tac) indsign names)
+    (Array.map2 (induct_discharge destopt avoid tac) indsign names))
   end
 
 (* Apply induction "in place" taking into account dependent
@@ -3066,7 +3160,7 @@ let apply_induction_in_context hyp0 elim indvars names induct_tac =
     let env = Proofview.Goal.env gl in
     let concl = Tacmach.New.pf_nf_concl gl in
     let statuslists,lhyp0,indhyps,deps = cook_sign hyp0 indvars env in
-    let deps = List.map (on_pi3 refresh_universes_strict) deps in
+(*     let deps = List.map (on_pi3 refresh_universes_strict) deps in *)
     let tmpcl = it_mkNamedProd_or_LetIn concl deps in
     let dephyps = List.map (fun (id,_,_) -> id) deps in
     let deps_cstr =
@@ -3163,11 +3257,11 @@ let induction_from_context isrec with_evars (indref,nparams,elim) (hyp0,lbind) n
 
 let induction_with_atomization_of_ind_arg isrec with_evars elim names (hyp0,lbind) inhyps =
   Proofview.Goal.enter begin fun gl ->
-  let elim_info = Tacmach.New.of_old (find_induction_type isrec elim hyp0) gl in
-  Tacticals.New.tclTHEN
-    (atomize_param_of_ind elim_info hyp0)
+  let sigma, elim_info = Tacmach.New.of_old (find_induction_type isrec elim hyp0) gl in
+  Tacticals.New.tclTHENLIST
+    [Proofview.V82.tclEVARS sigma; (atomize_param_of_ind elim_info hyp0);
     (induction_from_context isrec with_evars elim_info
-      (hyp0,lbind) names inhyps)
+      (hyp0,lbind) names inhyps)]
   end
 
 (* Induction on a list of induction arguments. Analyse the elim
@@ -3319,9 +3413,10 @@ let induct_destruct isrec with_evars (lc,elim,names,cls) =
       str "Example: induction x1 x2 x3 using my_scheme.");
     if not (Option.is_empty cls) then
       error "'in' clause not supported here.";
-    let finish_evar_resolution = Tacmach.New.pf_apply finish_evar_resolution gl in
-    let lc = List.map
-      (map_induction_arg finish_evar_resolution) lc in
+    let finish_evar_resolution (sigma, c) =
+      snd (finish_evar_resolution (Proofview.Goal.env gl) (Proofview.Goal.sigma gl) (sigma, c))
+    in
+    let lc = List.map (map_induction_arg finish_evar_resolution) lc in
     begin match lc with
     | [_] ->
       (* Hook to recover standard induction on non-standard induction schemes *)
@@ -3398,20 +3493,22 @@ let elim_scheme_type elim t gl =
     | Meta mv ->
         let clause' =
 	  (* t is inductive, then CUMUL or CONV is irrelevant *)
-	  clenv_unify ~flags:elim_flags Reduction.CUMUL t
+	  clenv_unify ~flags:(elim_flags ()) Reduction.CUMUL t
             (clenv_meta_type clause mv) clause in
-	res_pf clause' ~flags:elim_flags gl
+	res_pf clause' ~flags:(elim_flags ()) gl
     | _ -> anomaly (Pp.str "elim_scheme_type")
 
 let elim_type t gl =
   let (ind,t) = pf_reduce_to_atomic_ind gl t in
-  let elimc = lookup_eliminator ind (elimination_sort_of_goal gl) in
-  elim_scheme_type elimc t gl
+  let evd, elimc = find_ind_eliminator (fst ind) (elimination_sort_of_goal gl) gl in
+    tclTHEN (tclEVARS evd) (elim_scheme_type elimc t) gl
 
 let case_type t gl =
   let (ind,t) = pf_reduce_to_atomic_ind gl t in
-  let elimc = pf_apply build_case_analysis_scheme_default gl ind (elimination_sort_of_goal gl) in
-  elim_scheme_type elimc t gl
+  let evd, elimc = 
+    pf_apply build_case_analysis_scheme_default gl ind (elimination_sort_of_goal gl) 
+  in
+    tclTHEN (tclEVARS evd) (elim_scheme_type elimc t) gl
 
 
 (************************************************)
@@ -3492,7 +3589,7 @@ let symmetry_red allowred =
       Proofview.V82.tactic begin
         tclTHEN
           (convert_concl_no_check concl DEFAULTcast)
-          (apply eq_data.sym)
+          (pf_constr_of_global eq_data.sym apply)
       end
   | None,eq,eq_kind -> prove_symmetry eq eq_kind
   end
@@ -3587,8 +3684,8 @@ let transitivity_red allowred t =
         tclTHEN
           (convert_concl_no_check concl DEFAULTcast)
           (match t with
-	  | None -> eapply eq_data.trans
-	  | Some t -> apply_list [eq_data.trans;t])
+	  | None -> pf_constr_of_global eq_data.trans eapply
+	  | Some t -> pf_constr_of_global eq_data.trans (fun trans -> apply_list [trans;t]))
       end
   | None,eq,eq_kind ->
       match t with
@@ -3613,7 +3710,7 @@ let intros_transitivity  n  = Tacticals.New.tclTHEN intros (transitivity_gen n)
    the current goal, abstracted with respect to the local signature,
    is solved by tac *)
 
-let interpretable_as_section_decl d1 d2 = match d1,d2 with
+let interpretable_as_section_decl d1 d2 = match d2,d1 with
   | (_,Some _,_), (_,None,_) -> false
   | (_,Some b1,t1), (_,Some b2,t2) -> eq_constr b1 b2 && eq_constr t1 t2
   | (_,None,t1), (_,_,t2) -> eq_constr t1 t2
@@ -3639,9 +3736,16 @@ let abstract_subproof id tac =
     try flush_and_check_evars (Proofview.Goal.sigma gl) concl
     with Uninstantiated_evar _ ->
       error "\"abstract\" cannot handle existentials." in
+
+  let evd, ctx, concl = 
+    (* FIXME: should be done only if the tactic succeeds *)
+    let evd, nf = nf_evars_and_universes (Proofview.Goal.sigma gl) in
+    let ctx = Evd.get_universe_context_set evd in
+      evd, ctx, nf concl
+  in
   let solve_tac = tclCOMPLETE (tclTHEN (tclDO (List.length sign) intro) tac) in
-  let (const, safe) =
-    try Pfedit.build_constant_by_tactic id secsign concl solve_tac
+  let (const, safe, subst) =
+    try Pfedit.build_constant_by_tactic id secsign (concl, ctx) solve_tac
     with Proof_errors.TacticFailure e as src ->
     (* if the tactic [tac] fails, it reports a [TacticFailure e],
        which is an error irrelevant to the proof system (in fact it
@@ -3655,12 +3759,13 @@ let abstract_subproof id tac =
   let decl = (cd, IsProof Lemma) in
   (** ppedrot: seems legit to have abstracted subproofs as local*)
   let cst = Declare.declare_constant ~internal:Declare.KernelSilent ~local:true id decl in
-  let lem = mkConst cst in
+  let evd, lem = Evd.fresh_global (Global.env ()) evd (ConstRef cst) in
   let open Declareops in
   let eff = Safe_typing.sideff_of_con (Global.safe_env ()) cst in
   let effs = cons_side_effects eff no_seff in
   let args = List.rev (instance_from_named_context sign) in
-  let solve = Proofview.tclEFFECTS effs <*> new_exact_no_check (applist (lem, args)) in
+  let solve = Proofview.V82.tactic (tclEVARS evd) <*> 
+    Proofview.tclEFFECTS effs <*> new_exact_no_check (applist (lem, args)) in
   if not safe then Proofview.mark_as_unsafe <*> solve else solve
   end
 
@@ -3682,12 +3787,53 @@ let admit_as_an_axiom =
   simplest_case (Coqlib.build_coq_proof_admitted ()) <*>
   Proofview.mark_as_unsafe
 
+(*   let current_sign = Global.named_context() *)
+(*   and global_sign = pf_hyps gl in *)
+(*   let poly = Flags.is_universe_polymorphism () in (\*FIXME*\) *)
+(*   let sign,secsign = *)
+(*     List.fold_right *)
+(*       (fun (id,_,_ as d) (s1,s2) -> *)
+(* 	 if mem_named_context id current_sign & *)
+(*            interpretable_as_section_decl (Context.lookup_named id current_sign) d *)
+(*          then (s1,add_named_decl d s2) *)
+(* 	 else (add_named_decl d s1,s2)) *)
+(*       global_sign (empty_named_context,empty_named_context) in *)
+(*   let name = add_suffix (get_current_proof_name ()) "_admitted" in *)
+(*   let na = next_global_ident_away name (pf_ids_of_hyps gl) in *)
+(*   let evd, nf = nf_evars_and_universes (project gl) in *)
+(*   let ctx = Evd.universe_context evd in *)
+(*   let newconcl = nf (pf_concl gl) in *)
+(*   let newsign = Context.map_named_context nf sign in *)
+(*   let concl = it_mkNamedProd_or_LetIn newconcl newsign in *)
+(*   if occur_existential concl then error"\"admit\" cannot handle existentials."; *)
+(*   let entry =  *)
+(*       (Pfedit.get_used_variables(),poly,(concl,ctx),None)  *)
+(*   in *)
+(*   let cd = Entries.ParameterEntry entry in *)
+(*   let decl = (cd, IsAssumption Logical) in *)
+(*   (\** ppedrot: seems legit to have admitted subproofs as local*\) *)
+(*   let con = Declare.declare_constant ~internal:Declare.KernelSilent ~local:true na decl in *)
+(*   let evd, axiom = evd, (mkConstU (con, Univ.UContext.instance ctx)) in *)
+(*   (\* let evd, axiom = Evd.fresh_global (pf_env gl) (project gl) (ConstRef con) in *\) *)
+(*   let gl = tclTHEN (tclEVARS evd) *)
+(*     (tclTHEN (convert_concl_no_check newconcl DEFAULTcast) *)
+(*        (exact_check *)
+(* 	  (applist (axiom, *)
+(* 		    List.rev (Array.to_list (instance_from_named_context sign)))))) *)
+(*     gl *)
+(*   in *)
+(*     Pp.feedback Interface.AddedAxiom; *)
+(*     gl *)
+(* >>>>>>> .merge_file_iUuzZK *)
+
 let unify ?(state=full_transparent_state) x y gl =
   try
     let flags =
-      {default_unify_flags with
-	modulo_delta = state;
-	modulo_conv_on_closed_terms = Some state}
+      {(default_unify_flags ()) with
+       modulo_delta = state;
+       modulo_delta_types = state;
+       modulo_delta_in_merge = Some state;
+       modulo_conv_on_closed_terms = Some state}
     in
     let evd = w_unify (pf_env gl) (project gl) Reduction.CONV ~flags x y
     in tclEVARS evd gl
diff --git a/tactics/tactics.mli b/tactics/tactics.mli
index 9a2af0835..937efdae1 100644
--- a/tactics/tactics.mli
+++ b/tactics/tactics.mli
@@ -26,8 +26,8 @@ open Locus
 
 (** {6 General functions. } *)
 
-val head_constr       : constr -> constr * constr list
-val head_constr_bound : constr -> constr * constr list
+val head_constr       : constr -> constr
+val head_constr_bound : constr -> constr
 val is_quantified_hypothesis : Id.t -> goal sigma -> bool
 
 exception Bound
@@ -45,6 +45,9 @@ val fix             : Id.t option -> int -> tactic
 val mutual_cofix    : Id.t -> (Id.t * constr) list -> int -> tactic
 val cofix           : Id.t option -> tactic
 
+val convert         : constr -> constr -> tactic
+val convert_leq     : constr -> constr -> tactic
+
 (** {6 Introduction tactics. } *)
 
 val fresh_id_in_env : Id.t list -> Id.t -> env -> Id.t
diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4
index 2a35e32d9..8d3d33510 100644
--- a/tactics/tauto.ml4
+++ b/tactics/tauto.ml4
@@ -97,16 +97,16 @@ let is_unit_or_eq flags ist =
 let is_record t =
   let (hdapp,args) = decompose_app t in
     match (kind_of_term hdapp) with
-      | Ind ind  ->
+      | Ind (ind,u) ->
           let (mib,mip) = Global.lookup_inductive ind in
-	    mib.Declarations.mind_record
+	    mib.Declarations.mind_record <> None
       | _ -> false
 
 let bugged_is_binary t =
   isApp t &&
   let (hdapp,args) = decompose_app t in
     match (kind_of_term hdapp) with
-    | Ind ind  ->
+    | Ind (ind,u)  ->
         let (mib,mip) = Global.lookup_inductive ind in
          Int.equal mib.Declarations.mind_nparams 2
     | _ -> false
@@ -319,7 +319,7 @@ let tauto_gen flags =
   Proofview.tclBIND
     (Proofview.tclUNIT ())
     begin fun () -> try
-      let nnpp = constr_of_global (Nametab.global_of_path coq_nnpp_path) in
+      let nnpp = Universes.constr_of_global (Nametab.global_of_path coq_nnpp_path) in
     (* try intuitionistic version first to avoid an axiom if possible *)
       Tacticals.New.tclORELSE (tauto_intuitionistic flags) (tauto_classical flags nnpp)
     with Not_found ->
diff --git a/tactics/termdn.ml b/tactics/termdn.ml
new file mode 100644
index 000000000..1c4c4b648
--- /dev/null
+++ b/tactics/termdn.ml
@@ -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        *)
+(************************************************************************)
+
+open Util
+open Names
+open Term
+open Pattern
+open Patternops
+open Globnames
+
+(* Discrimination nets of terms.
+   See the module dn.ml for further explanations.
+   Eduardo (5/8/97) *)
+module Make =
+  functor (Z : Map.OrderedType) ->
+struct
+
+  module X = struct
+    type t = constr_pattern
+    let compare = Pervasives.compare (** FIXME *)
+  end
+
+  type term_label = 
+    | GRLabel of global_reference
+    | ProdLabel 
+    | LambdaLabel
+    | SortLabel
+	
+  module Y =  struct 
+     type t = term_label
+        let compare x y = 
+       let make_name n =
+	 match n with
+	 | GRLabel(ConstRef con) -> 
+	     GRLabel(ConstRef(constant_of_kn(canonical_con con)))
+	 | GRLabel(IndRef (kn,i)) ->
+	     GRLabel(IndRef(mind_of_kn(canonical_mind kn),i))
+	 | GRLabel(ConstructRef ((kn,i),j ))->
+	     GRLabel(ConstructRef((mind_of_kn(canonical_mind kn),i),j))
+	 | k -> k
+       in
+	 Pervasives.compare (make_name x) (make_name y)
+  end
+       
+      
+  module Dn = Dn.Make(X)(Y)(Z)
+      
+  type t = Dn.t
+
+  type 'a lookup_res = 'a Dn.lookup_res
+
+(*If we have: f a b c ..., decomp gives: (f,[a;b;c;...])*)
+
+let decomp =
+  let rec decrec acc c = match kind_of_term c with
+    | App (f,l) -> decrec (Array.fold_right (fun a l -> a::l) l acc) f
+    | Cast (c1,_,_) -> decrec acc c1
+    | Proj (p, c) -> decrec (c :: acc) (mkConst p)
+    | _ -> (c,acc)
+  in
+  decrec []
+
+let decomp_pat =
+  let rec decrec acc = function
+    | PApp (f,args) -> decrec (Array.to_list args @ acc) f
+    | c -> (c,acc)
+  in
+  decrec []
+
+let constr_pat_discr t =
+  if not (occur_meta_pattern t) then
+    None
+  else
+    match decomp_pat t with
+    | PRef ((IndRef _) as ref), args
+    | PRef ((ConstructRef _ ) as ref), args -> Some (GRLabel ref,args)
+    | PRef ((VarRef v) as ref), args -> Some(GRLabel ref,args)
+    | _ -> None
+
+let constr_pat_discr_st (idpred,cpred) t =
+  match decomp_pat t with
+  | PRef ((IndRef _) as ref), args
+  | PRef ((ConstructRef _ ) as ref), args -> Some (GRLabel ref,args)
+  | PRef ((VarRef v) as ref), args when not (Id.Pred.mem v idpred) ->
+      Some(GRLabel ref,args)
+  | PVar v, args when not (Id.Pred.mem v idpred) ->
+      Some(GRLabel (VarRef v),args)
+  | PRef ((ConstRef c) as ref), args when not (Cpred.mem c cpred) ->
+      Some (GRLabel ref, args)
+  | PProd (_, d, c), [] -> Some (ProdLabel, [d ; c])
+  | PLambda (_, d, c), l -> Some (LambdaLabel, [d ; c] @ l)
+  | PSort s, [] -> Some (SortLabel, [])
+  | _ -> None
+
+open Dn
+
+let constr_val_discr t =
+  let c, l = decomp t in
+    match kind_of_term c with
+    | Ind (ind_sp,u) -> Label(GRLabel (IndRef ind_sp),l)
+    | Construct (cstr_sp,u) -> Label(GRLabel (ConstructRef cstr_sp),l)
+    | Var id -> Label(GRLabel (VarRef id),l)
+    | Const _ -> Everything
+    | Proj _ -> Everything
+    | _ -> Nothing
+
+let constr_val_discr_st (idpred,cpred) t =
+  let c, l = decomp t in
+    match kind_of_term c with
+    | Const (c,_) -> if Cpred.mem c cpred then Everything else Label(GRLabel (ConstRef c),l)
+    | Ind (ind_sp,_) -> Label(GRLabel (IndRef ind_sp),l)
+    | Construct (cstr_sp,_) -> Label(GRLabel (ConstructRef cstr_sp),l)
+    | Proj (p,c) -> if Cpred.mem p cpred then Everything else Label(GRLabel (ConstRef p),c::l)
+    | Var id when not (Id.Pred.mem id idpred) -> Label(GRLabel (VarRef id),l)
+    | Prod (n, d, c) -> Label(ProdLabel, [d; c])
+    | Lambda (n, d, c) -> Label(LambdaLabel, [d; c] @ l)
+    | Sort _ -> Label (SortLabel, [])
+    | Evar _ -> Everything
+    | _ -> Nothing
+
+let create = Dn.create
+
+let add dn st = Dn.add dn (constr_pat_discr_st st)
+
+let rmv dn st = Dn.rmv dn (constr_pat_discr_st st)
+
+let lookup dn st t = Dn.lookup dn (constr_val_discr_st st) t
+
+let app f dn = Dn.app f dn
+
+end