Imported Upstream version 8.5~beta1+dfsg

256 files changed, 10281 insertions, 25165 deletions

diff --git a/plugins/btauto/Algebra.v b/plugins/btauto/Algebra.v
new file mode 100644
index 00000000..bc5a3900
--- /dev/null
+++ b/plugins/btauto/Algebra.v
@@ -0,0 +1,591 @@
+Require Import Bool PArith DecidableClass Omega ROmega.
+
+Ltac bool :=
+repeat match goal with
+| [ H : ?P && ?Q = true |- _ ] =>
+  apply andb_true_iff in H; destruct H
+| |- ?P && ?Q = true =>
+  apply <- andb_true_iff; split
+end.
+
+Arguments decide P /H.
+
+Hint Extern 5 => progress bool.
+
+Ltac define t x H :=
+set (x := t) in *; assert (H : t = x) by reflexivity; clearbody x.
+
+Lemma Decidable_sound : forall P (H : Decidable P),
+                          decide P = true -> P.
+Proof.
+intros P H Hp; apply -> Decidable_spec; assumption.
+Qed.
+
+Lemma Decidable_complete : forall P (H : Decidable P),
+  P -> decide P = true.
+Proof.
+intros P H Hp; apply <- Decidable_spec; assumption.
+Qed.
+
+Lemma Decidable_sound_alt : forall P (H : Decidable P),
+   ~ P -> decide P = false.
+Proof.
+intros P [wit spec] Hd; destruct wit; simpl; tauto. 
+Qed.
+
+Lemma Decidable_complete_alt : forall P (H : Decidable P),
+  decide P = false -> ~ P.
+Proof.
+  intros P [wit spec] Hd Hc; simpl in *; intuition congruence.
+Qed.
+
+Ltac try_rewrite :=
+repeat match goal with
+| [ H : ?P |- _ ] => rewrite H
+end.
+
+(* We opacify here decide for proofs, and will make it transparent for
+   reflexive tactics later on. *)
+
+Global Opaque decide.
+
+Ltac tac_decide :=
+match goal with
+| [ H : @decide ?P ?D = true |- _ ] => apply (@Decidable_sound P D) in H
+| [ H : @decide ?P ?D = false |- _ ] => apply (@Decidable_complete_alt P D) in H
+| [ |- @decide ?P ?D = true ] => apply (@Decidable_complete P D)
+| [ |- @decide ?P ?D = false ] => apply (@Decidable_sound_alt P D)
+| [ |- negb ?b = true ] => apply negb_true_iff
+| [ |- negb ?b = false ] => apply negb_false_iff
+| [ H : negb ?b = true |- _ ] => apply negb_true_iff in H
+| [ H : negb ?b = false |- _ ] => apply negb_false_iff in H
+end.
+
+Ltac try_decide := repeat tac_decide.
+
+Ltac make_decide P := match goal with
+| [ |- context [@decide P ?D] ] =>
+  let b := fresh "b" in
+  let H := fresh "H" in
+  define (@decide P D) b H; destruct b; try_decide
+| [ X : context [@decide P ?D] |- _ ] =>
+  let b := fresh "b" in
+  let H := fresh "H" in
+  define (@decide P D) b H; destruct b; try_decide
+end.
+
+Ltac case_decide := match goal with
+| [ |- context [@decide ?P ?D] ] =>
+  let b := fresh "b" in
+  let H := fresh "H" in
+  define (@decide P D) b H; destruct b; try_decide
+| [ X : context [@decide ?P ?D] |- _ ] =>
+  let b := fresh "b" in
+  let H := fresh "H" in
+  define (@decide P D) b H; destruct b; try_decide
+| [ |- context [Pos.compare ?x ?y] ] =>
+  destruct (Pos.compare_spec x y); try (exfalso; zify; romega)
+| [ X : context [Pos.compare ?x ?y] |- _ ] =>
+  destruct (Pos.compare_spec x y); try (exfalso; zify; romega)
+end.
+
+Section Definitions.
+
+(** * Global, inductive definitions. *)
+
+(** A Horner polynomial is either a constant, or a product P × (i + Q), where i 
+  is a variable. *)
+
+Inductive poly :=
+| Cst : bool -> poly
+| Poly : poly -> positive -> poly -> poly.
+
+(* TODO: We should use [positive] instead of [nat] to encode variables, for 
+ efficiency purpose. *)
+
+Inductive null : poly -> Prop :=
+| null_intro : null (Cst false).
+
+(** Polynomials satisfy a uniqueness condition whenever they are valid. A 
+  polynomial [p] satisfies [valid n p] whenever it is well-formed and each of 
+  its variable indices is < [n]. *)
+
+Inductive valid : positive -> poly -> Prop :=
+| valid_cst : forall k c, valid k (Cst c)
+| valid_poly : forall k p i q,
+  Pos.lt i k -> ~ null q -> valid i p -> valid (Pos.succ i) q -> valid k (Poly p i q).
+
+(** Linear polynomials are valid polynomials in which every variable appears at 
+  most once. *)
+
+Inductive linear : positive -> poly -> Prop :=
+| linear_cst : forall k c, linear k (Cst c)
+| linear_poly : forall k p i q, Pos.lt i k -> ~ null q ->
+  linear i p -> linear i q -> linear k (Poly p i q).
+
+End Definitions.
+
+Section Computational.
+
+Program Instance Decidable_PosEq : forall (p q : positive), Decidable (p = q) :=
+  { Decidable_witness := Pos.eqb p q }.
+Next Obligation.
+apply Pos.eqb_eq.
+Qed.
+
+Program Instance Decidable_PosLt : forall p q, Decidable (Pos.lt p q) :=
+  { Decidable_witness := Pos.ltb p q }.
+Next Obligation.
+apply Pos.ltb_lt.
+Qed.
+
+Program Instance Decidable_PosLe : forall p q, Decidable (Pos.le p q) :=
+  { Decidable_witness := Pos.leb p q }.
+Next Obligation.
+apply Pos.leb_le.
+Qed.
+
+(** * The core reflexive part. *)
+
+Hint Constructors valid.
+
+Fixpoint beq_poly pl pr :=
+match pl with
+| Cst cl =>
+  match pr with
+  | Cst cr => decide (cl = cr)
+  | Poly _ _ _ => false
+  end
+| Poly pl il ql =>
+  match pr with
+  | Cst _ => false
+  | Poly pr ir qr =>
+    decide (il = ir) && beq_poly pl pr && beq_poly ql qr
+  end
+end.
+
+(* We could do that with [decide equality] but dependency in proofs is heavy *)
+Program Instance Decidable_eq_poly : forall (p q : poly), Decidable (eq p q) := {
+  Decidable_witness := beq_poly p q
+}.
+
+Next Obligation.
+split.
+revert q; induction p; intros [] ?; simpl in *; bool; try_decide;
+  f_equal; first [intuition congruence|auto].
+revert q; induction p; intros [] Heq; simpl in *; bool; try_decide; intuition;
+  try injection Heq; first[congruence|intuition].
+Qed.
+
+Program Instance Decidable_null : forall p, Decidable (null p) := {
+  Decidable_witness := match p with Cst false => true | _ => false end
+}.
+Next Obligation.
+split.
+  destruct p as [[]|]; first [discriminate|constructor].
+  inversion 1; trivial.
+Qed.
+
+Definition list_nth {A} p (l : list A) def :=
+  Pos.peano_rect (fun _ => list A -> A)
+    (fun l => match l with nil => def | cons t l => t end)
+    (fun _ F l => match l with nil => def | cons t l => F l end) p l.
+
+Fixpoint eval var (p : poly) :=
+match p with
+| Cst c => c
+| Poly p i q =>
+  let vi := list_nth i var false in
+  xorb (eval var p) (andb vi (eval var q))
+end.
+
+Fixpoint valid_dec k p :=
+match p with
+| Cst c => true
+| Poly p i q =>
+  negb (decide (null q)) && decide (i < k)%positive &&
+    valid_dec i p && valid_dec (Pos.succ i) q
+end.
+
+Program Instance Decidable_valid : forall n p, Decidable (valid n p) := {
+  Decidable_witness := valid_dec n p
+}.
+Next Obligation.
+split.
+  revert n; induction p; unfold valid_dec in *; intuition; bool; try_decide; auto.
+  intros H; induction H; unfold valid_dec in *; bool; try_decide; auto.
+Qed.
+
+(** Basic algebra *)
+
+(* Addition of polynomials *)
+
+Fixpoint poly_add pl {struct pl} :=
+match pl with
+| Cst cl =>
+  fix F pr := match pr with
+  | Cst cr => Cst (xorb cl cr)
+  | Poly pr ir qr => Poly (F pr) ir qr
+  end
+| Poly pl il ql =>
+  fix F pr {struct pr} := match pr with
+  | Cst cr => Poly (poly_add pl pr) il ql
+  | Poly pr ir qr =>
+    match Pos.compare il ir with
+    | Eq =>
+      let qs := poly_add ql qr in
+      (* Ensure validity *)
+      if decide (null qs) then poly_add pl pr
+      else Poly (poly_add pl pr) il qs
+    | Gt => Poly (poly_add pl (Poly pr ir qr)) il ql
+    | Lt => Poly (F pr) ir qr
+    end
+  end
+end.
+
+(* Multiply a polynomial by a constant *)
+
+Fixpoint poly_mul_cst v p :=
+match p with
+| Cst c => Cst (andb c v)
+| Poly p i q =>
+  let r := poly_mul_cst v q in
+  (* Ensure validity *)
+  if decide (null r) then poly_mul_cst v p
+  else Poly (poly_mul_cst v p) i r
+end.
+
+(* Multiply a polynomial by a monomial *)
+
+Fixpoint poly_mul_mon k p :=
+match p with
+| Cst c =>
+  if decide (null p) then p
+  else Poly (Cst false) k p
+| Poly p i q =>
+  if decide (i <= k)%positive then Poly (Cst false) k (Poly p i q)
+  else Poly (poly_mul_mon k p) i (poly_mul_mon k q)
+end.
+
+(* Multiplication of polynomials *)
+
+Fixpoint poly_mul pl {struct pl} :=
+match pl with
+| Cst cl => poly_mul_cst cl
+| Poly pl il ql =>
+  fun pr =>
+    (* Multiply by a factor *)
+    let qs := poly_mul ql pr in
+    (* Ensure validity *)
+    if decide (null qs) then poly_mul pl pr
+    else poly_add (poly_mul pl pr) (poly_mul_mon il qs)
+end.
+
+(** Quotienting a polynomial by the relation X_i^2 ~ X_i *)
+
+(* Remove the multiple occurences of monomials x_k *)
+
+Fixpoint reduce_aux k p :=
+match p with
+| Cst c => Cst c
+| Poly p i q =>
+  if decide (i = k) then poly_add (reduce_aux k p) (reduce_aux k q)
+  else
+    let qs := reduce_aux i q in
+    (* Ensure validity *)
+    if decide (null qs) then (reduce_aux k p)
+    else Poly (reduce_aux k p) i qs
+end.
+
+(* Rewrite any x_k ^ {n + 1} to x_k *)
+
+Fixpoint reduce p :=
+match p with
+| Cst c => Cst c
+| Poly p i q =>
+  let qs := reduce_aux i q in
+  (* Ensure validity *)
+  if decide (null qs) then reduce p
+  else Poly (reduce p) i qs
+end.
+
+End Computational.
+
+Section Validity.
+
+(* Decision procedure of validity *)
+
+Hint Constructors valid linear.
+
+Lemma valid_le_compat : forall k l p, valid k p -> (k <= l)%positive -> valid l p.
+Proof.
+intros k l p H Hl; induction H; constructor; eauto.
+now eapply Pos.lt_le_trans; eassumption.
+Qed.
+
+Lemma linear_le_compat : forall k l p, linear k p -> (k <= l)%positive -> linear l p.
+Proof.
+intros k l p H; revert l; induction H; constructor; eauto; zify; romega.
+Qed.
+
+Lemma linear_valid_incl : forall k p, linear k p -> valid k p.
+Proof.
+intros k p H; induction H; constructor; auto.
+eapply valid_le_compat; eauto; zify; romega.
+Qed.
+
+End Validity.
+
+Section Evaluation.
+
+(* Useful simple properties *)
+
+Lemma eval_null_zero : forall p var, null p -> eval var p = false.
+Proof.
+intros p var []; reflexivity.
+Qed.
+
+Lemma eval_extensional_eq_compat : forall p var1 var2,
+  (forall x, list_nth x var1 false = list_nth x var2 false) -> eval var1 p = eval var2 p.
+Proof.
+intros p var1 var2 H; induction p; simpl; try_rewrite; auto.
+Qed.
+
+Lemma eval_suffix_compat : forall k p var1 var2,
+  (forall i, (i < k)%positive -> list_nth i var1 false = list_nth i var2 false) -> valid k p ->
+  eval var1 p = eval var2 p.
+Proof.
+intros k p var1 var2 Hvar Hv; revert var1 var2 Hvar.
+induction Hv; intros var1 var2 Hvar; simpl; [now auto|].
+rewrite Hvar; [|now auto]; erewrite (IHHv1 var1 var2).
+  + erewrite (IHHv2 var1 var2); [ring|].
+    intros; apply Hvar; zify; omega.
+  + intros; apply Hvar; zify; omega.
+Qed.
+
+End Evaluation.
+
+Section Algebra.
+
+(* Compatibility with evaluation *)
+
+Lemma poly_add_compat : forall pl pr var, eval var (poly_add pl pr) = xorb (eval var pl) (eval var pr).
+Proof.
+intros pl; induction pl; intros pr var; simpl.
++ induction pr; simpl; auto; solve [try_rewrite; ring].
++ induction pr; simpl; auto; try solve [try_rewrite; simpl; ring].
+  destruct (Pos.compare_spec p p0); repeat case_decide; simpl; first [try_rewrite; ring|idtac].
+    try_rewrite; ring_simplify; repeat rewrite xorb_assoc.
+    match goal with [ |- context [xorb (andb ?b1 ?b2) (andb ?b1 ?b3)] ] =>
+      replace (xorb (andb b1 b2) (andb b1 b3)) with (andb b1 (xorb b2 b3)) by ring
+    end.
+    rewrite <- IHpl2.
+    match goal with [ H : null ?p |- _ ] => rewrite (eval_null_zero _ _ H) end; ring.
+    simpl; rewrite IHpl1; simpl; ring.
+Qed.
+
+Lemma poly_mul_cst_compat : forall v p var,
+  eval var (poly_mul_cst v p) = andb v (eval var p).
+Proof.
+intros v p; induction p; intros var; simpl; [ring|].
+case_decide; simpl; try_rewrite; [ring_simplify|ring].
+replace (v && list_nth p2 var false && eval var p3) with (list_nth p2 var false && (v && eval var p3)) by ring.
+rewrite <- IHp2; inversion H; simpl; ring.
+Qed.
+
+Lemma poly_mul_mon_compat : forall i p var,
+  eval var (poly_mul_mon i p) = (list_nth i var false && eval var p).
+Proof.
+intros i p var; induction p; simpl; case_decide; simpl; try_rewrite; try ring.
+inversion H; ring.
+match goal with [ |- ?u = ?t ] => set (x := t); destruct x; reflexivity end.
+match goal with [ |- ?u = ?t ] => set (x := t); destruct x; reflexivity end.
+Qed.
+
+Lemma poly_mul_compat : forall pl pr var, eval var (poly_mul pl pr) = andb (eval var pl) (eval var pr).
+Proof.
+intros pl; induction pl; intros pr var; simpl.
+  apply poly_mul_cst_compat.
+  case_decide; simpl.
+    rewrite IHpl1; ring_simplify.
+    replace (eval var pr && list_nth p var false && eval var pl2)
+    with (list_nth p var false && (eval var pl2 && eval var pr)) by ring.
+    now rewrite <- IHpl2; inversion H; simpl; ring.
+    rewrite poly_add_compat, poly_mul_mon_compat, IHpl1, IHpl2; ring.
+Qed.
+
+Hint Extern 5 =>
+match goal with
+| [ |- (Pos.max ?x ?y <= ?z)%positive ] =>
+  apply Pos.max_case_strong; intros; zify; romega
+| [ |- (?z <= Pos.max ?x ?y)%positive ] =>
+  apply Pos.max_case_strong; intros; zify; romega
+| [ |- (Pos.max ?x ?y < ?z)%positive ] =>
+  apply Pos.max_case_strong; intros; zify; romega
+| [ |- (?z < Pos.max ?x ?y)%positive ] =>
+  apply Pos.max_case_strong; intros; zify; romega
+| _ => zify; omega
+end.
+Hint Resolve Pos.le_max_r Pos.le_max_l.
+
+Hint Constructors valid linear.
+
+(* Compatibility of validity w.r.t algebraic operations *)
+
+Lemma poly_add_valid_compat : forall kl kr pl pr, valid kl pl -> valid kr pr ->
+  valid (Pos.max kl kr) (poly_add pl pr).
+Proof.
+intros kl kr pl pr Hl Hr; revert kr pr Hr; induction Hl; intros kr pr Hr; simpl.
+{ eapply valid_le_compat; [clear k|apply Pos.le_max_r].
+  now induction Hr; auto. }
+{  assert (Hle : (Pos.max (Pos.succ i) kr <= Pos.max k kr)%positive) by auto.
+  apply (valid_le_compat (Pos.max (Pos.succ i) kr)); [|assumption].
+  clear - IHHl1 IHHl2 Hl2 Hr H0; induction Hr.
+    constructor; auto.
+      now rewrite <- (Pos.max_id i); intuition.
+    destruct (Pos.compare_spec i i0); subst; try case_decide; repeat (constructor; intuition).
+      + apply (valid_le_compat (Pos.max i0 i0)); [now auto|]; rewrite Pos.max_id; auto.
+      + apply (valid_le_compat (Pos.max i0 i0)); [now auto|]; rewrite Pos.max_id; zify; romega.
+      + apply (valid_le_compat (Pos.max (Pos.succ i0) (Pos.succ i0))); [now auto|]; rewrite Pos.max_id; zify; romega.
+      + apply (valid_le_compat (Pos.max (Pos.succ i) i0)); intuition.
+      + apply (valid_le_compat (Pos.max i (Pos.succ i0))); intuition.
+}
+Qed.
+
+Lemma poly_mul_cst_valid_compat : forall k v p, valid k p -> valid k (poly_mul_cst v p).
+Proof.
+intros k v p H; induction H; simpl; [now auto|].
+case_decide; [|now auto].
+eapply (valid_le_compat i); [now auto|zify; romega].
+Qed.
+
+Lemma poly_mul_mon_null_compat : forall i p, null (poly_mul_mon i p) -> null p.
+Proof.
+intros i p; induction p; simpl; case_decide; simpl; inversion 1; intuition.
+Qed.
+
+Lemma poly_mul_mon_valid_compat : forall k i p,
+  valid k p -> valid (Pos.max (Pos.succ i) k) (poly_mul_mon i p).
+Proof.
+intros k i p H; induction H; simpl poly_mul_mon; case_decide; intuition.
++ apply (valid_le_compat (Pos.succ i)); auto; constructor; intuition.
+  - match goal with [ H : null ?p |- _ ] => solve[inversion H] end.
++ apply (valid_le_compat k); auto; constructor; intuition.
+  - assert (X := poly_mul_mon_null_compat); intuition eauto.
+  - cutrewrite <- (Pos.max (Pos.succ i) i0 = i0); intuition.
+  - cutrewrite <- (Pos.max (Pos.succ i) (Pos.succ i0) = Pos.succ i0); intuition.
+Qed.
+
+Lemma poly_mul_valid_compat : forall kl kr pl pr, valid kl pl -> valid kr pr ->
+  valid (Pos.max kl kr) (poly_mul pl pr).
+Proof.
+intros kl kr pl pr Hl Hr; revert kr pr Hr.
+induction Hl; intros kr pr Hr; simpl.
++ apply poly_mul_cst_valid_compat; auto.
+  apply (valid_le_compat kr); now auto.
++ apply (valid_le_compat (Pos.max (Pos.max i kr) (Pos.max (Pos.succ i) (Pos.max (Pos.succ i) kr)))).
+  - case_decide.
+    { apply (valid_le_compat (Pos.max i kr)); auto. }
+    { apply poly_add_valid_compat; auto.
+      now apply poly_mul_mon_valid_compat; intuition. }
+  - repeat apply Pos.max_case_strong; zify; omega.
+Qed.
+
+(* Compatibility of linearity wrt to linear operations *)
+
+Lemma poly_add_linear_compat : forall kl kr pl pr, linear kl pl -> linear kr pr ->
+  linear (Pos.max kl kr) (poly_add pl pr).
+Proof.
+intros kl kr pl pr Hl; revert kr pr; induction Hl; intros kr pr Hr; simpl.
++ apply (linear_le_compat kr); [|apply Pos.max_case_strong; zify; omega].
+  now induction Hr; constructor; auto.
++ apply (linear_le_compat (Pos.max kr (Pos.succ i))); [|now auto].
+  induction Hr; simpl.
+  - constructor; auto.
+    replace i with (Pos.max i i) by (apply Pos.max_id); intuition.
+  - destruct (Pos.compare_spec i i0); subst; try case_decide; repeat (constructor; intuition).
+    { apply (linear_le_compat (Pos.max i0 i0)); [now auto|]; rewrite Pos.max_id; auto. }
+    { apply (linear_le_compat (Pos.max i0 i0)); [now auto|]; rewrite Pos.max_id; auto. }
+    { apply (linear_le_compat (Pos.max i0 i0)); [now auto|]; rewrite Pos.max_id; auto. }
+    { apply (linear_le_compat (Pos.max i0 (Pos.succ i))); intuition. }
+    { apply (linear_le_compat (Pos.max i (Pos.succ i0))); intuition. }
+Qed.
+
+End Algebra.
+
+Section Reduce.
+
+(* A stronger version of the next lemma *)
+
+Lemma reduce_aux_eval_compat : forall k p var, valid (Pos.succ k) p ->
+  (list_nth k var false && eval var (reduce_aux k p) = list_nth k var false && eval var p).
+Proof.
+intros k p var; revert k; induction p; intros k Hv; simpl; auto.
+inversion Hv; case_decide; subst.
++ rewrite poly_add_compat; ring_simplify.
+  specialize (IHp1 k); specialize (IHp2 k).
+  destruct (list_nth k var false); ring_simplify; [|now auto].
+  rewrite <- (andb_true_l (eval var p1)), <- (andb_true_l (eval var p3)).
+  rewrite <- IHp2; auto; rewrite <- IHp1; [ring|].
+  apply (valid_le_compat k); [now auto|zify; omega].
++ remember (list_nth k var false) as b; destruct b; ring_simplify; [|now auto].
+  case_decide; simpl.
+  - rewrite <- (IHp2 p2); [inversion H|now auto]; simpl.
+    replace (eval var p1) with (list_nth k var false && eval var p1) by (rewrite <- Heqb; ring); rewrite <- (IHp1 k).
+    { rewrite <- Heqb; ring. }
+    { apply (valid_le_compat p2); [auto|zify; omega]. }
+  - rewrite (IHp2 p2); [|now auto].
+    replace (eval var p1) with (list_nth k var false && eval var p1) by (rewrite <- Heqb; ring).
+    rewrite <- (IHp1 k); [rewrite <- Heqb; ring|].
+    apply (valid_le_compat p2); [auto|zify; omega].
+Qed.
+
+(* Reduction preserves evaluation by boolean assignations *)
+
+Lemma reduce_eval_compat : forall k p var, valid k p ->
+  eval var (reduce p) = eval var p.
+Proof.
+intros k p var H; induction H; simpl; auto.
+case_decide; try_rewrite; simpl.
++ rewrite <- reduce_aux_eval_compat; auto; inversion H3; simpl; ring.
++ repeat rewrite reduce_aux_eval_compat; try_rewrite; now auto.
+Qed.
+
+Lemma reduce_aux_le_compat : forall k l p, valid k p -> (k <= l)%positive ->
+  reduce_aux l p = reduce_aux k p.
+Proof.
+intros k l p; revert k l; induction p; intros k l H Hle; simpl; auto.
+inversion H; subst; repeat case_decide; subst; try (exfalso; zify; omega).
++ apply IHp1; [|now auto]; eapply valid_le_compat; [eauto|zify; omega].
++ f_equal; apply IHp1; auto.
+  now eapply valid_le_compat; [eauto|zify; omega].
+Qed.
+
+(* Reduce projects valid polynomials into linear ones *)
+
+Lemma linear_reduce_aux : forall i p, valid (Pos.succ i) p -> linear i (reduce_aux i p).
+Proof.
+intros i p; revert i; induction p; intros i Hp; simpl.
++ constructor.
++ inversion Hp; subst; case_decide; subst.
+  - rewrite <- (Pos.max_id i) at 1; apply poly_add_linear_compat.
+    { apply IHp1; eapply valid_le_compat; [eassumption|zify; omega]. }
+    { intuition. }
+  - case_decide.
+  { apply IHp1; eapply valid_le_compat; [eauto|zify; omega]. }
+  { constructor; try (zify; omega); auto.
+    erewrite (reduce_aux_le_compat p2); [|assumption|zify; omega].
+    apply IHp1; eapply valid_le_compat; [eauto|]; zify; omega. }
+Qed.
+
+Lemma linear_reduce : forall k p, valid k p -> linear k (reduce p).
+Proof.
+intros k p H; induction H; simpl.
++ now constructor.
++ case_decide.
+  - eapply linear_le_compat; [eauto|zify; omega].
+  - constructor; auto.
+    apply linear_reduce_aux; auto.
+Qed.
+
+End Reduce.
diff --git a/plugins/btauto/Btauto.v b/plugins/btauto/Btauto.v
new file mode 100644
index 00000000..d3331ccf
--- /dev/null
+++ b/plugins/btauto/Btauto.v
@@ -0,0 +1,3 @@
+Require Import Algebra Reflect.
+
+Declare ML Module "btauto_plugin".
diff --git a/plugins/btauto/Reflect.v b/plugins/btauto/Reflect.v
new file mode 100644
index 00000000..3bd7cd62
--- /dev/null
+++ b/plugins/btauto/Reflect.v
@@ -0,0 +1,398 @@
+Require Import Bool DecidableClass Algebra Ring PArith ROmega Omega.
+
+Section Bool.
+
+(* Boolean formulas and their evaluations *)
+
+Inductive formula :=
+| formula_var : positive -> formula
+| formula_btm : formula
+| formula_top : formula
+| formula_cnj : formula -> formula -> formula
+| formula_dsj : formula -> formula -> formula
+| formula_neg : formula -> formula
+| formula_xor : formula -> formula -> formula
+| formula_ifb : formula -> formula -> formula -> formula.
+
+Fixpoint formula_eval var f := match f with
+| formula_var x => list_nth x var false 
+| formula_btm => false
+| formula_top => true
+| formula_cnj fl fr => (formula_eval var fl) && (formula_eval var fr)
+| formula_dsj fl fr => (formula_eval var fl) || (formula_eval var fr)
+| formula_neg f => negb (formula_eval var f)
+| formula_xor fl fr => xorb (formula_eval var fl) (formula_eval var fr)
+| formula_ifb fc fl fr =>
+  if formula_eval var fc then formula_eval var fl else formula_eval var fr
+end.
+
+End Bool.
+
+(* Translation of formulas into polynomials *)
+
+Section Translation.
+
+(* This is straightforward. *)
+
+Fixpoint poly_of_formula f := match f with
+| formula_var x => Poly (Cst false) x (Cst true) 
+| formula_btm => Cst false
+| formula_top => Cst true
+| formula_cnj fl fr =>
+  let pl := poly_of_formula fl in
+  let pr := poly_of_formula fr in
+  poly_mul pl pr
+| formula_dsj fl fr =>
+  let pl := poly_of_formula fl in
+  let pr := poly_of_formula fr in
+  poly_add (poly_add pl pr) (poly_mul pl pr)
+| formula_neg f => poly_add (Cst true) (poly_of_formula f)
+| formula_xor fl fr => poly_add (poly_of_formula fl) (poly_of_formula fr)
+| formula_ifb fc fl fr =>
+  let pc := poly_of_formula fc in
+  let pl := poly_of_formula fl in
+  let pr := poly_of_formula fr in
+  poly_add pr (poly_add (poly_mul pc pl) (poly_mul pc pr))
+end.
+
+Opaque poly_add.
+
+(* Compatibility of translation wrt evaluation *)
+
+Lemma poly_of_formula_eval_compat : forall var f,
+  eval var (poly_of_formula f) = formula_eval var f.
+Proof.
+intros var f; induction f; simpl poly_of_formula; simpl formula_eval; auto.
+  now simpl; match goal with [ |- ?t = ?u ] => destruct u; reflexivity end.
+  rewrite poly_mul_compat, IHf1, IHf2; ring.
+  repeat rewrite poly_add_compat.
+  rewrite poly_mul_compat; try_rewrite.
+  now match goal with [ |- ?t = ?x || ?y ] => destruct x; destruct y; reflexivity end.
+  rewrite poly_add_compat; try_rewrite.
+  now match goal with [ |- ?t = negb ?x ] => destruct x; reflexivity end.
+  rewrite poly_add_compat; congruence.
+  rewrite ?poly_add_compat, ?poly_mul_compat; try_rewrite.
+  match goal with
+    [ |- ?t = if ?b1 then ?b2 else ?b3 ] => destruct b1; destruct b2; destruct b3; reflexivity
+  end.
+Qed.
+
+Hint Extern 5 => change 0 with (min 0 0).
+Local Hint Resolve poly_add_valid_compat poly_mul_valid_compat.
+Local Hint Constructors valid.
+Hint Extern 5 => zify; omega.
+
+(* Compatibility with validity *)
+
+Lemma poly_of_formula_valid_compat : forall f, exists n, valid n (poly_of_formula f).
+Proof.
+intros f; induction f; simpl.
++ exists (Pos.succ p); constructor; intuition; inversion H.
++ exists 1%positive; auto.
++ exists 1%positive; auto.
++ destruct IHf1 as [n1 Hn1]; destruct IHf2 as [n2 Hn2]; exists (Pos.max n1 n2); auto.
++ destruct IHf1 as [n1 Hn1]; destruct IHf2 as [n2 Hn2]; exists (Pos.max (Pos.max n1 n2) (Pos.max n1 n2)); auto.
++ destruct IHf as [n Hn]; exists (Pos.max 1 n); auto.
++ destruct IHf1 as [n1 Hn1]; destruct IHf2 as [n2 Hn2]; exists (Pos.max n1 n2); auto.
++ destruct IHf1 as [n1 Hn1]; destruct IHf2 as [n2 Hn2]; destruct IHf3 as [n3 Hn3]; eexists; eauto.
+Qed.
+
+(* The soundness lemma ; alas not complete! *)
+
+Lemma poly_of_formula_sound : forall fl fr var,
+  poly_of_formula fl = poly_of_formula fr -> formula_eval var fl = formula_eval var fr.
+Proof.
+intros fl fr var Heq.
+repeat rewrite <- poly_of_formula_eval_compat.
+rewrite Heq; reflexivity.
+Qed.
+
+End Translation.
+
+Section Completeness.
+
+(* Lemma reduce_poly_of_formula_simpl : forall fl fr var,
+  simpl_eval (var_of_list var) (reduce (poly_of_formula fl)) = simpl_eval (var_of_list var) (reduce (poly_of_formula fr)) ->
+  formula_eval var fl = formula_eval var fr.
+Proof.
+intros fl fr var Hrw.
+do 2 rewrite <- poly_of_formula_eval_compat.
+destruct (poly_of_formula_valid_compat fl) as [nl Hl].
+destruct (poly_of_formula_valid_compat fr) as [nr Hr].
+rewrite <- (reduce_eval_compat nl (poly_of_formula fl)); [|assumption].
+rewrite <- (reduce_eval_compat nr (poly_of_formula fr)); [|assumption].
+do 2 rewrite <- eval_simpl_eval_compat; assumption.
+Qed. *)
+
+(* Soundness of the method ; immediate *)
+
+Lemma reduce_poly_of_formula_sound : forall fl fr var,
+  reduce (poly_of_formula fl) = reduce (poly_of_formula fr) ->
+  formula_eval var fl = formula_eval var fr.
+Proof.
+intros fl fr var Heq.
+repeat rewrite <- poly_of_formula_eval_compat.
+destruct (poly_of_formula_valid_compat fl) as [nl Hl].
+destruct (poly_of_formula_valid_compat fr) as [nr Hr].
+rewrite <- (reduce_eval_compat nl (poly_of_formula fl)); auto.
+rewrite <- (reduce_eval_compat nr (poly_of_formula fr)); auto.
+rewrite Heq; reflexivity.
+Qed.
+
+Definition make_last {A} n (x def : A) :=
+  Pos.peano_rect (fun _ => list A)
+    (cons x nil)
+    (fun _ F => cons def F) n.
+
+(* Replace the nth element of a list *)
+
+Fixpoint list_replace l n b :=
+match l with
+| nil => make_last n b false
+| cons a l =>
+  Pos.peano_rect _
+    (cons b l) (fun n _ => cons a (list_replace l n b)) n
+end.
+
+(** Extract a non-null witness from a polynomial *)
+
+Existing Instance Decidable_null.
+
+Fixpoint boolean_witness p :=
+match p with
+| Cst c => nil
+| Poly p i q =>
+  if decide (null p) then
+    let var := boolean_witness q in
+    list_replace var i true
+  else
+    let var := boolean_witness p in
+    list_replace var i false
+end.
+
+Lemma list_nth_base : forall A (def : A) l,
+  list_nth 1 l def = match l with nil => def | cons x _ => x end.
+Proof.
+intros A def l; unfold list_nth.
+rewrite Pos.peano_rect_base; reflexivity.
+Qed.
+
+Lemma list_nth_succ : forall A n (def : A) l,
+  list_nth (Pos.succ n) l def =
+    match l with nil => def | cons _ l => list_nth n l def end.
+Proof.
+intros A def l; unfold list_nth.
+rewrite Pos.peano_rect_succ; reflexivity.
+Qed.
+
+Lemma list_nth_nil : forall A n (def : A),
+  list_nth n nil def = def.
+Proof.
+intros A n def; induction n using Pos.peano_rect.
++ rewrite list_nth_base; reflexivity.
++ rewrite list_nth_succ; reflexivity.
+Qed.
+
+Lemma make_last_nth_1 : forall A n i x def, i <> n ->
+  list_nth i (@make_last A n x def) def = def.
+Proof.
+intros A n; induction n using Pos.peano_rect; intros i x def Hd;
+  unfold make_last; simpl.
++ induction i using Pos.peano_case; [elim Hd; reflexivity|].
+  rewrite list_nth_succ, list_nth_nil; reflexivity.
++ unfold make_last; rewrite Pos.peano_rect_succ; fold (make_last n x def).
+  induction i using Pos.peano_case.
+  - rewrite list_nth_base; reflexivity.
+  - rewrite list_nth_succ; apply IHn; zify; omega.
+Qed.
+
+Lemma make_last_nth_2 : forall A n x def, list_nth n (@make_last A n x def) def = x.
+Proof.
+intros A n; induction n using Pos.peano_rect; intros x def; simpl.
++ reflexivity.
++ unfold make_last; rewrite Pos.peano_rect_succ; fold (make_last n x def).
+  rewrite list_nth_succ; auto.
+Qed.
+
+Lemma list_replace_nth_1 : forall var i j x, i <> j ->
+  list_nth i (list_replace var j x) false = list_nth i var false.
+Proof.
+intros var; induction var; intros i j x Hd; simpl.
++ rewrite make_last_nth_1, list_nth_nil; auto.
++ induction j using Pos.peano_rect.
+  - rewrite Pos.peano_rect_base.
+    induction i using Pos.peano_rect; [now elim Hd; auto|].
+    rewrite 2list_nth_succ; reflexivity.
+  - rewrite Pos.peano_rect_succ.
+    induction i using Pos.peano_rect.
+    { rewrite 2list_nth_base; reflexivity. }
+    { rewrite 2list_nth_succ; apply IHvar; zify; omega. }
+Qed.
+
+Lemma list_replace_nth_2 : forall var i x, list_nth i (list_replace var i x) false = x.
+Proof.
+intros var; induction var; intros i x; simpl.
++ now apply make_last_nth_2.
++ induction i using Pos.peano_rect.
+  - rewrite Pos.peano_rect_base, list_nth_base; reflexivity.
+  - rewrite Pos.peano_rect_succ, list_nth_succ; auto.
+Qed.
+
+(* The witness is correct only if the polynomial is linear *)
+
+Lemma boolean_witness_nonzero : forall k p, linear k p -> ~ null p ->
+  eval (boolean_witness p) p = true.
+Proof.
+intros k p Hl Hp; induction Hl; simpl.
+  destruct c; [reflexivity|elim Hp; now constructor].
+  case_decide.
+    rewrite eval_null_zero; [|assumption]; rewrite list_replace_nth_2; simpl.
+    match goal with [ |- (if ?b then true else false) = true ] =>
+      assert (Hrw : b = true); [|rewrite Hrw; reflexivity]
+    end.
+    erewrite eval_suffix_compat; [now eauto| |now apply linear_valid_incl; eauto].
+    now intros j Hd; apply list_replace_nth_1; zify; omega.
+    rewrite list_replace_nth_2, xorb_false_r.
+    erewrite eval_suffix_compat; [now eauto| |now apply linear_valid_incl; eauto].
+    now intros j Hd; apply list_replace_nth_1; zify; omega.
+Qed.
+
+(* This should be better when using the [vm_compute] tactic instead of plain reflexivity. *)
+
+Lemma reduce_poly_of_formula_sound_alt : forall var fl fr,
+  reduce (poly_add (poly_of_formula fl) (poly_of_formula fr)) = Cst false ->
+  formula_eval var fl = formula_eval var fr.
+Proof.
+intros var fl fr Heq.
+repeat rewrite <- poly_of_formula_eval_compat.
+destruct (poly_of_formula_valid_compat fl) as [nl Hl].
+destruct (poly_of_formula_valid_compat fr) as [nr Hr].
+rewrite <- (reduce_eval_compat nl (poly_of_formula fl)); auto.
+rewrite <- (reduce_eval_compat nr (poly_of_formula fr)); auto.
+rewrite <- xorb_false_l; change false with (eval var (Cst false)).
+rewrite <- poly_add_compat, <- Heq.
+repeat rewrite poly_add_compat.
+rewrite (reduce_eval_compat nl); [|assumption].
+rewrite (reduce_eval_compat (Pos.max nl nr)); [|apply poly_add_valid_compat; assumption].
+rewrite (reduce_eval_compat nr); [|assumption].
+rewrite poly_add_compat; ring.
+Qed.
+
+(* The completeness lemma *)
+
+(* Lemma reduce_poly_of_formula_complete : forall fl fr,
+  reduce (poly_of_formula fl) <> reduce (poly_of_formula fr) ->
+  {var | formula_eval var fl <> formula_eval var fr}.
+Proof.
+intros fl fr H.
+pose (p := poly_add (reduce (poly_of_formula fl)) (poly_opp (reduce (poly_of_formula fr)))).
+pose (var := boolean_witness p).
+exists var.
+  intros Hc; apply (f_equal Z_of_bool) in Hc.
+  assert (Hfl : linear 0 (reduce (poly_of_formula fl))).
+    now destruct (poly_of_formula_valid_compat fl) as [n Hn]; apply (linear_le_compat n); [|now auto]; apply linear_reduce; auto.
+  assert (Hfr : linear 0 (reduce (poly_of_formula fr))).
+    now destruct (poly_of_formula_valid_compat fr) as [n Hn]; apply (linear_le_compat n); [|now auto]; apply linear_reduce; auto.
+  repeat rewrite <- poly_of_formula_eval_compat in Hc.
+  define (decide (null p)) b Hb; destruct b; tac_decide.
+    now elim H; apply (null_sub_implies_eq 0 0); fold p; auto;
+    apply linear_valid_incl; auto.
+  elim (boolean_witness_nonzero 0 p); auto.
+    unfold p; rewrite <- (min_id 0); apply poly_add_linear_compat; try apply poly_opp_linear_compat; now auto.
+    unfold p at 2; rewrite poly_add_compat, poly_opp_compat.
+    destruct (poly_of_formula_valid_compat fl) as [nl Hnl].
+    destruct (poly_of_formula_valid_compat fr) as [nr Hnr].
+    repeat erewrite reduce_eval_compat; eauto.
+    fold var; rewrite Hc; ring.
+Defined. *)
+
+End Completeness.
+
+(* Reification tactics *)
+
+(* For reflexivity purposes, that would better be transparent *)
+
+Global Transparent decide poly_add.
+
+(* Ltac append_var x l k :=
+match l with
+| nil => constr: (k, cons x l)
+| cons x _ => constr: (k, l)
+| cons ?y ?l =>
+  let ans := append_var x l (S k) in
+  match ans with (?k, ?l) => constr: (k, cons y l) end
+end.
+
+Ltac build_formula t l :=
+match t with
+| true => constr: (formula_top, l)
+| false => constr: (formula_btm, l)
+| ?fl && ?fr =>
+  match build_formula fl l with (?tl, ?l) =>
+    match build_formula fr l with (?tr, ?l) =>
+      constr: (formula_cnj tl tr, l)
+    end
+  end
+| ?fl || ?fr =>
+  match build_formula fl l with (?tl, ?l) =>
+    match build_formula fr l with (?tr, ?l) =>
+      constr: (formula_dsj tl tr, l)
+    end
+  end
+| negb ?f =>
+  match build_formula f l with (?t, ?l) =>
+    constr: (formula_neg t, l)
+  end
+| _ =>
+  let ans := append_var t l 0 in
+  match ans with (?k, ?l) => constr: (formula_var k, l) end
+end.
+
+(* Extract a counterexample from a polynomial and display it *)
+
+Ltac counterexample p l :=
+  let var := constr: (boolean_witness p) in
+  let var := eval vm_compute in var in
+  let rec print l vl :=
+    match l with
+    | nil => idtac
+    | cons ?x ?l =>
+      match vl with
+      | nil =>
+        idtac x ":=" "false"; print l (@nil bool)
+      | cons ?v ?vl =>
+        idtac x ":=" v; print l vl
+      end
+    end
+  in
+  idtac "Counter-example:"; print l var.
+
+Ltac btauto_reify :=
+lazymatch goal with
+| [ |- @eq bool ?t ?u ] =>
+  lazymatch build_formula t (@nil bool) with
+  | (?fl, ?l) =>
+    lazymatch build_formula u l with
+    | (?fr, ?l) =>
+      change (formula_eval l fl = formula_eval l fr)
+    end
+  end
+| _ => fail "Cannot recognize a boolean equality"
+end.
+
+(* The long-awaited tactic *)
+
+Ltac btauto :=
+lazymatch goal with
+| [ |- @eq bool ?t ?u ] =>
+  lazymatch build_formula t (@nil bool) with
+  | (?fl, ?l) =>
+    lazymatch build_formula u l with
+    | (?fr, ?l) =>
+      change (formula_eval l fl = formula_eval l fr);
+      apply reduce_poly_of_formula_sound_alt;
+      vm_compute; (reflexivity || fail "Not a tautology")
+    end
+  end
+| _ => fail "Cannot recognize a boolean equality"
+end. *)
diff --git a/plugins/btauto/btauto_plugin.mllib b/plugins/btauto/btauto_plugin.mllib
new file mode 100644
index 00000000..319a9c30
--- /dev/null
+++ b/plugins/btauto/btauto_plugin.mllib
@@ -0,0 +1,3 @@
+Refl_btauto
+G_btauto
+Btauto_plugin_mod
diff --git a/plugins/ring/Setoid_ring.v b/plugins/btauto/g_btauto.ml4
index 4b484483..8e00b1c1 100644
--- a/plugins/ring/Setoid_ring.v
+++ b/plugins/btauto/g_btauto.ml4
@@ -1,12 +1,16 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-Require Export Setoid_ring_theory.
-Require Export Quote.
-Require Export Setoid_ring_normalize.
-Declare ML Module "ring_plugin".
+(*i camlp4deps: "grammar/grammar.cma"  i*)
+
+DECLARE PLUGIN "btauto_plugin"
+
+TACTIC EXTEND btauto
+| [ "btauto" ] -> [ Refl_btauto.Btauto.tac ]
+END
+
diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml
new file mode 100644
index 00000000..57268a9c
--- /dev/null
+++ b/plugins/btauto/refl_btauto.ml
@@ -0,0 +1,260 @@
+
+let contrib_name = "btauto"
+
+let init_constant dir s =
+  let find_constant contrib dir s =
+    Universes.constr_of_global (Coqlib.find_reference contrib dir s)
+  in
+  find_constant contrib_name dir s
+
+let get_constant dir s = lazy (Coqlib.gen_constant contrib_name dir s)
+
+let get_inductive dir s =
+  let glob_ref () = Coqlib.find_reference contrib_name ("Coq" :: dir) s in
+  Lazy.lazy_from_fun (fun () -> Globnames.destIndRef (glob_ref ()))
+
+let decomp_term (c : Term.constr) =
+  Term.kind_of_term (Term.strip_outer_cast c)
+
+let lapp c v  = Term.mkApp (Lazy.force c, v)
+
+let (===) = Term.eq_constr
+
+module CoqList = struct
+  let path = ["Init"; "Datatypes"]
+  let typ = get_constant path "list"
+  let _nil = get_constant path "nil"
+  let _cons = get_constant path "cons"
+
+  let cons ty h t = lapp _cons [|ty; h ; t|]
+  let nil ty = lapp _nil [|ty|]
+  let rec of_list ty = function
+    | [] -> nil ty
+    | t::q -> cons ty t (of_list ty q)
+  let type_of_list ty = lapp typ [|ty|]
+
+end
+
+module CoqPositive = struct
+  let path = ["Numbers"; "BinNums"]
+  let typ = get_constant path "positive"
+  let _xH = get_constant path "xH"
+  let _xO = get_constant path "xO"
+  let _xI = get_constant path "xI"
+
+  (* A coq nat from an int *)
+  let rec of_int n =
+    if n <= 1 then Lazy.force _xH
+    else
+      let ans = of_int (n / 2) in
+      if n mod 2 = 0 then lapp _xO [|ans|]
+      else lapp _xI [|ans|]
+
+end
+
+module Env = struct
+
+  module ConstrHashed = struct
+    type t = Term.constr
+    let equal = Term.eq_constr
+    let hash = Term.hash_constr
+  end
+
+  module ConstrHashtbl = Hashtbl.Make (ConstrHashed)
+
+  type t = (int ConstrHashtbl.t * int ref)
+
+  let add (tbl, off) (t : Term.constr) =
+    try ConstrHashtbl.find tbl t 
+    with
+    | Not_found -> 
+      let i = !off in 
+      let () = ConstrHashtbl.add tbl t i in
+      let () = incr off in
+      i
+
+  let empty () = (ConstrHashtbl.create 16, ref 1)
+
+  let to_list (env, _) =
+    (* we need to get an ordered list *)
+    let fold constr key accu = (key, constr) :: accu in
+    let l = ConstrHashtbl.fold fold env [] in
+    let sorted_l = List.sort (fun p1 p2 -> Int.compare (fst p1) (fst p2)) l in
+    List.map snd sorted_l
+
+end
+
+module Bool = struct
+
+  let typ = get_constant ["Init"; "Datatypes"] "bool"
+  let ind = get_inductive ["Init"; "Datatypes"] "bool"
+  let trueb = get_constant ["Init"; "Datatypes"] "true"
+  let falseb = get_constant ["Init"; "Datatypes"] "false"
+  let andb = get_constant ["Init"; "Datatypes"] "andb"
+  let orb = get_constant ["Init"; "Datatypes"] "orb"
+  let xorb = get_constant ["Init"; "Datatypes"] "xorb"
+  let negb = get_constant ["Init"; "Datatypes"] "negb"
+
+  type t =
+  | Var of int
+  | Const of bool
+  | Andb of t * t
+  | Orb of t * t
+  | Xorb of t * t
+  | Negb of t
+  | Ifb of t * t * t
+
+  let quote (env : Env.t) (c : Term.constr) : t =
+    let trueb = Lazy.force trueb in
+    let falseb = Lazy.force falseb in
+    let andb = Lazy.force andb in
+    let orb = Lazy.force orb in
+    let xorb = Lazy.force xorb in
+    let negb = Lazy.force negb in
+
+    let rec aux c = match decomp_term c with
+    | Term.App (head, args) ->
+      if head === andb && Array.length args = 2 then
+        Andb (aux args.(0), aux args.(1))
+      else if head === orb && Array.length args = 2 then
+        Orb (aux args.(0), aux args.(1))
+      else if head === xorb && Array.length args = 2 then
+        Xorb (aux args.(0), aux args.(1))
+      else if head === negb && Array.length args = 1 then
+        Negb (aux args.(0))
+      else Var (Env.add env c)
+    | Term.Case (info, r, arg, pats) ->
+      let is_bool =
+        let i = info.Term.ci_ind in
+        Names.eq_ind i (Lazy.force ind)
+      in
+      if is_bool then
+        Ifb ((aux arg), (aux pats.(0)), (aux pats.(1)))
+      else
+        Var (Env.add env c)
+    | _ ->
+      if c === falseb then Const false
+      else if c === trueb then Const true
+      else Var (Env.add env c)
+    in
+    aux c
+
+end
+
+module Btauto = struct
+
+  open Pp
+
+  let eq = get_constant ["Init"; "Logic"]  "eq"
+
+  let f_var = get_constant ["btauto"; "Reflect"] "formula_var"
+  let f_btm = get_constant ["btauto"; "Reflect"] "formula_btm"
+  let f_top = get_constant ["btauto"; "Reflect"] "formula_top"
+  let f_cnj = get_constant ["btauto"; "Reflect"] "formula_cnj"
+  let f_dsj = get_constant ["btauto"; "Reflect"] "formula_dsj"
+  let f_neg = get_constant ["btauto"; "Reflect"] "formula_neg"
+  let f_xor = get_constant ["btauto"; "Reflect"] "formula_xor"
+  let f_ifb = get_constant ["btauto"; "Reflect"] "formula_ifb"
+
+  let eval = get_constant ["btauto"; "Reflect"] "formula_eval"
+  let witness = get_constant ["btauto"; "Reflect"] "boolean_witness"
+
+  let soundness = get_constant ["btauto"; "Reflect"] "reduce_poly_of_formula_sound_alt"
+
+  let rec convert = function
+  | Bool.Var n -> lapp f_var [|CoqPositive.of_int n|]
+  | Bool.Const true -> Lazy.force f_top
+  | Bool.Const false -> Lazy.force f_btm
+  | Bool.Andb (b1, b2) -> lapp f_cnj [|convert b1; convert b2|]
+  | Bool.Orb (b1, b2) -> lapp f_dsj [|convert b1; convert b2|]
+  | Bool.Negb b -> lapp f_neg [|convert b|]
+  | Bool.Xorb (b1, b2) -> lapp f_xor [|convert b1; convert b2|]
+  | Bool.Ifb (b1, b2, b3) -> lapp f_ifb [|convert b1; convert b2; convert b3|]
+
+  let convert_env env : Term.constr = 
+    CoqList.of_list (Lazy.force Bool.typ) env
+
+  let reify env t = lapp eval [|convert_env env; convert t|]
+
+  let print_counterexample p env gl =
+    let var = lapp witness [|p|] in
+    (* Compute an assignment that dissatisfies the goal *)
+    let _, var = Tacmach.pf_reduction_of_red_expr gl (Genredexpr.CbvVm None) var in
+    let rec to_list l = match decomp_term l with
+    | Term.App (c, _)
+      when c === (Lazy.force CoqList._nil) -> []
+    | Term.App (c, [|_; h; t|])
+      when c === (Lazy.force CoqList._cons) ->
+      if h === (Lazy.force Bool.trueb) then (true :: to_list t)
+      else if h === (Lazy.force Bool.falseb) then (false :: to_list t)
+      else invalid_arg "to_list"
+    | _ -> invalid_arg "to_list"
+    in
+    let concat sep = function
+    | [] -> mt ()
+    | h :: t ->
+      let rec aux = function
+      | [] -> mt ()
+      | x :: t -> (sep ++ x ++ aux t)
+      in
+      h ++ aux t
+    in
+    let msg =
+      try
+        let var = to_list var in
+        let assign = List.combine env var in
+        let map_msg (key, v) =
+          let b = if v then str "true" else str "false" in
+          let term = Printer.pr_constr key in
+          term ++ spc () ++ str ":=" ++ spc () ++ b
+        in
+        let assign = List.map map_msg assign in
+        let l = str "[" ++ (concat (str ";" ++ spc ()) assign) ++ str "]" in
+        str "Not a tautology:" ++ spc () ++ l
+      with e when Errors.noncritical e -> (str "Not a tautology")
+    in
+    Tacticals.tclFAIL 0 msg gl
+
+  let try_unification env =
+    Proofview.Goal.nf_enter begin fun gl ->
+      let concl = Proofview.Goal.concl gl in
+      let eq = Lazy.force eq in
+      let t = decomp_term concl in
+      match t with
+      | Term.App (c, [|typ; p; _|]) when c === eq ->
+      (* should be an equality [@eq poly ?p (Cst false)] *)
+          let tac = Tacticals.New.tclORELSE0 Tactics.reflexivity (Proofview.V82.tactic (print_counterexample p env)) in
+          tac
+      | _ ->
+          let msg = str "Btauto: Internal error" in
+          Tacticals.New.tclFAIL 0 msg
+    end
+
+  let tac =
+    Proofview.Goal.nf_enter begin fun gl ->
+      let concl = Proofview.Goal.concl gl in
+      let eq = Lazy.force eq in
+      let bool = Lazy.force Bool.typ in
+      let t = decomp_term concl in
+      match t with
+      | Term.App (c, [|typ; tl; tr|])
+          when typ === bool && c === eq ->
+          let env = Env.empty () in
+          let fl = Bool.quote env tl in
+          let fr = Bool.quote env tr in
+          let env = Env.to_list env in
+          let fl = reify env fl in
+          let fr = reify env fr in
+          let changed_gl = Term.mkApp (c, [|typ; fl; fr|]) in
+          Tacticals.New.tclTHENLIST [
+            Tactics.change_concl changed_gl;
+            Tactics.apply (Lazy.force soundness);
+            Proofview.V82.tactic (Tactics.normalise_vm_in_concl);
+            try_unification env
+          ]
+      | _ ->
+          let msg = str "Cannot recognize a boolean equality" in
+          Tacticals.New.tclFAIL 0 msg
+    end
+
+end
diff --git a/plugins/btauto/vo.itarget b/plugins/btauto/vo.itarget
new file mode 100644
index 00000000..1f72d3ef
--- /dev/null
+++ b/plugins/btauto/vo.itarget
@@ -0,0 +1,3 @@
+Algebra.vo
+Reflect.vo
+Btauto.vo
diff --git a/plugins/cc/README b/plugins/cc/README
index 073b140e..c616b5da 100644
--- a/plugins/cc/README
+++ b/plugins/cc/README
@@ -3,7 +3,7 @@ cctac: congruence-closure for coq
 
 author: Pierre Corbineau, 
 	Stage de DEA au LSV, ENS Cachan
-	Thèse au LRI, Université Paris Sud XI 
+	Thèse au LRI, Université Paris Sud XI 
 
 Files :
 
diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml
index 056ae3a9..29bca862 100644
--- a/plugins/cc/ccalgo.ml
+++ b/plugins/cc/ccalgo.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,22 +8,24 @@
 
 (* This file implements the basic congruence-closure algorithm by *)
 (* Downey,Sethi and Tarjan. *)
+(* Plus some e-matching and constructor handling by P. Corbineau *)
 
+open Errors
 open Util
 open Pp
 open Goptions
 open Names
 open Term
+open Vars
 open Tacmach
 open Evd
-open Proof_type
 
 let init_size=5
 
 let cc_verbose=ref false
 
-let debug f x =
-  if !cc_verbose then f x
+let debug x =
+  if !cc_verbose then msg_debug x
 
 let _=
   let gdopt=
@@ -42,32 +44,39 @@ module ST=struct
 
   (* l: sign -> term r: term -> sign *)
 
-  type t = {toterm:(int*int,int) Hashtbl.t;
-	    tosign:(int,int*int) Hashtbl.t}
+  module IntTable = Hashtbl.Make(Int)
+  module IntPair =
+  struct
+    type t = int * int
+    let equal (i1, j1) (i2, j2) = Int.equal i1 i2 && Int.equal j1 j2
+    let hash (i, j) = Hashset.Combine.combine (Int.hash i) (Int.hash j)
+  end
+  module IntPairTable = Hashtbl.Make(IntPair)
+
+  type t = {toterm: int IntPairTable.t;
+	    tosign: (int * int) IntTable.t}
 
   let empty ()=
-    {toterm=Hashtbl.create init_size;
-     tosign=Hashtbl.create init_size}
+    {toterm=IntPairTable.create init_size;
+     tosign=IntTable.create init_size}
 
   let enter t sign st=
-    if Hashtbl.mem st.toterm sign then
-	anomaly "enter: signature already entered"
+    if IntPairTable.mem st.toterm sign then
+	anomaly ~label:"enter" (Pp.str "signature already entered")
     else
-	Hashtbl.replace st.toterm sign t;
-	Hashtbl.replace st.tosign t sign
-
-  let query sign st=Hashtbl.find st.toterm sign
+	IntPairTable.replace st.toterm sign t;
+	IntTable.replace st.tosign t sign
 
-  let rev_query term st=Hashtbl.find st.tosign term
+  let query sign st=IntPairTable.find st.toterm sign
 
   let delete st t=
-    try let sign=Hashtbl.find st.tosign t in
-	Hashtbl.remove st.toterm sign;
-	Hashtbl.remove st.tosign t
+    try let sign=IntTable.find st.tosign t in
+	IntPairTable.remove st.toterm sign;
+	IntTable.remove st.tosign t
     with
 	Not_found -> ()
 
-  let rec delete_set st s = Intset.iter (delete st) s
+  let delete_set st s = Int.Set.iter (delete st) s
 
 end
 
@@ -84,45 +93,78 @@ type pa_mark=
     Fmark of pa_fun
   | Cmark of pa_constructor
 
-module PacMap=Map.Make(struct
-			 type t=pa_constructor
-			 let compare=Pervasives.compare end)
+module PacOrd =
+struct
+  type t = pa_constructor
+  let compare { cnode = cnode0; arity = arity0; args = args0 }
+              { cnode = cnode1; arity = arity1; args = args1 } =
+    let cmp = Int.compare cnode0 cnode1 in
+    if cmp = 0 then
+      let cmp' = Int.compare arity0 arity1 in
+      if cmp' = 0 then
+        List.compare Int.compare args0 args1
+      else
+        cmp'
+    else
+      cmp
+end
+
+module PafOrd =
+struct
+  type t = pa_fun
+  let compare { fsym = fsym0; fnargs = fnargs0 } { fsym = fsym1; fnargs = fnargs1 } =
+    let cmp = Int.compare fsym0 fsym1 in
+    if cmp = 0 then
+      Int.compare fnargs0 fnargs1
+    else
+      cmp
+end
 
-module PafMap=Map.Make(struct
-			 type t=pa_fun
-			 let compare=Pervasives.compare end)
+module PacMap=Map.Make(PacOrd)
+module PafMap=Map.Make(PafOrd)
 
 type cinfo=
-    {ci_constr: constructor; (* inductive type *)
+    {ci_constr: pconstructor; (* inductive type *)
      ci_arity: int;     (* # args *)
      ci_nhyps: int}     (* # projectable args *)
 
+let family_eq f1 f2 = match f1, f2 with
+| InProp, InProp
+| InSet, InSet
+| InType, InType -> true
+| _ -> false
+
 type term=
     Symb of constr
   | Product of sorts_family * sorts_family
-  | Eps of identifier
+  | Eps of Id.t
   | Appli of term*term
   | Constructor of cinfo (* constructor arity + nhyps *)
 
 let rec term_equal t1 t2 =
   match t1, t2 with
-    | Symb c1, Symb c2 -> eq_constr c1 c2
-    | Product (s1, t1), Product (s2, t2) -> s1 = s2 && t1 = t2
-    | Eps i1, Eps i2 -> id_ord i1 i2 = 0
+    | Symb c1, Symb c2 -> eq_constr_nounivs c1 c2
+    | Product (s1, t1), Product (s2, t2) -> family_eq s1 s2 && family_eq t1 t2
+    | Eps i1, Eps i2 -> Id.equal i1 i2
     | Appli (t1, u1), Appli (t2, u2) -> term_equal t1 t2 && term_equal u1 u2
-    | Constructor {ci_constr=c1; ci_arity=i1; ci_nhyps=j1},
-      Constructor {ci_constr=c2; ci_arity=i2; ci_nhyps=j2} ->
-      i1 = i2 && j1 = j2 && eq_constructor c1 c2
-    | _ -> t1 = t2
+    | Constructor {ci_constr=(c1,u1); ci_arity=i1; ci_nhyps=j1},
+      Constructor {ci_constr=(c2,u2); ci_arity=i2; ci_nhyps=j2} ->
+      Int.equal i1 i2 && Int.equal j1 j2 && eq_constructor c1 c2 (* FIXME check eq? *)
+    | _ -> false
+
+open Hashset.Combine
 
-open Hashtbl_alt.Combine
+let hash_sorts_family = function
+| InProp -> 0
+| InSet -> 1
+| InType -> 2
 
 let rec hash_term = function
   | Symb c -> combine 1 (hash_constr c)
-  | Product (s1, s2) -> combine3 2 (Hashtbl.hash s1) (Hashtbl.hash s2)
-  | Eps i -> combine 3 (Hashtbl.hash i)
+  | Product (s1, s2) -> combine3 2 (hash_sorts_family s1) (hash_sorts_family s2)
+  | Eps i -> combine 3 (Id.hash i)
   | Appli (t1, t2) -> combine3 4 (hash_term t1) (hash_term t2)
-  | Constructor {ci_constr=c; ci_arity=i; ci_nhyps=j} -> combine4 5 (Hashtbl.hash c) i j
+  | Constructor {ci_constr=(c,u); ci_arity=i; ci_nhyps=j} -> combine4 5 (constructor_hash c) i j
 
 type ccpattern =
     PApp of term * ccpattern list (* arguments are reversed *)
@@ -151,14 +193,16 @@ type patt_kind =
   | Creates_variables
 
 type quant_eq =
-    {qe_hyp_id: identifier;
-     qe_pol: bool;
-     qe_nvars:int;
-     qe_lhs: ccpattern;
-     qe_lhs_valid:patt_kind;
-     qe_rhs: ccpattern;
-     qe_rhs_valid:patt_kind}
-
+  {
+    qe_hyp_id: Id.t;
+    qe_pol: bool;
+    qe_nvars:int;
+    qe_lhs: ccpattern;
+    qe_lhs_valid:patt_kind;
+    qe_rhs: ccpattern;
+    qe_rhs_valid:patt_kind
+  }
+    
 let swap eq : equality =
   let swap_rule=match eq.rule with
       Congruence -> Congruence
@@ -174,12 +218,11 @@ type inductive_status =
 
 type representative=
     {mutable weight:int;
-     mutable lfathers:Intset.t;
-     mutable fathers:Intset.t;
+     mutable lfathers:Int.Set.t;
+     mutable fathers:Int.Set.t;
      mutable inductive_status: inductive_status;
      class_type : Term.types;
-     mutable functions: Intset.t PafMap.t;
-     mutable constructors: int PacMap.t} (*pac -> term = app(constr,t) *)
+     mutable functions: Int.Set.t PafMap.t} (*pac -> term = app(constr,t) *)
 
 type cl = Rep of representative| Eqto of int*equality
 
@@ -188,12 +231,13 @@ type vertex = Leaf| Node of (int*int)
 type node =
     {mutable clas:cl;
      mutable cpath: int;
+     mutable constructors: int PacMap.t;
      vertex:vertex;
      term:term}
 
 module Constrhash = Hashtbl.Make
   (struct type t = constr
-	  let equal = eq_constr
+	  let equal = eq_constr_nounivs
 	  let hash = hash_constr
    end)
 module Typehash = Constrhash
@@ -205,9 +249,9 @@ module Termhash = Hashtbl.Make
    end)
 
 module Identhash = Hashtbl.Make
-  (struct type t = identifier
-	  let equal = Pervasives.(=)
-	  let hash = Hashtbl.hash
+  (struct type t = Id.t
+	  let equal = Id.equal
+	  let hash = Id.hash
    end)
 
 type forest=
@@ -221,45 +265,54 @@ type forest=
 type state =
     {uf: forest;
      sigtable:ST.t;
-     mutable terms: Intset.t;
+     mutable terms: Int.Set.t;
      combine: equality Queue.t;
      marks: (int * pa_mark) Queue.t;
      mutable diseq: disequality list;
      mutable quant: quant_eq list;
-     mutable pa_classes: Intset.t;
+     mutable pa_classes: Int.Set.t;
      q_history: (int array) Identhash.t;
      mutable rew_depth:int;
      mutable changed:bool;
-     by_type: Intset.t Typehash.t;
+     by_type: Int.Set.t Typehash.t;
      mutable gls:Proof_type.goal Tacmach.sigma}
 
 let dummy_node =
-  {clas=Eqto(min_int,{lhs=min_int;rhs=min_int;rule=Congruence});
-   cpath=min_int;
-   vertex=Leaf;
-   term=Symb (mkRel min_int)}
-
+  {
+    clas=Eqto (min_int,{lhs=min_int;rhs=min_int;rule=Congruence});
+    cpath=min_int;
+    constructors=PacMap.empty;
+    vertex=Leaf;
+    term=Symb (mkRel min_int)
+  }
+
+let empty_forest() =
+  {
+    max_size=init_size;
+    size=0;
+    map=Array.make init_size dummy_node;
+    epsilons=[];
+    axioms=Constrhash.create init_size;
+    syms=Termhash.create init_size
+  }
+    
 let empty depth gls:state =
-  {uf=
-     {max_size=init_size;
-      size=0;
-      map=Array.create init_size dummy_node;
-      epsilons=[];
-      axioms=Constrhash.create init_size;
-      syms=Termhash.create init_size};
-  terms=Intset.empty;
-  combine=Queue.create ();
-  marks=Queue.create ();
-  sigtable=ST.empty ();
-  diseq=[];
-  quant=[];
-  pa_classes=Intset.empty;
-  q_history=Identhash.create init_size;
-  rew_depth=depth;
-  by_type=Constrhash.create init_size;
-  changed=false;
-  gls=gls}
-
+  {
+    uf= empty_forest ();
+    terms=Int.Set.empty;
+    combine=Queue.create ();
+    marks=Queue.create ();
+    sigtable=ST.empty ();
+    diseq=[];
+    quant=[];
+    pa_classes=Int.Set.empty;
+    q_history=Identhash.create init_size;
+    rew_depth=depth;
+    by_type=Constrhash.create init_size;
+    changed=false;
+    gls=gls
+  }
+    
 let forest state = state.uf
 
 let compress_path uf i j = uf.map.(j).cpath<-i
@@ -274,15 +327,25 @@ let find uf i= find_aux uf [] i
 let get_representative uf i=
   match uf.map.(i).clas with
       Rep r -> r
-    | _ -> anomaly "get_representative: not a representative"
+    | _ -> anomaly ~label:"get_representative" (Pp.str "not a representative")
+
+let get_constructors uf i= uf.map.(i).constructors
 
 let find_pac uf i pac =
-  PacMap.find pac (get_representative uf i).constructors
+  PacMap.find pac (get_constructors uf i)
+
+let rec find_oldest_pac uf i pac=
+  try PacMap.find pac (get_constructors uf i) with
+    Not_found -> 
+      match uf.map.(i).clas with 
+	Eqto (j,_) -> find_oldest_pac uf j pac
+      | Rep _ -> raise Not_found
+     
 
 let get_constructor_info uf i=
   match uf.map.(i).term with
       Constructor cinfo->cinfo
-    | _ -> anomaly "get_constructor: not a constructor"
+    | _ -> anomaly ~label:"get_constructor" (Pp.str "not a constructor")
 
 let size uf i=
   (get_representative uf i).weight
@@ -294,13 +357,13 @@ let epsilons uf = uf.epsilons
 let add_lfather uf i t=
   let r=get_representative uf i in
     r.weight<-r.weight+1;
-    r.lfathers<-Intset.add t r.lfathers;
-    r.fathers <-Intset.add t r.fathers
+    r.lfathers<-Int.Set.add t r.lfathers;
+    r.fathers <-Int.Set.add t r.fathers
 
 let add_rfather uf i t=
   let r=get_representative uf i in
     r.weight<-r.weight+1;
-    r.fathers <-Intset.add t r.fathers
+    r.fathers <-Int.Set.add t r.fathers
 
 exception Discriminable of int * pa_constructor * int * pa_constructor
 
@@ -313,21 +376,21 @@ let tail_pac p=
 let fsucc paf =
   {paf with fnargs=succ paf.fnargs}
 
-let add_pac rep pac t =
-  if not (PacMap.mem pac rep.constructors) then
-    rep.constructors<-PacMap.add pac t rep.constructors
+let add_pac node pac t =
+  if not (PacMap.mem pac node.constructors) then
+    node.constructors<-PacMap.add pac t node.constructors
 
 let add_paf rep paf t =
   let already =
-    try PafMap.find paf rep.functions with Not_found -> Intset.empty in
-    rep.functions<- PafMap.add paf (Intset.add t already) rep.functions
+    try PafMap.find paf rep.functions with Not_found -> Int.Set.empty in
+    rep.functions<- PafMap.add paf (Int.Set.add t already) rep.functions
 
 let term uf i=uf.map.(i).term
 
 let subterms uf i=
   match uf.map.(i).vertex with
       Node(j,k) -> (j,k)
-    | _ -> anomaly "subterms: not a node"
+    | _ -> anomaly ~label:"subterms" (Pp.str "not a node")
 
 let signature uf i=
   let j,k=subterms uf i in (find uf j,find uf k)
@@ -335,9 +398,9 @@ let signature uf i=
 let next uf=
   let size=uf.size in
   let nsize= succ size in
-    if nsize=uf.max_size then
+    if Int.equal nsize uf.max_size then
       let newmax=uf.max_size * 3 / 2 + 1 in
-      let newmap=Array.create newmax dummy_node in
+      let newmap=Array.make newmax dummy_node in
 	begin
 	  uf.max_size<-newmax;
 	  Array.blit uf.map 0 newmap 0 size;
@@ -349,46 +412,63 @@ let next uf=
 
 let new_representative typ =
   {weight=0;
-   lfathers=Intset.empty;
-   fathers=Intset.empty;
+   lfathers=Int.Set.empty;
+   fathers=Int.Set.empty;
    inductive_status=Unknown;
    class_type=typ;
-   functions=PafMap.empty;
-   constructors=PacMap.empty}
+   functions=PafMap.empty}
 
 (* rebuild a constr from an applicative term *)
 
-let _A_ = Name (id_of_string "A")
-let _B_ = Name (id_of_string "A")
+let _A_ = Name (Id.of_string "A")
+let _B_ = Name (Id.of_string "A")
 let _body_ =  mkProd(Anonymous,mkRel 2,mkRel 2)
 
 let cc_product s1 s2 =
-  mkLambda(_A_,mkSort(Termops.new_sort_in_family s1),
-	   mkLambda(_B_,mkSort(Termops.new_sort_in_family s2),_body_))
+  mkLambda(_A_,mkSort(Universes.new_sort_in_family s1),
+	   mkLambda(_B_,mkSort(Universes.new_sort_in_family s2),_body_))
 
 let rec constr_of_term = function
-    Symb s->s
+    Symb s-> applist_projection s []
   | Product(s1,s2) -> cc_product s1 s2
   | Eps id -> mkVar id
-  | Constructor cinfo -> mkConstruct cinfo.ci_constr
+  | Constructor cinfo -> mkConstructU cinfo.ci_constr
   | Appli (s1,s2)->
       make_app [(constr_of_term s2)] s1
 and make_app l=function
     Appli (s1,s2)->make_app ((constr_of_term s2)::l) s1
-  | other -> applistc (constr_of_term other) l
+  | other -> 
+    applist_proj other l
+and applist_proj c l =
+  match c with
+  | Symb s -> applist_projection s l
+  | _ -> applistc (constr_of_term c) l
+and applist_projection c l =
+  match kind_of_term c with
+  | Const c when Environ.is_projection (fst c) (Global.env()) ->
+    let p = Projection.make (fst c) false in
+    (match l with 
+    | [] -> (* Expand the projection *)
+      let ty,_ = Typeops.type_of_constant (Global.env ()) c in
+      let pb = Environ.lookup_projection p (Global.env()) in
+      let ctx,_ = Term.decompose_prod_n_assum (pb.Declarations.proj_npars + 1) ty in
+	it_mkLambda_or_LetIn (mkProj(p,mkRel 1)) ctx
+    | hd :: tl ->
+      applistc (mkProj (p, hd)) tl)
+  | _ -> applistc c l
 
 let rec canonize_name c =
   let func =  canonize_name in
     match kind_of_term c with
-      | Const kn ->
+      | Const (kn,u) ->
 	  let canon_const = constant_of_kn (canonical_con kn) in 
-	    (mkConst canon_const)
-      | Ind (kn,i) ->
+	    (mkConstU (canon_const,u))
+      | Ind ((kn,i),u) ->
 	  let canon_mind = mind_of_kn (canonical_mind kn) in
-	    (mkInd (canon_mind,i))
-      | Construct ((kn,i),j) ->
+	    (mkIndU ((canon_mind,i),u))
+      | Construct (((kn,i),j),u) ->
 	  let canon_mind = mind_of_kn (canonical_mind kn) in
-	    mkConstruct ((canon_mind,i),j) 
+	    mkConstructU (((canon_mind,i),j),u)
       | Prod (na,t,ct) ->
 	  mkProd (na,func t, func ct)
       | Lambda (na,t,ct) ->
@@ -396,16 +476,22 @@ let rec canonize_name c =
       | LetIn (na,b,t,ct) ->
 	  mkLetIn (na, func b,func t,func ct)
       | App (ct,l) ->
-	  mkApp (func ct,array_smartmap func l)
+	  mkApp (func ct,Array.smartmap func l)
+      | Proj(p,c) ->
+	let p' = Projection.map (fun kn ->
+          constant_of_kn (canonical_con kn)) p in 
+	  (mkProj (p', func c))
       | _ -> c
 
 (* rebuild a term from a pattern and a substitution *)
 
 let build_subst uf subst =
-  Array.map (fun i ->
-	       try term uf i
-	       with e when Errors.noncritical e ->
-                 anomaly "incomplete matching") subst
+  Array.map
+    (fun i ->
+      try term uf i
+      with e when Errors.noncritical e ->
+        anomaly (Pp.str "incomplete matching"))
+    subst
 
 let rec inst_pattern subst = function
     PVar i ->
@@ -415,8 +501,8 @@ let rec inst_pattern subst = function
 	(fun spat f -> Appli (f,inst_pattern subst spat))
 	   args t
 
-let pr_idx_term state i = str "[" ++ int i ++ str ":=" ++
-  Termops.print_constr (constr_of_term (term state.uf i)) ++ str "]"
+let pr_idx_term uf i = str "[" ++ int i ++ str ":=" ++
+  Termops.print_constr (constr_of_term (term uf i)) ++ str "]"
 
 let pr_term t = str "[" ++
   Termops.print_constr (constr_of_term t) ++ str "]"
@@ -426,7 +512,8 @@ let rec add_term state t=
     try Termhash.find uf.syms t with
 	Not_found ->
 	  let b=next uf in
-	  let typ = pf_type_of state.gls (constr_of_term t) in
+          let trm = constr_of_term t in
+	  let typ = pf_type_of state.gls trm in
 	  let typ = canonize_name typ in
 	  let new_node=
 	    match t with
@@ -437,20 +524,23 @@ let rec add_term state t=
 		    Queue.add (b,Fmark paf) state.marks;
 		    {clas= Rep (new_representative typ);
 		     cpath= -1;
+		     constructors=PacMap.empty;
 		     vertex= Leaf;
 		     term= t}
 	      | Eps id ->
 		  {clas= Rep (new_representative typ);
 		   cpath= -1;
+		   constructors=PacMap.empty;
 		   vertex= Leaf;
 		   term= t}
 	      | Appli (t1,t2) ->
 		  let i1=add_term state t1 and i2=add_term state t2 in
 		    add_lfather uf (find uf i1) b;
 		    add_rfather uf (find uf i2) b;
-		    state.terms<-Intset.add b state.terms;
+		    state.terms<-Int.Set.add b state.terms;
 		    {clas= Rep (new_representative typ);
 		     cpath= -1;
+		     constructors=PacMap.empty;
 		     vertex= Node(i1,i2);
 		     term= t}
 	      | Constructor cinfo ->
@@ -465,15 +555,16 @@ let rec add_term state t=
 		    Queue.add (b,Cmark pac) state.marks;
 		    {clas=Rep (new_representative typ);
 		     cpath= -1;
+		     constructors=PacMap.empty;
 		     vertex=Leaf;
 		     term=t}
 	  in
 	    uf.map.(b)<-new_node;
 	    Termhash.add uf.syms t b;
 	    Typehash.replace state.by_type typ
-	      (Intset.add b
+	      (Int.Set.add b
 		 (try Typehash.find state.by_type typ with
-		      Not_found -> Intset.empty));
+		      Not_found -> Int.Set.empty));
 	    b
 
 let add_equality state c s t=
@@ -503,23 +594,23 @@ let is_redundant state id args =
     let prev_args = Identhash.find_all state.q_history id in
     List.exists
       (fun old_args ->
-	 Util.array_for_all2 (fun i j -> i = find state.uf j)
+	 Util.Array.for_all2 (fun i j -> Int.equal i (find state.uf j))
          norm_args old_args)
       prev_args
     with Not_found -> false
 
 let add_inst state (inst,int_subst) =
-  check_for_interrupt ();
+  Control.check_for_interrupt ();
   if state.rew_depth > 0 then
   if is_redundant state inst.qe_hyp_id int_subst then
-    debug msgnl (str "discarding redundant (dis)equality")
+    debug (str "discarding redundant (dis)equality")
   else
     begin
       Identhash.add state.q_history inst.qe_hyp_id int_subst;
       let subst = build_subst (forest state) int_subst in
       let prfhead= mkVar inst.qe_hyp_id in
       let args = Array.map constr_of_term subst in
-      let _ = array_rev args in (* highest deBruijn index first *)
+      let _ = Array.rev args in (* highest deBruijn index first *)
       let prf= mkApp(prfhead,args) in
 	  let s = inst_pattern subst inst.qe_lhs
 	  and t = inst_pattern subst inst.qe_rhs in
@@ -527,20 +618,18 @@ let add_inst state (inst,int_subst) =
 	    state.rew_depth<-pred state.rew_depth;
 	    if inst.qe_pol then
 	      begin
-		debug (fun () ->
-		  msgnl
-		   (str "Adding new equality, depth="++ int state.rew_depth);
-	          msgnl (str "  [" ++ Termops.print_constr prf ++ str " : " ++
-			   pr_term s ++ str " == " ++ pr_term t ++ str "]")) ();
+		debug (
+		   (str "Adding new equality, depth="++ int state.rew_depth) ++ fnl () ++
+	          (str "  [" ++ Termops.print_constr prf ++ str " : " ++
+			   pr_term s ++ str " == " ++ pr_term t ++ str "]"));
 		add_equality state prf s t
 	      end
 	    else
 	      begin
-		debug (fun () ->
-		  msgnl
-		   (str "Adding new disequality, depth="++ int state.rew_depth);
-	          msgnl (str "  [" ++ Termops.print_constr prf ++ str " : " ++
-			   pr_term s ++ str " <> " ++ pr_term t ++ str "]")) ();
+		debug (
+		   (str "Adding new disequality, depth="++ int state.rew_depth) ++ fnl () ++
+	          (str "  [" ++ Termops.print_constr prf ++ str " : " ++
+			   pr_term s ++ str " <> " ++ pr_term t ++ str "]"));
 		add_disequality state (Hyp prf) s t
 	      end
   end
@@ -552,75 +641,77 @@ let link uf i j eq = (* links i -> j *)
 
 let rec down_path uf i l=
   match uf.map.(i).clas with
-      Eqto(j,t)->down_path uf j (((i,j),t)::l)
+      Eqto (j,eq) ->down_path uf j (((i,j),eq)::l)
     | Rep _ ->l
 
+let eq_pair (i1, j1) (i2, j2) = Int.equal i1 i2 && Int.equal j1 j2
+
 let rec min_path=function
     ([],l2)->([],l2)
   | (l1,[])->(l1,[])
-  | (((c1,t1)::q1),((c2,t2)::q2)) when c1=c2 -> min_path (q1,q2)
+  | (((c1,t1)::q1),((c2,t2)::q2)) when eq_pair c1 c2 -> min_path (q1,q2)
   | cpl -> cpl
 
 let join_path uf i j=
-  assert (find uf i=find uf j);
+  assert (Int.equal (find uf i) (find uf j));
   min_path (down_path uf i [],down_path uf j [])
 
 let union state i1 i2 eq=
-  debug (fun () -> msgnl (str "Linking " ++ pr_idx_term state i1 ++
-		 str " and " ++ pr_idx_term state i2 ++ str ".")) ();
+  debug (str "Linking " ++ pr_idx_term state.uf i1 ++
+		 str " and " ++ pr_idx_term state.uf i2 ++ str ".");
   let r1= get_representative state.uf i1
   and r2= get_representative state.uf i2 in
     link state.uf i1 i2 eq;
     Constrhash.replace state.by_type r1.class_type
-      (Intset.remove i1
+      (Int.Set.remove i1
 	 (try Constrhash.find state.by_type r1.class_type with
-	      Not_found -> Intset.empty));
-    let f= Intset.union r1.fathers r2.fathers in
-      r2.weight<-Intset.cardinal f;
+	      Not_found -> Int.Set.empty));
+    let f= Int.Set.union r1.fathers r2.fathers in
+      r2.weight<-Int.Set.cardinal f;
       r2.fathers<-f;
-      r2.lfathers<-Intset.union r1.lfathers r2.lfathers;
+      r2.lfathers<-Int.Set.union r1.lfathers r2.lfathers;
       ST.delete_set state.sigtable r1.fathers;
-      state.terms<-Intset.union state.terms r1.fathers;
+      state.terms<-Int.Set.union state.terms r1.fathers;
       PacMap.iter
 	(fun pac b -> Queue.add (b,Cmark pac) state.marks)
-	r1.constructors;
+	state.uf.map.(i1).constructors;
       PafMap.iter
-	(fun paf -> Intset.iter
+	(fun paf -> Int.Set.iter
 	   (fun b -> Queue.add (b,Fmark paf) state.marks))
 	r1.functions;
       match r1.inductive_status,r2.inductive_status with
 	  Unknown,_ -> ()
 	| Partial pac,Unknown ->
 	    r2.inductive_status<-Partial pac;
-	    state.pa_classes<-Intset.remove i1 state.pa_classes;
-	    state.pa_classes<-Intset.add i2 state.pa_classes
+	    state.pa_classes<-Int.Set.remove i1 state.pa_classes;
+	    state.pa_classes<-Int.Set.add i2 state.pa_classes
 	| Partial _ ,(Partial _ |Partial_applied) ->
-	    state.pa_classes<-Intset.remove i1 state.pa_classes
+	    state.pa_classes<-Int.Set.remove i1 state.pa_classes
 	| Partial_applied,Unknown ->
 	    r2.inductive_status<-Partial_applied
 	| Partial_applied,Partial _ ->
-	    state.pa_classes<-Intset.remove i2 state.pa_classes;
+	    state.pa_classes<-Int.Set.remove i2 state.pa_classes;
 	    r2.inductive_status<-Partial_applied
 	| Total cpl,Unknown -> r2.inductive_status<-Total cpl;
 	| Total (i,pac),Total _ -> Queue.add (i,Cmark pac) state.marks
 	| _,_ -> ()
 
 let merge eq state = (* merge and no-merge *)
-  debug (fun () -> msgnl
-    (str "Merging " ++ pr_idx_term state eq.lhs ++
-       str " and " ++ pr_idx_term state eq.rhs ++ str ".")) ();
+  debug
+    (str "Merging " ++ pr_idx_term state.uf eq.lhs ++
+       str " and " ++ pr_idx_term state.uf eq.rhs ++ str ".");
   let uf=state.uf in
   let i=find uf eq.lhs
   and j=find uf eq.rhs in
-    if i<>j then
+    if not (Int.equal i j) then
       if (size uf i)<(size uf j) then
 	union state i j eq
       else
 	union state j i (swap eq)
 
 let update t state = (* update 1 and 2 *)
-  debug (fun () -> msgnl
-    (str "Updating term " ++ pr_idx_term state t ++ str ".")) ();
+  debug
+    (str "Updating term " ++ pr_idx_term state.uf t ++ str ".");
   let (i,j) as sign = signature state.uf t in
   let (u,v) = subterms state.uf t in
   let rep = get_representative state.uf i in
@@ -628,12 +719,12 @@ let update t state = (* update 1 and 2 *)
       match rep.inductive_status with
 	  Partial _ ->
 	    rep.inductive_status <- Partial_applied;
-	    state.pa_classes <- Intset.remove i state.pa_classes
+	    state.pa_classes <- Int.Set.remove i state.pa_classes
 	| _ -> ()
     end;
     PacMap.iter
       (fun pac _ -> Queue.add (t,Cmark (append_pac v pac)) state.marks)
-      rep.constructors;
+      (get_constructors state.uf i);
     PafMap.iter
       (fun paf _ -> Queue.add (t,Fmark (fsucc paf)) state.marks)
       rep.functions;
@@ -645,12 +736,13 @@ let update t state = (* update 1 and 2 *)
 
 let process_function_mark t rep paf state  =
   add_paf rep paf t;
-  state.terms<-Intset.union rep.lfathers state.terms
+  state.terms<-Int.Set.union rep.lfathers state.terms
 
 let process_constructor_mark t i rep pac state =
-    match rep.inductive_status with
+     add_pac state.uf.map.(i) pac t;
+     match rep.inductive_status with
 	Total (s,opac) ->
-	  if pac.cnode <> opac.cnode then (* Conflict *)
+	  if not (Int.equal pac.cnode opac.cnode) then (* Conflict *)
 	    raise (Discriminable (s,opac,t,pac))
 	  else (* Match *)
 	    let cinfo = get_constructor_info state.uf pac.cnode in
@@ -662,26 +754,26 @@ let process_constructor_mark t i rep pac state =
 			{lhs=s1;rhs=s2;rule=Injection(s,opac,t,pac,n)}
 			state.combine;
 		      f (n-1) q1 q2
-		  | _-> anomaly
-		      "add_pacs : weird error in injection subterms merge"
+		  | _-> anomaly ~label:"add_pacs"
+		      (Pp.str "weird error in injection subterms merge")
 	    in f cinfo.ci_nhyps opac.args pac.args
       | Partial_applied | Partial _ ->
-	  add_pac rep pac t;
-	  state.terms<-Intset.union rep.lfathers state.terms
+(*	  add_pac state.uf.map.(i) pac t; *)
+	  state.terms<-Int.Set.union rep.lfathers state.terms
       | Unknown ->
-	  if pac.arity = 0 then
+	  if Int.equal pac.arity 0 then
 	    rep.inductive_status <- Total (t,pac)
 	  else
 	    begin
-	      add_pac rep pac t;
-	      state.terms<-Intset.union rep.lfathers state.terms;
+	     (* add_pac state.uf.map.(i) pac t; *)
+	      state.terms<-Int.Set.union rep.lfathers state.terms;
 	      rep.inductive_status <- Partial pac;
-	      state.pa_classes<- Intset.add i state.pa_classes
+	      state.pa_classes<- Int.Set.add i state.pa_classes
 	    end
 
 let process_mark t m state =
-  debug (fun () -> msgnl
-    (str "Processing mark for term " ++ pr_idx_term state t ++ str ".")) ();
+  debug
+    (str "Processing mark for term " ++ pr_idx_term state.uf t ++ str ".");
   let i=find state.uf t in
   let rep=get_representative state.uf i in
     match m with
@@ -696,14 +788,15 @@ type explanation =
 let check_disequalities state =
   let uf=state.uf in
   let rec check_aux = function
-      dis::q ->
-	debug (fun () -> msg
-	(str "Checking if " ++ pr_idx_term state dis.lhs ++ str " = " ++
-	 pr_idx_term state dis.rhs ++ str " ... ")) ();
-	if find uf dis.lhs=find uf dis.rhs then
-	  begin debug msgnl (str "Yes");Some dis end
-	else
-	  begin debug msgnl (str "No");check_aux q end
+    | dis::q ->
+        let (info, ans) =
+          if Int.equal (find uf dis.lhs) (find uf dis.rhs) then (str "Yes", Some dis)
+          else (str "No", check_aux q)
+        in
+        let _ = debug
+        (str "Checking if " ++ pr_idx_term state.uf dis.lhs ++ str " = " ++
+         pr_idx_term state.uf dis.rhs ++ str " ... " ++ info) in
+        ans
     | [] -> None
   in
     check_aux state.diseq
@@ -720,13 +813,13 @@ let one_step state =
 	  true
       with Queue.Empty ->
 	try
-	  let t = Intset.choose state.terms in
-	    state.terms<-Intset.remove t state.terms;
+	  let t = Int.Set.choose state.terms in
+	    state.terms<-Int.Set.remove t state.terms;
 	    update t state;
 	    true
 	with Not_found -> false
 
-let __eps__ = id_of_string "_eps_"
+let __eps__ = Id.of_string "_eps_"
 
 let new_state_var typ state =
   let id = pf_get_new_id __eps__ state.gls in
@@ -752,10 +845,10 @@ let complete_one_class state i=
 	let ct = app (term state.uf i) typ pac.arity in
 	  state.uf.epsilons <- pac :: state.uf.epsilons;
 	  ignore (add_term state ct)
-    | _ -> anomaly "wrong incomplete class"
+    | _ -> anomaly (Pp.str "wrong incomplete class")
 
 let complete state =
-  Intset.iter (complete_one_class state) state.pa_classes
+  Int.Set.iter (complete_one_class state) state.pa_classes
 
 type matching_problem =
 {mp_subst : int array;
@@ -773,14 +866,14 @@ let make_fun_table state =
 	       (fun paf _ ->
 		  let elem =
 		    try PafMap.find paf !funtab
-		    with Not_found -> Intset.empty in
-		    funtab:= PafMap.add paf (Intset.add i elem) !funtab)
+		    with Not_found -> Int.Set.empty in
+		    funtab:= PafMap.add paf (Int.Set.add i elem) !funtab)
 	       rep.functions
 	 | _ -> ()) state.uf.map;
     !funtab
 
 
-let rec do_match state res pb_stack =
+let do_match state res pb_stack =
   let mp=Stack.pop pb_stack in
     match mp.mp_stack with
 	[] ->
@@ -795,13 +888,13 @@ let rec do_match state res pb_stack =
 		      Stack.push {mp with mp_stack=remains} pb_stack
 		    end
 		  else
-		    if mp.mp_subst.(pred i) = cl then
+		    if Int.equal mp.mp_subst.(pred i) cl then
 		      Stack.push {mp with mp_stack=remains} pb_stack
 		    else (* mismatch for non-linear variable in pattern *) ()
 	      | PApp (f,[]) ->
 		  begin
 		    try let j=Termhash.find uf.syms f in
-		      if find uf j =cl then
+		      if Int.equal (find uf j) cl then
 			Stack.push {mp with mp_stack=remains} pb_stack
 		    with Not_found -> ()
 		  end
@@ -819,7 +912,7 @@ let rec do_match state res pb_stack =
 			     mp_stack=
 			      (PApp(f,rem_args),s) ::
 				(last_arg,t) :: remains} pb_stack in
-		      Intset.iter aux good_terms
+		      Int.Set.iter aux good_terms
 		  with Not_found -> ()
 
 let paf_of_patt syms = function
@@ -836,21 +929,21 @@ let init_pb_stack state =
     begin
       let good_classes =
 	match inst.qe_lhs_valid with
-	  Creates_variables -> Intset.empty
+	  Creates_variables -> Int.Set.empty
 	| Normal ->
 	    begin
 	      try
 		let paf= paf_of_patt syms inst.qe_lhs in
 		  PafMap.find paf funtab
-	      with Not_found -> Intset.empty
+	      with Not_found -> Int.Set.empty
 	    end
 	| Trivial typ ->
 	    begin
 	      try
 		Typehash.find state.by_type typ
-	      with Not_found -> Intset.empty
+	      with Not_found -> Int.Set.empty
 	    end in
-	Intset.iter (fun i ->
+	Int.Set.iter (fun i ->
 		       Stack.push
 			 {mp_subst = Array.make inst.qe_nvars (-1);
 			  mp_inst=inst;
@@ -859,21 +952,21 @@ let init_pb_stack state =
     begin
       let good_classes =
 	match inst.qe_rhs_valid with
-	  Creates_variables -> Intset.empty
+	  Creates_variables -> Int.Set.empty
 	| Normal ->
 	    begin
 	      try
 		let paf= paf_of_patt syms inst.qe_rhs in
 		  PafMap.find paf funtab
-	      with Not_found -> Intset.empty
+	      with Not_found -> Int.Set.empty
 	    end
 	| Trivial typ ->
 	    begin
 	      try
 		Typehash.find state.by_type typ
-	      with Not_found -> Intset.empty
+	      with Not_found -> Int.Set.empty
 	    end in
-	Intset.iter (fun i ->
+	Int.Set.iter (fun i ->
 		       Stack.push
 			 {mp_subst = Array.make inst.qe_nvars (-1);
 			  mp_inst=inst;
@@ -886,28 +979,28 @@ let find_instances state =
   let pb_stack= init_pb_stack state in
   let res =ref [] in
   let _ =
-    debug msgnl (str "Running E-matching algorithm ... ");
+    debug (str "Running E-matching algorithm ... ");
     try
       while true do
-	check_for_interrupt ();
+	Control.check_for_interrupt ();
 	do_match state res pb_stack
       done;
-      anomaly "get out of here !"
+      anomaly (Pp.str "get out of here !")
     with Stack.Empty -> () in
     !res
 
 let rec execute first_run state =
-  debug msgnl (str "Executing ... ");
+  debug (str "Executing ... ");
   try
     while
-      check_for_interrupt ();
+      Control.check_for_interrupt ();
       one_step state do ()
     done;
     match check_disequalities state with
 	None ->
-	  if not(Intset.is_empty state.pa_classes) then
+	  if not(Int.Set.is_empty state.pa_classes) then
 	    begin
-	      debug msgnl (str "First run was incomplete, completing ... ");
+	      debug (str "First run was incomplete, completing ... ");
 	      complete state;
 	      execute false state
 	    end
@@ -922,12 +1015,12 @@ let rec execute first_run state =
 		  end
 		else
 	      begin
-		debug msgnl (str "Out of instances ... ");
+		debug (str "Out of instances ... ");
 		None
 	      end
 	    else
 	      begin
-		debug msgnl (str "Out of depth ... ");
+		debug (str "Out of depth ... ");
 		None
 	      end
       | Some dis -> Some
diff --git a/plugins/cc/ccalgo.mli b/plugins/cc/ccalgo.mli
index e4713728..c72843d5 100644
--- a/plugins/cc/ccalgo.mli
+++ b/plugins/cc/ccalgo.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -10,40 +10,39 @@ open Util
 open Term
 open Names
 
+type pa_constructor =
+    { cnode : int;
+      arity : int;
+      args  : int list}
+
+type pa_fun=
+    {fsym:int;
+     fnargs:int}
+
+
+module PafMap : Map.S with type key = pa_fun
+module PacMap : Map.S with type key = pa_constructor
+
 type cinfo =
-    {ci_constr: constructor; (* inductive type *)
+    {ci_constr: pconstructor; (* inductive type *)
      ci_arity: int;     (* # args *)
      ci_nhyps: int}     (* # projectable args *)
 
 type term =
     Symb of constr
   | Product of sorts_family * sorts_family
-  | Eps of identifier
+  | Eps of Id.t
   | Appli of term*term
   | Constructor of cinfo (* constructor arity + nhyps *)
 
-val term_equal : term -> term -> bool
+module Constrhash : Hashtbl.S with type key = constr
+module Termhash : Hashtbl.S with type key = term
 
-type patt_kind =
-    Normal
-  | Trivial of types
-  | Creates_variables
 
 type ccpattern =
     PApp of term * ccpattern list
   | PVar of int
 
-type pa_constructor =
-    { cnode : int;
-      arity : int;
-      args  : int list}
-
-module PacMap : Map.S with type key = pa_constructor
-
-type forest
-
-type state
-
 type rule=
     Congruence
   | Axiom of constr * bool
@@ -61,17 +60,67 @@ type equality = rule eq
 
 type disequality = from eq
 
+type patt_kind =
+    Normal
+  | Trivial of types
+  | Creates_variables
+
+type quant_eq=
+    {qe_hyp_id: Id.t;
+     qe_pol: bool;
+     qe_nvars:int;
+     qe_lhs: ccpattern;
+     qe_lhs_valid:patt_kind;
+     qe_rhs: ccpattern;
+     qe_rhs_valid:patt_kind}
+
+type inductive_status =
+    Unknown
+  | Partial of pa_constructor
+  | Partial_applied
+  | Total of (int * pa_constructor)
+
+type representative=
+    {mutable weight:int;
+     mutable lfathers:Int.Set.t;
+     mutable fathers:Int.Set.t;
+     mutable inductive_status: inductive_status;
+     class_type : Term.types;
+     mutable functions: Int.Set.t PafMap.t} (*pac -> term = app(constr,t) *)
+
+type cl = Rep of representative| Eqto of int*equality
+
+type vertex = Leaf| Node of (int*int)
+
+type node =
+    {mutable clas:cl;
+     mutable cpath: int;
+     mutable constructors: int PacMap.t;
+     vertex:vertex;
+     term:term}
+
+type forest=
+    {mutable max_size:int;
+     mutable size:int;
+     mutable map: node array;
+     axioms: (term*term) Constrhash.t;
+     mutable epsilons: pa_constructor list;
+     syms: int Termhash.t}
+
+type state
+
 type explanation =
     Discrimination of (int*pa_constructor*int*pa_constructor)
   | Contradiction of disequality
   | Incomplete
 
-module Constrhash : Hashtbl.S with type key = constr
-module Termhash : Hashtbl.S with type key = term
+type matching_problem
+
+val term_equal : term -> term -> bool
 
 val constr_of_term : term -> constr
 
-val debug : (Pp.std_ppcmds -> unit) -> Pp.std_ppcmds -> unit
+val debug : Pp.std_ppcmds -> unit
 
 val forest : state -> forest
 
@@ -87,7 +136,7 @@ val add_equality : state -> constr -> term -> term -> unit
 
 val add_disequality : state -> from -> term -> term -> unit
 
-val add_quant : state -> identifier -> bool ->
+val add_quant : state -> Id.t -> bool ->
   int * patt_kind * ccpattern * patt_kind * ccpattern -> unit
 
 val tail_pac : pa_constructor -> pa_constructor
@@ -96,6 +145,8 @@ val find : forest -> int -> int
 
 val find_pac : forest -> int -> pa_constructor -> int
 
+val find_oldest_pac : forest -> int -> pa_constructor -> int
+
 val term : forest -> int -> term
 
 val get_constructor_info : forest -> int -> cinfo
@@ -105,25 +156,7 @@ val subterms : forest -> int -> int * int
 val join_path : forest -> int -> int ->
   ((int * int) * equality) list * ((int * int) * equality) list
 
-type quant_eq=
-    {qe_hyp_id: identifier;
-     qe_pol: bool;
-     qe_nvars:int;
-     qe_lhs: ccpattern;
-     qe_lhs_valid:patt_kind;
-     qe_rhs: ccpattern;
-     qe_rhs_valid:patt_kind}
-
-
-type pa_fun=
-    {fsym:int;
-     fnargs:int}
-
-type matching_problem
-
-module PafMap: Map.S with type key = pa_fun
-
-val make_fun_table : state -> Intset.t PafMap.t
+val make_fun_table : state -> Int.Set.t PafMap.t
 
 val do_match :  state ->
     (quant_eq * int array) list ref -> matching_problem Stack.t -> unit
@@ -136,8 +169,9 @@ val find_instances : state -> (quant_eq * int array) list
 
 val execute : bool -> state -> explanation option
 
+val pr_idx_term : forest -> int -> Pp.std_ppcmds
 
-
+val empty_forest: unit -> forest
 
 
 
@@ -161,7 +195,7 @@ type term =
 
 type rule =
     Congruence
-  | Axiom of Names.identifier
+  | Axiom of Names.Id.t
   | Injection of int*int*int*int
 
 type equality =
@@ -207,19 +241,19 @@ val process_rec : UF.t -> equality list -> int list
 val cc : UF.t -> unit
 
 val make_uf :
-  (Names.identifier * (term * term)) list -> UF.t
+  (Names.Id.t * (term * term)) list -> UF.t
 
 val add_one_diseq : UF.t -> (term * term) -> int * int
 
 val add_disaxioms :
-  UF.t -> (Names.identifier * (term * term)) list ->
-  (Names.identifier * (int * int)) list
+  UF.t -> (Names.Id.t * (term * term)) list ->
+  (Names.Id.t * (int * int)) list
 
 val check_equal : UF.t -> int * int -> bool
 
 val find_contradiction : UF.t ->
-  (Names.identifier * (int * int)) list ->
-  (Names.identifier * (int * int))
+  (Names.Id.t * (int * int)) list ->
+  (Names.Id.t * (int * int))
 *)
 
 
diff --git a/plugins/cc/ccproof.ml b/plugins/cc/ccproof.ml
index 037e9f66..42c03234 100644
--- a/plugins/cc/ccproof.ml
+++ b/plugins/cc/ccproof.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -9,10 +9,10 @@
 (* This file uses the (non-compressed) union-find structure to generate *)
 (* proof-trees that will be transformed into proof-terms in cctac.ml4   *)
 
-open Util
-open Names
+open Errors
 open Term
 open Ccalgo
+open Pp
 
 type rule=
     Ax of constr
@@ -20,7 +20,7 @@ type rule=
   | Refl of term
   | Trans of proof*proof
   | Congr of proof*proof
-  | Inject of proof*constructor*int*int
+  | Inject of proof*pconstructor*int*int
 and proof =
     {p_lhs:term;p_rhs:term;p_rule:rule}
 
@@ -47,7 +47,7 @@ let rec ptrans p1 p3=
 	{p_lhs=p1.p_lhs;
 	 p_rhs=p3.p_rhs;
 	 p_rule=Trans (p1,p3)}
-      else anomaly "invalid cc transitivity"
+      else anomaly (Pp.str "invalid cc transitivity")
 
 let rec psym p =
   match p.p_rule with
@@ -85,67 +85,72 @@ let rec nth_arg t n=
 	if n>0 then
 	  nth_arg t1 (n-1)
 	else t2
-    | _ -> anomaly "nth_arg: not enough args"
+    | _ -> anomaly ~label:"nth_arg" (Pp.str "not enough args")
 
 let pinject p c n a =
   {p_lhs=nth_arg p.p_lhs (n-a);
    p_rhs=nth_arg p.p_rhs (n-a);
    p_rule=Inject(p,c,n,a)}
 
-let build_proof uf=
+let rec equal_proof uf i j=
+  debug (str "equal_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ pr_idx_term uf j);
+  if i=j then prefl (term uf i) else
+    let (li,lj)=join_path uf i j in
+    ptrans (path_proof uf i li) (psym (path_proof uf j lj))
+      
+and edge_proof uf ((i,j),eq)=
+  debug (str "edge_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ pr_idx_term uf j);
+  let pi=equal_proof uf i eq.lhs in
+  let pj=psym (equal_proof uf j eq.rhs) in
+  let pij=
+    match eq.rule with
+      Axiom (s,reversed)->
+	if reversed then psymax (axioms uf) s
+	else pax (axioms uf) s
+    | Congruence ->congr_proof uf eq.lhs eq.rhs
+    | Injection (ti,ipac,tj,jpac,k) -> (* pi_k ipac = p_k jpac *) 
+      let p=ind_proof uf ti ipac tj jpac in
+      let cinfo= get_constructor_info uf ipac.cnode in
+      pinject p cinfo.ci_constr cinfo.ci_nhyps k in  
+  ptrans (ptrans pi pij) pj
+  
+and constr_proof uf i ipac=
+  debug (str "constr_proof " ++ pr_idx_term uf i ++ brk (1,20));
+  let t=find_oldest_pac uf i ipac in
+  let eq_it=equal_proof uf i t in
+  if ipac.args=[] then
+    eq_it
+  else
+    let fipac=tail_pac ipac in
+    let (fi,arg)=subterms uf t in
+    let targ=term uf arg in
+    let p=constr_proof uf fi fipac in
+    ptrans eq_it (pcongr p (prefl targ))
+      
+and path_proof uf i l=
+  debug (str "path_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ str "{" ++
+	   (prlist_with_sep (fun () -> str ",") (fun ((_,j),_) -> int j) l) ++ str "}");
+  match l with
+  | [] -> prefl (term uf i)
+  | x::q->ptrans (path_proof uf (snd (fst x)) q) (edge_proof uf x)
+    
+and congr_proof uf i j=
+  debug (str "congr_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ pr_idx_term uf j);
+  let (i1,i2) = subterms uf i
+  and (j1,j2) = subterms uf j in
+  pcongr (equal_proof uf i1 j1) (equal_proof uf i2 j2)
+    
+and ind_proof uf i ipac j jpac=
+   debug (str "ind_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ pr_idx_term uf j);
+  let p=equal_proof uf i j
+  and p1=constr_proof uf i ipac
+  and p2=constr_proof uf j jpac in
+  ptrans (psym p1) (ptrans p p2)
 
-  let axioms = axioms uf in
-
-  let rec equal_proof i j=
-    if i=j then prefl (term uf i) else
-      let (li,lj)=join_path uf i j in
-	ptrans (path_proof i li) (psym (path_proof j lj))
-
-  and edge_proof ((i,j),eq)=
-    let pi=equal_proof i eq.lhs in
-    let pj=psym (equal_proof j eq.rhs) in
-    let pij=
-      match eq.rule with
-	  Axiom (s,reversed)->
-	    if reversed then psymax axioms s
-	    else pax axioms s
-	| Congruence ->congr_proof eq.lhs eq.rhs
-	| Injection (ti,ipac,tj,jpac,k) ->
-	    let p=ind_proof ti ipac tj jpac in
-	    let cinfo= get_constructor_info uf ipac.cnode in
-	      pinject p cinfo.ci_constr cinfo.ci_nhyps k
-    in  ptrans (ptrans pi pij) pj
-
-  and constr_proof i t ipac=
-    if ipac.args=[] then
-      equal_proof i t
-    else
-      let npac=tail_pac ipac in
-      let (j,arg)=subterms uf t in
-      let targ=term uf arg in
-      let rj=find uf j in
-      let u=find_pac uf rj npac in
-      let p=constr_proof j u npac in
-	ptrans (equal_proof i t) (pcongr p (prefl targ))
-
-  and path_proof i=function
-      [] -> prefl (term uf i)
-    | x::q->ptrans (path_proof (snd (fst x)) q) (edge_proof x)
-
-  and congr_proof i j=
-    let (i1,i2) = subterms uf i
-    and (j1,j2) = subterms uf j in
-      pcongr (equal_proof i1 j1) (equal_proof i2 j2)
-
-  and ind_proof i ipac j jpac=
-    let p=equal_proof i j
-    and p1=constr_proof i i ipac
-    and p2=constr_proof j j jpac in
-      ptrans (psym p1) (ptrans p p2)
-  in
-    function
-	`Prove (i,j) -> equal_proof i j
-      | `Discr (i,ci,j,cj)-> ind_proof i ci j cj
+let build_proof uf=
+  function
+  | `Prove (i,j) -> equal_proof uf i j
+  | `Discr (i,ci,j,cj)-> ind_proof uf i ci j cj
 
 
 
diff --git a/plugins/cc/ccproof.mli b/plugins/cc/ccproof.mli
index d55d3ef7..0e0eb6d2 100644
--- a/plugins/cc/ccproof.mli
+++ b/plugins/cc/ccproof.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -16,14 +16,44 @@ type rule=
   | Refl of term
   | Trans of proof*proof
   | Congr of proof*proof
-  | Inject of proof*constructor*int*int
+  | Inject of proof*pconstructor*int*int
 and proof =
     private {p_lhs:term;p_rhs:term;p_rule:rule}
 
+(** Proof smart constructors *)
+
+val prefl:term -> proof
+
+val pcongr: proof -> proof -> proof
+
+val ptrans: proof -> proof -> proof
+
+val psym: proof -> proof
+
+val pax : (Ccalgo.term * Ccalgo.term) Ccalgo.Constrhash.t ->
+           Ccalgo.Constrhash.key -> proof
+
+val psymax :  (Ccalgo.term * Ccalgo.term) Ccalgo.Constrhash.t ->
+           Ccalgo.Constrhash.key -> proof
+
+val pinject :  proof -> pconstructor -> int -> int -> proof
+
+(** Proof building functions *)
+
+val equal_proof : forest -> int -> int -> proof
+
+val edge_proof : forest -> (int*int)*equality -> proof
+
+val path_proof : forest -> int -> ((int*int)*equality) list -> proof
+
+val congr_proof :  forest -> int -> int -> proof
+
+val ind_proof : forest -> int -> pa_constructor -> int -> pa_constructor -> proof
+
+(** Main proof building function *)
+
 val build_proof :
   forest ->
   [ `Discr of int * pa_constructor * int * pa_constructor
   | `Prove of int * int ] -> proof
 
-
-
diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml
index 60d42916..7110e5b2 100644
--- a/plugins/cc/cctac.ml
+++ b/plugins/cc/cctac.ml
@@ -1,49 +1,39 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i camlp4deps: "parsing/grammar.cma" i*)
-
 (* This file is the interface between the c-c algorithm and Coq *)
 
 open Evd
-open Proof_type
 open Names
-open Libnames
-open Nameops
 open Inductiveops
 open Declarations
 open Term
+open Vars
 open Tacmach
 open Tactics
-open Tacticals
 open Typing
 open Ccalgo
-open Tacinterp
 open Ccproof
 open Pp
+open Errors
 open Util
-open Format
-
-let constant dir s = lazy (Coqlib.gen_constant "CC" dir s)
-
-let _f_equal = constant ["Init";"Logic"] "f_equal"
-
-let _eq_rect = constant ["Init";"Logic"] "eq_rect"
-
-let _refl_equal = constant ["Init";"Logic"] "eq_refl"
 
-let _sym_eq = constant ["Init";"Logic"] "eq_sym"
+let reference dir s = Coqlib.gen_reference "CC" dir s
 
-let _trans_eq = constant ["Init";"Logic"] "eq_trans"
-
-let _eq = constant ["Init";"Logic"] "eq"
-
-let _False = constant ["Init";"Logic"] "False"
+let _f_equal = reference ["Init";"Logic"] "f_equal"
+let _eq_rect = reference ["Init";"Logic"] "eq_rect"
+let _refl_equal = reference ["Init";"Logic"] "eq_refl"
+let _sym_eq = reference ["Init";"Logic"] "eq_sym"
+let _trans_eq = reference ["Init";"Logic"] "eq_trans"
+let _eq = reference ["Init";"Logic"] "eq"
+let _False = reference ["Init";"Logic"] "False"
+let _True = reference ["Init";"Logic"] "True"
+let _I = reference ["Init";"Logic"] "I"
 
 let whd env=
   let infos=Closure.create_clos_infos Closure.betaiotazeta env in
@@ -55,7 +45,8 @@ let whd_delta env=
 
 (* decompose member of equality in an applicative format *)
 
-let sf_of env sigma c = family_of_sort (sort_of env sigma c)
+(** FIXME: evar leak *)
+let sf_of env sigma c = family_of_sort (sort_of env (ref sigma) c)
 
 let rec decompose_term env sigma t=
     match kind_of_term (whd env t) with
@@ -70,32 +61,37 @@ let rec decompose_term env sigma t=
 	Appli(Appli(Product (sort_a,sort_b) ,
 		    decompose_term env sigma a),
 	      decompose_term env sigma b)
-    | Construct c->
-	let (mind,i_ind),i_con = c in 
+    | Construct c ->
+	let (((mind,i_ind),i_con),u)= c in 
 	let canon_mind = mind_of_kn (canonical_mind mind) in
 	let canon_ind = canon_mind,i_ind in
 	let (oib,_)=Global.lookup_inductive (canon_ind) in
-	let nargs=mis_constructor_nargs_env env (canon_ind,i_con) in
-	  Constructor {ci_constr= (canon_ind,i_con);
+	let nargs=constructor_nallargs_env env (canon_ind,i_con) in
+	  Constructor {ci_constr= ((canon_ind,i_con),u);
 		       ci_arity=nargs;
 		       ci_nhyps=nargs-oib.mind_nparams}
     | Ind c -> 
-	let mind,i_ind = c in 
+	let (mind,i_ind),u = c in 
 	let canon_mind = mind_of_kn (canonical_mind mind) in
-	let canon_ind = canon_mind,i_ind in  (Symb (mkInd canon_ind))
-    | Const c -> 
+	let canon_ind = canon_mind,i_ind in  (Symb (mkIndU (canon_ind,u)))
+    | Const (c,u) -> 
 	let canon_const = constant_of_kn (canonical_con c) in 
-	  (Symb (mkConst canon_const))
+	  (Symb (mkConstU (canon_const,u)))
+    | Proj (p, c) -> 
+	let canon_const kn = constant_of_kn (canonical_con kn) in 
+	let p' = Projection.map canon_const p in
+	  (Appli (Symb (mkConst (Projection.constant p')), decompose_term env sigma c))
     | _ ->if closed0 t then (Symb t) else raise Not_found
 
 (* decompose equality in members and type *)
+open Globnames
 
 let atom_of_constr env sigma term =
   let wh =  (whd_delta env term) in
   let kot = kind_of_term wh in
     match kot with
       App (f,args)->
-	  if eq_constr f (Lazy.force _eq) && (Array.length args)=3
+	if is_global _eq f && Int.equal (Array.length args) 3
 	  then `Eq (args.(0),
 		   decompose_term env sigma args.(1),
 		   decompose_term env sigma args.(2))
@@ -107,9 +103,9 @@ let rec pattern_of_constr env sigma c =
       App (f,args)->
 	let pf = decompose_term env sigma f in
 	let pargs,lrels = List.split
-	  (array_map_to_list (pattern_of_constr env sigma) args) in
+	  (Array.map_to_list (pattern_of_constr env sigma) args) in
 	  PApp (pf,List.rev pargs),
-	List.fold_left Intset.union Intset.empty lrels
+	List.fold_left Int.Set.union Int.Set.empty lrels
     | Prod (_,a,_b) when not (Termops.dependent (mkRel 1) _b) ->
 	let b = Termops.pop _b in
 	let pa,sa = pattern_of_constr env sigma a in
@@ -117,11 +113,11 @@ let rec pattern_of_constr env sigma c =
 	let sort_b = sf_of env sigma b in
 	let sort_a = sf_of env sigma a in
 	  PApp(Product (sort_a,sort_b),
-	       [pa;pb]),(Intset.union sa sb)
-    | Rel i -> PVar i,Intset.singleton i
+	       [pa;pb]),(Int.Set.union sa sb)
+    | Rel i -> PVar i,Int.Set.singleton i
     | _ ->
 	let pf = decompose_term env sigma c in
-	  PApp (pf,[]),Intset.empty
+	  PApp (pf,[]),Int.Set.empty
 
 let non_trivial = function
     PVar _ -> false
@@ -129,23 +125,21 @@ let non_trivial = function
 
 let patterns_of_constr env sigma nrels term=
   let f,args=
-    try destApp (whd_delta env term)
-    with e when Errors.noncritical e -> raise Not_found
-  in
-	if eq_constr f (Lazy.force _eq) && (Array.length args)=3
+    try destApp (whd_delta env term) with DestKO -> raise Not_found in
+	if is_global _eq f && Int.equal (Array.length args) 3
 	then
 	  let patt1,rels1 = pattern_of_constr env sigma args.(1)
 	  and patt2,rels2 = pattern_of_constr env sigma args.(2) in
 	  let valid1 =
-	    if Intset.cardinal rels1 <> nrels then Creates_variables
+	    if not (Int.equal (Int.Set.cardinal rels1) nrels) then Creates_variables
 	    else if non_trivial patt1 then Normal
 	    else Trivial args.(0)
 	  and valid2 =
-	    if Intset.cardinal rels2 <> nrels then Creates_variables
+	    if not (Int.equal (Int.Set.cardinal rels2) nrels) then Creates_variables
 	    else if non_trivial patt2 then Normal
 	    else Trivial args.(0) in
-	    if valid1 <> Creates_variables
-	      || valid2 <> Creates_variables  then
+	    if valid1 != Creates_variables
+	      || valid2 != Creates_variables  then
 	      nrels,valid1,patt1,valid2,patt2
 	    else raise Not_found
 	else raise Not_found
@@ -153,7 +147,7 @@ let patterns_of_constr env sigma nrels term=
 let rec quantified_atom_of_constr env sigma nrels term =
   match kind_of_term (whd_delta env term) with
       Prod (id,atom,ff) -> 
-	if eq_constr ff (Lazy.force _False) then
+	if is_global _False ff then
 	  let patts=patterns_of_constr env sigma nrels atom in
 	      `Nrule patts
 	else 
@@ -165,7 +159,7 @@ let rec quantified_atom_of_constr env sigma nrels term =
 let litteral_of_constr env sigma term=
   match kind_of_term (whd_delta env term) with
     | Prod (id,atom,ff) -> 
-	if eq_constr ff (Lazy.force _False) then
+	if is_global _False ff then
 	  match (atom_of_constr env sigma atom) with
 	      `Eq(t,a,b) -> `Neq(t,a,b)
 	    | `Other(p) -> `Nother(p)
@@ -182,7 +176,7 @@ let litteral_of_constr env sigma term=
 
 (* store all equalities from the context *)
 
-let rec make_prb gls depth additionnal_terms =
+let make_prb gls depth additionnal_terms =
   let env=pf_env gls in
   let sigma=sig_sig gls in
   let state = empty depth gls in
@@ -213,9 +207,9 @@ let rec make_prb gls depth additionnal_terms =
 		 neg_hyps:=(cid,nh):: !neg_hyps
 	     | `Rule patts -> add_quant state id true patts
 	     | `Nrule patts -> add_quant state id false patts
-	 end) (Environ.named_context_of_val (Goal.V82.hyps gls.sigma gls.it));
+	 end) (Environ.named_context_of_val (Goal.V82.nf_hyps gls.sigma gls.it));
     begin
-      match atom_of_constr env sigma (pf_concl gls) with
+      match atom_of_constr env sigma (Evarutil.nf_evar sigma (pf_concl gls)) with
 	  `Eq (t,a,b) -> add_disequality state Goal a b
 	|	`Other g ->
 		  List.iter
@@ -226,226 +220,256 @@ let rec make_prb gls depth additionnal_terms =
 
 (* indhyps builds the array of arrays of constructor hyps for (ind largs) *)
 
-let build_projection intype outtype (cstr:constructor) special default gls=
+let build_projection intype outtype (cstr:pconstructor) special default gls=
   let env=pf_env gls in
-  let (h,argv) =
-    try destApp intype with
-	Invalid_argument _ -> (intype,[||])  in
-  let ind=destInd h in
-  let types=Inductiveops.arities_of_constructors env ind in
+  let (h,argv) = try destApp intype with DestKO -> (intype,[||]) in
+  let ind,u=destInd h in
+  let types=Inductiveops.arities_of_constructors env (ind,u) in
   let lp=Array.length types in
-  let ci=pred (snd cstr) in
+  let ci=pred (snd(fst cstr)) in
   let branch i=
-    let ti=Term.prod_appvect types.(i) argv in
+    let ti= prod_appvect types.(i) argv in
     let rc=fst (decompose_prod_assum ti) in
     let head=
-      if i=ci then special else default in
+      if Int.equal i ci then special else default in
       it_mkLambda_or_LetIn head rc in
   let branches=Array.init lp branch in
   let casee=mkRel 1 in
   let pred=mkLambda(Anonymous,intype,outtype) in
   let case_info=make_case_info (pf_env gls) ind RegularStyle in
   let body= mkCase(case_info, pred, casee, branches) in
-  let id=pf_get_new_id (id_of_string "t") gls in
+  let id=pf_get_new_id (Id.of_string "t") gls in
     mkLambda(Name id,intype,body)
 
 (* generate an adhoc tactic following the proof tree  *)
 
 let _M =mkMeta
 
-let rec proof_tac p gls =
+let app_global f args k = 
+  Tacticals.pf_constr_of_global f (fun fc -> k (mkApp (fc, args)))
+
+let new_app_global f args k = 
+  Tacticals.New.pf_constr_of_global f (fun fc -> k (mkApp (fc, args)))
+
+let new_refine c = Proofview.V82.tactic (refine c)
+
+let rec proof_tac p : unit Proofview.tactic =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let type_of t = Tacmach.New.pf_type_of gl t in
+  try (* type_of can raise exceptions *)
   match p.p_rule with
-      Ax c -> exact_check c gls
+      Ax c -> exact_check c
     | SymAx c ->
 	let l=constr_of_term p.p_lhs and
 	    r=constr_of_term p.p_rhs in
-        let typ = Termops.refresh_universes (pf_type_of gls l) in
-	  exact_check
-	    (mkApp(Lazy.force _sym_eq,[|typ;r;l;c|])) gls
+        let typ = (* Termops.refresh_universes *) type_of l in
+        new_app_global _sym_eq [|typ;r;l;c|] exact_check
     | Refl t ->
 	let lr = constr_of_term t in
-	let typ = Termops.refresh_universes (pf_type_of gls lr) in
-	exact_check
-	   (mkApp(Lazy.force _refl_equal,[|typ;constr_of_term t|])) gls
+	let typ = (* Termops.refresh_universes *) type_of lr in
+        new_app_global _refl_equal [|typ;constr_of_term t|] exact_check
     | Trans (p1,p2)->
 	let t1 = constr_of_term p1.p_lhs and
 	    t2 = constr_of_term p1.p_rhs and
 	    t3 = constr_of_term p2.p_rhs in
-	let typ = Termops.refresh_universes (pf_type_of gls t2) in
-	let prf =
-	  mkApp(Lazy.force _trans_eq,[|typ;t1;t2;t3;_M 1;_M 2|]) in
-	  tclTHENS (refine prf) [(proof_tac p1);(proof_tac p2)] gls
+	let typ = (* Termops.refresh_universes *) (type_of t2) in
+	let prf = new_app_global _trans_eq [|typ;t1;t2;t3;_M 1;_M 2|] in
+          Tacticals.New.tclTHENS (prf new_refine) [(proof_tac p1);(proof_tac p2)]
     | Congr (p1,p2)->
 	let tf1=constr_of_term p1.p_lhs
 	and tx1=constr_of_term p2.p_lhs
 	and tf2=constr_of_term p1.p_rhs
 	and tx2=constr_of_term p2.p_rhs in
-	let typf = Termops.refresh_universes (pf_type_of gls tf1) in
-	let typx = Termops.refresh_universes (pf_type_of gls tx1) in
-	let typfx = Termops.refresh_universes (pf_type_of gls (mkApp (tf1,[|tx1|]))) in
-	let id = pf_get_new_id (id_of_string "f") gls in
+	let typf = (* Termops.refresh_universes  *)(type_of tf1) in
+	let typx = (* Termops.refresh_universes *) (type_of tx1) in
+	let typfx = (* Termops.refresh_universes *) (type_of (mkApp (tf1,[|tx1|]))) in
+        let id = Tacmach.New.of_old (fun gls -> pf_get_new_id (Id.of_string "f") gls) gl in
 	let appx1 = mkLambda(Name id,typf,mkApp(mkRel 1,[|tx1|])) in
 	let lemma1 =
-	  mkApp(Lazy.force _f_equal,
-		[|typf;typfx;appx1;tf1;tf2;_M 1|]) in
+	  app_global _f_equal
+		[|typf;typfx;appx1;tf1;tf2;_M 1|] in
 	let lemma2=
-	  mkApp(Lazy.force _f_equal,
-		[|typx;typfx;tf2;tx1;tx2;_M 1|]) in
+	  app_global _f_equal
+		[|typx;typfx;tf2;tx1;tx2;_M 1|] in
 	let prf =
-	  mkApp(Lazy.force _trans_eq,
+	  app_global _trans_eq
 		[|typfx;
 		  mkApp(tf1,[|tx1|]);
 		  mkApp(tf2,[|tx1|]);
-		  mkApp(tf2,[|tx2|]);_M 2;_M 3|]) in
-	  tclTHENS (refine prf)
-	    [tclTHEN (refine lemma1) (proof_tac p1);
-  	     tclFIRST
-	       [tclTHEN (refine lemma2) (proof_tac p2);
+		  mkApp(tf2,[|tx2|]);_M 2;_M 3|] in
+	  Tacticals.New.tclTHENS (Proofview.V82.tactic (prf refine))
+	    [Tacticals.New.tclTHEN (Proofview.V82.tactic (lemma1 refine)) (proof_tac p1);
+  	     Tacticals.New.tclFIRST
+	       [Tacticals.New.tclTHEN (Proofview.V82.tactic (lemma2 refine)) (proof_tac p2);
 		reflexivity;
-		fun gls ->
-		  errorlabstrm  "Congruence"
+                Proofview.tclZERO (UserError ("Congruence" ,
 		    (Pp.str
-		       "I don't know how to handle dependent equality")]] gls
+		       "I don't know how to handle dependent equality")))]]
   | Inject (prf,cstr,nargs,argind) ->
 	 let ti=constr_of_term prf.p_lhs in
 	 let tj=constr_of_term prf.p_rhs in
 	 let default=constr_of_term p.p_lhs in
-	 let intype = Termops.refresh_universes (pf_type_of gls ti) in
-	 let outtype = Termops.refresh_universes (pf_type_of gls default) in
+	 let intype = (* Termops.refresh_universes *) (type_of ti) in
+	 let outtype = (* Termops.refresh_universes *) (type_of default) in
 	 let special=mkRel (1+nargs-argind) in
-	 let proj=build_projection intype outtype cstr special default gls in
+         let proj =
+           Tacmach.New.of_old (build_projection intype outtype cstr special default) gl
+         in
 	 let injt=
-	   mkApp (Lazy.force _f_equal,[|intype;outtype;proj;ti;tj;_M 1|]) in
-	   tclTHEN (refine injt) (proof_tac prf) gls
+           app_global _f_equal [|intype;outtype;proj;ti;tj;_M 1|] in
+	   Tacticals.New.tclTHEN (Proofview.V82.tactic (injt refine)) (proof_tac prf)
+  with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e
+  end
 
-let refute_tac c t1 t2 p gls =
+let refute_tac c t1 t2 p =
+  Proofview.Goal.nf_enter begin fun gl ->
   let tt1=constr_of_term t1 and tt2=constr_of_term t2 in
-  let intype = Termops.refresh_universes (pf_type_of gls tt1) in
-  let neweq=
-    mkApp(Lazy.force _eq,
-	  [|intype;tt1;tt2|]) in
-  let hid=pf_get_new_id (id_of_string "Heq") gls in
+  let intype =
+    Tacmach.New.of_old (fun gls -> (* Termops.refresh_universes *) (pf_type_of gls tt1)) gl
+  in
+  let neweq= new_app_global _eq [|intype;tt1;tt2|] in
+  let hid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "Heq")) gl in
   let false_t=mkApp (c,[|mkVar hid|]) in
-    tclTHENS (assert_tac (Name hid) neweq)
-      [proof_tac p; simplest_elim false_t] gls
+    Tacticals.New.tclTHENS (neweq (assert_before (Name hid)))
+      [proof_tac p; simplest_elim false_t]
+  end
 
-let convert_to_goal_tac c t1 t2 p gls =
+let refine_exact_check c gl =
+  let evm, _ = pf_apply e_type_of gl c in
+    Tacticals.tclTHEN (Refiner.tclEVARS evm) (Proofview.V82.of_tactic (exact_check c)) gl
+
+let convert_to_goal_tac c t1 t2 p = 
+  Proofview.Goal.nf_enter begin fun gl ->
   let tt1=constr_of_term t1 and tt2=constr_of_term t2 in
-  let sort = Termops.refresh_universes (pf_type_of gls tt2) in
-  let neweq=mkApp(Lazy.force _eq,[|sort;tt1;tt2|]) in
-  let e=pf_get_new_id (id_of_string "e") gls in
-  let x=pf_get_new_id (id_of_string "X") gls in
+  let sort =
+    Tacmach.New.of_old (fun gls -> (* Termops.refresh_universes *) (pf_type_of gls tt2)) gl
+  in
+  let neweq= new_app_global _eq [|sort;tt1;tt2|] in
+  let e = Tacmach.New.of_old (pf_get_new_id (Id.of_string "e")) gl in
+  let x = Tacmach.New.of_old (pf_get_new_id (Id.of_string "X")) gl in
   let identity=mkLambda (Name x,sort,mkRel 1) in
-  let endt=mkApp (Lazy.force _eq_rect,
-		  [|sort;tt1;identity;c;tt2;mkVar e|]) in
-    tclTHENS (assert_tac (Name e) neweq)
-      [proof_tac p;exact_check endt] gls
+  let endt=app_global _eq_rect [|sort;tt1;identity;c;tt2;mkVar e|] in
+    Tacticals.New.tclTHENS (neweq (assert_before (Name e)))
+      [proof_tac p; Proofview.V82.tactic (endt refine_exact_check)]
+  end
 
-let convert_to_hyp_tac c1 t1 c2 t2 p gls =
+let convert_to_hyp_tac c1 t1 c2 t2 p =
+  Proofview.Goal.nf_enter begin fun gl ->
   let tt2=constr_of_term t2 in
-  let h=pf_get_new_id (id_of_string "H") gls in
+  let h = Tacmach.New.of_old (pf_get_new_id (Id.of_string "H")) gl in
   let false_t=mkApp (c2,[|mkVar h|]) in
-    tclTHENS (assert_tac (Name h) tt2)
+    Tacticals.New.tclTHENS (assert_before (Name h) tt2)
       [convert_to_goal_tac c1 t1 t2 p;
-       simplest_elim false_t] gls
-
-let discriminate_tac cstr p gls =
-  let t1=constr_of_term p.p_lhs and t2=constr_of_term p.p_rhs in
-  let intype = Termops.refresh_universes (pf_type_of gls t1) in
-  let concl=pf_concl gls in
-  let outsort = mkType (Termops.new_univ ()) in
-  let xid=pf_get_new_id (id_of_string "X") gls in
-  let tid=pf_get_new_id (id_of_string "t") gls in
-  let identity=mkLambda(Name xid,outsort,mkLambda(Name tid,mkRel 1,mkRel 1)) in
-  let trivial=pf_type_of gls identity in
-  let outtype = mkType (Termops.new_univ ()) in
-  let pred=mkLambda(Name xid,outtype,mkRel 1) in
-  let hid=pf_get_new_id (id_of_string "Heq") gls in
-  let proj=build_projection intype outtype cstr trivial concl gls in
-  let injt=mkApp (Lazy.force _f_equal,
-		  [|intype;outtype;proj;t1;t2;mkVar hid|]) in
-  let endt=mkApp (Lazy.force _eq_rect,
-		  [|outtype;trivial;pred;identity;concl;injt|]) in
-  let neweq=mkApp(Lazy.force _eq,[|intype;t1;t2|]) in
-    tclTHENS (assert_tac (Name hid) neweq)
-      [proof_tac p;exact_check endt] gls
+       simplest_elim false_t]
+  end
+
+let discriminate_tac (cstr,u as cstru) p =
+  Proofview.Goal.nf_enter begin fun gl ->
+    let t1=constr_of_term p.p_lhs and t2=constr_of_term p.p_rhs in
+    let intype =
+      Tacmach.New.of_old (fun gls -> (* Termops.refresh_universes *) (pf_type_of gls t1)) gl
+    in
+    let concl = Proofview.Goal.concl gl in
+    (* let evm,outsort = Evd.new_sort_variable Evd.univ_rigid (project gls) in  *)
+    (* let outsort = mkSort outsort in *)
+    let xid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "X")) gl in
+    (* let tid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "t")) gl in *)
+    (* let identity=mkLambda(Name xid,outsort,mkLambda(Name tid,mkRel 1,mkRel 1)) in *)
+    let identity = Universes.constr_of_global _I in
+    (* let trivial=pf_type_of gls identity in *)
+    let trivial = Universes.constr_of_global _True in
+    let evm, outtype = Evd.new_sort_variable Evd.univ_flexible (Proofview.Goal.sigma gl) in 
+    let outtype = mkSort outtype in
+    let pred=mkLambda(Name xid,outtype,mkRel 1) in
+    let hid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "Heq")) gl in
+    let proj = Tacmach.New.of_old (build_projection intype outtype cstru trivial concl) gl in
+    let injt=app_global _f_equal
+                    [|intype;outtype;proj;t1;t2;mkVar hid|] in
+    let endt k =
+      injt (fun injt ->
+        app_global _eq_rect
+          [|outtype;trivial;pred;identity;concl;injt|] k) in
+    let neweq=new_app_global _eq [|intype;t1;t2|] in
+    Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS evm)
+      (Tacticals.New.tclTHENS (neweq (assert_before (Name hid)))
+        [proof_tac p; Proofview.V82.tactic (endt refine_exact_check)])
+  end
 
 (* wrap everything *)
 
 let build_term_to_complete uf meta pac =
   let cinfo = get_constructor_info uf pac.cnode in
   let real_args = List.map (fun i -> constr_of_term (term uf i)) pac.args in
-  let dummy_args = List.rev (list_tabulate meta pac.arity) in
+  let dummy_args = List.rev (List.init pac.arity meta) in
   let all_args = List.rev_append real_args dummy_args in
-    applistc (mkConstruct cinfo.ci_constr) all_args
-
-let cc_tactic depth additionnal_terms gls=
-  Coqlib.check_required_library ["Coq";"Init";"Logic"];
-  let _ = debug Pp.msgnl (Pp.str "Reading subgoal ...") in
-  let state = make_prb gls depth additionnal_terms in
-  let _ = debug Pp.msgnl (Pp.str "Problem built, solving ...") in
-  let sol = execute true state in
-  let _ = debug Pp.msgnl (Pp.str "Computation completed.") in
-  let uf=forest state in
+    applistc (mkConstructU cinfo.ci_constr) all_args
+
+let cc_tactic depth additionnal_terms =
+  Proofview.Goal.nf_enter begin fun gl ->
+    Coqlib.check_required_library Coqlib.logic_module_name;
+    let _ = debug (Pp.str "Reading subgoal ...") in
+    let state = Tacmach.New.of_old (fun gls -> make_prb gls depth additionnal_terms) gl in
+    let _ = debug (Pp.str "Problem built, solving ...") in
+    let sol = execute true state in
+    let _ = debug (Pp.str "Computation completed.") in
+    let uf=forest state in
     match sol with
-	None -> tclFAIL 0 (str "congruence failed") gls
-      | Some reason ->
-	  debug Pp.msgnl (Pp.str "Goal solved, generating proof ...");
-	  match reason with
-	      Discrimination (i,ipac,j,jpac) ->
-		let p=build_proof uf (`Discr (i,ipac,j,jpac)) in
-		let cstr=(get_constructor_info uf ipac.cnode).ci_constr in
-		  discriminate_tac cstr p gls
-	    | Incomplete ->
-		let metacnt = ref 0 in
-		let newmeta _ = incr metacnt; _M !metacnt in
-		let terms_to_complete =
-		  List.map
-		    (build_term_to_complete uf newmeta)
-		    (epsilons uf) in
-		  Pp.msgnl
-		    (Pp.str "Goal is solvable by congruence but \
+      None -> Tacticals.New.tclFAIL 0 (str "congruence failed")
+    | Some reason ->
+	debug (Pp.str "Goal solved, generating proof ...");
+	match reason with
+	  Discrimination (i,ipac,j,jpac) ->
+	    let p=build_proof uf (`Discr (i,ipac,j,jpac)) in
+	    let cstr=(get_constructor_info uf ipac.cnode).ci_constr in
+	    discriminate_tac cstr p
+	| Incomplete ->
+            let env = Proofview.Goal.env gl in
+	    let metacnt = ref 0 in
+	    let newmeta _ = incr metacnt; _M !metacnt in
+	    let terms_to_complete =
+	      List.map
+		(build_term_to_complete uf newmeta)
+		(epsilons uf) in
+	    Pp.msg_info
+	      (Pp.str "Goal is solvable by congruence but \
  some arguments are missing.");
-		  Pp.msgnl
-		    (Pp.str "  Try " ++
-		     hov 8
-		       begin
-			 str "\"congruence with (" ++
-			 prlist_with_sep
-			   (fun () -> str ")" ++ pr_spc () ++ str "(")
-			   (Termops.print_constr_env (pf_env gls))
-			   terms_to_complete ++
-			 str ")\","
-		       end);
-		  Pp.msgnl
-		    (Pp.str "  replacing metavariables by arbitrary terms.");
-		  tclFAIL 0 (str "Incomplete") gls
-	    | Contradiction dis ->
-		let p=build_proof uf (`Prove (dis.lhs,dis.rhs)) in
-		let ta=term uf dis.lhs and tb=term uf dis.rhs in
-		  match dis.rule with
-		      Goal -> proof_tac p gls
-		    | Hyp id -> refute_tac id ta tb p gls
-		    | HeqG id ->
-			convert_to_goal_tac id ta tb p gls
-		    | HeqnH (ida,idb) ->
-			convert_to_hyp_tac ida ta idb tb p gls
-
+	    Pp.msg_info
+	      (Pp.str "  Try " ++
+		 hov 8
+		 begin
+		   str "\"congruence with (" ++
+		     prlist_with_sep
+		     (fun () -> str ")" ++ spc () ++ str "(")
+		     (Termops.print_constr_env env)
+		     terms_to_complete ++
+		     str ")\","
+		 end ++
+		 Pp.str "  replacing metavariables by arbitrary terms.");
+	    Tacticals.New.tclFAIL 0 (str "Incomplete")
+	| Contradiction dis ->
+	    let p=build_proof uf (`Prove (dis.lhs,dis.rhs)) in
+	    let ta=term uf dis.lhs and tb=term uf dis.rhs in
+	    match dis.rule with
+	      Goal -> proof_tac p
+	    | Hyp id -> refute_tac id ta tb p
+	    | HeqG id ->
+		convert_to_goal_tac id ta tb p
+	    | HeqnH (ida,idb) ->
+		convert_to_hyp_tac ida ta idb tb p
+  end
 
 let cc_fail gls =
   errorlabstrm  "Congruence" (Pp.str "congruence failed.")
 
 let congruence_tac depth l =
-  tclORELSE
-    (tclTHEN (tclREPEAT introf) (cc_tactic depth l))
-    cc_fail
+  Tacticals.New.tclORELSE
+    (Tacticals.New.tclTHEN (Tacticals.New.tclREPEAT introf) (cc_tactic depth l))
+    (Proofview.V82.tactic cc_fail)
 
 (* Beware: reflexivity = constructor 1 = apply refl_equal
    might be slow now, let's rather do something equivalent
    to a "simple apply refl_equal" *)
 
-let simple_reflexivity () = apply (Lazy.force _refl_equal)
-
 (* The [f_equal] tactic.
 
    It mimics the use of lemmas [f_equal], [f_equal2], etc.
@@ -453,22 +477,35 @@ let simple_reflexivity () = apply (Lazy.force _refl_equal)
    the fact that congruence is called internally.
 *)
 
-let f_equal gl =
-  let cut_eq c1 c2 =
-    let ty = Termops.refresh_universes (pf_type_of gl c1) in
-    tclTHENTRY
-      (Tactics.cut (mkApp (Lazy.force _eq, [|ty; c1; c2|])))
-      (simple_reflexivity ())
-  in
-  try match kind_of_term (pf_concl gl) with
-    | App (r,[|_;t;t'|]) when eq_constr r (Lazy.force _eq) ->
-	begin match kind_of_term t, kind_of_term t' with
-	  | App (f,v), App (f',v') when Array.length v = Array.length v' ->
+let f_equal =
+  Proofview.Goal.nf_enter begin fun gl ->
+    let concl = Proofview.Goal.concl gl in
+    let type_of = Tacmach.New.pf_type_of gl in
+    let cut_eq c1 c2 =
+      try (* type_of can raise an exception *)
+        let ty = (* Termops.refresh_universes *) (type_of c1) in
+        if eq_constr_nounivs c1 c2 then Proofview.tclUNIT ()
+        else
+          Tacticals.New.tclTRY (Tacticals.New.tclTHEN
+          ((new_app_global _eq [|ty; c1; c2|]) Tactics.cut)
+          (Tacticals.New.tclTRY ((new_app_global _refl_equal [||]) apply)))
+      with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e
+    in
+    Proofview.tclORELSE
+      begin match kind_of_term concl with
+      | App (r,[|_;t;t'|]) when Globnames.is_global _eq r ->
+	  begin match kind_of_term t, kind_of_term t' with
+	  | App (f,v), App (f',v') when Int.equal (Array.length v) (Array.length v') ->
 	      let rec cuts i =
-		if i < 0 then tclTRY (congruence_tac 1000 [])
-		else tclTHENFIRST (cut_eq v.(i) v'.(i)) (cuts (i-1))
-	      in cuts (Array.length v - 1) gl
-	  | _ -> tclIDTAC gl
-	end
-    | _ -> tclIDTAC gl
-  with Type_errors.TypeError _ -> tclIDTAC gl
+		if i < 0 then Tacticals.New.tclTRY (congruence_tac 1000 [])
+		else Tacticals.New.tclTHENFIRST (cut_eq v.(i) v'.(i)) (cuts (i-1))
+	      in cuts (Array.length v - 1)
+	  | _ -> Proofview.tclUNIT ()
+	  end
+      | _ -> Proofview.tclUNIT ()
+      end
+      begin function (e, info) -> match e with
+        | Type_errors.TypeError _ -> Proofview.tclUNIT ()
+        | e -> Proofview.tclZERO ~info e
+      end
+  end
diff --git a/plugins/cc/cctac.mli b/plugins/cc/cctac.mli
index 60a1b2ec..7c1d9f1c 100644
--- a/plugins/cc/cctac.mli
+++ b/plugins/cc/cctac.mli
@@ -1,6 +1,7 @@
+
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -9,12 +10,12 @@
 open Term
 open Proof_type
 
-val proof_tac: Ccproof.proof -> Proof_type.tactic
+val proof_tac: Ccproof.proof -> unit Proofview.tactic
 
-val cc_tactic : int -> constr list -> tactic
+val cc_tactic : int -> constr list ->  unit Proofview.tactic
 
 val cc_fail : tactic
 
-val congruence_tac : int -> constr list -> tactic
+val congruence_tac : int -> constr list -> unit Proofview.tactic
 
-val f_equal : tactic
+val f_equal : unit Proofview.tactic
diff --git a/plugins/cc/g_congruence.ml4 b/plugins/cc/g_congruence.ml4
index 8b3fe770..aa31c6f0 100644
--- a/plugins/cc/g_congruence.ml4
+++ b/plugins/cc/g_congruence.ml4
@@ -1,16 +1,16 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i camlp4deps: "parsing/grammar.cma" i*)
+(*i camlp4deps: "grammar/grammar.cma" i*)
 
 open Cctac
-open Tactics
-open Tacticals
+
+DECLARE PLUGIN "cc_plugin"
 
 (* Tactic registration *)
 
diff --git a/plugins/decl_mode/decl_expr.mli b/plugins/decl_mode/decl_expr.mli
index 86b5e95b..7467604a 100644
--- a/plugins/decl_mode/decl_expr.mli
+++ b/plugins/decl_mode/decl_expr.mli
@@ -1,22 +1,21 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
 open Names
-open Util
 open Tacexpr
 
 type 'it statement =
-    {st_label:name;
+    {st_label:Name.t;
      st_it:'it}
 
 type thesis_kind =
     Plain
-  | For of identifier
+  | For of Id.t
 
 type 'this or_thesis =
     This of 'this
@@ -60,8 +59,8 @@ type ('hyp,'constr,'pat,'tac) bare_proof_instr =
   | Pconsider of 'constr*('hyp,'constr) hyp list
   | Pclaim of 'constr statement
   | Pfocus of 'constr statement
-  | Pdefine of identifier * 'hyp list * 'constr
-  | Pcast of identifier or_thesis * 'constr
+  | Pdefine of Id.t * 'hyp list * 'constr
+  | Pcast of Id.t or_thesis * 'constr
   | Psuppose of ('hyp,'constr) hyp list
   | Pcase of 'hyp list*'pat*(('hyp,'constr or_thesis) hyp list)
   | Ptake of 'constr list
@@ -77,15 +76,15 @@ type ('hyp,'constr,'pat,'tac) gen_proof_instr=
 
 
 type raw_proof_instr =
-    ((identifier*(Topconstr.constr_expr option)) located,
-     Topconstr.constr_expr,
-     Topconstr.cases_pattern_expr,
+    ((Id.t*(Constrexpr.constr_expr option)) Loc.located,
+     Constrexpr.constr_expr,
+     Constrexpr.cases_pattern_expr,
      raw_tactic_expr) gen_proof_instr
 
 type glob_proof_instr =
-    ((identifier*(Genarg.glob_constr_and_expr option)) located,
-     Genarg.glob_constr_and_expr,
-     Topconstr.cases_pattern_expr,
+    ((Id.t*(Tacexpr.glob_constr_and_expr option)) Loc.located,
+     Tacexpr.glob_constr_and_expr,
+     Constrexpr.cases_pattern_expr,
      Tacexpr.glob_tactic_expr) gen_proof_instr
 
 type proof_pattern =
@@ -94,7 +93,7 @@ type proof_pattern =
      pat_constr: Term.constr;
      pat_typ: Term.types;
      pat_pat: Glob_term.cases_pattern;
-     pat_expr: Topconstr.cases_pattern_expr}
+     pat_expr: Constrexpr.cases_pattern_expr}
 
 type proof_instr =
     (Term.constr statement,
diff --git a/plugins/decl_mode/decl_interp.ml b/plugins/decl_mode/decl_interp.ml
index 60988dd1..1c56586c 100644
--- a/plugins/decl_mode/decl_interp.ml
+++ b/plugins/decl_mode/decl_interp.ml
@@ -1,27 +1,29 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+open Errors
 open Util
 open Names
-open Topconstr
-open Tacinterp
-open Tacmach
+open Constrexpr
+open Tacintern
 open Decl_expr
 open Decl_mode
-open Pretyping.Default
+open Pretyping
 open Glob_term
 open Term
+open Vars
 open Pp
-open Compat
+open Decl_kinds
+open Misctypes
 
 (* INTERN *)
 
-let glob_app (loc,hd,args) = if args =[] then hd else GApp(loc,hd,args)
+let glob_app (loc,hd,args) = if List.is_empty args then hd else GApp(loc,hd,args)
 
 let intern_justification_items globs =
   Option.map (List.map (intern_constr globs))
@@ -41,8 +43,7 @@ let intern_constr_or_thesis globs = function
   | This c -> This (intern_constr globs c)
 
 let add_var id globs=
-  let l1,l2=globs.ltacvars in
-    {globs with ltacvars= (id::l1),(id::l2)}
+    {globs with ltacvars = Id.Set.add id globs.ltacvars}
 
 let add_name nam globs=
  match nam with
@@ -56,7 +57,7 @@ let intern_hyp iconstr globs = function
       Hprop (intern_statement iconstr globs st)
 
 let intern_hyps iconstr globs hyps =
-  snd (list_fold_map (intern_hyp iconstr) globs hyps)
+  snd (List.fold_map (intern_hyp iconstr) globs hyps)
 
 let intern_cut intern_it globs cut=
   let nglobs,nstat=intern_it globs cut.cut_stat in
@@ -73,10 +74,10 @@ let intern_hyp_list args globs =
   let intern_one globs (loc,(id,opttyp)) =
     (add_var id globs),
     (loc,(id,Option.map (intern_constr globs) opttyp)) in
-  list_fold_map intern_one globs args
+  List.fold_map intern_one globs args
 
 let intern_suffices_clause globs (hyps,c) =
-  let nglobs,nhyps = list_fold_map (intern_hyp intern_constr) globs hyps in
+  let nglobs,nhyps = List.fold_map (intern_hyp intern_constr) globs hyps in
     nglobs,(nhyps,intern_constr_or_thesis nglobs c)
 
 let intern_fundecl args body globs=
@@ -93,10 +94,11 @@ let rec add_vars_of_simple_pattern globs = function
 	(UserError ("simple_pattern",str "\"(_ | _)\" is not allowed here"))
   | CPatDelimiters (_,_,p) ->
       add_vars_of_simple_pattern globs p
-  | CPatCstr (_,_,pl) | CPatCstrExpl (_,_,pl) ->
-      List.fold_left add_vars_of_simple_pattern globs pl
-  | CPatNotation(_,_,(pl,pll)) ->
-      List.fold_left add_vars_of_simple_pattern globs (List.flatten (pl::pll))
+  | CPatCstr (_,_,pl1,pl2) ->
+    List.fold_left add_vars_of_simple_pattern
+      (List.fold_left add_vars_of_simple_pattern globs pl1) pl2
+  | CPatNotation(_,_,(pl,pll),pl') ->
+      List.fold_left add_vars_of_simple_pattern globs (List.flatten (pl::pl'::pll))
   | CPatAtom (_,Some (Libnames.Ident (_,id))) -> add_var id globs
   |  _  -> globs
 
@@ -135,33 +137,33 @@ let rec intern_bare_proof_instr globs = function
   | Pcast (id,typ) ->
       Pcast (id,intern_constr globs typ)
 
-let rec intern_proof_instr globs instr=
+let intern_proof_instr globs instr=
   {emph = instr.emph;
    instr = intern_bare_proof_instr globs instr.instr}
 
 (* INTERP *)
 
-let interp_justification_items sigma env =
-    Option.map (List.map (fun c ->understand sigma env (fst c)))
+let interp_justification_items env sigma =
+    Option.map (List.map (fun c -> fst (*FIXME*)(understand env sigma (fst c))))
 
-let interp_constr check_sort sigma env c =
+let interp_constr check_sort env sigma c =
   if check_sort then
-    understand_type sigma env (fst c)
+    fst (understand env sigma ~expected_type:IsType (fst c) (* FIXME *))
   else
-    understand sigma env (fst c)
+    fst (understand env sigma (fst c))
 
 let special_whd env =
   let infos=Closure.create_clos_infos Closure.betadeltaiota env in
     (fun t -> Closure.whd_val infos (Closure.inject t))
 
-let _eq = Libnames.constr_of_global (Coqlib.glob_eq)
+let _eq = lazy (Universes.constr_of_global (Coqlib.glob_eq))
 
 let decompose_eq env id =
   let typ = Environ.named_type id env in
   let whd = special_whd env typ in
     match kind_of_term whd with
 	App (f,args)->
-	  if eq_constr f _eq && (Array.length args)=3
+	  if eq_constr f (Lazy.force _eq) && Int.equal (Array.length args) 3
 	  then args.(0)
 	  else error "Previous step is not an equality."
       | _ -> error "Previous step is not an equality."
@@ -170,30 +172,30 @@ let get_eq_typ info env =
   let typ = decompose_eq env (get_last env) in
     typ
 
-let interp_constr_in_type typ sigma env c =
-  understand sigma env (fst c) ~expected_type:typ
+let interp_constr_in_type typ env sigma c =
+  fst (understand env sigma (fst c) ~expected_type:(OfType typ))(*FIXME*)
 
-let interp_statement interp_it sigma env st =
+let interp_statement interp_it env sigma st =
   {st_label=st.st_label;
-   st_it=interp_it sigma env st.st_it}
+   st_it=interp_it env sigma st.st_it}
 
-let interp_constr_or_thesis check_sort sigma env = function
+let interp_constr_or_thesis check_sort env sigma = function
     Thesis n -> Thesis n
-  | This c -> This (interp_constr check_sort sigma env c)
+  | This c -> This (interp_constr check_sort env sigma c)
 
 let abstract_one_hyp inject h glob =
   match h with
       Hvar (loc,(id,None)) ->
-	GProd (dummy_loc,Name id, Explicit, GHole (loc,Evd.BinderType (Name id)), glob)
+	GProd (Loc.ghost,Name id, Explicit, GHole (loc,Evar_kinds.BinderType (Name id), Misctypes.IntroAnonymous, None), glob)
     | Hvar (loc,(id,Some typ)) ->
-	GProd (dummy_loc,Name id, Explicit, fst typ, glob)
+	GProd (Loc.ghost,Name id, Explicit, fst typ, glob)
     | Hprop st ->
-	GProd (dummy_loc,st.st_label, Explicit, inject st.st_it, glob)
+	GProd (Loc.ghost,st.st_label, Explicit, inject st.st_it, glob)
 
 let glob_constr_of_hyps inject hyps head =
   List.fold_right (abstract_one_hyp inject) hyps head
 
-let glob_prop = GSort (dummy_loc,GProp Null)
+let glob_prop = GSort (Loc.ghost,GProp)
 
 let rec match_hyps blend names constr = function
     [] -> [],substl names constr
@@ -210,13 +212,13 @@ let rec match_hyps blend names constr = function
       let rhyps,head = match_hyps blend qnames body q in
 	qhyp::rhyps,head
 
-let interp_hyps_gen inject blend sigma env hyps head =
-  let constr=understand sigma env (glob_constr_of_hyps inject hyps head) in
+let interp_hyps_gen inject blend env sigma hyps head =
+  let constr= fst(*FIXME*) (understand env sigma (glob_constr_of_hyps inject hyps head)) in
     match_hyps blend [] constr hyps
 
-let interp_hyps sigma env hyps = fst (interp_hyps_gen fst (fun x _ -> x) sigma env hyps glob_prop)
+let interp_hyps env sigma hyps = fst (interp_hyps_gen fst (fun x _ -> x) env sigma hyps glob_prop)
 
-let dummy_prefix= id_of_string "__"
+let dummy_prefix= Id.of_string "__"
 
 let rec deanonymize ids =
   function
@@ -234,34 +236,34 @@ let rec deanonymize ids =
 
 let rec glob_of_pat =
   function
-      PatVar (loc,Anonymous) -> anomaly "Anonymous pattern variable"
+      PatVar (loc,Anonymous) -> anomaly (Pp.str "Anonymous pattern variable")
     | PatVar (loc,Name id) ->
 	  GVar (loc,id)
     | PatCstr(loc,((ind,_) as cstr),lpat,_) ->
 	let mind= fst (Global.lookup_inductive ind) in
 	let rec add_params n q =
 	  if n<=0 then q else
-	    add_params (pred n) (GHole(dummy_loc,
-				       Evd.TomatchTypeParameter(ind,n))::q) in
+	    add_params (pred n) (GHole(Loc.ghost,
+				       Evar_kinds.TomatchTypeParameter(ind,n), Misctypes.IntroAnonymous, None)::q) in
 	    let args = List.map glob_of_pat lpat in
-	      glob_app(loc,GRef(dummy_loc,Libnames.ConstructRef cstr),
+	      glob_app(loc,GRef(Loc.ghost,Globnames.ConstructRef cstr,None),
 		   add_params mind.Declarations.mind_nparams args)
 
 let prod_one_hyp = function
     (loc,(id,None)) ->
       (fun glob ->
-	 GProd (dummy_loc,Name id, Explicit,
-		GHole (loc,Evd.BinderType (Name id)), glob))
+	 GProd (Loc.ghost,Name id, Explicit,
+		GHole (loc,Evar_kinds.BinderType (Name id), Misctypes.IntroAnonymous, None), glob))
   | (loc,(id,Some typ)) ->
       (fun glob ->
-	 GProd (dummy_loc,Name id, Explicit, fst typ, glob))
+	 GProd (Loc.ghost,Name id, Explicit, fst typ, glob))
 
 let prod_one_id (loc,id) glob =
-  GProd (dummy_loc,Name id, Explicit,
-	 GHole (loc,Evd.BinderType (Name id)), glob)
+  GProd (Loc.ghost,Name id, Explicit,
+	 GHole (loc,Evar_kinds.BinderType (Name id), Misctypes.IntroAnonymous, None), glob)
 
 let let_in_one_alias (id,pat) glob =
-  GLetIn (dummy_loc,Name id, glob_of_pat pat, glob)
+  GLetIn (Loc.ghost,Name id, glob_of_pat pat, glob)
 
 let rec bind_primary_aliases map pat =
   match pat with
@@ -275,7 +277,7 @@ let rec bind_primary_aliases map pat =
 	  List.fold_left bind_primary_aliases map1 lpat
 
 let bind_secondary_aliases map subst =
-  List.fold_left (fun map (ids,idp) -> (ids,List.assoc idp map)::map) map subst
+  Id.Map.fold (fun ids idp map -> (ids,Id.List.assoc idp map)::map) subst map
 
 let bind_aliases patvars subst patt =
   let map = bind_primary_aliases [] patt in
@@ -285,10 +287,10 @@ let bind_aliases patvars subst patt =
 let interp_pattern env pat_expr =
   let patvars,pats = Constrintern.intern_pattern env pat_expr in
     match pats with
-	[] -> anomaly "empty pattern list"
+	[] -> anomaly (Pp.str "empty pattern list")
       | [subst,patt] ->
 	  (patvars,bind_aliases patvars subst patt,patt)
-      | _  -> anomaly "undetected disjunctive pattern"
+      | _  -> anomaly (Pp.str "undetected disjunctive pattern")
 
 let rec match_args dest names constr = function
     [] -> [],names,substl names constr
@@ -314,9 +316,9 @@ let rec match_aliases names constr = function
       let args,bnames,body = match_aliases qnames body q in
 	st::args,bnames,body
 
-let detype_ground c = Detyping.detype false [] [] c
+let detype_ground env c = Detyping.detype false [] env Evd.empty c
 
-let interp_cases info sigma env params (pat:cases_pattern_expr) hyps =
+let interp_cases info env sigma params (pat:cases_pattern_expr) hyps =
   let et,pinfo =
     match info.pm_stack with
 	Per(et,pi,_,_)::_ -> et,pi
@@ -325,31 +327,31 @@ let interp_cases info sigma env params (pat:cases_pattern_expr) hyps =
   let num_params = pinfo.per_nparams in
   let _ =
     let expected = mib.Declarations.mind_nparams - num_params in
-      if List.length params <> expected then
+      if not (Int.equal (List.length params) expected) then
 	errorlabstrm "suppose it is" 
 	  (str "Wrong number of extra arguments: " ++ 
-	     (if expected = 0 then str "none" else int expected) ++ spc () ++
+	     (if Int.equal expected 0 then str "none" else int expected) ++ spc () ++
 	     str "expected.") in
   let app_ind =
-    let rind = GRef (dummy_loc,Libnames.IndRef pinfo.per_ind) in
-    let rparams = List.map detype_ground pinfo.per_params in
+    let rind = GRef (Loc.ghost,Globnames.IndRef pinfo.per_ind,None) in
+    let rparams = List.map (detype_ground env) pinfo.per_params in
     let rparams_rec =
       List.map
 	(fun (loc,(id,_)) ->
 	   GVar (loc,id)) params in
     let dum_args=
-      list_tabulate (fun _ -> GHole (dummy_loc,Evd.QuestionMark (Evd.Define false)))
-	oib.Declarations.mind_nrealargs in
-      glob_app(dummy_loc,rind,rparams@rparams_rec@dum_args) in
+      List.init oib.Declarations.mind_nrealargs
+	(fun _ -> GHole (Loc.ghost,Evar_kinds.QuestionMark (Evar_kinds.Define false),Misctypes.IntroAnonymous, None)) in
+      glob_app(Loc.ghost,rind,rparams@rparams_rec@dum_args) in
   let pat_vars,aliases,patt = interp_pattern env pat in
   let inject = function
-      Thesis (Plain) -> Glob_term.GSort(dummy_loc,GProp Null)
+      Thesis (Plain) -> Glob_term.GSort(Loc.ghost,GProp)
     | Thesis (For rec_occ) ->
-	if not (List.mem rec_occ pat_vars) then
+	if not (Id.List.mem rec_occ pat_vars) then
 	  errorlabstrm "suppose it is"
 	    (str "Variable " ++ Nameops.pr_id rec_occ ++
 	       str " does not occur in pattern.");
-	Glob_term.GSort(dummy_loc,GProp Null)
+	Glob_term.GSort(Loc.ghost,GProp)
     | This (c,_) -> c in
   let term1 = glob_constr_of_hyps inject hyps glob_prop in
   let loc_ids,npatt =
@@ -357,13 +359,13 @@ let interp_cases info sigma env params (pat:cases_pattern_expr) hyps =
     let npatt= deanonymize rids patt in
       List.rev (fst !rids),npatt in
   let term2 =
-    GLetIn(dummy_loc,Anonymous,
-	   GCast(dummy_loc,glob_of_pat npatt,
-		 CastConv (DEFAULTcast,app_ind)),term1) in
+    GLetIn(Loc.ghost,Anonymous,
+	   GCast(Loc.ghost,glob_of_pat npatt,
+		 CastConv app_ind),term1) in
   let term3=List.fold_right let_in_one_alias aliases term2 in
   let term4=List.fold_right prod_one_id loc_ids term3 in
   let term5=List.fold_right prod_one_hyp params term4 in
-  let constr = understand  sigma env term5 in
+  let constr = fst (understand env sigma term5)(*FIXME*) in
   let tparams,nam4,rest4 = match_args destProd [] constr params in
   let tpatvars,nam3,rest3 = match_args destProd nam4 rest4 loc_ids in
   let taliases,nam2,rest2 = match_aliases nam3 rest3 aliases in
@@ -380,22 +382,22 @@ let interp_cases info sigma env params (pat:cases_pattern_expr) hyps =
 	     pat_pat=patt;
 	     pat_expr=pat},thyps
 
-let interp_cut interp_it sigma env cut=
-  let nenv,nstat = interp_it sigma env cut.cut_stat in
+let interp_cut interp_it env sigma cut=
+  let nenv,nstat = interp_it env sigma cut.cut_stat in
     {cut with
        cut_stat=nstat;
-       cut_by=interp_justification_items sigma nenv cut.cut_by}
+       cut_by=interp_justification_items nenv sigma cut.cut_by}
 
-let interp_no_bind interp_it sigma env x =
-  env,interp_it sigma env x
+let interp_no_bind interp_it env sigma x =
+  env,interp_it env sigma x
 
-let interp_suffices_clause sigma env (hyps,cot)=
+let interp_suffices_clause env sigma (hyps,cot)=
   let (locvars,_) as res =
     match cot with
 	This (c,_) ->
-	  let nhyps,nc = interp_hyps_gen fst (fun x _ -> x) sigma env hyps c in
+	  let nhyps,nc = interp_hyps_gen fst (fun x _ -> x) env sigma hyps c in
 	  nhyps,This nc
-      | Thesis Plain as th  -> interp_hyps sigma env hyps,th
+      | Thesis Plain as th  -> interp_hyps env sigma hyps,th
       | Thesis (For n) -> error "\"thesis for\" is not applicable here." in
   let push_one hyp env0 =
     match hyp with
@@ -406,66 +408,66 @@ let interp_suffices_clause sigma env (hyps,cot)=
   let nenv = List.fold_right push_one locvars env in
     nenv,res
 
-let interp_casee sigma env = function
-    Real c -> Real (understand sigma env (fst c))
-  | Virtual cut -> Virtual (interp_cut (interp_no_bind (interp_statement (interp_constr true))) sigma env cut)
+let interp_casee env sigma = function
+    Real c -> Real (fst (understand env sigma (fst c)))(*FIXME*)
+  | Virtual cut -> Virtual (interp_cut (interp_no_bind (interp_statement (interp_constr true))) env sigma cut)
 
 let abstract_one_arg = function
     (loc,(id,None)) ->
       (fun glob ->
-	 GLambda (dummy_loc,Name id, Explicit,
-		GHole (loc,Evd.BinderType (Name id)), glob))
+	 GLambda (Loc.ghost,Name id, Explicit,
+		GHole (loc,Evar_kinds.BinderType (Name id),Misctypes.IntroAnonymous,None), glob))
   | (loc,(id,Some typ)) ->
       (fun glob ->
-	 GLambda (dummy_loc,Name id, Explicit, fst typ, glob))
+	 GLambda (Loc.ghost,Name id, Explicit, fst typ, glob))
 
 let glob_constr_of_fun args body =
   List.fold_right abstract_one_arg args (fst body)
 
-let interp_fun sigma env args body =
-  let constr=understand sigma env (glob_constr_of_fun args body) in
+let interp_fun env sigma args body =
+  let constr=fst (*FIXME*) (understand env sigma (glob_constr_of_fun args body)) in
     match_args destLambda [] constr args
 
-let rec interp_bare_proof_instr info (sigma:Evd.evar_map) (env:Environ.env) = function
-    Pthus i -> Pthus (interp_bare_proof_instr info sigma env i)
-  | Pthen i -> Pthen (interp_bare_proof_instr info sigma env i)
-  | Phence i -> Phence (interp_bare_proof_instr info sigma env i)
+let rec interp_bare_proof_instr info env sigma = function
+    Pthus i -> Pthus (interp_bare_proof_instr info env sigma i)
+  | Pthen i -> Pthen (interp_bare_proof_instr info env sigma i)
+  | Phence i -> Phence (interp_bare_proof_instr info env sigma i)
   | Pcut c -> Pcut (interp_cut
 		      (interp_no_bind (interp_statement
 					 (interp_constr_or_thesis true)))
-		      sigma env c)
+		      env sigma c)
   | Psuffices c ->
-      Psuffices (interp_cut interp_suffices_clause sigma env c)
+      Psuffices (interp_cut interp_suffices_clause env sigma c)
   | Prew (s,c) -> Prew (s,interp_cut
 			  (interp_no_bind (interp_statement
 			     (interp_constr_in_type (get_eq_typ info env))))
-			  sigma env c)
+			  env sigma c)
 
-  | Psuppose hyps -> Psuppose (interp_hyps sigma env hyps)
+  | Psuppose hyps -> Psuppose (interp_hyps env sigma hyps)
   | Pcase (params,pat,hyps) ->
-      let tparams,tpat,thyps = interp_cases info sigma env params pat hyps in
+      let tparams,tpat,thyps = interp_cases info env sigma params pat hyps in
 	Pcase (tparams,tpat,thyps)
   | Ptake witl ->
-      Ptake (List.map (fun c -> understand sigma env (fst c)) witl)
-  | Pconsider (c,hyps) -> Pconsider (interp_constr false sigma env c,
-				     interp_hyps sigma env hyps)
-  | Pper (et,c) -> Pper (et,interp_casee sigma env c)
+      Ptake (List.map (fun c -> fst (*FIXME*) (understand env sigma (fst c))) witl)
+  | Pconsider (c,hyps) -> Pconsider (interp_constr false env sigma c,
+				     interp_hyps env sigma hyps)
+  | Pper (et,c) -> Pper (et,interp_casee env sigma c)
   | Pend bt -> Pend bt
   | Pescape -> Pescape
-  | Passume hyps -> Passume (interp_hyps sigma env hyps)
-  | Pgiven hyps -> Pgiven (interp_hyps sigma env hyps)
-  | Plet hyps -> Plet (interp_hyps sigma env hyps)
-  | Pclaim st -> Pclaim (interp_statement (interp_constr true) sigma env st)
-  | Pfocus st -> Pfocus (interp_statement (interp_constr true) sigma env st)
+  | Passume hyps -> Passume (interp_hyps env sigma hyps)
+  | Pgiven hyps -> Pgiven (interp_hyps env sigma hyps)
+  | Plet hyps -> Plet (interp_hyps env sigma hyps)
+  | Pclaim st -> Pclaim (interp_statement (interp_constr true) env sigma st)
+  | Pfocus st -> Pfocus (interp_statement (interp_constr true) env sigma st)
   | Pdefine (id,args,body) ->
-      let nargs,_,nbody = interp_fun sigma env args body in
+      let nargs,_,nbody = interp_fun env sigma args body in
 	Pdefine (id,nargs,nbody)
   | Pcast (id,typ) ->
-      Pcast(id,interp_constr true sigma env typ)
+      Pcast(id,interp_constr true env sigma typ)
 
-let rec interp_proof_instr info sigma env instr=
+let interp_proof_instr info env sigma instr=
   {emph = instr.emph;
-   instr = interp_bare_proof_instr info sigma env instr.instr}
+   instr = interp_bare_proof_instr info env sigma instr.instr}
 
 
 
diff --git a/plugins/decl_mode/decl_interp.mli b/plugins/decl_mode/decl_interp.mli
index f7227946..b3d6f82b 100644
--- a/plugins/decl_mode/decl_interp.mli
+++ b/plugins/decl_mode/decl_interp.mli
@@ -1,16 +1,15 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Tacinterp
+open Tacintern
 open Decl_expr
-open Mod_subst
 
 
 val intern_proof_instr : glob_sign -> raw_proof_instr -> glob_proof_instr
 val interp_proof_instr : Decl_mode.pm_info ->
-  Evd.evar_map -> Environ.env -> glob_proof_instr -> proof_instr
+  Environ.env -> Evd.evar_map -> glob_proof_instr -> proof_instr
diff --git a/plugins/decl_mode/decl_mode.ml b/plugins/decl_mode/decl_mode.ml
index 55742386..d169dc13 100644
--- a/plugins/decl_mode/decl_mode.ml
+++ b/plugins/decl_mode/decl_mode.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -9,9 +9,9 @@
 open Names
 open Term
 open Evd
+open Errors
 open Util
 
-
 let daimon_flag = ref false
 
 let set_daimon_flag () = daimon_flag:=true
@@ -20,15 +20,13 @@ let get_daimon_flag () = !daimon_flag
 
 
 
-(* Information associated to goals. *)
-open Store.Field
 
 type split_tree=
-    Skip_patt of Idset.t * split_tree
-  | Split_patt of Idset.t * inductive *
-		(bool array * (Idset.t * split_tree) option) array
+    Skip_patt of Id.Set.t * split_tree
+  | Split_patt of Id.Set.t * inductive *
+		(bool array * (Id.Set.t * split_tree) option) array
   | Close_patt of split_tree
-  | End_patt of (identifier * (int * int))
+  | End_patt of (Id.t * (int * int))
 
 type elim_kind =
     EK_dep of split_tree
@@ -48,7 +46,7 @@ type per_info =
      per_wf:recpath}
 
 type stack_info =
-    Per of Decl_expr.elim_type * per_info * elim_kind * identifier list
+    Per of Decl_expr.elim_type * per_info * elim_kind * Id.t list
   | Suppose_case
   | Claim
   | Focus_claim
@@ -69,27 +67,27 @@ let mode_of_pftreestate pts =
   (* spiwack: it used to be "top_goal_..." but this should be fine *)
   let { it = goals ; sigma = sigma } = Proof.V82.subgoals pts in
   let goal = List.hd goals in
-    if info.get (Goal.V82.extra sigma goal) = None then
-      Mode_tactic 
-    else
-      Mode_proof
+  match Store.get (Goal.V82.extra sigma goal) info with
+  | None -> Mode_tactic 
+  | Some _ -> Mode_proof
 	  
 let get_current_mode () =
-  try
+  try 
     mode_of_pftreestate (Pfedit.get_pftreestate ())
-  with e when Errors.noncritical e -> Mode_none
+  with Proof_global.NoCurrentProof -> Mode_none
 
 let check_not_proof_mode str =
- if get_current_mode () = Mode_proof then
-   error str
+ match get_current_mode () with
+ | Mode_proof -> error str
+ | _ -> ()
 
 let get_info sigma gl=
-  match info.get (Goal.V82.extra sigma gl) with
+  match Store.get (Goal.V82.extra sigma gl) info with
   | None ->  invalid_arg "get_info"
   | Some pm -> pm
 
 let try_get_info sigma gl =
-  info.get (Goal.V82.extra sigma gl)
+  Store.get (Goal.V82.extra sigma gl) info
 
 let get_stack pts =
   let { it = goals ; sigma = sigma } = Proof.V82.subgoals pts in
@@ -102,11 +100,13 @@ let proof_cond = Proof.no_cond proof_focus
 
 let focus p =
   let inf = get_stack p in
-  Proof.focus proof_cond inf 1 p
+  Proof_global.simple_with_current_proof (fun _ -> Proof.focus proof_cond inf 1)
 
-let unfocus = Proof.unfocus proof_focus
+let unfocus () =
+  Proof_global.simple_with_current_proof (fun _ p -> Proof.unfocus proof_focus p ())
 
-let maximal_unfocus = Proof_global.maximal_unfocus proof_focus
+let maximal_unfocus () = 
+  Proof_global.simple_with_current_proof (fun _ -> Proof.maximal_unfocus proof_focus)
 
 let get_top_stack pts =
   try
@@ -116,8 +116,7 @@ let get_top_stack pts =
     let info = get_info sigma gl in
     info.pm_stack
 
-let get_last env =
-  try
-    let (id,_,_) =  List.hd (Environ.named_context env) in id
-  with Invalid_argument _ -> error "no previous statement to use"
+let get_last env = match Environ.named_context env with
+  | (id,_,_)::_ -> id
+  | [] -> error "no previous statement to use"
 
diff --git a/plugins/decl_mode/decl_mode.mli b/plugins/decl_mode/decl_mode.mli
index b36f2333..2864ba18 100644
--- a/plugins/decl_mode/decl_mode.mli
+++ b/plugins/decl_mode/decl_mode.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -9,7 +9,6 @@
 open Names
 open Term
 open Evd
-open Tacmach
 
 val set_daimon_flag : unit -> unit
 val clear_daimon_flag : unit -> unit
@@ -27,11 +26,11 @@ val get_current_mode : unit -> command_mode
 val check_not_proof_mode : string -> unit
 
 type split_tree=
-    Skip_patt of Idset.t * split_tree
-  | Split_patt of Idset.t * inductive *
-		(bool array * (Idset.t * split_tree) option) array
+    Skip_patt of Id.Set.t * split_tree
+  | Split_patt of Id.Set.t * inductive *
+		(bool array * (Id.Set.t * split_tree) option) array
   | Close_patt of split_tree
-  | End_patt of (identifier * (int * int))
+  | End_patt of (Id.t * (int * int))
 
 type elim_kind =
     EK_dep of split_tree
@@ -51,7 +50,7 @@ type per_info =
      per_wf:recpath}
 
 type stack_info =
-    Per of Decl_expr.elim_type * per_info * elim_kind * Names.identifier list
+    Per of Decl_expr.elim_type * per_info * elim_kind * Names.Id.t list
   | Suppose_case
   | Claim
   | Focus_claim
@@ -59,7 +58,7 @@ type stack_info =
 type pm_info =
     {pm_stack : stack_info list }
 
-val info : pm_info Store.Field.t
+val info : pm_info Store.field
 
 val get_info : Evd.evar_map -> Proof_type.goal -> pm_info
 
@@ -69,10 +68,12 @@ val get_stack : Proof.proof -> stack_info list
 
 val get_top_stack : Proof.proof -> stack_info list
 
-val get_last:  Environ.env -> identifier
+val get_last:  Environ.env -> Id.t
+(** [get_last] raises a [UserError] when it cannot find a previous
+    statement in the environment. *)
 
 val focus : Proof.proof -> unit
 
-val unfocus : Proof.proof -> unit
+val unfocus : unit -> unit
 
-val maximal_unfocus : Proof.proof -> unit
+val maximal_unfocus : unit -> unit
diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml
index e69f2bb6..9d25681d 100644
--- a/plugins/decl_mode/decl_proof_instr.ml
+++ b/plugins/decl_mode/decl_proof_instr.ml
@@ -1,34 +1,34 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+open Errors
 open Util
 open Pp
 open Evd
 
-open Refiner
-open Proof_type
 open Tacmach
-open Tacinterp
+open Tacintern
 open Decl_expr
 open Decl_mode
 open Decl_interp
 open Glob_term
+open Glob_ops
 open Names
 open Nameops
 open Declarations
 open Tactics
 open Tacticals
 open Term
+open Vars
 open Termops
 open Namegen
-open Reductionops
 open Goptions
-
+open Misctypes
 
 (* Strictness option *)
 
@@ -49,20 +49,21 @@ let _ =
 
 let tcl_change_info_gen info_gen =
   (fun gls ->
+     let it = sig_it gls in
      let concl = pf_concl gls in
-     let hyps = Goal.V82.hyps (project gls) (sig_it gls) in
-     let extra = Goal.V82.extra (project gls) (sig_it gls) in
+     let hyps = Goal.V82.hyps (project gls) it in
+     let extra = Goal.V82.extra (project gls) it in
      let (gl,ev,sigma) = Goal.V82.mk_goal (project gls) hyps concl (info_gen extra) in
-     let sigma = Goal.V82.partial_solution sigma (sig_it gls) ev in
-     { it = [gl] ; sigma= sigma } )
-
-open Store.Field
+     let sigma = Goal.V82.partial_solution sigma it ev in
+     { it = [gl] ; sigma= sigma; } )
 
-let tcl_change_info info gls =  
-  let info_gen = Decl_mode.info.set info in
+let tcl_change_info info gls =
+  let info_gen s = Store.set s Decl_mode.info info in
   tcl_change_info_gen info_gen gls
 
-let tcl_erase_info gls =  tcl_change_info_gen (Decl_mode.info.remove) gls
+let tcl_erase_info gls =
+  let info_gen s = Store.remove s Decl_mode.info in
+  tcl_change_info_gen info_gen gls
 
 let special_whd gl=
   let infos=Closure.create_clos_infos Closure.betadeltaiota (pf_env gl) in
@@ -74,7 +75,7 @@ let special_nf gl=
 
 let is_good_inductive env ind =
   let mib,oib = Inductive.lookup_mind_specif env ind in
-    oib.mind_nrealargs = 0 && not (Inductiveops.mis_is_recursive (ind,mib,oib))
+    Int.equal oib.mind_nrealargs 0 && not (Inductiveops.mis_is_recursive (ind,mib,oib))
 
 let check_not_per pts =
   if not (Proof.is_done pts) then
@@ -90,7 +91,7 @@ let mk_evd metalist gls =
     meta_declare meta typ evd in
     List.fold_right add_one metalist evd0
 
-let is_tmp id = (string_of_id id).[0] = '_'
+let is_tmp id = (Id.to_string id).[0] == '_'
 
 let tmp_ids gls =
   let ctx = pf_hyps gls in
@@ -108,7 +109,7 @@ let clean_tmp gls =
     clean_all (tmp_ids gls) gls
 
 let assert_postpone id t =
-  assert_tac (Name id) t
+  assert_before (Name id) t
 
 (* start a proof *)
 
@@ -118,7 +119,7 @@ let start_proof_tac gls=
   tcl_change_info info gls
 
 let go_to_proof_mode () =
-  Pfedit.by start_proof_tac;
+  ignore (Pfedit.by (Proofview.V82.tactic start_proof_tac));
   let p = Proof_global.give_me_the_proof () in
   Decl_mode.focus p
 
@@ -126,50 +127,34 @@ let go_to_proof_mode () =
 
 let daimon_tac gls =
   set_daimon_flag ();
-  {it=[];sigma=sig_sig gls}
-
-
-(* marking closed blocks *)
-
-let rec is_focussing_instr = function
-    Pthus i | Pthen i | Phence i -> is_focussing_instr i
-  | Pescape | Pper _ | Pclaim _ | Pfocus _
-  | Psuppose _ | Pcase (_,_,_)  -> true
-  | _ -> false
-
-let mark_rule_as_done = function
-    Decl_proof true -> Decl_proof false
-  | Decl_proof false ->
-      anomaly "already marked as done"
-  | _ -> anomaly "mark_rule_as_done"
-
+  {it=[];sigma=sig_sig gls;}
 
 (* post-instruction focus management *)
 
 (* spiwack: This used to fail if there was no focusing command
    above, but I don't think it ever happened. I hope it doesn't mess
    things up*)
-let goto_current_focus pts = 
-  Decl_mode.maximal_unfocus pts
+let goto_current_focus () = 
+  Decl_mode.maximal_unfocus ()
 
-let goto_current_focus_or_top pts =
-  goto_current_focus pts
+let goto_current_focus_or_top () =
+  goto_current_focus ()
 
 (* return *)
 
-let close_tactic_mode pts =
-  try goto_current_focus pts
+let close_tactic_mode () =
+  try goto_current_focus ()
   with Not_found ->
     error "\"return\" cannot be used outside of Declarative Proof Mode."
 
 let return_from_tactic_mode () =
-  close_tactic_mode (Proof_global.give_me_the_proof ())
+  close_tactic_mode ()
 
 (* end proof/claim *)
 
 let close_block bt pts =
     if Proof.no_focused_goal pts then
-      goto_current_focus pts
+      goto_current_focus ()
     else
       let stack =
 	if Proof.is_done pts then
@@ -179,7 +164,7 @@ let close_block bt pts =
       in
       match bt,stack with
 	B_claim, Claim::_ | B_focus, Focus_claim::_ | B_proof, [] ->
-	  (goto_current_focus pts)
+	  (goto_current_focus ())
       | _, Claim::_ ->
 	  error "\"end claim\" expected."
       | _, Focus_claim::_ ->
@@ -192,7 +177,7 @@ let close_block bt pts =
 		ET_Case_analysis -> error "\"end cases\" expected."
 	      | ET_Induction ->  error "\"end induction\" expected."
 	  end
-      | _,_ -> anomaly "Lonely suppose on stack."
+      | _,_ -> anomaly (Pp.str "Lonely suppose on stack.")
 
 
 (* utility for suppose / suppose it is *)
@@ -202,15 +187,15 @@ let close_previous_case pts =
     Proof.is_done pts
   then
     match get_top_stack pts with
-	Per (et,_,_,_) :: _ -> anomaly "Weird case occured ..."
+	Per (et,_,_,_) :: _ -> anomaly (Pp.str "Weird case occured ...")
       | Suppose_case :: Per (et,_,_,_) :: _ ->
-	  goto_current_focus (pts)
+	  goto_current_focus ()
       | _ -> error "Not inside a proof per cases or induction."
   else
     match get_stack pts with
 	Per (et,_,_,_) :: _ -> ()
       | Suppose_case :: Per (et,_,_,_) :: _ ->
-	  goto_current_focus ((pts))
+	  goto_current_focus ()
       | _ -> error "Not inside a proof per cases or induction."
 
 (* Proof instructions *)
@@ -225,38 +210,38 @@ let filter_hyps f gls =
       tclTRY (clear [id])  in
     tclMAP filter_aux (pf_hyps gls) gls
 
-let local_hyp_prefix = id_of_string "___"
+let local_hyp_prefix = Id.of_string "___"
 
 let add_justification_hyps keep items gls =
   let add_aux c gls=
     match kind_of_term c with
 	Var id ->
-	  keep:=Idset.add id !keep;
+	  keep:=Id.Set.add id !keep;
 	  tclIDTAC gls
       | _ ->
 	  let id=pf_get_new_id local_hyp_prefix gls in
-	    keep:=Idset.add id !keep;
-	    tclTHEN (letin_tac None (Names.Name id) c None Tacexpr.nowhere)
-              (thin_body [id]) gls in
+	    keep:=Id.Set.add id !keep;
+	    tclTHEN (Proofview.V82.of_tactic (letin_tac None (Names.Name id) c None Locusops.nowhere))
+              (Proofview.V82.of_tactic (clear_body [id])) gls in
     tclMAP add_aux items gls
 
 let prepare_goal items gls =
-  let tokeep = ref Idset.empty in
+  let tokeep = ref Id.Set.empty in
   let auxres = add_justification_hyps tokeep items gls in
    tclTHENLIST
      [ (fun _ -> auxres);
-       filter_hyps (let keep = !tokeep in fun id -> Idset.mem id keep)] gls
+       filter_hyps (let keep = !tokeep in fun id -> Id.Set.mem id keep)] gls
 
 let my_automation_tac = ref
-  (fun gls -> anomaly "No automation registered")
+  (Proofview.tclZERO (Errors.make_anomaly (Pp.str"No automation registered")))
 
 let register_automation_tac tac = my_automation_tac:= tac
 
-let automation_tac gls = !my_automation_tac gls
+let automation_tac = Proofview.tclBIND (Proofview.tclUNIT ()) (fun () -> !my_automation_tac)
 
 let justification tac gls=
     tclORELSE
-      (tclSOLVE [tclTHEN tac assumption])
+      (tclSOLVE [tclTHEN tac (Proofview.V82.of_tactic assumption)])
       (fun gls ->
 	 if get_strictness () then
 	   error "Insufficient justification."
@@ -267,7 +252,7 @@ let justification tac gls=
 	   end) gls
 
 let default_justification elems gls=
-  justification (tclTHEN (prepare_goal elems) automation_tac) gls
+  justification (tclTHEN (prepare_goal elems) (Proofview.V82.of_tactic automation_tac)) gls
 
 (* code for conclusion refining *)
 
@@ -302,21 +287,21 @@ type stackd_elt =
 
 let rec replace_in_list m l = function
     [] -> raise Not_found
-  | c::q -> if m=fst c then l@q else c::replace_in_list m l q
+  | c::q -> if Int.equal m (fst c) then l@q else c::replace_in_list m l q
 
 let enstack_subsubgoals env se stack gls=
   let hd,params = decompose_app (special_whd gls se.se_type) in
     match kind_of_term hd with
-	Ind ind when is_good_inductive env ind ->
+	Ind (ind,u as indu) when is_good_inductive env ind -> (* MS: FIXME *)
 	  let mib,oib=
 	    Inductive.lookup_mind_specif env ind in
           let gentypes=
-            Inductive.arities_of_constructors ind (mib,oib) in
+            Inductive.arities_of_constructors indu (mib,oib) in
 	  let process i gentyp =
-	    let constructor = mkConstruct(ind,succ i)
+	    let constructor = mkConstructU ((ind,succ i),u)
 	      (* constructors numbering*) in
 	    let appterm = applist (constructor,params) in
-	    let apptype = Term.prod_applist gentyp params in
+	    let apptype = prod_applist gentyp params in
 	    let rc,_ = Reduction.dest_prod env apptype in
 	    let rec meta_aux last lenv = function
 		[] -> (last,lenv,[])
@@ -352,7 +337,7 @@ let rec nf_list evd =
 	if meta_defined evd m then
 	    nf_list evd others
 	else
-	  (m,nf_meta evd typ)::nf_list evd others
+	  (m,Reductionops.nf_meta evd typ)::nf_list evd others
 
 let find_subsubgoal c ctyp skip submetas gls =
   let env= pf_env gls in
@@ -372,7 +357,7 @@ let find_subsubgoal c ctyp skip submetas gls =
       try
 	let unifier =
 	  Unification.w_unify env se.se_evd Reduction.CUMUL
-	    ~flags:Unification.elim_flags ctyp se.se_type in
+	    ~flags:(Unification.elim_flags ()) ctyp se.se_type in
 	  if n <= 0 then
 	      {se with
 		 se_evd=meta_assign se.se_meta
@@ -387,23 +372,23 @@ let find_subsubgoal c ctyp skip submetas gls =
 	  dfs n
 	end in
   let nse= try dfs skip with Stack.Empty -> raise Not_found in
-    nf_list nse.se_evd nse.se_meta_list,nf_meta nse.se_evd (mkMeta 0)
+    nf_list nse.se_evd nse.se_meta_list,Reductionops.nf_meta nse.se_evd (mkMeta 0)
 
 let concl_refiner metas body gls =
   let concl = pf_concl gls in
   let evd = sig_sig gls in
   let env = pf_env gls in
-  let sort = family_of_sort (Typing.sort_of env evd concl) in
+  let sort = family_of_sort (Typing.sort_of env (ref evd) concl) in
   let rec aux env avoid subst = function
-      [] -> anomaly "concl_refiner: cannot happen"
+      [] -> anomaly ~label:"concl_refiner" (Pp.str "cannot happen")
     | (n,typ)::rest ->
 	let _A = subst_meta subst typ in
 	let x = id_of_name_using_hdchar env _A Anonymous in
 	let _x = fresh_id avoid x gls in
 	let nenv = Environ.push_named (_x,None,_A) env in
-	let asort = family_of_sort (Typing.sort_of nenv evd _A) in
+	let asort = family_of_sort (Typing.sort_of nenv (ref evd) _A) in
 	let nsubst = (n,mkVar _x)::subst in
-	  if rest = [] then
+	  if List.is_empty rest then
 	    asort,_A,mkNamedLambda _x _A (subst_meta nsubst body)
 	  else
 	    let bsort,_B,nbody =
@@ -451,8 +436,8 @@ let thus_tac c ctyp submetas gls =
       find_subsubgoal c ctyp 0 submetas gls
     with Not_found ->
       error "I could not relate this statement to the thesis." in
-  if list = [] then
-    exact_check proof gls
+  if List.is_empty list then
+    Proofview.V82.of_tactic (exact_check proof) gls
   else
     let refiner = concl_refiner list proof gls in
       Tactics.refine refiner gls
@@ -465,12 +450,13 @@ let mk_stat_or_thesis info gls = function
       error "\"thesis for ...\" is not applicable here."
   | Thesis Plain -> pf_concl gls
 
-let just_tac _then cut info gls0 = 
-  let last_item = if _then then 
-      let last_id = try get_last (pf_env gls0) with Failure _ -> 
-		error "\"then\" and \"hence\" require at least one previous fact"  in
-		[mkVar last_id]
-	    else []  
+let just_tac _then cut info gls0 =
+  let last_item =
+    if _then then
+      try [mkVar (get_last (pf_env gls0))]
+      with UserError _ ->
+	error "\"then\" and \"hence\" require at least one previous fact"
+    else []
   in
   let items_tac gls = 
     match cut.cut_by with
@@ -479,9 +465,9 @@ let just_tac _then cut info gls0 =
   let method_tac gls =
     match cut.cut_using with
         None ->
-	  automation_tac gls
+	  Proofview.V82.of_tactic automation_tac gls
       | Some tac ->
-	  (Tacinterp.eval_tactic tac) gls in
+	  Proofview.V82.of_tactic (Tacinterp.eval_tactic tac) gls in
     justification (tclTHEN items_tac method_tac) gls0
 
 let instr_cut mkstat _thus _then cut gls0 =
@@ -489,28 +475,27 @@ let instr_cut mkstat _thus _then cut gls0 =
   let stat = cut.cut_stat in
   let (c_id,_) = match stat.st_label with
       Anonymous ->
-	pf_get_new_id (id_of_string "_fact") gls0,false
+	pf_get_new_id (Id.of_string "_fact") gls0,false
     | Name id -> id,true in
   let c_stat = mkstat info gls0 stat.st_it in
   let thus_tac gls=
     if _thus then
       thus_tac (mkVar c_id) c_stat [] gls
     else tclIDTAC gls in
-    tclTHENS (assert_postpone c_id c_stat)
+    tclTHENS (Proofview.V82.of_tactic (assert_postpone c_id c_stat))
       [tclTHEN tcl_erase_info (just_tac _then cut info);
        thus_tac] gls0
 
 
-
 (* iterated equality *)
-let _eq = Libnames.constr_of_global (Coqlib.glob_eq)
+let _eq = lazy (Universes.constr_of_global (Coqlib.glob_eq))
 
 let decompose_eq id gls =
   let typ = pf_get_hyp_typ gls id in
   let whd =  (special_whd gls typ) in
     match kind_of_term whd with
 	App (f,args)->
-	  if eq_constr f _eq && (Array.length args)=3
+	  if eq_constr f (Lazy.force _eq) && Int.equal (Array.length args) 3
 	  then (args.(0),
 		args.(1),
 		args.(2))
@@ -520,8 +505,7 @@ let decompose_eq id gls =
 let instr_rew _thus rew_side cut gls0 =
   let last_id =
     try get_last (pf_env gls0)
-    with e when Errors.noncritical e ->
-      error "No previous equality."
+    with UserError _ -> error "No previous equality."
   in
   let typ,lhs,rhs = decompose_eq last_id gls0 in
   let items_tac gls =
@@ -531,14 +515,14 @@ let instr_rew _thus rew_side cut gls0 =
   let method_tac gls =
     match cut.cut_using with
         None ->
-	  automation_tac gls
+	  Proofview.V82.of_tactic automation_tac gls
       | Some tac ->
-	  (Tacinterp.eval_tactic tac) gls in
+	  Proofview.V82.of_tactic (Tacinterp.eval_tactic tac) gls in
   let just_tac gls =
     justification (tclTHEN items_tac method_tac) gls in
   let (c_id,_) = match cut.cut_stat.st_label with
       Anonymous ->
-	pf_get_new_id (id_of_string "_eq") gls0,false
+	pf_get_new_id (Id.of_string "_eq") gls0,false
     | Name id -> id,true in
   let thus_tac new_eq gls=
     if _thus then
@@ -546,28 +530,27 @@ let instr_rew _thus rew_side cut gls0 =
     else tclIDTAC gls in
     match rew_side with
 	Lhs ->
-	  let new_eq = mkApp(_eq,[|typ;cut.cut_stat.st_it;rhs|]) in
-	    tclTHENS (assert_postpone c_id new_eq)
+	  let new_eq = mkApp(Lazy.force _eq,[|typ;cut.cut_stat.st_it;rhs|]) in
+	    tclTHENS (Proofview.V82.of_tactic (assert_postpone c_id new_eq))
 	      [tclTHEN tcl_erase_info
-		 (tclTHENS (transitivity lhs)
-		    [just_tac;exact_check (mkVar last_id)]);
+		 (tclTHENS (Proofview.V82.of_tactic (transitivity lhs))
+		    [just_tac;Proofview.V82.of_tactic (exact_check (mkVar last_id))]);
 	       thus_tac new_eq] gls0
       | Rhs ->
-	  let new_eq = mkApp(_eq,[|typ;lhs;cut.cut_stat.st_it|]) in
-	    tclTHENS (assert_postpone c_id new_eq)
+	  let new_eq = mkApp(Lazy.force _eq,[|typ;lhs;cut.cut_stat.st_it|]) in
+	    tclTHENS (Proofview.V82.of_tactic (assert_postpone c_id new_eq))
 	      [tclTHEN tcl_erase_info
-		 (tclTHENS (transitivity rhs)
-		    [exact_check (mkVar last_id);just_tac]);
+		 (tclTHENS (Proofview.V82.of_tactic (transitivity rhs))
+		    [Proofview.V82.of_tactic (exact_check (mkVar last_id));just_tac]);
 	       thus_tac new_eq] gls0
 
 
-
 (* tactics for claim/focus *)
 
 let instr_claim _thus st gls0 =
   let info = get_its_info gls0 in
   let (id,_) = match st.st_label with
-      Anonymous -> pf_get_new_id (id_of_string "_claim") gls0,false
+      Anonymous -> pf_get_new_id (Id.of_string "_claim") gls0,false
     | Name id -> id,true in
   let thus_tac gls=
     if _thus then
@@ -575,7 +558,7 @@ let instr_claim _thus st gls0 =
     else tclIDTAC gls in
   let ninfo1 = {pm_stack=
       (if _thus then Focus_claim else Claim)::info.pm_stack} in
-    tclTHENS (assert_postpone id st.st_it)
+    tclTHENS (Proofview.V82.of_tactic (assert_postpone id st.st_it))
       [thus_tac;
        tcl_change_info ninfo1] gls0
 
@@ -584,10 +567,10 @@ let instr_claim _thus st gls0 =
 let push_intro_tac coerce nam gls =
       let (hid,_) =
 	match nam with
-	    Anonymous -> pf_get_new_id (id_of_string "_hyp") gls,false
+	    Anonymous -> pf_get_new_id (Id.of_string "_hyp") gls,false
 	  | Name id -> id,true in
 	tclTHENLIST
-	  [intro_mustbe_force hid;
+	  [Proofview.V82.of_tactic (intro_mustbe_force hid);
 	   coerce hid]
 	  gls
 
@@ -597,7 +580,7 @@ let assume_tac hyps gls =
        tclTHEN
 	 (push_intro_tac
 	    (fun id ->
-	       convert_hyp (id,None,st.st_it)) st.st_label))
+	       Proofview.V82.of_tactic (convert_hyp (id,None,st.st_it))) st.st_label))
 	 hyps tclIDTAC gls
 
 let assume_hyps_or_theses hyps gls =
@@ -607,7 +590,7 @@ let assume_hyps_or_theses hyps gls =
 	   tclTHEN
 	     (push_intro_tac
 		(fun id ->
-		   convert_hyp (id,None,c)) nam)
+		   Proofview.V82.of_tactic (convert_hyp (id,None,c))) nam)
        | Hprop {st_label=nam;st_it=Thesis (tk)} ->
 	   tclTHEN
 	     (push_intro_tac
@@ -619,7 +602,7 @@ let assume_st hyps gls =
     (fun st ->
        tclTHEN
 	 (push_intro_tac
-	    (fun id -> convert_hyp (id,None,st.st_it)) st.st_label))
+	    (fun id -> Proofview.V82.of_tactic (convert_hyp (id,None,st.st_it))) st.st_label))
 	 hyps tclIDTAC gls
 
 let assume_st_letin hyps gls =
@@ -628,7 +611,7 @@ let assume_st_letin hyps gls =
        tclTHEN
 	 (push_intro_tac
 	    (fun id ->
-	       convert_hyp (id,Some (fst st.st_it),snd st.st_it)) st.st_label))
+	       Proofview.V82.of_tactic (convert_hyp (id,Some (fst st.st_it),snd st.st_it))) st.st_label))
 	 hyps tclIDTAC gls
 
 (* suffices *)
@@ -653,12 +636,12 @@ let rec build_applist prod = function
     [] -> [],prod
   | n::q ->
       let (_,typ,_) = destProd prod in
-      let ctx,head = build_applist (Term.prod_applist prod [mkMeta n]) q in
+      let ctx,head = build_applist (prod_applist prod [mkMeta n]) q in
 	(n,typ)::ctx,head
 
 let instr_suffices _then cut gls0 =
   let info = get_its_info gls0 in
-  let c_id = pf_get_new_id (id_of_string "_cofact") gls0 in
+  let c_id = pf_get_new_id (Id.of_string "_cofact") gls0 in
   let ctx,hd = cut.cut_stat in
   let c_stat = build_product ctx (mk_stat_or_thesis info gls0 hd) in
   let metas = metas_from 1 ctx in
@@ -666,7 +649,7 @@ let instr_suffices _then cut gls0 =
   let c_term = applist (mkVar c_id,List.map mkMeta metas) in
   let thus_tac gls=
     thus_tac c_term c_head c_ctx gls in
-   tclTHENS (assert_postpone c_id c_stat)
+   tclTHENS (Proofview.V82.of_tactic (assert_postpone c_id c_stat))
      [tclTHENLIST
 	 [ assume_tac ctx;
 	   tcl_erase_info;
@@ -680,13 +663,13 @@ let conjunction_arity id gls =
   let hd,params = decompose_app (special_whd gls typ) in
   let env =pf_env gls in
     match kind_of_term hd with
-	Ind ind when is_good_inductive env ind ->
+	Ind (ind,u as indu) when is_good_inductive env ind ->
 	  let mib,oib=
 	    Inductive.lookup_mind_specif env ind in
           let gentypes=
-            Inductive.arities_of_constructors ind (mib,oib) in
-	  let _ = if Array.length gentypes <> 1 then raise Not_found in
-	  let apptype = Term.prod_applist gentypes.(0) params in
+            Inductive.arities_of_constructors indu (mib,oib) in
+	  let _ = if not (Int.equal (Array.length gentypes) 1) then raise Not_found in
+	  let apptype = prod_applist gentypes.(0) params in
 	  let rc,_ = Reduction.dest_prod env apptype in
 	    List.length rc
       | _ -> raise Not_found
@@ -695,9 +678,9 @@ let rec intron_then n ids ltac gls =
   if n<=0 then
     ltac ids gls
   else
-    let id = pf_get_new_id (id_of_string "_tmp") gls in
+    let id = pf_get_new_id (Id.of_string "_tmp") gls in
       tclTHEN
-	(intro_mustbe_force id)
+	(Proofview.V82.of_tactic (intro_mustbe_force id))
 	(intron_then (pred n) (id::ids) ltac) gls
 
 
@@ -710,9 +693,9 @@ let rec consider_match may_intro introduced available expected gls =
     | [],hyps ->
 	if may_intro then
 	  begin
- 	    let id = pf_get_new_id (id_of_string "_tmp") gls in
+ 	    let id = pf_get_new_id (Id.of_string "_tmp") gls in
 	      tclIFTHENELSE
-		(intro_mustbe_force id)
+		(Proofview.V82.of_tactic (intro_mustbe_force id))
 		(consider_match true [] [id] hyps)
 		(fun _ ->
 		   error "Not enough sub-hypotheses to match statements.")
@@ -722,14 +705,14 @@ let rec consider_match may_intro introduced available expected gls =
 	  error "Not enough sub-hypotheses to match statements."
 	    (* should tell which ones *)
     | id::rest_ids,(Hvar st | Hprop st)::rest ->
-	tclIFTHENELSE (convert_hyp (id,None,st.st_it))
+	tclIFTHENELSE (Proofview.V82.of_tactic (convert_hyp (id,None,st.st_it)))
 	  begin
 	    match st.st_label with
 		Anonymous ->
 		  consider_match may_intro ((id,false)::introduced) rest_ids rest
 	      | Name hid ->
 		  tclTHENLIST
-		    [rename_hyp [id,hid];
+		    [Proofview.V82.of_tactic (rename_hyp [id,hid]);
 		     consider_match may_intro ((hid,true)::introduced) rest_ids rest]
 	  end
 	  begin
@@ -738,7 +721,7 @@ let rec consider_match may_intro introduced available expected gls =
 		 try conjunction_arity id gls with
 		     Not_found -> error "Matching hypothesis not found." in
 		 tclTHENLIST
-		   [general_case_analysis false (mkVar id,NoBindings);
+		   [Proofview.V82.of_tactic (simplest_case (mkVar id));
 		    intron_then nhyps []
 		      (fun l -> consider_match may_intro introduced
 			 (List.rev_append l rest_ids) expected)] gls)
@@ -750,9 +733,9 @@ let consider_tac c hyps gls =
       Var id ->
 	consider_match false [] [id] hyps gls
     | _ ->
-	let id = pf_get_new_id (id_of_string "_tmp") gls in
+	let id = pf_get_new_id (Id.of_string "_tmp") gls in
 	tclTHEN
-	  (forward None (Some (dummy_loc, Genarg.IntroIdentifier id)) c)
+	  (Proofview.V82.of_tactic (pose_proof (Name id) c))
  	  (consider_match false [] [id] hyps) gls
 
 
@@ -783,7 +766,7 @@ let rec build_function args body =
 
 let define_tac id args body gls =
   let t = build_function args body in
-    letin_tac None (Name id) t None Tacexpr.nowhere gls
+    Proofview.V82.of_tactic (letin_tac None (Name id) t None Locusops.nowhere) gls
 
 (* tactics for reconsider *)
 
@@ -791,11 +774,11 @@ let cast_tac id_or_thesis typ gls =
   match id_or_thesis with
       This id ->
 	let (_,body,_) = pf_get_hyp gls id in
-	  convert_hyp (id,body,typ) gls
+	  Proofview.V82.of_tactic (convert_hyp (id,body,typ)) gls
     | Thesis (For _ ) ->
 	error "\"thesis for ...\" is not applicable here."
     | Thesis Plain ->
-          convert_concl typ DEFAULTcast gls
+          Proofview.V82.of_tactic (convert_concl typ DEFAULTcast) gls
 
 (* per cases *)
 
@@ -804,7 +787,7 @@ let is_rec_pos (main_ind,wft) =
       None -> false
     | Some index ->
 	match fst (Rtree.dest_node wft) with
-	    Mrec (_,i) when i = index -> true
+	    Mrec (_,i) when Int.equal i index -> true
 	  | _ -> false
 
 let rec constr_trees (main_ind,wft) ind =
@@ -841,7 +824,7 @@ let map_tree id_fun mapi = function
 
 
 let start_tree env ind rp =
-  init_tree Idset.empty ind rp (fun _ _ -> None)
+  init_tree Id.Set.empty ind rp (fun _ _ -> None)
 
 let build_per_info etype casee gls =
   let concl=pf_concl gls in
@@ -849,17 +832,17 @@ let build_per_info etype casee gls =
   let ctyp=pf_type_of gls casee in
   let is_dep = dependent casee concl in
   let hd,args = decompose_app (special_whd gls ctyp) in
-  let ind =
+  let (ind,u) =
     try
       destInd hd
-    with e when Errors.noncritical e ->
+    with DestKO ->
       error "Case analysis must be done on an inductive object." in
   let mind,oind = Global.lookup_inductive ind in
   let nparams,index =
     match etype with
 	ET_Induction -> mind.mind_nparams_rec,Some (snd ind)
       | _ -> mind.mind_nparams,None in
-  let params,real_args = list_chop nparams args in
+  let params,real_args = List.chop nparams args in
   let abstract_obj c body =
     let typ=pf_type_of gls c in
       lambda_create env (typ,subst_term c body) in
@@ -889,8 +872,8 @@ let per_tac etype casee gls=
 	      {pm_stack=
 		  Per(etype,per_info,ek,[])::info.pm_stack} gls
       | Virtual cut ->
-	  assert (cut.cut_stat.st_label=Anonymous);
-	  let id = pf_get_new_id (id_of_string "anonymous_matched") gls in
+	  assert (cut.cut_stat.st_label == Anonymous);
+	  let id = pf_get_new_id (Id.of_string "anonymous_matched") gls in
 	  let c = mkVar id in
 	  let modified_cut =
 	    {cut with cut_stat={cut.cut_stat with st_label=Name id}} in
@@ -914,17 +897,17 @@ let register_nodep_subcase id= function
 	  | EK_nodep -> clauses,Per(et,pi,EK_nodep,id::clauses)::s
 	  | EK_dep _ -> error "Do not mix \"suppose\" with \"suppose it is\"."
       end
-  | _ -> anomaly "wrong stack state"
+  | _ -> anomaly (Pp.str "wrong stack state")
 
 let suppose_tac hyps gls0 =
   let info = get_its_info gls0 in
   let thesis = pf_concl gls0 in
-  let id = pf_get_new_id (id_of_string "subcase_") gls0 in
+  let id = pf_get_new_id (Id.of_string "subcase_") gls0 in
   let clause = build_product hyps thesis in
   let ninfo1 = {pm_stack=Suppose_case::info.pm_stack} in
   let old_clauses,stack = register_nodep_subcase id info.pm_stack in
   let ninfo2 = {pm_stack=stack} in
-    tclTHENS (assert_postpone id clause)
+    tclTHENS (Proofview.V82.of_tactic (assert_postpone id clause))
       [tclTHENLIST [tcl_change_info ninfo1;
 		    assume_tac hyps;
 		    clear old_clauses];
@@ -949,17 +932,17 @@ let rec tree_of_pats ((id,_) as cpl) pats =
 	  | (patt,rp) :: rest_args ->
 	      match patt with
 		  PatVar (_,v) ->
-		    Skip_patt (Idset.singleton id,
+		    Skip_patt (Id.Set.singleton id,
 			       tree_of_pats cpl (rest_args::stack))
 		| PatCstr (_,(ind,cnum),args,nam) ->
 		    let nexti i ati =
-		      if i = pred cnum then
+		      if Int.equal i (pred cnum) then
 			let nargs =
-			  list_map_i (fun j a -> (a,ati.(j))) 0 args in
-			  Some (Idset.singleton id,
+			  List.map_i (fun j a -> (a,ati.(j))) 0 args in
+			  Some (Id.Set.singleton id,
 				tree_of_pats cpl (nargs::rest_args::stack))
 		      else None
-		      in init_tree Idset.empty ind rp nexti
+		      in init_tree Id.Set.empty ind rp nexti
 
 let rec add_branch ((id,_) as cpl) pats tree=
   match pats with
@@ -968,7 +951,7 @@ let rec add_branch ((id,_) as cpl) pats tree=
 	  match tree with
 	      End_patt cpl0 -> End_patt cpl0
 		(* this ensures precedence for overlapping patterns *)
-	    | _ -> anomaly "tree is expected to end here"
+	    | _ -> anomaly (Pp.str "tree is expected to end here")
 	end
     | args::stack ->
 	match args with
@@ -977,7 +960,7 @@ let rec add_branch ((id,_) as cpl) pats tree=
 		match tree with
 		   Close_patt t ->
 		     Close_patt (add_branch cpl stack t)
-		  | _ -> anomaly "we should pop here"
+		  | _ -> anomaly (Pp.str "we should pop here")
 	      end
 	  | (patt,rp) :: rest_args ->
 	      match patt with
@@ -985,23 +968,23 @@ let rec add_branch ((id,_) as cpl) pats tree=
 		    begin
 		      match tree with
 			  Skip_patt (ids,t) ->
-			    Skip_patt (Idset.add id ids,
+			    Skip_patt (Id.Set.add id ids,
 				       add_branch cpl (rest_args::stack) t)
 			| Split_patt (_,_,_) ->
-			    map_tree (Idset.add id)
+			    map_tree (Id.Set.add id)
 			      (fun i bri ->
 				 append_branch cpl 1 (rest_args::stack) bri)
 			      tree
-			| _ -> anomaly "No pop/stop expected here"
+			| _ -> anomaly (Pp.str "No pop/stop expected here")
 		    end
 		| PatCstr (_,(ind,cnum),args,nam) ->
 		      match tree with
 			Skip_patt (ids,t) ->
 			  let nexti i ati =
-			    if i = pred cnum then
+			    if Int.equal i (pred cnum) then
 			      let nargs =
-				list_map_i (fun j a -> (a,ati.(j))) 0 args in
-				Some (Idset.add id ids,
+				List.map_i (fun j a -> (a,ati.(j))) 0 args in
+				Some (Id.Set.add id ids,
 				      add_branch cpl (nargs::rest_args::stack)
 					(skip_args t ids (Array.length ati)))
 			    else
@@ -1009,57 +992,57 @@ let rec add_branch ((id,_) as cpl) pats tree=
 				    skip_args t ids (Array.length ati))
 			  in init_tree ids ind rp nexti
 		      | Split_patt (_,ind0,_) ->
-			  if (ind <> ind0) then error
+			  if (not (eq_ind ind ind0)) then error
 			    (* this can happen with coercions *)
 	                    "Case pattern belongs to wrong inductive type.";
 			  let mapi i ati bri =
-			    if i = pred cnum then
+			    if Int.equal i (pred cnum) then
 			      let nargs =
-				list_map_i (fun j a -> (a,ati.(j))) 0 args in
+				List.map_i (fun j a -> (a,ati.(j))) 0 args in
 				append_branch cpl 0
 				  (nargs::rest_args::stack) bri
 			    else bri in
 			    map_tree_rp rp (fun ids -> ids) mapi tree
-		      | _ -> anomaly "No pop/stop expected here"
+		      | _ -> anomaly (Pp.str "No pop/stop expected here")
 and append_branch ((id,_) as cpl) depth pats = function
     Some (ids,tree) ->
-      Some (Idset.add id ids,append_tree cpl depth pats tree)
+      Some (Id.Set.add id ids,append_tree cpl depth pats tree)
   | None ->
-      Some (Idset.singleton id,tree_of_pats cpl pats)
+      Some (Id.Set.singleton id,tree_of_pats cpl pats)
 and append_tree ((id,_) as cpl) depth pats tree =
   if depth<=0 then add_branch cpl pats tree
   else match tree with
       Close_patt t ->
 	Close_patt (append_tree cpl (pred depth) pats t)
     | Skip_patt (ids,t) ->
-	Skip_patt (Idset.add id ids,append_tree cpl depth pats t)
-    | End_patt _ -> anomaly "Premature end of branch"
+	Skip_patt (Id.Set.add id ids,append_tree cpl depth pats t)
+    | End_patt _ -> anomaly (Pp.str "Premature end of branch")
     | Split_patt (_,_,_) ->
-	map_tree (Idset.add id)
+	map_tree (Id.Set.add id)
 	  (fun i bri -> append_branch cpl (succ depth) pats bri) tree
 
 (* suppose it is *)
 
 let rec st_assoc id = function
     [] -> raise Not_found
-  | st::_ when st.st_label = id  -> st.st_it
+  | st::_ when Name.equal st.st_label id  -> st.st_it
   | _ :: rest -> st_assoc id rest
 
 let thesis_for obj typ per_info env=
   let rc,hd1=decompose_prod typ in
   let cind,all_args=decompose_app typ in
-  let ind = destInd cind in
-  let _ = if ind <> per_info.per_ind then
+  let ind,u = destInd cind in
+  let _ = if not (eq_ind ind per_info.per_ind) then
     errorlabstrm "thesis_for"
-      ((Printer.pr_constr_env env obj) ++ spc () ++
+      ((Printer.pr_constr_env env Evd.empty obj) ++ spc () ++
 	 str"cannot give an induction hypothesis (wrong inductive type).") in
-  let params,args = list_chop per_info.per_nparams all_args in
+  let params,args = List.chop per_info.per_nparams all_args in
   let _ = if not (List.for_all2 eq_constr params per_info.per_params) then
     errorlabstrm "thesis_for"
-      ((Printer.pr_constr_env env obj) ++ spc () ++
+      ((Printer.pr_constr_env env Evd.empty obj) ++ spc () ++
 	 str "cannot give an induction hypothesis (wrong parameters).") in
   let hd2 = (applist ((lift (List.length rc) per_info.per_pred),args@[obj])) in
-    compose_prod rc (whd_beta Evd.empty hd2)
+    compose_prod rc (Reductionops.whd_beta Evd.empty hd2)
 
 let rec build_product_dep pat_info per_info args body gls =
   match args with
@@ -1119,18 +1102,18 @@ let rec register_dep_subcase id env per_info pat = function
 
 let case_tac params pat_info hyps gls0 =
   let info = get_its_info gls0 in
-  let id = pf_get_new_id (id_of_string "subcase_") gls0 in
+  let id = pf_get_new_id (Id.of_string "subcase_") gls0 in
   let et,per_info,ek,old_clauses,rest =
     match info.pm_stack with
 	Per (et,pi,ek,old_clauses)::rest -> (et,pi,ek,old_clauses,rest)
-      | _ -> anomaly "wrong place for cases" in
+      | _ -> anomaly (Pp.str "wrong place for cases") in
   let clause = build_dep_clause params pat_info per_info hyps gls0 in
   let ninfo1 = {pm_stack=Suppose_case::info.pm_stack} in
   let nek = 
     register_dep_subcase (id,(List.length params,List.length hyps)) 
       (pf_env gls0) per_info pat_info.pat_pat ek in  
   let ninfo2 = {pm_stack=Per(et,per_info,nek,id::old_clauses)::rest} in
-    tclTHENS (assert_postpone id clause)
+    tclTHENS (Proofview.V82.of_tactic (assert_postpone id clause))
       [tclTHENLIST
 	 [tcl_change_info ninfo1;
 	  assume_st (params@pat_info.pat_vars);
@@ -1141,14 +1124,14 @@ let case_tac params pat_info hyps gls0 =
 
 (* end cases *)
 
-type instance_stack =
-    (constr option*(constr list) list) list
+type ('a, 'b) instance_stack =
+    ('b * (('a option * constr list) list)) list
 
-let initial_instance_stack ids =
+let initial_instance_stack ids : (_, _) instance_stack =
   List.map (fun id -> id,[None,[]]) ids
 
 let push_one_arg arg = function
-    [] -> anomaly "impossible"
+    [] -> anomaly (Pp.str "impossible")
   | (head,args) :: ctx ->
       ((head,(arg::args)) :: ctx)
 
@@ -1157,7 +1140,7 @@ let push_arg arg stacks =
 
 
 let push_one_head c ids (id,stack) =
-  let head = if Idset.mem id ids then Some c else None in
+  let head = if Id.Set.mem id ids then Some c else None in
     id,(head,[]) :: stack
 
 let push_head c ids stacks =
@@ -1166,7 +1149,7 @@ let push_head c ids stacks =
 let pop_one (id,stack) =
   let nstack=
     match stack with
-	[] -> anomaly "impossible"
+	[] -> anomaly (Pp.str "impossible")
       | [c] as l -> l
       | (Some head,args)::(head0,args0)::ctx ->
 	  let arg = applist (head,(List.rev args)) in
@@ -1183,13 +1166,13 @@ let hrec_for fix_id per_info gls obj_id =
   let typ=pf_get_hyp_typ gls obj_id in
   let rc,hd1=decompose_prod typ in
   let cind,all_args=decompose_app typ in
-  let ind = destInd cind in assert (ind=per_info.per_ind);
-  let params,args= list_chop per_info.per_nparams all_args in
+  let ind,u = destInd cind in assert (eq_ind ind per_info.per_ind);
+  let params,args= List.chop per_info.per_nparams all_args in
   assert begin
     try List.for_all2 eq_constr params per_info.per_params with
         Invalid_argument _ -> false end;
   let hd2 = applist (mkVar fix_id,args@[obj]) in
-    compose_lam rc (whd_beta gls.sigma hd2)
+    compose_lam rc (Reductionops.whd_beta gls.sigma hd2)
 
 
 let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls =
@@ -1202,18 +1185,18 @@ let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls =
 	  execute_cases fix_name per_info tacnext args0 next_objs nhrec t gls
     | End_patt (id,(nparams,nhyps)),[] -> 
 	begin
-	  match List.assoc id args with
+	  match Id.List.assoc id args with
 	      [None,br_args] -> 
 		let all_metas = 
-		  list_tabulate (fun n -> mkMeta (succ n)) (nparams + nhyps)  in
-		let param_metas,hyp_metas = list_chop nparams all_metas in
+		  List.init (nparams + nhyps) (fun n -> mkMeta (succ n))  in
+		let param_metas,hyp_metas = List.chop nparams all_metas in
 		  tclTHEN
-		    (tclDO nhrec introf)
+		    (tclDO nhrec (Proofview.V82.of_tactic introf))
 		    (tacnext 
 		       (applist (mkVar id,
 				 List.append param_metas 
 				   (List.rev_append br_args hyp_metas)))) gls
-	    | _ -> anomaly "wrong stack size"
+	    | _ -> anomaly (Pp.str "wrong stack size")
 	end
     | Split_patt (ids,ind,br), casee::next_objs ->
 	let (mind,oind) as spec = Global.lookup_inductive ind in
@@ -1222,18 +1205,19 @@ let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls =
 	let env=pf_env gls in
 	let ctyp=pf_type_of gls casee in
 	let hd,all_args = decompose_app (special_whd gls ctyp) in
-	let _ = assert (destInd hd = ind) in (* just in case *)
-	let params,real_args = list_chop nparams all_args in
+	let ind', u = destInd hd in
+	let _ = assert (eq_ind ind' ind) in (* just in case *)
+	let params,real_args = List.chop nparams all_args in
 	let abstract_obj c body =
 	  let typ=pf_type_of gls c in
 	    lambda_create env (typ,subst_term c body) in
 	let elim_pred = List.fold_right abstract_obj
 	  real_args (lambda_create env (ctyp,subst_term casee concl)) in
 	let case_info = Inductiveops.make_case_info env ind RegularStyle in
-	let gen_arities = Inductive.arities_of_constructors ind spec in
+	let gen_arities = Inductive.arities_of_constructors (ind,u) spec in
 	let f_ids typ =
 	  let sign =
-	    (prod_assum (Term.prod_applist typ params)) in
+	    (prod_assum (prod_applist typ params)) in
 	    find_intro_names sign gls in
 	let constr_args_ids = Array.map f_ids gen_arities in
 	let case_term =
@@ -1243,7 +1227,7 @@ let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls =
 	  let args_ids = constr_args_ids.(i) in
 	  let rec aux n = function
 	      [] ->
-		assert (n=Array.length recargs);
+		assert (Int.equal n (Array.length recargs));
 		next_objs,[],nhrec
 	    | id :: q ->
 		let objs,recs,nrec = aux (succ n) q in
@@ -1252,7 +1236,7 @@ let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls =
 		  else (mkVar id::objs),recs,nrec in
 	  let objs,recs,nhrec = aux 0 args_ids in
 	    tclTHENLIST
-	      [tclMAP intro_mustbe_force args_ids;
+	      [tclMAP (fun id -> Proofview.V82.of_tactic (intro_mustbe_force id)) args_ids;
 	       begin
 		 fun gls1 ->
 		   let hrecs =
@@ -1269,7 +1253,7 @@ let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls =
 		 | Some (sub_ids,tree) ->
 		     let br_args =
 		       List.filter
-			 (fun (id,_) -> Idset.mem id sub_ids) args in
+			 (fun (id,_) -> Id.Set.mem id sub_ids) args in
 		     let construct =
 		       applist (mkConstruct(ind,succ i),params) in
 		     let p_args =
@@ -1280,22 +1264,24 @@ let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls =
 	    (refine case_term)
 	    (Array.mapi branch_tac br) gls
     | Split_patt (_, _, _) , [] ->
-	anomaly "execute_cases : Nothing to split"
+	anomaly ~label:"execute_cases " (Pp.str "Nothing to split")
     | Skip_patt _ , [] ->
-	anomaly "execute_cases : Nothing to skip"
+	anomaly ~label:"execute_cases " (Pp.str "Nothing to skip")
     | End_patt (_,_) , _ :: _  ->
-	anomaly "execute_cases : End of branch with garbage left"
-
-let understand_my_constr c gls =
-  let env = pf_env gls in
-  let nc = names_of_rel_context env in
-  let rawc = Detyping.detype false [] nc c in
-  let rec frob = function GEvar _ -> GHole (dummy_loc,QuestionMark Expand) | rc ->  map_glob_constr frob rc in
-    Pretyping.Default.understand_tcc (sig_sig gls) env ~expected_type:(pf_concl gls) (frob rawc)
+	anomaly ~label:"execute_cases " (Pp.str "End of branch with garbage left")
+
+let understand_my_constr env sigma c concl =
+  let env = env in
+  let rawc = Detyping.detype false [] env Evd.empty c in
+  let rec frob = function
+    | GEvar _ -> GHole (Loc.ghost,Evar_kinds.QuestionMark Evar_kinds.Expand,Misctypes.IntroAnonymous,None)
+    | rc ->  map_glob_constr frob rc
+  in
+  Pretyping.understand_tcc env sigma ~expected_type:(Pretyping.OfType concl) (frob rawc)
 
 let my_refine c gls =
-  let oc = understand_my_constr c gls in
-  Refine.refine oc gls
+  let oc sigma = understand_my_constr (pf_env gls) sigma c (pf_concl gls) in
+  Proofview.V82.of_tactic (Tactics.New.refine oc) gls
 
 (* end focus/claim *)
 
@@ -1304,43 +1290,41 @@ let end_tac et2 gls =
   let et1,pi,ek,clauses =
     match info.pm_stack with
 	Suppose_case::_ ->
-	  anomaly "This case should already be trapped"
+	  anomaly (Pp.str "This case should already be trapped")
       | Claim::_ ->
 	  error "\"end claim\" expected."
       | Focus_claim::_ ->
 	  error "\"end focus\" expected."
       | Per(et',pi,ek,clauses)::_ -> (et',pi,ek,clauses)
       | [] ->
-	  anomaly "This case should already be trapped" in
-  let et =
-    if et1 <> et2 then
-      match et1 with
-	  ET_Case_analysis ->
-	    error "\"end cases\" expected."
-	| ET_Induction ->
-	    error "\"end induction\" expected."
-    else et1 in
+	  anomaly (Pp.str "This case should already be trapped") in
+  let et = match et1, et2 with
+  | ET_Case_analysis, ET_Case_analysis -> et1
+  | ET_Induction, ET_Induction -> et1
+  | ET_Case_analysis, _ -> error "\"end cases\" expected."
+  | ET_Induction, _ -> error "\"end induction\" expected."
+  in
     tclTHEN
       tcl_erase_info
       begin
 	match et,ek with
 	    _,EK_unknown ->
-	      tclSOLVE [simplest_elim pi.per_casee]
+	      tclSOLVE [Proofview.V82.of_tactic (simplest_elim pi.per_casee)]
 	  | ET_Case_analysis,EK_nodep ->
 	      tclTHEN
-		(general_case_analysis false (pi.per_casee,NoBindings))
+		(Proofview.V82.of_tactic (simplest_case pi.per_casee))
 		(default_justification (List.map mkVar clauses))
 	  | ET_Induction,EK_nodep ->
 	      tclTHENLIST
 		[generalize (pi.per_args@[pi.per_casee]);
-		 simple_induct (AnonHyp (succ (List.length pi.per_args)));
+		 Proofview.V82.of_tactic (simple_induct (AnonHyp (succ (List.length pi.per_args))));
 		 default_justification (List.map mkVar clauses)]
 	  | ET_Case_analysis,EK_dep tree ->
 		 execute_cases Anonymous pi 
 		   (fun c -> tclTHENLIST 
 		      [my_refine c;
 		       clear clauses;
-		       justification assumption])
+		       justification (Proofview.V82.of_tactic assumption)])
 		   (initial_instance_stack clauses) [pi.per_casee] 0 tree
 	  | ET_Induction,EK_dep tree ->
 	      let nargs = (List.length pi.per_args) in
@@ -1348,20 +1332,20 @@ let end_tac et2 gls =
 		  begin
 		    fun gls0 ->
 		      let fix_id =
-			pf_get_new_id (id_of_string "_fix") gls0 in
+			pf_get_new_id (Id.of_string "_fix") gls0 in
 		      let c_id =
-			pf_get_new_id (id_of_string "_main_arg") gls0 in
+			pf_get_new_id (Id.of_string "_main_arg") gls0 in
 			tclTHENLIST
 			  [fix (Some fix_id) (succ nargs);
-			   tclDO nargs introf;
-			   intro_mustbe_force c_id;
+			   tclDO nargs (Proofview.V82.of_tactic introf);
+			   Proofview.V82.of_tactic (intro_mustbe_force c_id);
 			   execute_cases (Name fix_id) pi
 			     (fun c ->
 				tclTHENLIST
 				  [clear [fix_id];
 				   my_refine c;
 				   clear clauses;
-				   justification assumption])
+				   justification (Proofview.V82.of_tactic assumption)])
 			     (initial_instance_stack clauses)
 			     [mkVar c_id]  0 tree] gls0
 		  end
@@ -1409,7 +1393,7 @@ let rec do_proof_instr_gen _thus _then instr =
     | Psuppose hyps      -> suppose_tac hyps
     | Pcase (params,pat_info,hyps) -> case_tac params pat_info hyps
     | Pend (B_elim et) -> end_tac et
-    | Pend _ -> anomaly "Not applicable"
+    | Pend _ -> anomaly (Pp.str "Not applicable")
     | Pescape -> escape_tac
 
 let eval_instr {instr=instr} =
@@ -1454,33 +1438,33 @@ let rec postprocess pts instr =
 	  in
 	    try
 	      Inductiveops.control_only_guard env pfterm;
-	      goto_current_focus_or_top pts
+	      goto_current_focus_or_top ()
  	    with
 		Type_errors.TypeError(env,
 				      Type_errors.IllFormedRecBody(_,_,_,_,_)) ->
-		  anomaly "\"end induction\" generated an ill-formed fixpoint"
+		  anomaly (Pp.str "\"end induction\" generated an ill-formed fixpoint")
 	end
     | Pend _ ->
-	goto_current_focus_or_top (pts)
+	goto_current_focus_or_top ()
 
 let do_instr raw_instr pts =
   let has_tactic = preprocess pts raw_instr.instr in
   begin
     if has_tactic then
-      let { it=gls ; sigma=sigma } = Proof.V82.subgoals pts in
-      let gl = { it=List.hd gls ; sigma=sigma } in
+            let { it=gls ; sigma=sigma; } = Proof.V82.subgoals pts in
+      let gl = { it=List.hd gls ; sigma=sigma; } in
       let env=  pf_env gl in
-      let ist = {ltacvars = ([],[]); ltacrecvars = [];
-		 gsigma = sigma; genv = env} in
+      let ist = {ltacvars = Id.Set.empty; ltacrecvars = Id.Map.empty; genv = env} in
       let glob_instr = intern_proof_instr ist raw_instr in
       let instr =
-	interp_proof_instr (get_its_info gl) sigma env glob_instr in
-      Pfedit.by (tclTHEN (eval_instr instr) clean_tmp)
+	interp_proof_instr (get_its_info gl) env sigma glob_instr in
+      ignore (Pfedit.by (Proofview.V82.tactic (tclTHEN (eval_instr instr) clean_tmp)))
     else () end;
   postprocess pts raw_instr.instr;
   (* spiwack: this should restore a compatible semantics with
      v8.3 where we never stayed focused on 0 goal. *)
-  Decl_mode.maximal_unfocus pts
+  Proof_global.set_proof_mode "Declarative" ;
+  Decl_mode.maximal_unfocus ()
 
 let proof_instr raw_instr =
   let p = Proof_global.give_me_the_proof () in
diff --git a/plugins/decl_mode/decl_proof_instr.mli b/plugins/decl_mode/decl_proof_instr.mli
index 48986c2d..f86bfea7 100644
--- a/plugins/decl_mode/decl_proof_instr.mli
+++ b/plugins/decl_mode/decl_proof_instr.mli
@@ -1,12 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Refiner
 open Names
 open Term
 open Tacmach
@@ -15,9 +14,9 @@ open Decl_mode
 val go_to_proof_mode: unit -> unit
 val return_from_tactic_mode: unit -> unit
 
-val register_automation_tac: tactic -> unit
+val register_automation_tac: unit Proofview.tactic -> unit
 
-val automation_tac : tactic
+val automation_tac : unit Proofview.tactic
 
 val concl_refiner:
   Termops.meta_type_map -> constr -> Proof_type.goal sigma -> constr
@@ -28,27 +27,27 @@ val proof_instr: Decl_expr.raw_proof_instr -> unit
 val tcl_change_info : Decl_mode.pm_info -> tactic
 
 val execute_cases :
-    Names.name ->
+    Name.t ->
     Decl_mode.per_info ->
     (Term.constr -> Proof_type.tactic) ->
-    (Names.Idset.elt * (Term.constr option * Term.constr list) list) list ->
+    (Id.Set.elt * (Term.constr option * Term.constr list) list) list ->
     Term.constr list -> int -> Decl_mode.split_tree -> Proof_type.tactic
 
 val tree_of_pats : 
-  identifier * (int * int) -> (Glob_term.cases_pattern*recpath) list list ->
+  Id.t * (int * int) -> (Glob_term.cases_pattern*recpath) list list ->
   split_tree
 
 val add_branch : 
-  identifier * (int * int) -> (Glob_term.cases_pattern*recpath) list list ->
+  Id.t * (int * int) -> (Glob_term.cases_pattern*recpath) list list ->
   split_tree -> split_tree
 
 val append_branch :
-  identifier *(int * int) -> int -> (Glob_term.cases_pattern*recpath) list list ->
-  (Names.Idset.t * Decl_mode.split_tree) option ->
-  (Names.Idset.t * Decl_mode.split_tree) option
+  Id.t *(int * int) -> int -> (Glob_term.cases_pattern*recpath) list list ->
+  (Id.Set.t * Decl_mode.split_tree) option ->
+  (Id.Set.t * Decl_mode.split_tree) option
 
 val append_tree :
-  identifier * (int * int) -> int -> (Glob_term.cases_pattern*recpath) list list ->
+  Id.t * (int * int) -> int -> (Glob_term.cases_pattern*recpath) list list ->
   split_tree -> split_tree
 
 val build_dep_clause :   Term.types Decl_expr.statement list ->
@@ -58,7 +57,7 @@ val build_dep_clause :   Term.types Decl_expr.statement list ->
     Decl_expr.hyp list -> Proof_type.goal Tacmach.sigma -> Term.types
 
 val register_dep_subcase :    
-    Names.identifier * (int * int) ->
+    Id.t * (int * int) ->
     Environ.env ->
     Decl_mode.per_info ->
     Glob_term.cases_pattern -> Decl_mode.elim_kind -> Decl_mode.elim_kind
@@ -69,41 +68,41 @@ val thesis_for :     Term.constr ->
 val close_previous_case : Proof.proof -> unit
 
 val pop_stacks :
-  (Names.identifier *
+  (Id.t *
      (Term.constr option * Term.constr list) list) list ->
-  (Names.identifier *
+  (Id.t *
      (Term.constr option * Term.constr list) list) list
 
 val push_head :   Term.constr ->
-  Names.Idset.t ->
-  (Names.identifier *
+  Id.Set.t ->
+  (Id.t *
      (Term.constr option * Term.constr list) list) list ->
-  (Names.identifier *
+  (Id.t *
      (Term.constr option * Term.constr list) list) list
 
 val push_arg : Term.constr ->
-  (Names.identifier *
+  (Id.t *
      (Term.constr option * Term.constr list) list) list ->
-  (Names.identifier *
+  (Id.t *
      (Term.constr option * Term.constr list) list) list
 
 val hrec_for:
-    Names.identifier ->
+    Id.t ->
     Decl_mode.per_info -> Proof_type.goal Tacmach.sigma ->
-    Names.identifier -> Term.constr
+    Id.t -> Term.constr
 
 val consider_match :
    bool ->
-    (Names.Idset.elt*bool) list ->
-    Names.Idset.elt list ->
+    (Id.Set.elt*bool) list ->
+    Id.Set.elt list ->
     (Term.types Decl_expr.statement, Term.types) Decl_expr.hyp list ->
     Proof_type.tactic
 
 val init_tree:
-    Names.Idset.t ->
-    Names.inductive ->
+    Id.Set.t ->
+    inductive ->
     int option * Declarations.wf_paths ->
     (int ->
      (int option * Declarations.recarg Rtree.t) array ->
-     (Names.Idset.t * Decl_mode.split_tree) option) ->
+     (Id.Set.t * Decl_mode.split_tree) option) ->
     Decl_mode.split_tree
diff --git a/plugins/decl_mode/g_decl_mode.ml4 b/plugins/decl_mode/g_decl_mode.ml4
index 9a1e00ee..03929b3b 100644
--- a/plugins/decl_mode/g_decl_mode.ml4
+++ b/plugins/decl_mode/g_decl_mode.ml4
@@ -1,35 +1,33 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i camlp4deps: "parsing/grammar.cma" i*)
-
-(* arnaud: veiller à l'aspect tutorial des commentaires *)
+(*i camlp4deps: "grammar/grammar.cma" i*)
 
+open Util
+open Compat
 open Pp
-open Tok
 open Decl_expr
 open Names
-open Term
-open Genarg
 open Pcoq
+open Vernacexpr
+open Tok (* necessary for camlp4 *)
 
 open Pcoq.Constr
 open Pcoq.Tactic
-open Pcoq.Vernac_
 
 let pr_goal gs =
   let (g,sigma) = Goal.V82.nf_evar (Tacmach.project gs) (Evd.sig_it gs) in
-  let env = Goal.V82.unfiltered_env sigma g in
+  let env = Goal.V82.env sigma g in
   let preamb,thesis,penv,pc =
     (str "     *** Declarative Mode ***" ++ fnl ()++fnl ()),
     (str "thesis := "  ++ fnl ()),
-    Printer.pr_context_of env,
-    Printer.pr_goal_concl_style_env env (Goal.V82.concl sigma g)
+    Printer.pr_context_of env sigma,
+    Printer.pr_goal_concl_style_env env sigma (Goal.V82.concl sigma g)
   in
     preamb ++
     str"  " ++ hv 0 (penv ++ fnl () ++
@@ -37,7 +35,7 @@ let pr_goal gs =
 		       str "============================" ++ fnl ()  ++
 		       thesis ++ str " " ++  pc) ++ fnl ()
 
-(* arnaud: rebrancher ça 
+(* arnaud: rebrancher ça ?
 let pr_open_subgoals () =
   let p = Proof_global.give_me_the_proof () in
   let { Evd.it = goals ; sigma = sigma } = Proof.V82.subgoals p in
@@ -45,29 +43,27 @@ let pr_open_subgoals () =
   pr_subgoals close_cmd sigma goals
 *)
 
-let pr_proof_instr instr = 
-  Util.anomaly "Cannot print a proof_instr"
+let pr_raw_proof_instr _ _ _ instr =
+  Errors.anomaly (Pp.str "Cannot print a proof_instr")
     (* arnaud: Il nous faut quelque chose de type extr_genarg_printer si on veut aller
                      dans cette direction
        Ppdecl_proof.pr_proof_instr (Global.env()) instr
     *)
-let pr_raw_proof_instr instr =
-  Util.anomaly "Cannot print a raw proof_instr"
-let pr_glob_proof_instr instr =
-  Util.anomaly "Cannot print a non-interpreted proof_instr"
+let pr_proof_instr _ _ _ instr = Empty.abort instr
+let pr_glob_proof_instr _ _ _ instr = Empty.abort instr
 
 let interp_proof_instr _ { Evd.it = gl ; sigma = sigma }=
   Decl_interp.interp_proof_instr 
     (Decl_mode.get_info sigma gl)
-    (sigma)
     (Goal.V82.env sigma gl)
+    (sigma)
 
 let vernac_decl_proof () = 
   let pf = Proof_global.give_me_the_proof () in
   if Proof.is_done pf then 
-    Util.error "Nothing left to prove here."
+    Errors.error "Nothing left to prove here."
   else
-    Proof.transaction pf begin fun () ->
+    begin
       Decl_proof_instr.go_to_proof_mode () ;
       Proof_global.set_proof_mode "Declarative" ;
       Vernacentries.print_subgoals ()
@@ -75,24 +71,18 @@ let vernac_decl_proof () =
 
 (* spiwack: some bureaucracy is not performed here *)
 let vernac_return () =
-  Proof.transaction (Proof_global.give_me_the_proof ()) begin fun () ->
+  begin
     Decl_proof_instr.return_from_tactic_mode () ;
     Proof_global.set_proof_mode "Declarative" ;
     Vernacentries.print_subgoals ()
   end
 
 let vernac_proof_instr instr =
-  Proof.transaction (Proof_global.give_me_the_proof ()) begin fun () ->
+  begin
     Decl_proof_instr.proof_instr instr;
     Vernacentries.print_subgoals ()
   end
 
-(* We create a new parser entry [proof_mode]. The Declarative proof mode
-    will replace the normal parser entry for tactics with this one. *)
-let proof_mode = Gram.entry_create "vernac:proof_command"
-(* Auxiliary grammar entry. *)
-let proof_instr = Gram.entry_create "proofmode:instr"
-
 (* Before we can write an new toplevel command (see below) 
     which takes a [proof_instr] as argument, we need to declare
     how to parse it, print it, globalise it and interprete it.
@@ -101,33 +91,28 @@ let proof_instr = Gram.entry_create "proofmode:instr"
     indirect through the [proof_instr] grammar entry. *)
 (* spiwack: proposal: doing that directly from argextend.ml4, maybe ? *)
 
-(* [Genarg.create_arg] creates a new embedding into Genarg. *)
-let (wit_proof_instr,globwit_proof_instr,rawwit_proof_instr) =
-  Genarg.create_arg None "proof_instr"
-let _ = Tacinterp.add_interp_genarg "proof_instr"
-  begin
-  begin fun e x -> (* declares the globalisation function *)
-    Genarg.in_gen globwit_proof_instr 
-      (Decl_interp.intern_proof_instr e (Genarg.out_gen rawwit_proof_instr x))
-  end,
-  begin fun ist gl x -> (* declares the interpretation function *)
-    Tacmach.project gl ,
-    Genarg.in_gen wit_proof_instr 
-      (interp_proof_instr ist gl (Genarg.out_gen globwit_proof_instr x))
-  end,
-  begin fun _ x -> x end (* declares the substitution function, irrelevant in our case *)
-   end
+(* Only declared at raw level, because only used in vernac commands. *)
+let wit_proof_instr : (raw_proof_instr, Empty.t, Empty.t) Genarg.genarg_type =
+  Genarg.make0 None "proof_instr"
+
+(* We create a new parser entry [proof_mode]. The Declarative proof mode
+    will replace the normal parser entry for tactics with this one. *)
+let proof_mode : vernac_expr Gram.entry =
+  Gram.entry_create "vernac:proof_command"
+(* Auxiliary grammar entry. *)
+let proof_instr : raw_proof_instr Gram.entry =
+  Pcoq.create_generic_entry "proof_instr" (Genarg.rawwit wit_proof_instr)
 
-let _ = Pptactic.declare_extra_genarg_pprule
-  (rawwit_proof_instr, pr_raw_proof_instr)
-  (globwit_proof_instr, pr_glob_proof_instr)
-  (wit_proof_instr, pr_proof_instr)
+let _ = Pptactic.declare_extra_genarg_pprule wit_proof_instr
+  pr_raw_proof_instr pr_glob_proof_instr pr_proof_instr
+
+let classify_proof_instr _ = VtProofStep false, VtLater
 
 (* We use the VERNAC EXTEND facility with a custom non-terminal
     to populate [proof_mode] with a new toplevel interpreter.
     The "-" indicates that the rule does not start with a distinguished
     string. *)
-VERNAC proof_mode EXTEND ProofInstr
+VERNAC proof_mode EXTEND ProofInstr CLASSIFIED BY classify_proof_instr
   [ - proof_instr(instr) ] -> [ vernac_proof_instr instr ]
 END
 
@@ -140,7 +125,7 @@ GEXTEND Gram
   GLOBAL: proof_mode ;
 
   proof_mode: LAST
-    [ [ c=G_vernac.subgoal_command -> c (Some 1) ] ]
+    [ [ c=G_vernac.subgoal_command -> c (Some (Vernacexpr.SelectNth 1)) ] ]
   ;
 END  
 
@@ -171,12 +156,11 @@ let _ =
 				       end
 				   }
 
-(* Two new vernacular commands *)
 VERNAC COMMAND EXTEND DeclProof
-  [ "proof" ] -> [ vernac_decl_proof () ]
+[ "proof" ] => [ VtProofMode "Declarative", VtNow ] -> [ vernac_decl_proof () ]
 END
 VERNAC COMMAND EXTEND  DeclReturn
-  [ "return" ] -> [ vernac_return () ]
+[ "return" ] => [ VtProofMode "Classic", VtNow ] -> [ vernac_return () ]
 END
 
 let none_is_empty = function
@@ -192,7 +176,7 @@ GLOBAL: proof_instr;
   statement :
     [[ i=ident ; ":" ; c=constr -> {st_label=Name i;st_it=c}
      | i=ident -> {st_label=Anonymous;
-		   st_it=Topconstr.CRef (Libnames.Ident (loc, i))}
+		   st_it=Constrexpr.CRef (Libnames.Ident (!@loc, i), None)}
      | c=constr -> {st_label=Anonymous;st_it=c}
      ]];
   constr_or_thesis :
@@ -205,7 +189,7 @@ GLOBAL: proof_instr;
     |
       [ i=ident ; ":" ; cot=constr_or_thesis -> {st_label=Name i;st_it=cot}
       | i=ident -> {st_label=Anonymous;
-		    st_it=This (Topconstr.CRef (Libnames.Ident (loc, i)))}
+		    st_it=This (Constrexpr.CRef (Libnames.Ident (!@loc, i), None))}
       | c=constr -> {st_label=Anonymous;st_it=This c}
       ]
     ];
@@ -273,7 +257,7 @@ GLOBAL: proof_instr;
   ;
   (* examiner s'il est possible de faire R _ et _ R pour R une relation qcq*)
   loc_id: 
-    [[ id=ident -> fun x -> (loc,(id,x)) ]];
+    [[ id=ident -> fun x -> (!@loc,(id,x)) ]];
   hyp:
     [[ id=loc_id -> id None ;
      | id=loc_id ; ":" ; c=constr -> id (Some c)]]
@@ -405,5 +389,3 @@ GLOBAL: proof_instr;
     [[ e=emphasis;i=bare_proof_instr;"." -> {emph=e;instr=i}]]
   ;
 END;;
-
- 
diff --git a/plugins/decl_mode/ppdecl_proof.ml b/plugins/decl_mode/ppdecl_proof.ml
index 102da8cc..27308666 100644
--- a/plugins/decl_mode/ppdecl_proof.ml
+++ b/plugins/decl_mode/ppdecl_proof.ml
@@ -1,12 +1,12 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Util
+open Errors
 open Pp
 open Decl_expr
 open Names
@@ -20,6 +20,8 @@ let pr_label = function
     Anonymous -> mt ()
   | Name id -> pr_id id ++ spc () ++ str ":" ++ spc ()
 
+let pr_constr env c = pr_constr env Evd.empty c
+
 let pr_justification_items env = function
     Some [] -> mt ()
   | Some (_::_ as l) ->
@@ -75,7 +77,7 @@ and print_vars pconstr gtyp env sep _be _have vars =
       begin
 	let nenv =
 	  match st.st_label with
-	      Anonymous -> anomaly "anonymous variable"
+	      Anonymous -> anomaly (Pp.str "anonymous variable")
 	    | Name id -> Environ.push_named (id,None,st.st_it) env in
 	let pr_sep = if sep then pr_comma () else mt () in
 		spc() ++ pr_sep ++
@@ -173,14 +175,14 @@ let rec pr_bare_proof_instr _then _thus env = function
       str "per" ++ spc () ++ pr_elim_type et ++ spc () ++
       pr_casee env c
   | Pend (B_elim et) -> str "end" ++ spc () ++ pr_elim_type et
-  | _ -> anomaly "unprintable instruction"
+  | _ -> anomaly (Pp.str "unprintable instruction")
 
 let pr_emph = function
     0 -> str "    "
   | 1 -> str "*   "
   | 2 -> str "**  "
   | 3 -> str "*** "
-  | _ -> anomaly "unknown emphasis"
+  | _ -> anomaly (Pp.str "unknown emphasis")
 
 let pr_proof_instr env instr =
   pr_emph instr.emph ++ spc () ++
diff --git a/plugins/derive/Derive.v b/plugins/derive/Derive.v
new file mode 100644
index 00000000..0d5a93b0
--- /dev/null
+++ b/plugins/derive/Derive.v
@@ -0,0 +1 @@
+Declare ML Module "derive_plugin".
\ No newline at end of file
diff --git a/plugins/derive/derive.ml b/plugins/derive/derive.ml
new file mode 100644
index 00000000..439b1a5c
--- /dev/null
+++ b/plugins/derive/derive.ml
@@ -0,0 +1,104 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+let map_const_entry_body (f:Term.constr->Term.constr) (x:Entries.const_entry_body)
+    : Entries.const_entry_body =
+  Future.chain ~pure:true x begin fun ((b,ctx),fx) ->
+    (f b , ctx) , fx
+  end
+
+(** [start_deriving f suchthat lemma] starts a proof of [suchthat]
+    (which can contain references to [f]) in the context extended by
+    [f:=?x]. When the proof ends, [f] is defined as the value of [?x]
+    and [lemma] as the proof. *)
+let start_deriving f suchthat lemma =
+
+  let env = Global.env () in
+  let sigma = Evd.from_env env in
+  let kind = Decl_kinds.(Global,false,DefinitionBody Definition) in
+
+  (** create a sort variable for the type of [f] *)
+  (* spiwack: I don't know what the rigidity flag does, picked the one
+     that looked the most general. *)
+  let (sigma,f_type_sort) = Evd.new_sort_variable Evd.univ_flexible_alg sigma in
+  let f_type_type = Term.mkSort f_type_sort in
+  (** create the initial goals for the proof: |- Type ; |- ?1 ; f:=?2 |- suchthat *)
+  let goals =
+    let open Proofview in
+        TCons ( env , sigma , f_type_type , (fun sigma f_type ->
+        TCons ( env , sigma , f_type , (fun sigma ef ->
+        let env' = Environ.push_named (f , (Some ef) , f_type) env in
+        let evdref = ref sigma in
+        let suchthat = Constrintern.interp_type_evars env' evdref suchthat in
+        TCons ( env' , !evdref , suchthat , (fun sigma _ ->
+        TNil sigma))))))
+    in
+
+    (** The terminator handles the registering of constants when the proof is closed. *)
+    let terminator com =
+      let open Proof_global in
+      (** Extracts the relevant information from the proof. [Admitted]
+          and [Save] result in user errors. [opaque] is [true] if the
+          proof was concluded by [Qed], and [false] if [Defined]. [f_def]
+          and [lemma_def] correspond to the proof of [f] and of
+          [suchthat], respectively. *)
+      let (opaque,f_def,lemma_def) =
+        match com with
+        | Admitted -> Errors.error"Admitted isn't supported in Derive."
+        | Proved (_,Some _,_) ->
+            Errors.error"Cannot save a proof of Derive with an explicit name."
+        | Proved (opaque, None, obj) ->
+            match Proof_global.(obj.entries) with
+            | [_;f_def;lemma_def] ->
+                opaque , f_def , lemma_def
+            | _ -> assert false
+      in
+      (** The opacity of [f_def] is adjusted to be [false], as it
+          must. Then [f] is declared in the global environment. *)
+      let f_def = { f_def with Entries.const_entry_opaque = false } in
+      let f_def = Entries.DefinitionEntry f_def , Decl_kinds.(IsDefinition Definition) in
+      let f_kn = Declare.declare_constant f f_def in
+      let f_kn_term = Term.mkConst f_kn in
+      (** In the type and body of the proof of [suchthat] there can be
+          references to the variable [f]. It needs to be replaced by
+          references to the constant [f] declared above. This substitution
+          performs this precise action. *)
+      let substf c = Vars.replace_vars [f,f_kn_term] c in
+      (** Extracts the type of the proof of [suchthat]. *)
+      let lemma_pretype =
+        match Entries.(lemma_def.const_entry_type) with
+        | Some t -> t
+        | None -> assert false (* Proof_global always sets type here. *)
+      in
+      (** The references of [f] are subsituted appropriately. *)
+      let lemma_type = substf lemma_pretype in
+      (** The same is done in the body of the proof. *)
+      let lemma_body =
+        map_const_entry_body substf Entries.(lemma_def.const_entry_body)
+      in
+      let lemma_def = let open Entries in { lemma_def with
+        const_entry_body = lemma_body ;
+        const_entry_type = Some lemma_type ;
+        const_entry_opaque = opaque ; }
+      in
+      let lemma_def =
+        Entries.DefinitionEntry lemma_def ,
+        Decl_kinds.(IsProof Proposition)
+      in
+      ignore (Declare.declare_constant lemma lemma_def)
+      in
+
+  let () = Proof_global.start_dependent_proof lemma kind goals terminator in
+  let _ = Proof_global.with_current_proof begin fun _ p ->
+    Proof.run_tactic env Proofview.(tclFOCUS 1 2 shelve) p
+  end in
+  ()
+
+
+
+
diff --git a/plugins/field/LegacyField.v b/plugins/derive/derive.mli
index a5a85790..b49ef6b9 100644
--- a/plugins/field/LegacyField.v
+++ b/plugins/derive/derive.mli
@@ -1,14 +1,13 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-Require Export LegacyField_Compl.
-Require Export LegacyField_Theory.
-Require Export LegacyField_Tactic.
-Declare ML Module "field_plugin".
-
-(* Command declarations are moved to the ML side *)
+(** [start_deriving f suchthat lemma] starts a proof of [suchthat]
+    (which can contain references to [f]) in the context extended by
+    [f:=?x]. When the proof ends, [f] is defined as the value of [?x]
+    and [lemma] as the proof. *)
+val start_deriving : Names.Id.t -> Constrexpr.constr_expr -> Names.Id.t -> unit
diff --git a/plugins/derive/derive_plugin.mllib b/plugins/derive/derive_plugin.mllib
new file mode 100644
index 00000000..5ee0fc6d
--- /dev/null
+++ b/plugins/derive/derive_plugin.mllib
@@ -0,0 +1,2 @@
+Derive
+G_derive
diff --git a/plugins/subtac/subtac_cases.mli b/plugins/derive/g_derive.ml4
index 5ef42b13..c031e3bc 100644
--- a/plugins/subtac/subtac_cases.mli
+++ b/plugins/derive/g_derive.ml4
@@ -1,21 +1,16 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i*)
-open Util
-open Names
-open Term
-open Evd
-open Environ
-open Inductiveops
-open Glob_term
-open Evarutil
-(*i*)
+(*i camlp4deps: "grammar/grammar.cma"  i*)
 
-(*s Compilation of pattern-matching, subtac style. *)
-module Cases_F(C : Coercion.S) : Cases.S
+let classify_derive_command _ = Vernacexpr.(VtStartProof ("Classic",Doesn'tGuaranteeOpacity,[]),VtLater)
+
+VERNAC COMMAND EXTEND Derive CLASSIFIED BY classify_derive_command
+| [ "Derive" ident(f) "SuchThat" constr(suchthat) "As" ident(lemma) ] ->
+     [ Derive.start_deriving f suchthat lemma ]
+END
diff --git a/plugins/derive/vo.itarget b/plugins/derive/vo.itarget
new file mode 100644
index 00000000..b4809821
--- /dev/null
+++ b/plugins/derive/vo.itarget
@@ -0,0 +1 @@
+Derive.vo
\ No newline at end of file
diff --git a/plugins/extraction/ExtrOcamlBasic.v b/plugins/extraction/ExtrOcamlBasic.v
index 3a06c0a3..9dbda821 100644
--- a/plugins/extraction/ExtrOcamlBasic.v
+++ b/plugins/extraction/ExtrOcamlBasic.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/plugins/extraction/ExtrOcamlBigIntConv.v b/plugins/extraction/ExtrOcamlBigIntConv.v
index 78544d44..4cc76d86 100644
--- a/plugins/extraction/ExtrOcamlBigIntConv.v
+++ b/plugins/extraction/ExtrOcamlBigIntConv.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -10,7 +10,7 @@
 
 (** NB: The extracted code should be linked with [nums.cm(x)a]
     from ocaml's stdlib and with the wrapper [big.ml] that
-    simlifies the use of [Big_int] (it could be found in the sources
+    simplifies the use of [Big_int] (it can be found in the sources
     of Coq). *)
 
 Require Import Arith ZArith.
@@ -105,4 +105,4 @@ Definition check :=
 Extraction "/tmp/test.ml" check test.
 
 ... and we check that test=check
-*)
\ No newline at end of file
+*)
diff --git a/plugins/extraction/ExtrOcamlIntConv.v b/plugins/extraction/ExtrOcamlIntConv.v
index 424a42c5..eb43d69f 100644
--- a/plugins/extraction/ExtrOcamlIntConv.v
+++ b/plugins/extraction/ExtrOcamlIntConv.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/plugins/extraction/ExtrOcamlNatBigInt.v b/plugins/extraction/ExtrOcamlNatBigInt.v
index 926b8c6c..1386c2ad 100644
--- a/plugins/extraction/ExtrOcamlNatBigInt.v
+++ b/plugins/extraction/ExtrOcamlNatBigInt.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -13,7 +13,7 @@ Require Import ExtrOcamlBasic.
 
 (** NB: The extracted code should be linked with [nums.cm(x)a]
     from ocaml's stdlib and with the wrapper [big.ml] that
-    simlifies the use of [Big_int] (it could be found in the sources
+    simplifies the use of [Big_int] (it can be found in the sources
     of Coq). *)
 
 (** Disclaimer: trying to obtain efficient certified programs
diff --git a/plugins/extraction/ExtrOcamlNatInt.v b/plugins/extraction/ExtrOcamlNatInt.v
index 105298e0..5f653ee1 100644
--- a/plugins/extraction/ExtrOcamlNatInt.v
+++ b/plugins/extraction/ExtrOcamlNatInt.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/plugins/extraction/ExtrOcamlString.v b/plugins/extraction/ExtrOcamlString.v
index aee3c386..ce8025bf 100644
--- a/plugins/extraction/ExtrOcamlString.v
+++ b/plugins/extraction/ExtrOcamlString.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/plugins/extraction/ExtrOcamlZBigInt.v b/plugins/extraction/ExtrOcamlZBigInt.v
index 6e98a377..3d59669a 100644
--- a/plugins/extraction/ExtrOcamlZBigInt.v
+++ b/plugins/extraction/ExtrOcamlZBigInt.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -13,7 +13,7 @@ Require Import ExtrOcamlBasic.
 
 (** NB: The extracted code should be linked with [nums.cm(x)a]
     from ocaml's stdlib and with the wrapper [big.ml] that
-    simlifies the use of [Big_int] (it could be found in the sources
+    simplifies the use of [Big_int] (it can be found in the sources
     of Coq). *)
 
 (** Disclaimer: trying to obtain efficient certified programs
diff --git a/plugins/extraction/ExtrOcamlZInt.v b/plugins/extraction/ExtrOcamlZInt.v
index ea001c80..79d67495 100644
--- a/plugins/extraction/ExtrOcamlZInt.v
+++ b/plugins/extraction/ExtrOcamlZInt.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -43,7 +43,7 @@ Extract Constant Pos.max => "Pervasives.max".
 Extract Constant Pos.compare =>
  "fun x y -> if x=y then Eq else if x<y then Lt else Gt".
 Extract Constant Pos.compare_cont =>
- "fun x y c -> if x=y then c else if x<y then Lt else Gt".
+ "fun c x y -> if x=y then c else if x<y then Lt else Gt".
 
 
 Extract Constant N.add => "(+)".
diff --git a/plugins/extraction/README b/plugins/extraction/README
index 64c871fd..458ba0de 100644
--- a/plugins/extraction/README
+++ b/plugins/extraction/README
@@ -6,7 +6,7 @@
 What is it ?
 ------------
 
-The extraction is a mechanism allowing to produce functional code
+The extraction is a mechanism that produces functional code
 (Ocaml/Haskell/Scheme) out of any Coq terms (either programs or
 proofs).
 
@@ -14,7 +14,7 @@ Who did it ?
 ------------
 
 The current implementation (from version 7.0 up to now) has been done
-by P. Letouzey during his PhD, helped by J.C. Filliâtre and supervised
+by P. Letouzey during his PhD, helped by J.C. Filliâtre and supervised
 by C. Paulin. 
 
 An earlier implementation (versions 6.x) was due to B. Werner and
@@ -118,7 +118,7 @@ Axioms, and then "Extract Constant ..."
 
 
 [1]:
-Exécution de termes de preuves: une nouvelle méthode d'extraction 
+Exécution de termes de preuves: une nouvelle méthode d'extraction 
 pour le Calcul des Constructions Inductives, Pierre Letouzey,
 DEA thesis, 2000, 
 http://www.pps.jussieu.fr/~letouzey/download/rapport_dea.ps.gz
@@ -129,7 +129,7 @@ Types 2002 Post-Workshop Proceedings.
 http://www.pps.jussieu.fr/~letouzey/download/extraction2002.ps.gz
 
 [3]: 
-Programmation fonctionnelle certifiée: l'extraction de programmes
+Programmation fonctionnelle certifiée: l'extraction de programmes
 dans l'assistant Coq. Pierre Letouzey, PhD thesis, 2004.
 http://www.pps.jussieu.fr/~letouzey/download/these_letouzey.ps.gz
 http://www.pps.jussieu.fr/~letouzey/download/these_letouzey_English.ps.gz
diff --git a/plugins/extraction/big.ml b/plugins/extraction/big.ml
index 2fd0e1b5..f2a965c9 100644
--- a/plugins/extraction/big.ml
+++ b/plugins/extraction/big.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/plugins/extraction/common.ml b/plugins/extraction/common.ml
index 558b8359..21819aa8 100644
--- a/plugins/extraction/common.ml
+++ b/plugins/extraction/common.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -9,23 +9,20 @@
 open Pp
 open Util
 open Names
-open Term
-open Declarations
 open Namegen
 open Nameops
 open Libnames
+open Globnames
 open Table
 open Miniml
 open Mlutil
-open Modutil
-open Mod_subst
 
 let string_of_id id =
-  let s = Names.string_of_id id in
+  let s = Names.Id.to_string id in
   for i = 0 to String.length s - 2 do
-    if s.[i] = '_' && s.[i+1] = '_' then warning_id s
+    if s.[i] == '_' && s.[i+1] == '_' then warning_id s
   done;
-  ascii_of_ident s
+  Unicode.ascii_of_ident s
 
 let is_mp_bound = function MPbound _ -> true | _ -> false
 
@@ -42,7 +39,7 @@ let pp_apply st par args = match args with
 (** Same as [pp_apply], but with also protection of the head by parenthesis *)
 
 let pp_apply2 st par args =
-  let par' = args <> [] || par in
+  let par' = not (List.is_empty args) || par in
   pp_apply (pp_par par' st) par args
 
 let pr_binding = function
@@ -82,20 +79,20 @@ let is_digit = function
 
 let begins_with_CoqXX s =
   let n = String.length s in
-  n >= 4 && s.[0] = 'C' && s.[1] = 'o' && s.[2] = 'q' &&
+  n >= 4 && s.[0] == 'C' && s.[1] == 'o' && s.[2] == 'q' &&
   let i = ref 3 in
   try while !i < n do
-    if s.[!i] = '_' then i:=n (*Stop*)
+    if s.[!i] == '_' then i:=n (*Stop*)
     else if is_digit s.[!i] then incr i
     else raise Not_found
   done; true
   with Not_found -> false
 
 let unquote s =
-  if lang () <> Scheme then s
+  if lang () != Scheme then s
   else
     let s = String.copy s in
-    for i=0 to String.length s - 1 do if s.[i] = '\'' then s.[i] <- '~' done;
+    for i=0 to String.length s - 1 do if s.[i] == '\'' then s.[i] <- '~' done;
     s
 
 let rec qualify delim = function
@@ -112,17 +109,28 @@ let pseudo_qualify = qualify "__"
 let is_upper s = match s.[0] with 'A' .. 'Z' -> true | _ -> false
 let is_lower s = match s.[0] with 'a' .. 'z' | '_' -> true | _ -> false
 
-let lowercase_id id = id_of_string (String.uncapitalize (string_of_id id))
+let lowercase_id id = Id.of_string (String.uncapitalize (string_of_id id))
 let uppercase_id id =
   let s = string_of_id id in
-  assert (s<>"");
-  if s.[0] = '_' then id_of_string ("Coq_"^s)
-  else id_of_string (String.capitalize s)
+  assert (not (String.is_empty s));
+  if s.[0] == '_' then Id.of_string ("Coq_"^s)
+  else Id.of_string (String.capitalize s)
 
 type kind = Term | Type | Cons | Mod
 
+module KOrd =
+struct
+  type t = kind * string
+  let compare (k1, s1) (k2, s2) =
+    let c = Pervasives.compare k1 k2 (** OK *) in
+    if c = 0 then String.compare s1 s2
+    else c
+end
+
+module KMap = Map.Make(KOrd)
+
 let upperkind = function
-  | Type -> lang () = Haskell
+  | Type -> lang () == Haskell
   | Term -> false
   | Cons | Mod -> true
 
@@ -131,12 +139,12 @@ let kindcase_id k id =
 
 (*s de Bruijn environments for programs *)
 
-type env = identifier list * Idset.t
+type env = Id.t list * Id.Set.t
 
 (*s Generic renaming issues for local variable names. *)
 
 let rec rename_id id avoid =
-  if Idset.mem id avoid then rename_id (lift_subscript id) avoid else id
+  if Id.Set.mem id avoid then rename_id (lift_subscript id) avoid else id
 
 let rec rename_vars avoid = function
   | [] ->
@@ -148,14 +156,14 @@ let rec rename_vars avoid = function
   | id :: idl ->
       let (idl, avoid) = rename_vars avoid idl in
       let id = rename_id (lowercase_id id) avoid in
-      (id :: idl, Idset.add id avoid)
+      (id :: idl, Id.Set.add id avoid)
 
 let rename_tvars avoid l =
   let rec rename avoid = function
     | [] -> [],avoid
     | id :: idl ->
 	let id = rename_id (lowercase_id id) avoid in
-	let idl, avoid = rename (Idset.add id avoid) idl in
+	let idl, avoid = rename (Id.Set.add id avoid) idl in
 	(id :: idl, avoid) in
   fst (rename avoid l)
 
@@ -165,7 +173,7 @@ let push_vars ids (db,avoid) =
 
 let get_db_name n (db,_) =
   let id = List.nth db (pred n) in
-  if id = dummy_name then id_of_string "__" else id
+  if Id.equal id dummy_name then Id.of_string "__" else id
 
 
 (*S Renamings of global objects. *)
@@ -182,37 +190,44 @@ let set_phase, get_phase =
   let ph = ref Impl in ((:=) ph), (fun () -> !ph)
 
 let set_keywords, get_keywords =
-  let k = ref Idset.empty in
+  let k = ref Id.Set.empty in
   ((:=) k), (fun () -> !k)
 
 let add_global_ids, get_global_ids =
-  let ids = ref Idset.empty in
+  let ids = ref Id.Set.empty in
   register_cleanup (fun () -> ids := get_keywords ());
-  let add s = ids := Idset.add s !ids
+  let add s = ids := Id.Set.add s !ids
   and get () = !ids
   in (add,get)
 
 let empty_env () = [], get_global_ids ()
 
-let mktable autoclean =
-  let h = Hashtbl.create 97 in
-  if autoclean then register_cleanup (fun () -> Hashtbl.clear h);
-  (Hashtbl.replace h, Hashtbl.find h, fun () -> Hashtbl.clear h)
-
 (* We might have built [global_reference] whose canonical part is
    inaccurate. We must hence compare only the user part,
    hence using a Hashtbl might be incorrect *)
 
+let mktable_id autoclean =
+  let m = ref Id.Map.empty in
+  let clear () = m := Id.Map.empty in
+  if autoclean then register_cleanup clear;
+  (fun r v -> m := Id.Map.add r v !m), (fun r -> Id.Map.find r !m), clear
+
 let mktable_ref autoclean =
   let m = ref Refmap'.empty in
   let clear () = m := Refmap'.empty in
   if autoclean then register_cleanup clear;
   (fun r v -> m := Refmap'.add r v !m), (fun r -> Refmap'.find r !m), clear
 
+let mktable_modpath autoclean =
+  let m = ref MPmap.empty in
+  let clear () = m := MPmap.empty in
+  if autoclean then register_cleanup clear;
+  (fun r v -> m := MPmap.add r v !m), (fun r -> MPmap.find r !m), clear
+
 (* A table recording objects in the first level of all MPfile *)
 
 let add_mpfiles_content,get_mpfiles_content,clear_mpfiles_content =
-  mktable false
+  mktable_modpath false
 
 let get_mpfiles_content mp =
   try get_mpfiles_content mp
@@ -258,7 +273,7 @@ let params_ren_add, params_ren_mem =
 
 type visible_layer = { mp : module_path;
 		       params : module_path list;
-		       content : ((kind*string),label) Hashtbl.t }
+		       mutable content : Label.t KMap.t; }
 
 let pop_visible, push_visible, get_visible =
   let vis = ref [] in
@@ -269,35 +284,47 @@ let pop_visible, push_visible, get_visible =
       | v :: vl ->
 	  vis := vl;
 	  (* we save the 1st-level-content of MPfile for later use *)
-	  if get_phase () = Impl && modular () && is_modfile v.mp
+	  if get_phase () == Impl && modular () && is_modfile v.mp
 	  then add_mpfiles_content v.mp v.content
   and push mp mps =
-    vis := { mp = mp; params = mps; content = Hashtbl.create 97 } :: !vis
+    vis := { mp = mp; params = mps; content = KMap.empty } :: !vis
   and get () = !vis
   in (pop,push,get)
 
 let get_visible_mps () = List.map (function v -> v.mp) (get_visible ())
 let top_visible () = match get_visible () with [] -> assert false | v::_ -> v
 let top_visible_mp () = (top_visible ()).mp
-let add_visible ks l = Hashtbl.add (top_visible ()).content ks l
+let add_visible ks l =
+  let visible = top_visible () in
+  visible.content <- KMap.add ks l visible.content
 
 (* table of local module wrappers used to provide non-ambiguous names *)
 
+module DupOrd =
+struct
+  type t = ModPath.t * Label.t
+  let compare (mp1, l1) (mp2, l2) =
+    let c = Label.compare l1 l2 in
+    if Int.equal c 0 then ModPath.compare mp1 mp2 else c
+end
+
+module DupMap = Map.Make(DupOrd)
+
 let add_duplicate, check_duplicate =
-  let index = ref 0 and dups = ref Gmap.empty in
-  register_cleanup (fun () -> index := 0; dups := Gmap.empty);
+  let index = ref 0 and dups = ref DupMap.empty in
+  register_cleanup (fun () -> index := 0; dups := DupMap.empty);
   let add mp l =
      incr index;
-     let ren = "Coq__" ^ string_of_int (!index) in
-     dups := Gmap.add (mp,l) ren !dups
-  and check mp l = Gmap.find (mp, l) !dups
+     let ren = "Coq__" ^ string_of_int !index in
+     dups := DupMap.add (mp,l) ren !dups
+  and check mp l = DupMap.find (mp, l) !dups
   in (add,check)
 
 type reset_kind = AllButExternal | Everything
 
 let reset_renaming_tables flag =
   do_cleanup ();
-  if flag = Everything then clear_mpfiles_content ()
+  if flag == Everything then clear_mpfiles_content ()
 
 (*S Renaming functions *)
 
@@ -312,8 +339,8 @@ let modular_rename k id =
     if upperkind k then "Coq_",is_upper else "coq_",is_lower
   in
   if not (is_ok s) ||
-    (Idset.mem id (get_keywords ())) ||
-    (String.length s >= 4 && String.sub s 0 4 = prefix)
+    (Id.Set.mem id (get_keywords ())) ||
+    (String.length s >= 4 && String.equal (String.sub s 0 4) prefix)
   then prefix ^ s
   else s
 
@@ -321,10 +348,10 @@ let modular_rename k id =
     with unique numbers *)
 
 let modfstlev_rename =
-  let add_prefixes,get_prefixes,_ = mktable true in
+  let add_prefixes,get_prefixes,_ = mktable_id true in
   fun l ->
-    let coqid = id_of_string "Coq" in
-    let id = id_of_label l in
+    let coqid = Id.of_string "Coq" in
+    let id = Label.to_id l in
     try
       let coqset = get_prefixes id in
       let nextcoq = next_ident_away coqid coqset in
@@ -343,23 +370,26 @@ let rec mp_renaming_fun mp = match mp with
   | _ when not (modular ()) && at_toplevel mp -> [""]
   | MPdot (mp,l) ->
       let lmp = mp_renaming mp in
-      if lmp = [""] then (modfstlev_rename l)::lmp
-      else (modular_rename Mod (id_of_label l))::lmp
+      let mp = match lmp with
+      | [""] -> modfstlev_rename l
+      | _ -> modular_rename Mod (Label.to_id l)
+      in
+      mp ::lmp
   | MPbound mbid ->
-      let s = modular_rename Mod (id_of_mbid mbid) in
+      let s = modular_rename Mod (MBId.to_id mbid) in
       if not (params_ren_mem mp) then [s]
-      else let i,_,_ = repr_mbid mbid in [s^"__"^string_of_int i]
+      else let i,_,_ = MBId.repr mbid in [s^"__"^string_of_int i]
   | MPfile _ ->
       assert (modular ()); (* see [at_toplevel] above *)
-      assert (get_phase () = Pre);
-      let current_mpfile = (list_last (get_visible ())).mp in
-      if mp <> current_mpfile then mpfiles_add mp;
+      assert (get_phase () == Pre);
+      let current_mpfile = (List.last (get_visible ())).mp in
+      if not (ModPath.equal mp current_mpfile) then mpfiles_add mp;
       [string_of_modfile mp]
 
 (* ... and its version using a cache *)
 
 and mp_renaming =
-  let add,get,_ = mktable true in
+  let add,get,_ = mktable_modpath true in
   fun x ->
     try if is_mp_bound (base_mp x) then raise Not_found; get x
     with Not_found -> let y = mp_renaming_fun x in add x y; y
@@ -370,17 +400,17 @@ and mp_renaming =
 let ref_renaming_fun (k,r) =
   let mp = modpath_of_r r in
   let l = mp_renaming mp in
-  let l = if lang () <> Ocaml && not (modular ()) then [""] else l in
+  let l = if lang () != Ocaml && not (modular ()) then [""] else l in
   let s =
     let idg = safe_basename_of_global r in
-    if l = [""] (* this happens only at toplevel of the monolithic case *)
-    then
-      let globs = Idset.elements (get_global_ids ()) in
+    match l with
+    | [""] -> (* this happens only at toplevel of the monolithic case *)
+      let globs = Id.Set.elements (get_global_ids ()) in
       let id = next_ident_away (kindcase_id k idg) globs in
       string_of_id id
-    else modular_rename k idg
+    | _ -> modular_rename k idg
   in
-  add_global_ids (id_of_string s);
+  add_global_ids (Id.of_string s);
   s::l
 
 (* Cached version of the last function *)
@@ -399,27 +429,30 @@ let ref_renaming =
 
 let rec clash mem mp0 ks = function
   | [] -> false
-  | mp :: _ when mp = mp0 -> false
+  | mp :: _ when ModPath.equal mp mp0 -> false
   | mp :: _ when mem mp ks -> true
   | _ :: mpl -> clash mem mp0 ks mpl
 
 let mpfiles_clash mp0 ks =
-  clash (fun mp -> Hashtbl.mem (get_mpfiles_content mp)) mp0 ks
+  clash (fun mp k -> KMap.mem k (get_mpfiles_content mp)) mp0 ks
     (List.rev (mpfiles_list ()))
 
 let rec params_lookup mp0 ks = function
   | [] -> false
-  | param :: _ when mp0 = param -> true
+  | param :: _ when ModPath.equal mp0 param -> true
   | param :: params ->
-      if ks = (Mod, List.hd (mp_renaming param)) then params_ren_add param;
+      let () = match ks with
+      | (Mod, mp) when String.equal (List.hd (mp_renaming param)) mp -> params_ren_add param
+      | _ -> ()
+      in
       params_lookup mp0 ks params
 
 let visible_clash mp0 ks =
   let rec clash = function
     | [] -> false
-    | v :: _ when v.mp = mp0 -> false
+    | v :: _ when ModPath.equal v.mp mp0 -> false
     | v :: vis ->
-	let b = Hashtbl.mem v.content ks in
+	let b = KMap.mem ks v.content in
 	if b && not (is_mp_bound mp0) then true
 	else begin
 	  if b then params_ren_add mp0;
@@ -433,9 +466,9 @@ let visible_clash mp0 ks =
 let visible_clash_dbg mp0 ks =
   let rec clash = function
     | [] -> None
-    | v :: _ when v.mp = mp0 -> None
+    | v :: _ when ModPath.equal v.mp mp0 -> None
     | v :: vis ->
-	try Some (v.mp,Hashtbl.find v.content ks)
+	try Some (v.mp,KMap.find ks v.content)
 	with Not_found ->
 	  if params_lookup mp0 ks v.params then None
 	  else clash vis
@@ -455,7 +488,7 @@ let opened_libraries () =
     let to_open =
       List.filter
 	(fun mp ->
-	   not (List.exists (Hashtbl.mem (get_mpfiles_content mp)) used_ks))
+	   not (List.exists (fun k -> KMap.mem k (get_mpfiles_content mp)) used_ks))
 	used_files
     in
     mpfiles_clear ();
@@ -476,7 +509,7 @@ let opened_libraries () =
 
 let pp_duplicate k' prefix mp rls olab =
   let rls', lbl =
-    if k'<>Mod then
+    if k' != Mod then
       (* Here rls=[s], the ref to print is <prefix>.<s>, and olab<>None *)
       rls, Option.get olab
     else
@@ -485,7 +518,7 @@ let pp_duplicate k' prefix mp rls olab =
   in
   try dottify (check_duplicate prefix lbl :: rls')
   with Not_found ->
-    assert (get_phase () = Pre); (* otherwise it's too late *)
+    assert (get_phase () == Pre); (* otherwise it's too late *)
     add_duplicate prefix lbl; dottify rls
 
 let fstlev_ks k = function
@@ -498,8 +531,8 @@ let fstlev_ks k = function
 
 let pp_ocaml_local k prefix mp rls olab =
   (* what is the largest prefix of [mp] that belongs to [visible]? *)
-  assert (k <> Mod || mp <> prefix); (* mp as whole module isn't in itself *)
-  let rls' = list_skipn (mp_length prefix) rls in
+  assert (k != Mod || not (ModPath.equal mp prefix)); (* mp as whole module isn't in itself *)
+  let rls' = List.skipn (mp_length prefix) rls in
   let k's = fstlev_ks k rls' in
   (* Reference r / module path mp is of the form [<prefix>.s.<...>]. *)
   if not (visible_clash prefix k's) then dottify rls'
@@ -510,7 +543,7 @@ let pp_ocaml_local k prefix mp rls olab =
 
 let pp_ocaml_bound base rls =
   (* clash with a MPbound will be detected and fixed by renaming this MPbound *)
-  if get_phase () = Pre then ignore (visible_clash base (Mod,List.hd rls));
+  if get_phase () == Pre then ignore (visible_clash base (Mod,List.hd rls));
   dottify rls
 
 (* [pp_ocaml_extern] : [mp] isn't local, it is defined in another [MPfile]. *)
@@ -519,7 +552,7 @@ let pp_ocaml_extern k base rls = match rls with
   | [] -> assert false
   | base_s :: rls' ->
       if (not (modular ())) (* Pseudo qualification with "" *)
-	|| (rls' = [])  (* Case of a file A.v used as a module later *)
+	|| (List.is_empty rls')  (* Case of a file A.v used as a module later *)
 	|| (not (mpfiles_mem base)) (* Module not opened *)
 	|| (mpfiles_clash base (fstlev_ks k rls')) (* Conflict in opened files *)
 	|| (visible_clash base (fstlev_ks k rls')) (* Local conflict *)
@@ -549,7 +582,7 @@ let pp_haskell_gen k mp rls = match rls with
   | s::rls' ->
     let str = pseudo_qualify rls' in
     let str = if is_upper str && not (upperkind k) then ("_"^str) else str in
-    let prf = if base_mp mp <> top_visible_mp () then s ^ "." else "" in
+    let prf = if not (ModPath.equal (base_mp mp) (top_visible_mp ())) then s ^ "." else "" in
     prf ^ str
 
 (* Main name printing function for a reference *)
@@ -559,7 +592,7 @@ let pp_global k r =
   assert (List.length ls > 1);
   let s = List.hd ls in
   let mp,_,l = repr_of_r r in
-  if mp = top_visible_mp () then
+  if ModPath.equal mp (top_visible_mp ()) then
     (* simpliest situation: definition of r (or use in the same context) *)
     (* we update the visible environment *)
     (add_visible (k,s) l; unquote s)
@@ -575,7 +608,7 @@ let pp_global k r =
 let pp_module mp =
   let ls = mp_renaming mp in
   match mp with
-    | MPdot (mp0,l) when mp0 = top_visible_mp () ->
+    | MPdot (mp0,l) when ModPath.equal mp0 (top_visible_mp ()) ->
 	(* simpliest situation: definition of mp (or use in the same context) *)
 	(* we update the visible environment *)
 	let s = List.hd ls in
@@ -587,7 +620,7 @@ let pp_module mp =
     the constants are directly turned into chars *)
 
 let mk_ind path s =
-  make_mind (MPfile (dirpath_of_string path)) empty_dirpath (mk_label s)
+  MutInd.make2 (MPfile (dirpath_of_string path)) (Label.make s)
 
 let ind_ascii = mk_ind "Coq.Strings.Ascii" "ascii"
 
@@ -598,7 +631,7 @@ let check_extract_ascii () =
       | Haskell -> "Char"
       | _ -> raise Not_found
     in
-    find_custom (IndRef (ind_ascii,0)) = char_type
+    String.equal (find_custom (IndRef (ind_ascii, 0))) (char_type)
   with Not_found -> false
 
 let is_list_cons l =
@@ -606,14 +639,16 @@ let is_list_cons l =
 
 let is_native_char = function
   | MLcons(_,ConstructRef ((kn,0),1),l) ->
-    kn = ind_ascii && check_extract_ascii () && is_list_cons l
+    MutInd.equal kn ind_ascii && check_extract_ascii () && is_list_cons l
   | _ -> false
 
-let pp_native_char c =
+let get_native_char c =
   let rec cumul = function
     | [] -> 0
     | MLcons(_,ConstructRef(_,j),[])::l -> (2-j) + 2 * (cumul l)
     | _ -> assert false
   in
   let l = match c with MLcons(_,_,l) -> l | _ -> assert false in
-  str ("'"^Char.escaped (Char.chr (cumul l))^"'")
+  Char.chr (cumul l)
+
+let pp_native_char c = str ("'"^Char.escaped (get_native_char c)^"'")
diff --git a/plugins/extraction/common.mli b/plugins/extraction/common.mli
index 7375f2d4..a8ab4fd3 100644
--- a/plugins/extraction/common.mli
+++ b/plugins/extraction/common.mli
@@ -1,15 +1,14 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
 open Names
-open Libnames
+open Globnames
 open Miniml
-open Mlutil
 open Pp
 
 (** By default, in module Format, you can do horizontal placing of blocks
@@ -33,17 +32,17 @@ val pp_tuple_light : (bool -> 'a -> std_ppcmds) -> 'a list -> std_ppcmds
 val pp_tuple : ('a -> std_ppcmds) -> 'a list -> std_ppcmds
 val pp_boxed_tuple : ('a -> std_ppcmds) -> 'a list -> std_ppcmds
 
-val pr_binding : identifier list -> std_ppcmds
+val pr_binding : Id.t list -> std_ppcmds
 
-val rename_id : identifier -> Idset.t -> identifier
+val rename_id : Id.t -> Id.Set.t -> Id.t
 
-type env = identifier list * Idset.t
+type env = Id.t list * Id.Set.t
 val empty_env : unit -> env
 
-val rename_vars: Idset.t -> identifier list -> env
-val rename_tvars: Idset.t -> identifier list -> identifier list
-val push_vars : identifier list -> env -> identifier list * env
-val get_db_name : int -> env -> identifier
+val rename_vars: Id.Set.t -> Id.t list -> env
+val rename_tvars: Id.Set.t -> Id.t list -> Id.t list
+val push_vars : Id.t list -> env -> Id.t list * env
+val get_db_name : int -> env -> Id.t
 
 type phase = Pre | Impl | Intf
 
@@ -63,13 +62,13 @@ val top_visible_mp : unit -> module_path
 val push_visible : module_path -> module_path list -> unit
 val pop_visible : unit -> unit
 
-val check_duplicate : module_path -> label -> string
+val check_duplicate : module_path -> Label.t -> string
 
 type reset_kind = AllButExternal | Everything
 
 val reset_renaming_tables : reset_kind -> unit
 
-val set_keywords : Idset.t -> unit
+val set_keywords : Id.Set.t -> unit
 
 (** For instance: [mk_ind "Coq.Init.Datatypes" "nat"] *)
 
@@ -80,4 +79,5 @@ val mk_ind : string -> string -> mutual_inductive
     the constants are directly turned into chars *)
 
 val is_native_char : ml_ast -> bool
+val get_native_char : ml_ast -> char
 val pp_native_char : ml_ast -> std_ppcmds
diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml
index 84088292..42e69d34 100644
--- a/plugins/extraction/extract_env.ml
+++ b/plugins/extraction/extract_env.ml
@@ -1,18 +1,20 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+open Miniml
 open Term
 open Declarations
 open Names
 open Libnames
+open Globnames
 open Pp
+open Errors
 open Util
-open Miniml
 open Table
 open Extraction
 open Modutil
@@ -24,33 +26,41 @@ open Mod_subst
 (***************************************)
 
 let toplevel_env () =
-  let seg = Lib.contents_after None in
   let get_reference = function
     | (_,kn), Lib.Leaf o ->
 	let mp,_,l = repr_kn kn in
-	let seb = match Libobject.object_tag o with
-	  | "CONSTANT" -> SFBconst (Global.lookup_constant (constant_of_kn kn))
-	  | "INDUCTIVE" -> SFBmind (Global.lookup_mind (mind_of_kn kn))
-	  | "MODULE" -> SFBmodule (Global.lookup_module (MPdot (mp,l)))
+	begin match Libobject.object_tag o with
+	  | "CONSTANT" ->
+            let constant = Global.lookup_constant (constant_of_kn kn) in
+            Some (l, SFBconst constant)
+	  | "INDUCTIVE" ->
+            let inductive = Global.lookup_mind (mind_of_kn kn) in
+            Some (l, SFBmind inductive)
+	  | "MODULE" ->
+            let modl = Global.lookup_module (MPdot (mp, l)) in
+            Some (l, SFBmodule modl)
 	  | "MODULE TYPE" ->
-	      SFBmodtype (Global.lookup_modtype (MPdot (mp,l)))
-	  | _ -> failwith "caught"
-	in l,seb
-    | _ -> failwith "caught"
+            let modtype = Global.lookup_modtype (MPdot (mp, l)) in
+            Some (l, SFBmodtype modtype)
+          | "INCLUDE" -> error "No extraction of toplevel Include yet."
+	  | _ -> None
+        end
+    | _ -> None
   in
-  SEBstruct (List.rev (map_succeed get_reference seg))
+  List.rev (List.map_filter get_reference (Lib.contents ()))
 
 
 let environment_until dir_opt =
   let rec parse = function
-    | [] when dir_opt = None -> [current_toplevel (), toplevel_env ()]
+    | [] when Option.is_empty dir_opt -> [Lib.current_mp (), toplevel_env ()]
     | [] -> []
     | d :: l ->
-	match (Global.lookup_module (MPfile d)).mod_expr with
-	  | Some meb ->
-	      if dir_opt = Some d then [MPfile d, meb]
-	      else (MPfile d, meb) :: (parse l)
-	  | _ -> assert false
+      let meb =
+        Modops.destr_nofunctor (Global.lookup_module (MPfile d)).mod_type
+      in
+      match dir_opt with
+      | Some d' when DirPath.equal d d' -> [MPfile d, meb]
+      | _ -> (MPfile d, meb) :: (parse l)
   in parse (Library.loaded_libraries ())
 
 
@@ -61,16 +71,12 @@ module type VISIT = sig
   (* Reset the dependencies by emptying the visit lists *)
   val reset : unit -> unit
 
-  (* Add the module_path and all its prefixes to the mp visit list *)
-  val add_mp : module_path -> unit
-
-  (* Same, but we'll keep all fields of these modules *)
+  (* Add the module_path and all its prefixes to the mp visit list.
+     We'll keep all fields of these modules. *)
   val add_mp_all : module_path -> unit
 
-  (* Add kernel_name / constant / reference / ... in the visit lists.
+  (* Add reference / ... in the visit lists.
      These functions silently add the mp of their arg in the mp list *)
-  val add_ind : mutual_inductive -> unit
-  val add_con : constant -> unit
   val add_ref : global_reference -> unit
   val add_decl_deps : ml_decl -> unit
   val add_spec_deps : ml_spec -> unit
@@ -84,9 +90,6 @@ module type VISIT = sig
 end
 
 module Visit : VISIT = struct
-  (* What used to be in a single KNset should now be split into a KNset
-     (for inductives and modules names) and a Cset_env for constants
-     (and still the remaining MPset) *)
   type must_visit =
       { mutable ind : KNset.t; mutable con : KNset.t;
 	mutable mp : MPset.t; mutable mp_all : MPset.t }
@@ -122,6 +125,15 @@ module Visit : VISIT = struct
   let add_spec_deps = spec_iter_references add_ref add_ref add_ref
 end
 
+let add_field_label mp = function
+  | (lab, SFBconst _) -> Visit.add_ref (ConstRef (Constant.make2 mp lab))
+  | (lab, SFBmind _) -> Visit.add_ref (IndRef (MutInd.make2 mp lab, 0))
+  | (lab, (SFBmodule _|SFBmodtype _)) -> Visit.add_mp_all (MPdot (mp,lab))
+
+let rec add_labels mp = function
+  | MoreFunctor (_,_,m) -> add_labels mp m
+  | NoFunctor sign -> List.iter (add_field_label mp) sign
+
 exception Impossible
 
 let check_arity env cb =
@@ -131,31 +143,31 @@ let check_arity env cb =
 let check_fix env cb i =
   match cb.const_body with
     | Def lbody ->
-	(match kind_of_term (Declarations.force lbody) with
-	  | Fix ((_,j),recd) when i=j -> check_arity env cb; (true,recd)
-	  | CoFix (j,recd) when i=j -> check_arity env cb; (false,recd)
+	(match kind_of_term (Mod_subst.force_constr lbody) with
+	  | Fix ((_,j),recd) when Int.equal i j -> check_arity env cb; (true,recd)
+	  | CoFix (j,recd) when Int.equal i j -> check_arity env cb; (false,recd)
 	  | _ -> raise Impossible)
     | Undef _ | OpaqueDef _ -> raise Impossible
 
 let prec_declaration_equal (na1, ca1, ta1) (na2, ca2, ta2) =
-  na1 = na2 &&
-  array_equal eq_constr ca1 ca2 &&
-  array_equal eq_constr ta1 ta2
+  Array.equal Name.equal na1 na2 &&
+  Array.equal eq_constr ca1 ca2 &&
+  Array.equal eq_constr ta1 ta2
 
 let factor_fix env l cb msb =
   let _,recd as check = check_fix env cb 0 in
   let n = Array.length (let fi,_,_ = recd in fi) in
-  if n = 1 then [|l|], recd, msb
+  if Int.equal n 1 then [|l|], recd, msb
   else begin
     if List.length msb < n-1 then raise Impossible;
-    let msb', msb'' = list_chop (n-1) msb in
+    let msb', msb'' = List.chop (n-1) msb in
     let labels = Array.make n l in
-    list_iter_i
+    List.iteri
       (fun j ->
 	 function
 	   | (l,SFBconst cb') ->
 	       let check' = check_fix env cb' (j+1) in
-	       if not (fst check = fst check' &&
+	       if not ((fst check : bool) == (fst check') &&
 		   prec_declaration_equal (snd check) (snd check'))
 	       then raise Impossible;
 	       labels.(j+1) <- l;
@@ -163,113 +175,102 @@ let factor_fix env l cb msb =
     labels, recd, msb''
   end
 
-(** Expanding a [struct_expr_body] into a version without abbreviations
+(** Expanding a [module_alg_expr] into a version without abbreviations
     or functor applications. This is done via a detour to entries
     (hack proposed by Elie)
 *)
 
-let rec seb2mse = function
-  | SEBapply (s,s',_) -> Entries.MSEapply(seb2mse s, seb2mse s')
-  | SEBident mp -> Entries.MSEident mp
-  | _ -> failwith "seb2mse: received a non-atomic seb"
-
-let expand_seb env mp seb =
-  let seb,_,_,_ =
-    let inl = Some (Flags.get_inline_level()) in
-    Mod_typing.translate_struct_module_entry env mp inl (seb2mse seb)
-  in seb
-
-(** When possible, we use the nicer, shorter, algebraic type structures
-    instead of the expanded ones. *)
-
-let my_type_of_mb mb =
-  let m0 = mb.mod_type in
-  match mb.mod_type_alg with Some m -> m0,m | None -> m0,m0
-
-let my_type_of_mtb mtb =
-  let m0 = mtb.typ_expr in
-  match mtb.typ_expr_alg with Some m -> m0,m | None -> m0,m0
+let expand_mexpr env mp me =
+  let inl = Some (Flags.get_inline_level()) in
+  let sign,_,_,_ = Mod_typing.translate_mse env (Some mp) inl me in
+  sign
 
 (** Ad-hoc update of environment, inspired by [Mod_type.check_with_aux_def].
     To check with Elie. *)
 
-let rec msid_of_seb = function
-  | SEBident mp -> mp
-  | SEBwith (seb,_) -> msid_of_seb seb
+let rec mp_of_mexpr = function
+  | MEident mp -> mp
+  | MEwith (seb,_) -> mp_of_mexpr seb
   | _ -> assert false
 
-let env_for_mtb_with_def env mp seb idl =
-  let sig_b = match seb with
-    | SEBstruct(sig_b) -> sig_b
-    | _ -> assert false
-  in
-  let l = label_of_id (List.hd idl) in
-  let spot = function (l',SFBconst _) -> l = l' | _ -> false in
-  let before = fst (list_split_when spot sig_b) in
-  Modops.add_signature mp before empty_delta_resolver env
+let env_for_mtb_with_def env mp me idl =
+  let struc = Modops.destr_nofunctor me in
+  let l = Label.of_id (List.hd idl) in
+  let spot = function (l',SFBconst _) -> Label.equal l l' | _ -> false in
+  let before = fst (List.split_when spot struc) in
+  Modops.add_structure mp before empty_delta_resolver env
 
 (* From a [structure_body] (i.e. a list of [structure_field_body])
    to specifications. *)
 
-let rec extract_sfb_spec env mp = function
+let rec extract_structure_spec env mp = function
   | [] -> []
   | (l,SFBconst cb) :: msig ->
-      let kn = make_con mp empty_dirpath l in
+      let kn = Constant.make2 mp l in
       let s = extract_constant_spec env kn cb in
-      let specs = extract_sfb_spec env mp msig in
+      let specs = extract_structure_spec env mp msig in
       if logical_spec s then specs
       else begin Visit.add_spec_deps s; (l,Spec s) :: specs end
   | (l,SFBmind _) :: msig ->
-      let mind = make_mind mp empty_dirpath l in
+      let mind = MutInd.make2 mp l in
       let s = Sind (mind, extract_inductive env mind) in
-      let specs = extract_sfb_spec env mp msig in
+      let specs = extract_structure_spec env mp msig in
       if logical_spec s then specs
       else begin Visit.add_spec_deps s; (l,Spec s) :: specs end
   | (l,SFBmodule mb) :: msig ->
-      let specs = extract_sfb_spec env mp msig in
-      let spec = extract_seb_spec env mb.mod_mp (my_type_of_mb mb) in
+      let specs = extract_structure_spec env mp msig in
+      let spec = extract_mbody_spec env mb.mod_mp mb in
       (l,Smodule spec) :: specs
   | (l,SFBmodtype mtb) :: msig ->
-      let specs = extract_sfb_spec env mp msig in
-      let spec = extract_seb_spec env mtb.typ_mp (my_type_of_mtb mtb) in
+      let specs = extract_structure_spec env mp msig in
+      let spec = extract_mbody_spec env mtb.mod_mp mtb in
       (l,Smodtype spec) :: specs
 
-(* From [struct_expr_body] to specifications *)
+(* From [module_expression] to specifications *)
 
-(* Invariant: the [seb] given to [extract_seb_spec] should either come
+(* Invariant: the [me] given to [extract_mexpr_spec] should either come
    from a [mod_type] or [type_expr] field, or their [_alg] counterparts.
-   This way, any encountered [SEBident] should be a true module type.
+   This way, any encountered [MEident] should be a true module type.
 *)
 
-and extract_seb_spec env mp1 (seb,seb_alg) = match seb_alg with
-  | SEBident mp -> Visit.add_mp_all mp; MTident mp
-  | SEBwith(seb',With_definition_body(idl,cb))->
-      let env' = env_for_mtb_with_def env (msid_of_seb seb') seb idl in
-      let mt = extract_seb_spec env mp1 (seb,seb') in
-      (match extract_with_type env' cb with (* cb peut contenir des kn  *)
+and extract_mexpr_spec env mp1 (me_struct,me_alg) = match me_alg with
+  | MEident mp -> Visit.add_mp_all mp; MTident mp
+  | MEwith(me',WithDef(idl,c))->
+      let env' = env_for_mtb_with_def env (mp_of_mexpr me') me_struct idl in
+      let mt = extract_mexpr_spec env mp1 (me_struct,me') in
+      (match extract_with_type env' c with (* cb may contain some kn *)
 	 | None -> mt
 	 | Some (vl,typ) -> MTwith(mt,ML_With_type(idl,vl,typ)))
-  | SEBwith(seb',With_module_body(idl,mp))->
+  | MEwith(me',WithMod(idl,mp))->
       Visit.add_mp_all mp;
-      MTwith(extract_seb_spec env mp1 (seb,seb'),
-	     ML_With_module(idl,mp))
-  | SEBfunctor (mbid, mtb, seb_alg') ->
-      let seb' = match seb with
-	| SEBfunctor (mbid',_,seb') when mbid' = mbid -> seb'
+      MTwith(extract_mexpr_spec env mp1 (me_struct,me'), ML_With_module(idl,mp))
+  | MEapply _ -> extract_msignature_spec env mp1 me_struct
+
+and extract_mexpression_spec env mp1 (me_struct,me_alg) = match me_alg with
+  | MoreFunctor (mbid, mtb, me_alg') ->
+      let me_struct' = match me_struct with
+	| MoreFunctor (mbid',_,me') when MBId.equal mbid' mbid -> me'
 	| _ -> assert false
       in
       let mp = MPbound mbid in
-      let env' = Modops.add_module (Modops.module_body_of_type mp mtb) env in
-      MTfunsig (mbid, extract_seb_spec env mp (my_type_of_mtb mtb),
-		extract_seb_spec env' mp1 (seb',seb_alg'))
-  | SEBstruct (msig) ->
-      let env' = Modops.add_signature mp1 msig empty_delta_resolver env in
-      MTsig (mp1, extract_sfb_spec env' mp1 msig)
-  | SEBapply _ ->
-      if seb <> seb_alg then extract_seb_spec env mp1 (seb,seb)
-      else assert false
-
+      let env' = Modops.add_module_type mp mtb env in
+      MTfunsig (mbid, extract_mbody_spec env mp mtb,
+		extract_mexpression_spec env' mp1 (me_struct',me_alg'))
+  | NoFunctor m -> extract_mexpr_spec env mp1 (me_struct,m)
+
+and extract_msignature_spec env mp1 = function
+  | NoFunctor struc ->
+      let env' = Modops.add_structure mp1 struc empty_delta_resolver env in
+      MTsig (mp1, extract_structure_spec env' mp1 struc)
+  | MoreFunctor (mbid, mtb, me) ->
+      let mp = MPbound mbid in
+      let env' = Modops.add_module_type mp mtb env in
+      MTfunsig (mbid, extract_mbody_spec env mp mtb,
+		extract_msignature_spec env' mp1 me)
 
+and extract_mbody_spec env mp mb = match mb.mod_type_alg with
+  | Some ty -> extract_mexpression_spec env mp (mb.mod_type,ty)
+  | None -> extract_msignature_spec env mp mb.mod_type
 
 (* From a [structure_body] (i.e. a list of [structure_field_body])
    to implementations.
@@ -278,88 +279,117 @@ and extract_seb_spec env mp1 (seb,seb_alg) = match seb_alg with
    important: last to first ensures correct dependencies.
 *)
 
-let rec extract_sfb env mp all = function
+let rec extract_structure env mp ~all = function
   | [] -> []
-  | (l,SFBconst cb) :: msb ->
+  | (l,SFBconst cb) :: struc ->
       (try
-	 let vl,recd,msb = factor_fix env l cb msb in
-	 let vc = Array.map (make_con mp empty_dirpath) vl in
-	 let ms = extract_sfb env mp all msb in
-	 let b = array_exists Visit.needed_con vc in
+	 let vl,recd,struc = factor_fix env l cb struc in
+	 let vc = Array.map (Constant.make2 mp) vl in
+	 let ms = extract_structure env mp ~all struc in
+	 let b = Array.exists Visit.needed_con vc in
 	 if all || b then
 	   let d = extract_fixpoint env vc recd in
 	   if (not b) && (logical_decl d) then ms
 	   else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end
 	 else ms
        with Impossible ->
-	 let ms = extract_sfb env mp all msb in
-	 let c = make_con mp empty_dirpath l in
+	 let ms = extract_structure env mp ~all struc in
+	 let c = Constant.make2 mp l in
 	 let b = Visit.needed_con c in
 	 if all || b then
 	   let d = extract_constant env c cb in
 	   if (not b) && (logical_decl d) then ms
 	   else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end
 	 else ms)
-  | (l,SFBmind mib) :: msb ->
-      let ms = extract_sfb env mp all msb in
-      let mind = make_mind mp empty_dirpath l in
+  | (l,SFBmind mib) :: struc ->
+      let ms = extract_structure env mp ~all struc in
+      let mind = MutInd.make2 mp l in
       let b = Visit.needed_ind mind in
       if all || b then
 	let d = Dind (mind, extract_inductive env mind) in
 	if (not b) && (logical_decl d) then ms
 	else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end
       else ms
-  | (l,SFBmodule mb) :: msb ->
-      let ms = extract_sfb env mp all msb in
+  | (l,SFBmodule mb) :: struc ->
+      let ms = extract_structure env mp ~all struc in
       let mp = MPdot (mp,l) in
-      if all || Visit.needed_mp mp then
-	(l,SEmodule (extract_module env mp true mb)) :: ms
+      let all' = all || Visit.needed_mp_all mp in
+      if all' || Visit.needed_mp mp then
+	(l,SEmodule (extract_module env mp ~all:all' mb)) :: ms
       else ms
-  | (l,SFBmodtype mtb) :: msb ->
-      let ms = extract_sfb env mp all msb in
+  | (l,SFBmodtype mtb) :: struc ->
+      let ms = extract_structure env mp ~all struc in
       let mp = MPdot (mp,l) in
-       if all || Visit.needed_mp mp then
-	(l,SEmodtype (extract_seb_spec env mp (my_type_of_mtb mtb))) :: ms
+      if all || Visit.needed_mp mp then
+        (l,SEmodtype (extract_mbody_spec env mp mtb)) :: ms
       else ms
 
-(* From [struct_expr_body] to implementations *)
+(* From [module_expr] and [module_expression] to implementations *)
 
-and extract_seb env mp all = function
-  | (SEBident _ | SEBapply _) as seb when lang () <> Ocaml ->
-      (* in Haskell/Scheme, we expand everything *)
-      extract_seb env mp all (expand_seb env mp seb)
-  | SEBident mp ->
+and extract_mexpr env mp = function
+  | MEwith _ -> assert false (* no 'with' syntax for modules *)
+  | me when lang () != Ocaml ->
+      (* In Haskell/Scheme, we expand everything.
+         For now, we also extract everything, dead code will be removed later
+         (see [Modutil.optimize_struct]. *)
+      extract_msignature env mp ~all:true (expand_mexpr env mp me)
+  | MEident mp ->
       if is_modfile mp && not (modular ()) then error_MPfile_as_mod mp false;
-      Visit.add_mp_all mp; MEident mp
-  | SEBapply (meb, meb',_) ->
-      MEapply (extract_seb env mp true meb,
-	       extract_seb env mp true meb')
-  | SEBfunctor (mbid, mtb, meb) ->
+      Visit.add_mp_all mp; Miniml.MEident mp
+  | MEapply (me, arg) ->
+      Miniml.MEapply (extract_mexpr env mp me,
+	              extract_mexpr env mp (MEident arg))
+
+and extract_mexpression env mp = function
+  | NoFunctor me -> extract_mexpr env mp me
+  | MoreFunctor (mbid, mtb, me) ->
+      let mp1 = MPbound mbid in
+      let env' = Modops.add_module_type mp1 mtb	env in
+      Miniml.MEfunctor
+        (mbid,
+         extract_mbody_spec env mp1 mtb,
+	 extract_mexpression env' mp me)
+
+and extract_msignature env mp ~all = function
+  | NoFunctor struc ->
+      let env' = Modops.add_structure mp struc empty_delta_resolver env in
+      Miniml.MEstruct (mp,extract_structure env' mp ~all struc)
+  | MoreFunctor (mbid, mtb, me) ->
       let mp1 = MPbound mbid in
-      let env' = Modops.add_module (Modops.module_body_of_type  mp1 mtb)
-	env  in
-      MEfunctor (mbid, extract_seb_spec env mp1 (my_type_of_mtb mtb),
-		 extract_seb env' mp true meb)
-  | SEBstruct (msb) ->
-      let env' = Modops.add_signature mp msb empty_delta_resolver env in
-      MEstruct (mp,extract_sfb env' mp all msb)
-  | SEBwith (_,_) -> anomaly "Not available yet"
-
-and extract_module env mp all mb =
+      let env' = Modops.add_module_type mp1 mtb	env in
+      Miniml.MEfunctor
+        (mbid,
+         extract_mbody_spec env mp1 mtb,
+	 extract_msignature env' mp ~all me)
+
+and extract_module env mp ~all mb =
   (* A module has an empty [mod_expr] when :
      - it is a module variable (for instance X inside a Module F [X:SIG])
      - it is a module assumption (Declare Module).
      Since we look at modules from outside, we shouldn't have variables.
      But a Declare Module at toplevel seems legal (cf #2525). For the
      moment we don't support this situation. *)
-  match mb.mod_expr with
-    | None -> error_no_module_expr mp
-    | Some me ->
-      { ml_mod_expr = extract_seb env mp all me;
-	ml_mod_type = extract_seb_spec env mp (my_type_of_mb mb) }
-
-
-let unpack = function MEstruct (_,sel) -> sel | _ -> assert false
+  let impl = match mb.mod_expr with
+    | Abstract -> error_no_module_expr mp
+    | Algebraic me -> extract_mexpression env mp me
+    | Struct sign ->
+      (* This module has a signature, otherwise it would be FullStruct.
+         We extract just the elements required by this signature. *)
+      let () = add_labels mp mb.mod_type in
+      extract_msignature env mp ~all:false sign
+    | FullStruct -> extract_msignature env mp ~all mb.mod_type
+  in
+  (* Slight optimization: for modules without explicit signatures
+     ([FullStruct] case), we build the type out of the extracted
+     implementation *)
+  let typ = match mb.mod_expr with
+    | FullStruct ->
+      assert (Option.is_empty mb.mod_type_alg);
+      mtyp_of_mexpr impl
+    | _ -> extract_mbody_spec env mp mb
+  in
+  { ml_mod_expr = impl;
+    ml_mod_type = typ }
 
 let mono_environment refs mpl =
   Visit.reset ();
@@ -368,7 +398,8 @@ let mono_environment refs mpl =
   let env = Global.env () in
   let l = List.rev (environment_until None) in
   List.rev_map
-    (fun (mp,m) -> mp, unpack (extract_seb env mp (Visit.needed_mp_all mp) m))
+    (fun (mp,struc) ->
+      mp, extract_structure env mp ~all:(Visit.needed_mp_all mp) struc)
     l
 
 (**************************************)
@@ -383,7 +414,7 @@ let descr () = match lang () with
 (* From a filename string "foo.ml" or "foo", builds "foo.ml" and "foo.mli"
    Works similarly for the other languages. *)
 
-let default_id = id_of_string "Main"
+let default_id = Id.of_string "Main"
 
 let mono_filename f =
   let d = descr () in
@@ -396,10 +427,10 @@ let mono_filename f =
 	  else f
 	in
 	let id =
-	  if lang () <> Haskell then default_id
+	  if lang () != Haskell then default_id
 	  else
-            try id_of_string (Filename.basename f)
-	    with e when Errors.noncritical e ->
+            try Id.of_string (Filename.basename f)
+	    with UserError _ ->
               error "Extraction: provided filename is not a valid identifier"
 	in
 	Some (f^d.file_suffix), Option.map ((^) f) d.sig_suffix, id
@@ -409,7 +440,7 @@ let mono_filename f =
 let module_filename mp =
   let f = file_of_modfile mp in
   let d = descr () in
-  Some (f^d.file_suffix), Option.map ((^) f) d.sig_suffix, id_of_string f
+  Some (f^d.file_suffix), Option.map ((^) f) d.sig_suffix, Id.of_string f
 
 (*s Extraction of one decl to stdout. *)
 
@@ -420,8 +451,9 @@ let print_one_decl struc mp decl =
   ignore (d.pp_struct struc);
   set_phase Impl;
   push_visible mp [];
-  msgnl (d.pp_decl decl);
-  pop_visible ()
+  let ans = d.pp_decl decl in
+  pop_visible ();
+  ans
 
 (*s Extraction of a ml struct to a file. *)
 
@@ -449,31 +481,39 @@ let formatter dry file =
       (* note: max_indent should be < margin above, otherwise it's ignored *)
   ft
 
+let get_comment () =
+  let s = file_comment () in
+  if String.is_empty s then None
+  else
+    let split_comment = Str.split (Str.regexp "[ \t\n]+") s in
+    Some (prlist_with_sep spc str split_comment)
+
 let print_structure_to_file (fn,si,mo) dry struc =
   Buffer.clear buf;
   let d = descr () in
   reset_renaming_tables AllButExternal;
   let unsafe_needs = {
-    mldummy = struct_ast_search ((=) MLdummy) struc;
+    mldummy = struct_ast_search ((==) MLdummy) struc;
     tdummy = struct_type_search Mlutil.isDummy struc;
-    tunknown = struct_type_search ((=) Tunknown) struc;
+    tunknown = struct_type_search ((==) Tunknown) struc;
     magic =
-      if lang () <> Haskell then false
+      if lang () != Haskell then false
       else struct_ast_search (function MLmagic _ -> true | _ -> false) struc }
   in
   (* First, a dry run, for computing objects to rename or duplicate *)
   set_phase Pre;
   let devnull = formatter true None in
-  msg_with devnull (d.pp_struct struc);
+  pp_with devnull (d.pp_struct struc);
   let opened = opened_libraries () in
   (* Print the implementation *)
   let cout = if dry then None else Option.map open_out fn in
   let ft = formatter dry cout in
+  let comment = get_comment () in
   begin try
     (* The real printing of the implementation *)
     set_phase Impl;
-    msg_with ft (d.preamble mo opened unsafe_needs);
-    msg_with ft (d.pp_struct struc);
+    pp_with ft (d.preamble mo comment opened unsafe_needs);
+    pp_with ft (d.pp_struct struc);
     Option.iter close_out cout;
   with reraise ->
     Option.iter close_out cout; raise reraise
@@ -486,8 +526,8 @@ let print_structure_to_file (fn,si,mo) dry struc =
        let ft = formatter false (Some cout) in
        begin try
 	 set_phase Intf;
-	 msg_with ft (d.sig_preamble mo opened unsafe_needs);
-	 msg_with ft (d.pp_sig (signature_of_structure struc));
+	 pp_with ft (d.sig_preamble mo comment opened unsafe_needs);
+	 pp_with ft (d.pp_sig (signature_of_structure struc));
 	 close_out cout;
        with reraise ->
 	 close_out cout; raise reraise
@@ -495,8 +535,8 @@ let print_structure_to_file (fn,si,mo) dry struc =
        info_file si)
     (if dry then None else si);
   (* Print the buffer content via Coq standard formatter (ok with coqide). *)
-  if Buffer.length buf <> 0 then begin
-    Pp.message (Buffer.contents buf);
+  if not (Int.equal (Buffer.length buf) 0) then begin
+    Pp.msg_info (str (Buffer.contents buf));
     Buffer.reset buf
   end
 
@@ -515,7 +555,7 @@ let init modular library =
   set_modular modular;
   set_library library;
   reset ();
-  if modular && lang () = Scheme then error_scheme ()
+  if modular && lang () == Scheme then error_scheme ()
 
 let warns () =
   warning_opaques (access_opaque ());
@@ -531,7 +571,7 @@ let rec locate_ref = function
       let mpo = try Some (Nametab.locate_module q) with Not_found -> None
       and ro =
         try Some (Smartlocate.global_with_alias r)
-        with e when Errors.noncritical e -> None
+        with Nametab.GlobalizationError _ | UserError _ -> None
       in
       match mpo, ro with
 	| None, None -> Nametab.error_global_not_found q
@@ -576,7 +616,7 @@ let separate_extraction lr =
     is \verb!Extraction! [qualid]. *)
 
 let simple_extraction r =
-  Vernacentries.dump_global (Genarg.AN r);
+  Vernacentries.dump_global (Misctypes.AN r);
   match locate_ref [r] with
   | ([], [mp]) as p -> full_extr None p
   | [r],[] ->
@@ -584,9 +624,13 @@ let simple_extraction r =
       let struc = optimize_struct ([r],[]) (mono_environment [r] []) in
       let d = get_decl_in_structure r struc in
       warns ();
-      if is_custom r then msgnl (str "(** User defined extraction *)");
-      print_one_decl struc (modpath_of_r r) d;
-      reset ()
+      let flag =
+        if is_custom r then str "(** User defined extraction *)" ++ fnl()
+        else mt ()
+      in
+      let ans = flag ++ print_one_decl struc (modpath_of_r r) d in
+      reset ();
+      Pp.msg_info ans
   | _ -> assert false
 
 
@@ -602,9 +646,9 @@ let extraction_library is_rec m =
   Visit.add_mp_all (MPfile dir_m);
   let env = Global.env () in
   let l = List.rev (environment_until (Some dir_m)) in
-  let select l (mp,meb) =
+  let select l (mp,struc) =
     if Visit.needed_mp mp
-    then (mp, unpack (extract_seb env mp true meb)) :: l
+    then (mp, extract_structure env mp true struc) :: l
     else l
   in
   let struc = List.fold_left select [] l in
@@ -612,9 +656,22 @@ let extraction_library is_rec m =
   warns ();
   let print = function
     | (MPfile dir as mp, sel) as e ->
-	let dry = not is_rec && dir <> dir_m in
+	let dry = not is_rec && not (DirPath.equal dir dir_m) in
 	print_structure_to_file (module_filename mp) dry [e]
     | _ -> assert false
   in
   List.iter print struc;
   reset ()
+
+let structure_for_compute c =
+  init false false;
+  let env = Global.env () in
+  let ast, mlt = Extraction.extract_constr env c in
+  let ast = Mlutil.normalize ast in
+  let refs = ref Refset.empty in
+  let add_ref r = refs := Refset.add r !refs in
+  let () = ast_iter_references add_ref add_ref add_ref ast in
+  let refs = Refset.elements !refs in
+  let struc = optimize_struct (refs,[]) (mono_environment refs []) in
+  let flatstruc = List.map snd (List.flatten (List.map snd struc)) in
+  flatstruc, ast, mlt
diff --git a/plugins/extraction/extract_env.mli b/plugins/extraction/extract_env.mli
index 31f5a620..e5fe76f5 100644
--- a/plugins/extraction/extract_env.mli
+++ b/plugins/extraction/extract_env.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -10,11 +10,12 @@
 
 open Names
 open Libnames
+open Globnames
 
 val simple_extraction : reference -> unit
 val full_extraction : string option -> reference list -> unit
 val separate_extraction : reference list -> unit
-val extraction_library : bool -> identifier -> unit
+val extraction_library : bool -> Id.t -> unit
 
 (* For debug / external output via coqtop.byte + Drop : *)
 
@@ -24,4 +25,10 @@ val mono_environment :
 (* Used by the Relation Extraction plugin *)
 
 val print_one_decl :
-  Miniml.ml_structure -> module_path -> Miniml.ml_decl -> unit
+  Miniml.ml_structure -> module_path -> Miniml.ml_decl -> Pp.std_ppcmds
+
+(* Used by Extraction Compute *)
+
+val structure_for_compute :
+  Term.constr ->
+    Miniml.ml_flat_structure * Miniml.ml_ast * Miniml.ml_type
diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml
index a5b1e3c6..080512b2 100644
--- a/plugins/extraction/extraction.ml
+++ b/plugins/extraction/extraction.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -10,7 +10,10 @@
 open Util
 open Names
 open Term
+open Vars
+open Context
 open Declarations
+open Declareops
 open Environ
 open Reduction
 open Reductionops
@@ -19,9 +22,7 @@ open Termops
 open Inductiveops
 open Recordops
 open Namegen
-open Summary
-open Libnames
-open Nametab
+open Globnames
 open Miniml
 open Table
 open Mlutil
@@ -36,13 +37,13 @@ let none = Evd.empty
 
 let type_of env c =
   try
-    let polyprop = (lang() = Haskell) in
+    let polyprop = (lang() == Haskell) in
     Retyping.get_type_of ~polyprop env none (strip_outer_cast c)
   with SingletonInductiveBecomesProp id -> error_singleton_become_prop id
 
 let sort_of env c =
   try
-    let polyprop = (lang() = Haskell) in
+    let polyprop = (lang() == Haskell) in
     Retyping.get_sort_family_of ~polyprop env none (strip_outer_cast c)
   with SingletonInductiveBecomesProp id -> error_singleton_become_prop id
 
@@ -55,8 +56,8 @@ let sort_of env c =
      More formally, a type scheme has type $(x_1:X_1)\ldots(x_n:X_n)s$ with
      [s = Set], [Prop] or [Type]
    \item [Default] denotes the other cases. It may be inexact after
-     instanciation. For example [(X:Type)X] is [Default] and may give [Set]
-     after instanciation, which is rather [TypeScheme]
+     instantiation. For example [(X:Type)X] is [Default] and may give [Set]
+     after instantiation, which is rather [TypeScheme]
    \item [Logic] denotes a term of sort [Prop], or a type scheme on sort [Prop]
    \item [Info] is the opposite. The same example [(X:Type)X] shows
      that an [Info] term might in fact be [Logic] later on.
@@ -71,17 +72,19 @@ type flag = info * scheme
 (*s [flag_of_type] transforms a type [t] into a [flag].
   Really important function. *)
 
-let rec flag_of_type env t =
+let rec flag_of_type env t : flag =
   let t = whd_betadeltaiota env none t in
   match kind_of_term t with
     | Prod (x,t,c) -> flag_of_type (push_rel (x,None,t) env) c
-    | Sort (Prop Null) -> (Logic,TypeScheme)
+    | Sort s when Sorts.is_prop s -> (Logic,TypeScheme)
     | Sort _ -> (Info,TypeScheme)
-    | _ -> if (sort_of env t) = InProp then (Logic,Default) else (Info,Default)
+    | _ -> if (sort_of env t) == InProp then (Logic,Default) else (Info,Default)
 
 (*s Two particular cases of [flag_of_type]. *)
 
-let is_default env t = (flag_of_type env t = (Info, Default))
+let is_default env t = match flag_of_type env t with
+| (Info, Default) -> true
+| _ -> false
 
 exception NotDefault of kill_reason
 
@@ -91,7 +94,9 @@ let check_default env t =
     | Logic,_ -> raise (NotDefault Kother)
     | _ -> ()
 
-let is_info_scheme env t = (flag_of_type env t = (Info, TypeScheme))
+let is_info_scheme env t = match flag_of_type env t with
+| (Info, TypeScheme) -> true
+| _ -> false
 
 (*s [type_sign] gernerates a signature aimed at treating a type application. *)
 
@@ -109,16 +114,31 @@ let rec type_scheme_nb_args env c =
 	if is_info_scheme env t then n+1 else n
     | _ -> 0
 
-let _ = register_type_scheme_nb_args type_scheme_nb_args
+let _ = Hook.set type_scheme_nb_args_hook type_scheme_nb_args
 
 (*s [type_sign_vl] does the same, plus a type var list. *)
 
+(* When generating type variables, we avoid any ' in their names
+   (otherwise this may cause a lexer conflict in ocaml with 'a').
+   We also get rid of unicode characters. Anyway, since type variables
+   are local, the created name is just a matter of taste...
+   See also Bug #3227 *)
+
+let make_typvar n vl =
+  let id = id_of_name n in
+  let id' =
+    let s = Id.to_string id in
+    if not (String.contains s '\'') && Unicode.is_basic_ascii s then id
+    else id_of_name Anonymous
+  in
+  next_ident_away id' vl
+
 let rec type_sign_vl env c =
   match kind_of_term (whd_betadeltaiota env none c) with
     | Prod (n,t,d) ->
 	let s,vl = type_sign_vl (push_rel_assum (n,t) env) d in
 	if not (is_info_scheme env t) then Kill Kother::s, vl
-	else Keep::s, (next_ident_away (id_of_name n) vl) :: vl
+	else Keep::s, (make_typvar n vl) :: vl
     | _ -> [],[]
 
 let rec nb_default_params env c =
@@ -136,7 +156,8 @@ let sign_with_implicits r s nb_params =
     | [] -> []
     | sign::s ->
 	let sign' =
-	  if sign = Keep && List.mem i implicits then Kill Kother else sign
+	  if sign == Keep && Int.List.mem i implicits
+          then Kill Kother else sign
 	in sign' :: add_impl (succ i) s
   in
   add_impl (1+nb_params) s
@@ -145,11 +166,11 @@ let sign_with_implicits r s nb_params =
 
 let rec handle_exn r n fn_name = function
   | MLexn s ->
-      (try Scanf.sscanf s "UNBOUND %d"
+      (try Scanf.sscanf s "UNBOUND %d%!"
 	 (fun i ->
 	    assert ((0 < i) && (i <= n));
 	    MLexn ("IMPLICIT "^ msg_non_implicit r (n+1-i) (fn_name i)))
-       with e when Errors.noncritical e -> MLexn s)
+       with Scanf.Scan_failure _ | End_of_file -> MLexn s)
   | a -> ast_map (handle_exn r n fn_name) a
 
 (*S Management of type variable contexts. *)
@@ -170,8 +191,8 @@ let db_from_sign s =
   an inductive type (see just below). *)
 
 let rec db_from_ind dbmap i =
-  if i = 0 then []
-  else (try Intmap.find i dbmap with Not_found -> 0)::(db_from_ind dbmap (i-1))
+  if Int.equal i 0 then []
+  else (try Int.Map.find i dbmap with Not_found -> 0)::(db_from_ind dbmap (i-1))
 
 (*s [parse_ind_args] builds a map: [i->j] iff the i-th Coq argument
   of a constructor corresponds to the j-th type var of the ML inductive. *)
@@ -185,34 +206,43 @@ let rec db_from_ind dbmap i =
 
 let parse_ind_args si args relmax =
   let rec parse i j = function
-    | [] -> Intmap.empty
+    | [] -> Int.Map.empty
     | Kill _ :: s -> parse (i+1) j s
     | Keep :: s ->
       (match kind_of_term args.(i-1) with
-	 | Rel k -> Intmap.add (relmax+1-k) j (parse (i+1) (j+1) s)
+	 | Rel k -> Int.Map.add (relmax+1-k) j (parse (i+1) (j+1) s)
 	 | _ -> parse (i+1) (j+1) s)
   in parse 1 1 si
 
 let oib_equal o1 o2 =
-  id_ord o1.mind_typename o2.mind_typename = 0 &&
-  list_equal eq_rel_declaration o1.mind_arity_ctxt o2.mind_arity_ctxt &&
-  begin match o1.mind_arity, o2.mind_arity with
-  | Monomorphic {mind_user_arity=c1; mind_sort=s1},
-    Monomorphic {mind_user_arity=c2; mind_sort=s2} ->
-      eq_constr c1 c2 && s1 = s2
-  | ma1, ma2 -> ma1 = ma2 end &&
-  o1.mind_consnames = o2.mind_consnames
+  Id.equal o1.mind_typename o2.mind_typename &&
+  List.equal eq_rel_declaration o1.mind_arity_ctxt o2.mind_arity_ctxt &&
+    begin
+      match o1.mind_arity, o2.mind_arity with
+      | RegularArity {mind_user_arity=c1; mind_sort=s1}, RegularArity {mind_user_arity=c2; mind_sort=s2} ->
+	eq_constr c1 c2 && Sorts.equal s1 s2
+      | TemplateArity p1, TemplateArity p2 ->
+	let eq o1 o2 = Option.equal Univ.Level.equal o1 o2 in
+	  List.equal eq p1.template_param_levels p2.template_param_levels &&
+	    Univ.Universe.equal p1.template_level p2.template_level
+      | _, _ -> false
+    end &&
+    Array.equal Id.equal o1.mind_consnames o2.mind_consnames
+
+let eq_record x y =
+  Option.equal (Option.equal (fun (_, x, y) (_, x', y') -> Array.for_all2 eq_constant x x')) x y
 
 let mib_equal m1 m2 =
-  array_equal oib_equal m1.mind_packets m1.mind_packets &&
-  m1.mind_record = m2.mind_record &&
-  m1.mind_finite = m2.mind_finite &&
-  m1.mind_ntypes = m2.mind_ntypes &&
-  list_equal eq_named_declaration m1.mind_hyps m2.mind_hyps &&
-  m1.mind_nparams = m2.mind_nparams &&
-  m1.mind_nparams_rec = m2.mind_nparams_rec &&
-  list_equal eq_rel_declaration m1.mind_params_ctxt m2.mind_params_ctxt &&
-  m1.mind_constraints = m2.mind_constraints
+  Array.equal oib_equal m1.mind_packets m1.mind_packets &&
+  eq_record m1.mind_record m2.mind_record &&
+  (m1.mind_finite : Decl_kinds.recursivity_kind) == m2.mind_finite &&
+  Int.equal m1.mind_ntypes m2.mind_ntypes &&
+  List.equal eq_named_declaration m1.mind_hyps m2.mind_hyps &&
+  Int.equal m1.mind_nparams m2.mind_nparams &&
+  Int.equal m1.mind_nparams_rec m2.mind_nparams_rec &&
+  List.equal eq_rel_declaration m1.mind_params_ctxt m2.mind_params_ctxt &&
+  (* Univ.UContext.eq *) m1.mind_universes == m2.mind_universes (** FIXME *)
+  (* m1.mind_universes = m2.mind_universes *)
 
 (*S Extraction of a type. *)
 
@@ -235,7 +265,7 @@ let rec extract_type env db j c args =
 	   | [] -> assert false (* A lambda cannot be a type. *)
 	   | a :: args -> extract_type env db j (subst1 a d) args)
     | Prod (n,t,d) ->
-	assert (args = []);
+	assert (List.is_empty args);
 	let env' = push_rel_assum (n,t) env in
 	(match flag_of_type env t with
 	   | (Info, Default) ->
@@ -255,10 +285,10 @@ let rec extract_type env db j c args =
 	       (match expand env mld with
 		  | Tdummy d -> Tdummy d
 		  | _ ->
-		      let reason = if lvl=TypeScheme then Ktype else Kother in
+		      let reason = if lvl == TypeScheme then Ktype else Kother in
 		      Tarr (Tdummy reason, mld)))
     | Sort _ -> Tdummy Ktype (* The two logical cases. *)
-    | _ when sort_of env (applist (c, args)) = InProp -> Tdummy Kother
+    | _ when sort_of env (applist (c, args)) == InProp -> Tdummy Kother
     | Rel n ->
 	(match lookup_rel n env with
            | (_,Some t,_) -> extract_type env db j (lift n t) args
@@ -266,11 +296,11 @@ let rec extract_type env db j c args =
 	       (* Asks [db] a translation for [n]. *)
 	       if n > List.length db then Tunknown
 	       else let n' = List.nth db (n-1) in
-	       if n' = 0 then Tunknown else Tvar n')
-    | Const kn ->
+	       if Int.equal n' 0 then Tunknown else Tvar n')
+    | Const (kn,u as c) ->
 	let r = ConstRef kn in
 	let cb = lookup_constant kn env in
-	let typ = Typeops.type_of_constant_type env cb.const_type in
+	let typ,_ = Typeops.type_of_constant env c in
 	(match flag_of_type env typ with
 	   | (Logic,_) -> assert false (* Cf. logical cases above *)
 	   | (Info, TypeScheme) ->
@@ -279,23 +309,23 @@ let rec extract_type env db j c args =
 		  | Undef _ | OpaqueDef _ -> mlt
 		  | Def _ when is_custom r -> mlt
 		  | Def lbody ->
-		      let newc = applist (Declarations.force lbody, args) in
+		      let newc = applist (Mod_subst.force_constr lbody, args) in
 		      let mlt' = extract_type env db j newc [] in
 		      (* ML type abbreviations interact badly with Coq *)
 		      (* reduction, so [mlt] and [mlt'] might be different: *)
 		      (* The more precise is [mlt'], extracted after reduction *)
 		      (* The shortest is [mlt], which use abbreviations *)
 		      (* If possible, we take [mlt], otherwise [mlt']. *)
-		      if expand env mlt = expand env mlt' then mlt else mlt')
+		      if eq_ml_type (expand env mlt) (expand env mlt') then mlt else mlt')
 	   | (Info, Default) ->
                (* Not an ML type, for example [(c:forall X, X->X) Type nat] *)
 	       (match cb.const_body with
 		  | Undef _  | OpaqueDef _ -> Tunknown (* Brutal approx ... *)
 		  | Def lbody ->
 		      (* We try to reduce. *)
-		      let newc = applist (Declarations.force lbody, args) in
+		      let newc = applist (Mod_subst.force_constr lbody, args) in
 		      extract_type env db j newc []))
-    | Ind (kn,i) ->
+    | Ind ((kn,i),u) ->
 	let s = (extract_ind env kn).ind_packets.(i).ip_sign in
 	extract_type_app env db (IndRef (kn,i),s) args
     | Case _ | Fix _ | CoFix _ -> Tunknown
@@ -308,7 +338,7 @@ let rec extract_type env db j c args =
 and extract_type_app env db (r,s) args =
   let ml_args =
     List.fold_right
-      (fun (b,c) a -> if b=Keep then
+      (fun (b,c) a -> if b == Keep then
 	 let p = List.length (fst (splay_prod env none (type_of env c))) in
          let db = iterate (fun l -> 0 :: l) p db in
          (extract_type_scheme env db c p) :: a
@@ -326,7 +356,7 @@ and extract_type_app env db (r,s) args =
 (* [db] is a context for translating Coq [Rel] into ML type [Tvar]. *)
 
 and extract_type_scheme env db c p =
-  if p=0 then extract_type env db 0 c []
+  if Int.equal p 0 then extract_type env db 0 c []
   else
     let c = whd_betaiotazeta Evd.empty c in
     match kind_of_term c with
@@ -335,7 +365,7 @@ and extract_type_scheme env db c p =
       | _ ->
           let rels = fst (splay_prod env none (type_of env c)) in
           let env = push_rels_assum rels env in
-          let eta_args = List.rev_map mkRel (interval 1 p) in
+          let eta_args = List.rev_map mkRel (List.interval 1 p) in
           extract_type env db 0 (lift p c) eta_args
 
 
@@ -356,9 +386,9 @@ and extract_ind env kn = (* kn is supposed to be in long form *)
        When at toplevel of the monolithic case, we cannot do much
        (cf Vector and bug #2570) *)
     let equiv =
-      if lang () <> Ocaml ||
+      if lang () != Ocaml ||
 	 (not (modular ()) && at_toplevel (mind_modpath kn)) ||
-	 kn_ord (canonical_mind kn) (user_mind kn) = 0
+	 KerName.equal (canonical_mind kn) (user_mind kn)
       then
 	NoEquiv
       else
@@ -375,32 +405,34 @@ and extract_ind env kn = (* kn is supposed to be in long form *)
     (* First pass: we store inductive signatures together with *)
     (* their type var list. *)
     let packets =
-      Array.map
-	(fun mip ->
-	   let b = snd (mind_arity mip) <> InProp in
-	   let ar = Inductive.type_of_inductive env (mib,mip) in
-	   let s,v = if b then type_sign_vl env ar else [],[] in
+      Array.mapi
+	(fun i mip ->
+	   let (ind,u), ctx = 
+	     Universes.fresh_inductive_instance env (kn,i) in
+	   let ar = Inductive.type_of_inductive env ((mib,mip),u) in
+	   let info = (fst (flag_of_type env ar) = Info) in
+	   let s,v = if info then type_sign_vl env ar else [],[] in
 	   let t = Array.make (Array.length mip.mind_nf_lc) [] in
 	   { ip_typename = mip.mind_typename;
 	     ip_consnames = mip.mind_consnames;
-	     ip_logical = (not b);
+	     ip_logical = not info;
 	     ip_sign = s;
 	     ip_vars = v;
-	     ip_types = t })
+	     ip_types = t }, u)
 	mib.mind_packets
     in
 
     add_ind kn mib
       {ind_kind = Standard;
        ind_nparams = npar;
-       ind_packets = packets;
+       ind_packets = Array.map fst packets;
        ind_equiv = equiv
       };
     (* Second pass: we extract constructors *)
     for i = 0 to mib.mind_ntypes - 1 do
-      let p = packets.(i) in
+      let p,u = packets.(i) in
       if not p.ip_logical then
-	let types = arities_of_constructors env (kn,i) in
+	let types = arities_of_constructors env ((kn,i),u) in
 	for j = 0 to Array.length types - 1 do
 	  let t = snd (decompose_prod_n npar types.(j)) in
 	  let prods,head = dest_prod epar t in
@@ -420,18 +452,18 @@ and extract_ind env kn = (* kn is supposed to be in long form *)
 	let ip = (kn, 0) in
 	let r = IndRef ip in
 	if is_custom r then raise (I Standard);
-	if not mib.mind_finite then raise (I Coinductive);
-	if mib.mind_ntypes <> 1 then raise (I Standard);
-	let p = packets.(0) in
+	if mib.mind_finite == Decl_kinds.CoFinite then raise (I Coinductive);
+	if not (Int.equal mib.mind_ntypes 1) then raise (I Standard);
+	let p,u = packets.(0) in
 	if p.ip_logical then raise (I Standard);
-	if Array.length p.ip_types <> 1 then raise (I Standard);
+	if not (Int.equal (Array.length p.ip_types) 1) then raise (I Standard);
 	let typ = p.ip_types.(0) in
 	let l = List.filter (fun t -> not (isDummy (expand env t))) typ in
 	if not (keep_singleton ()) &&
-	    List.length l = 1 && not (type_mem_kn kn (List.hd l))
+	    Int.equal (List.length l) 1 && not (type_mem_kn kn (List.hd l))
 	then raise (I Singleton);
-	if l = [] then raise (I Standard);
-	if not mib.mind_record then raise (I Standard);
+	if List.is_empty l then raise (I Standard);
+	if Option.is_empty mib.mind_record then raise (I Standard);
 	(* Now we're sure it's a record. *)
 	(* First, we find its field names. *)
 	let rec names_prod t = match kind_of_term t with
@@ -441,10 +473,10 @@ and extract_ind env kn = (* kn is supposed to be in long form *)
 	  | _ -> []
 	in
 	let field_names =
-	  list_skipn mib.mind_nparams (names_prod mip0.mind_user_lc.(0)) in
-	assert (List.length field_names = List.length typ);
+	  List.skipn mib.mind_nparams (names_prod mip0.mind_user_lc.(0)) in
+	assert (Int.equal (List.length field_names) (List.length typ));
 	let projs = ref Cset.empty in
-	let mp,d,_ = repr_mind kn in
+	let mp = MutInd.modpath kn in
 	let rec select_fields l typs = match l,typs with
 	  | [],[] -> []
 	  | _::l, typ::typs when isDummy (expand env typ) ->
@@ -452,9 +484,9 @@ and extract_ind env kn = (* kn is supposed to be in long form *)
 	  | Anonymous::l, typ::typs ->
 	      None :: (select_fields l typs)
 	  | Name id::l, typ::typs ->
-	      let knp = make_con mp d (label_of_id id) in
+	      let knp = Constant.make2 mp (Label.of_id id) in
 	      (* Is it safe to use [id] for projections [foo.id] ? *)
-	      if List.for_all ((=) Keep) (type2signature env typ)
+	      if List.for_all ((==) Keep) (type2signature env typ)
 	      then projs := Cset.add knp !projs;
 	      Some (ConstRef knp) :: (select_fields l typs)
 	  | _ -> assert false
@@ -465,9 +497,10 @@ and extract_ind env kn = (* kn is supposed to be in long form *)
 	(* If so, we use this information. *)
 	begin try
 	  let n = nb_default_params env
-            (Inductive.type_of_inductive env (mib,mip0))
+            (Inductive.type_of_inductive env ((mib,mip0),u))
 	  in
-	  let check_proj kn = if Cset.mem kn !projs then add_projection n kn in
+	  let check_proj kn = if Cset.mem kn !projs then add_projection n kn ip
+          in
 	  List.iter (Option.iter check_proj) (lookup_projections ip)
 	with Not_found -> ()
 	end;
@@ -476,7 +509,7 @@ and extract_ind env kn = (* kn is supposed to be in long form *)
     in
     let i = {ind_kind = ind_info;
 	     ind_nparams = npar;
-	     ind_packets = packets;
+	     ind_packets = Array.map fst packets;
 	     ind_equiv = equiv }
     in
     add_ind kn mib i;
@@ -495,7 +528,7 @@ and extract_type_cons env db dbmap c i =
   match kind_of_term (whd_betadeltaiota env none c) with
     | Prod (n,t,d) ->
 	let env' = push_rel_assum (n,t) env in
-	let db' = (try Intmap.find i dbmap with Not_found -> 0) :: db in
+	let db' = (try Int.Map.find i dbmap with Not_found -> 0) :: db in
 	let l = extract_type_cons env' db' dbmap d (i+1) in
 	(extract_type env db 0 t []) :: l
     | _ -> []
@@ -511,13 +544,14 @@ and mlt_env env r = match r with
 	   | _ -> None
        with Not_found ->
 	 let cb = Environ.lookup_constant kn env in
-	 let typ = Typeops.type_of_constant_type env cb.const_type in
+	 let typ = Typeops.type_of_constant_type env cb.const_type
+ (* FIXME not sure if we should instantiate univs here *) in
 	 match cb.const_body with
 	   | Undef _ | OpaqueDef _ -> None
 	   | Def l_body ->
 	       (match flag_of_type env typ with
 		  | Info,TypeScheme ->
-		      let body = Declarations.force l_body in
+		      let body = Mod_subst.force_constr l_body in
 		      let s,vl = type_sign_vl env typ in
 		      let db = db_from_sign s in
 		      let t = extract_type_scheme env db body (List.length s)
@@ -539,7 +573,7 @@ let record_constant_type env kn opt_typ =
     lookup_type kn
   with Not_found ->
     let typ = match opt_typ with
-      | None -> Typeops.type_of_constant env kn
+      | None -> Typeops.type_of_constant_type env (lookup_constant kn env).const_type
       | Some typ -> typ
     in let mlt = extract_type env [] 1 typ []
     in let schema = (type_maxvar mlt, mlt)
@@ -594,10 +628,12 @@ let rec extract_term env mle mlt c args =
 	with NotDefault d ->
 	  let mle' = Mlenv.push_std_type mle (Tdummy d) in
 	  ast_pop (extract_term env' mle' mlt c2 args'))
-    | Const kn ->
-	extract_cst_app env mle mlt kn args
-    | Construct cp ->
-	extract_cons_app env mle mlt cp args
+    | Const (kn,u) ->
+	extract_cst_app env mle mlt kn u args
+    | Construct (cp,u) ->
+	extract_cons_app env mle mlt cp u args
+    | Proj (p, c) ->
+        extract_cst_app env mle mlt (Projection.constant p) Univ.Instance.empty (c :: args)
     | Rel n ->
 	(* As soon as the expected [mlt] for the head is known, *)
 	(* we unify it with an fresh copy of the stored type of [Rel n]. *)
@@ -645,14 +681,15 @@ and make_mlargs env e s args typs =
 
 (*s Extraction of a constant applied to arguments. *)
 
-and extract_cst_app env mle mlt kn args =
+and extract_cst_app env mle mlt kn u args =
   (* First, the [ml_schema] of the constant, in expanded version. *)
   let nb,t = record_constant_type env kn None in
   let schema = nb, expand env t in
   (* Can we instantiate types variables for this constant ? *)
   (* In Ocaml, inside the definition of this constant, the answer is no. *)
   let instantiated =
-    if lang () = Ocaml && List.mem kn !current_fixpoints then var2var' (snd schema)
+    if lang () == Ocaml && List.mem_f Constant.equal kn !current_fixpoints
+    then var2var' (snd schema)
     else instantiation schema
   in
   (* Then the expected type of this constant. *)
@@ -674,14 +711,14 @@ and extract_cst_app env mle mlt kn args =
   (* The ml arguments, already expunged from known logical ones *)
   let mla = make_mlargs env mle s args metas in
   let mla =
-    if magic1 || lang () <> Ocaml then mla
+    if magic1 || lang () != Ocaml then mla
     else
       try
         (* for better optimisations later, we discard dependent args
            of projections and replace them by fake args that will be
            removed during final pretty-print. *)
-	let l,l' = list_chop (projection_arity (ConstRef kn)) mla in
-	if l' <> [] then (List.map (fun _ -> MLexn "Proj Args") l) @ l'
+	let l,l' = List.chop (projection_arity (ConstRef kn)) mla in
+	if not (List.is_empty l') then (List.map (fun _ -> MLexn "Proj Args") l) @ l'
 	else mla
       with e when Errors.noncritical e -> mla
   in
@@ -689,7 +726,7 @@ and extract_cst_app env mle mlt kn args =
      one [Kill Kother] lead to a dummy lam. So a [MLdummy] is left
      accordingly. *)
   let optdummy = match sign_kind s_full with
-    | UnsafeLogicalSig when lang () <> Haskell -> [MLdummy]
+    | UnsafeLogicalSig when lang () != Haskell -> [MLdummy]
     | _ -> []
   in
   (* Different situations depending of the number of arguments: *)
@@ -702,7 +739,7 @@ and extract_cst_app env mle mlt kn args =
     (* Partially applied function with some logical arg missing.
        We complete via eta and expunge logical args. *)
     let ls' = ls-la in
-    let s' = list_skipn la s in
+    let s' = List.skipn la s in
     let mla = (List.map (ast_lift ls') mla) @ (eta_args_sign ls' s') in
     let e = anonym_or_dummy_lams (mlapp head mla) s' in
     put_magic_if magic2 (remove_n_lams (List.length optdummy) e)
@@ -717,14 +754,14 @@ and extract_cst_app env mle mlt kn args =
    they are fixed, and thus are not used for the computation.
    \end{itemize} *)
 
-and extract_cons_app env mle mlt (((kn,i) as ip,j) as cp) args =
+and extract_cons_app env mle mlt (((kn,i) as ip,j) as cp) u args =
   (* First, we build the type of the constructor, stored in small pieces. *)
   let mi = extract_ind env kn in
   let params_nb = mi.ind_nparams in
   let oi = mi.ind_packets.(i) in
   let nb_tvars = List.length oi.ip_vars
   and types = List.map (expand env) oi.ip_types.(j-1) in
-  let list_tvar = List.map (fun i -> Tvar i) (interval 1 nb_tvars) in
+  let list_tvar = List.map (fun i -> Tvar i) (List.interval 1 nb_tvars) in
   let type_cons = type_recomp (types, Tglob (IndRef ip, list_tvar)) in
   let type_cons = instantiation (nb_tvars, type_cons) in
   (* Then, the usual variables [s], [ls], [la], ... *)
@@ -734,7 +771,7 @@ and extract_cons_app env mle mlt (((kn,i) as ip,j) as cp) args =
   let la = List.length args in
   assert (la <= ls + params_nb);
   let la' = max 0 (la - params_nb) in
-  let args' = list_lastn la' args in
+  let args' = List.lastn la' args in
   (* Now, we build the expected type of the constructor *)
   let metas = List.map new_meta args' in
   (* If stored and expected types differ, then magic! *)
@@ -742,7 +779,7 @@ and extract_cons_app env mle mlt (((kn,i) as ip,j) as cp) args =
   let magic1 = needs_magic (type_cons, type_recomp (metas, a)) in
   let magic2 = needs_magic (a, mlt) in
   let head mla =
-    if mi.ind_kind = Singleton then
+    if mi.ind_kind == Singleton then
       put_magic_if magic1 (List.hd mla) (* assert (List.length mla = 1) *)
     else
       let typeargs = match snd (type_decomp type_cons) with
@@ -759,11 +796,11 @@ and extract_cons_app env mle mlt (((kn,i) as ip,j) as cp) args =
       (dummy_lams (anonym_or_dummy_lams head' s) (params_nb - la))
   else
     let mla = make_mlargs env mle s args' metas in
-    if la = ls + params_nb
+    if Int.equal la (ls + params_nb)
     then put_magic_if (magic2 && not magic1) (head mla)
     else (* [ params_nb <= la <= ls + params_nb ] *)
       let ls' = params_nb + ls - la in
-      let s' = list_lastn ls' s in
+      let s' = List.lastn ls' s in
       let mla = (List.map (ast_lift ls') mla) @ (eta_args_sign ls' s') in
       put_magic_if magic2 (anonym_or_dummy_lams (head mla) s')
 
@@ -772,22 +809,22 @@ and extract_cons_app env mle mlt (((kn,i) as ip,j) as cp) args =
 and extract_case env mle ((kn,i) as ip,c,br) mlt =
   (* [br]: bodies of each branch (in functional form) *)
   (* [ni]: number of arguments without parameters in each branch *)
-  let ni = mis_constr_nargs_env env ip in
+  let ni = constructors_nrealargs_env env ip in
   let br_size = Array.length br in
-  assert (Array.length ni = br_size);
-  if br_size = 0 then begin
+  assert (Int.equal (Array.length ni) br_size);
+  if Int.equal br_size 0 then begin
     add_recursors env kn; (* May have passed unseen if logical ... *)
     MLexn "absurd case"
   end else
     (* [c] has an inductive type, and is not a type scheme type. *)
     let t = type_of env c in
     (* The only non-informative case: [c] is of sort [Prop] *)
-    if (sort_of env t) = InProp then
+    if (sort_of env t) == InProp then
       begin
 	add_recursors env kn; (* May have passed unseen if logical ... *)
 	(* Logical singleton case: *)
 	(* [match c with C i j k -> t] becomes [t'] *)
-	assert (br_size = 1);
+	assert (Int.equal br_size 1);
 	let s = iterate (fun l -> Kill Kother :: l) ni.(0) [] in
 	let mlt = iterate (fun t -> Tarr (Tdummy Kother, t)) ni.(0) mlt in
 	let e = extract_maybe_term env mle mlt br.(0) in
@@ -816,13 +853,13 @@ and extract_case env mle ((kn,i) as ip,c,br) mlt =
 	let e' = handle_exn r (List.length s) (fun _ -> Anonymous) e in
 	(List.rev ids, Pusual r, e')
       in
-      if mi.ind_kind = Singleton then
+      if mi.ind_kind == Singleton then
 	begin
 	  (* Informative singleton case: *)
 	  (* [match c with C i -> t] becomes [let i = c' in t'] *)
-	  assert (br_size = 1);
+	  assert (Int.equal br_size 1);
 	  let (ids,_,e') = extract_branch 0 in
-	  assert (List.length ids = 1);
+	  assert (Int.equal (List.length ids) 1);
 	  MLletin (tmp_id (List.hd ids),a,e')
 	end
       else
@@ -838,7 +875,7 @@ and extract_fix env mle i (fi,ti,ci as recd) mlt =
   let metas = Array.map new_meta fi in
   metas.(i) <- mlt;
   let mle = Array.fold_left Mlenv.push_type mle metas in
-  let ei = array_map2 (extract_maybe_term env mle) metas ci in
+  let ei = Array.map2 (extract_maybe_term env mle) metas ci in
   MLfix (i, Array.map id_of_name fi, ei)
 
 (*S ML declarations. *)
@@ -846,14 +883,14 @@ and extract_fix env mle i (fi,ti,ci as recd) mlt =
 (* [decomp_lams_eta env c t] finds the number [n] of products in the type [t],
    and decompose the term [c] in [n] lambdas, with eta-expansion if needed. *)
 
-let rec decomp_lams_eta_n n m env c t =
+let decomp_lams_eta_n n m env c t =
   let rels = fst (splay_prod_n env none n t) in
   let rels = List.map (fun (id,_,c) -> (id,c)) rels in
   let rels',c = decompose_lam c in
   let d = n - m in
   (* we'd better keep rels' as long as possible. *)
-  let rels = (list_firstn d rels) @ rels' in
-  let eta_args = List.rev_map mkRel (interval 1 d) in
+  let rels = (List.firstn d rels) @ rels' in
+  let eta_args = List.rev_map mkRel (List.interval 1 d) in
   rels, applist (lift d c,eta_args)
 
 (* Let's try to identify some situation where extracted code
@@ -864,7 +901,7 @@ let rec gentypvar_ok c = match kind_of_term c with
   | App (c,v) ->
       (* if all arguments are variables, these variables will
 	 disappear after extraction (see [empty_s] below) *)
-      array_for_all isRel v && gentypvar_ok c
+      Array.for_all isRel v && gentypvar_ok c
   | Cast (c,_,_) -> gentypvar_ok c
   | _ -> false
 
@@ -891,26 +928,26 @@ let extract_std_constant env kn body typ =
     and m = nb_lam body in
     if n <= m then decompose_lam_n n body
     else
-      let s,s' = list_chop m s in
-      if List.for_all ((=) Keep) s' &&
-	(lang () = Haskell || sign_kind s <> UnsafeLogicalSig)
+      let s,s' = List.chop m s in
+      if List.for_all ((==) Keep) s' &&
+	(lang () == Haskell || sign_kind s != UnsafeLogicalSig)
       then decompose_lam_n m body
       else decomp_lams_eta_n n m env body typ
   in
   (* Should we do one eta-expansion to avoid non-generalizable '_a ? *)
   let rels, c =
     let n = List.length rels in
-    let s,s' = list_chop n s in
+    let s,s' = List.chop n s in
     let k = sign_kind s in
-    let empty_s = (k = EmptySig || k = SafeLogicalSig) in
-    if lang () = Ocaml && empty_s && not (gentypvar_ok c)
-      && s' <> [] && type_maxvar t <> 0
+    let empty_s = (k == EmptySig || k == SafeLogicalSig) in
+    if lang () == Ocaml && empty_s && not (gentypvar_ok c)
+      && not (List.is_empty s') && not (Int.equal (type_maxvar t) 0)
     then decomp_lams_eta_n (n+1) n env body typ
     else rels,c
   in
   let n = List.length rels in
-  let s = list_firstn n s in
-  let l,l' = list_chop n l in
+  let s = List.firstn n s in
+  let l,l' = List.chop n l in
   let t' = type_recomp (l',t') in
   (* The initial ML environment. *)
   let mle = List.fold_left Mlenv.push_std_type Mlenv.empty l in
@@ -948,7 +985,7 @@ let extract_fixpoint env vkn (fi,ti,ci) =
   (* for replacing recursive calls [Rel ..] by the corresponding [Const]: *)
   let sub = List.rev_map mkConst kns in
   for i = 0 to n-1 do
-    if sort_of env ti.(i) <> InProp then begin
+    if sort_of env ti.(i) != InProp then begin
       let e,t = extract_std_constant env vkn.(i) (substl sub ci.(i)) ti.(i) in
       terms.(i) <- e;
       types.(i) <- t;
@@ -988,17 +1025,21 @@ let extract_constant env kn cb =
     | (Info,TypeScheme) ->
         (match cb.const_body with
 	  | Undef _ -> warn_info (); mk_typ_ax ()
-	  | Def c -> mk_typ (force c)
+	  | Def c -> mk_typ (Mod_subst.force_constr c)
 	  | OpaqueDef c ->
 	    add_opaque r;
-	    if access_opaque () then mk_typ (force_opaque c) else mk_typ_ax ())
+	    if access_opaque () then
+              mk_typ (Opaqueproof.force_proof (Environ.opaque_tables env) c)
+            else mk_typ_ax ())
     | (Info,Default) ->
         (match cb.const_body with
 	  | Undef _ -> warn_info (); mk_ax ()
-	  | Def c -> mk_def (force c)
+	  | Def c -> mk_def (Mod_subst.force_constr c)
 	  | OpaqueDef c ->
 	    add_opaque r;
-	    if access_opaque () then mk_def (force_opaque c) else mk_ax ())
+	    if access_opaque () then
+              mk_def (Opaqueproof.force_proof (Environ.opaque_tables env) c)
+            else mk_ax ())
 
 let extract_constant_spec env kn cb =
   let r = ConstRef kn in
@@ -1012,27 +1053,32 @@ let extract_constant_spec env kn cb =
 	  | Undef _ | OpaqueDef _ -> Stype (r, vl, None)
 	  | Def body ->
 	      let db = db_from_sign s in
-	      let t = extract_type_scheme env db (force body) (List.length s)
+              let body = Mod_subst.force_constr body in
+	      let t = extract_type_scheme env db body (List.length s)
 	      in Stype (r, vl, Some t))
     | (Info, Default) ->
 	let t = snd (record_constant_type env kn (Some typ)) in
 	Sval (r, type_expunge env t)
 
-let extract_with_type env cb =
-  let typ = Typeops.type_of_constant_type env cb.const_type in
+let extract_with_type env c =
+  let typ = type_of env c in
   match flag_of_type env typ with
     | (Info, TypeScheme) ->
 	let s,vl = type_sign_vl env typ in
 	let db = db_from_sign s in
-	let c = match cb.const_body with
-	  | Def body -> force body
-	  (* A "with Definition ..." is necessarily transparent *)
-	  | Undef _ | OpaqueDef _ -> assert false
-	in
 	let t = extract_type_scheme env db c (List.length s) in
 	Some (vl, t)
     | _ -> None
 
+let extract_constr env c =
+  reset_meta_count ();
+  let typ = type_of env c in
+  match flag_of_type env typ with
+    | (_,TypeScheme) -> MLdummy, Tdummy Ktype
+    | (Logic,_) -> MLdummy, Tdummy Kother
+    | (Info,Default) ->
+      let mlt = extract_type env [] 1 typ [] in
+      extract_term env Mlenv.empty mlt c [], mlt
 
 let extract_inductive env kn =
   let ind = extract_ind env kn in
@@ -1043,7 +1089,7 @@ let extract_inductive env kn =
       | [] -> []
       | t::l ->
 	  let l' = filter (succ i) l in
-	  if isDummy (expand env t) || List.mem i implicits then l'
+	  if isDummy (expand env t) || Int.List.mem i implicits then l'
 	  else t::l'
     in filter (1+ind.ind_nparams) l
   in
@@ -1058,9 +1104,9 @@ let logical_decl = function
   | Dterm (_,MLdummy,Tdummy _) -> true
   | Dtype (_,[],Tdummy _) -> true
   | Dfix (_,av,tv) ->
-      (array_for_all ((=) MLdummy) av) &&
-      (array_for_all isDummy tv)
-  | Dind (_,i) -> array_for_all (fun ip -> ip.ip_logical) i.ind_packets
+      (Array.for_all ((==) MLdummy) av) &&
+      (Array.for_all isDummy tv)
+  | Dind (_,i) -> Array.for_all (fun ip -> ip.ip_logical) i.ind_packets
   | _ -> false
 
 (*s Is a [ml_spec] logical ? *)
@@ -1068,5 +1114,5 @@ let logical_decl = function
 let logical_spec = function
   | Stype (_, [], Some (Tdummy _)) -> true
   | Sval (_,Tdummy _) -> true
-  | Sind (_,i) -> array_for_all (fun ip -> ip.ip_logical) i.ind_packets
+  | Sind (_,i) -> Array.for_all (fun ip -> ip.ip_logical) i.ind_packets
   | _ -> false
diff --git a/plugins/extraction/extraction.mli b/plugins/extraction/extraction.mli
index f10f3589..6bd2541b 100644
--- a/plugins/extraction/extraction.mli
+++ b/plugins/extraction/extraction.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -12,20 +12,25 @@ open Names
 open Term
 open Declarations
 open Environ
-open Libnames
 open Miniml
 
 val extract_constant : env -> constant -> constant_body -> ml_decl
 
 val extract_constant_spec : env -> constant -> constant_body -> ml_spec
 
-val extract_with_type : env -> constant_body -> ( identifier list * ml_type ) option
+(** For extracting "module ... with ..." declaration *)
+
+val extract_with_type : env -> constr -> ( Id.t list * ml_type ) option
 
 val extract_fixpoint :
   env -> constant array -> (constr, types) prec_declaration -> ml_decl
 
 val extract_inductive : env -> mutual_inductive -> ml_ind
 
+(** For extraction compute *)
+
+val extract_constr : env -> constr -> ml_ast * ml_type
+
 (*s Is a [ml_decl] or a [ml_spec] logical ? *)
 
 val logical_decl : ml_decl -> bool
diff --git a/plugins/extraction/g_extraction.ml4 b/plugins/extraction/g_extraction.ml4
index a2b6b14a..3caa558f 100644
--- a/plugins/extraction/g_extraction.ml4
+++ b/plugins/extraction/g_extraction.ml4
@@ -1,17 +1,15 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i camlp4deps: "parsing/grammar.cma" i*)
+(*i camlp4deps: "grammar/grammar.cma" i*)
 
 (* ML names *)
 
-open Vernacexpr
-open Pcoq
 open Genarg
 open Pp
 open Names
@@ -35,7 +33,7 @@ let pr_int_or_id _ _ _ = function
 ARGUMENT EXTEND int_or_id
   TYPED AS int_or_id
   PRINTED BY pr_int_or_id
-| [ preident(id) ] -> [ ArgId (id_of_string id) ]
+| [ preident(id) ] -> [ ArgId (Id.of_string id) ]
 | [ integer(i) ] -> [ ArgInt i ]
 END
 
@@ -53,7 +51,7 @@ END
 
 (* Extraction commands *)
 
-VERNAC COMMAND EXTEND Extraction
+VERNAC COMMAND EXTEND Extraction CLASSIFIED AS QUERY
 (* Extraction in the Coq toplevel *)
 | [ "Extraction" global(x) ] -> [ simple_extraction x ]
 | [ "Recursive" "Extraction" ne_global_list(l) ] -> [ full_extraction None l ]
@@ -63,85 +61,85 @@ VERNAC COMMAND EXTEND Extraction
   -> [ full_extraction (Some f) l ]
 END
 
-VERNAC COMMAND EXTEND SeparateExtraction
+VERNAC COMMAND EXTEND SeparateExtraction CLASSIFIED AS QUERY
 (* Same, with content splitted in several files *)
 | [ "Separate" "Extraction" ne_global_list(l) ]
   -> [ separate_extraction l ]
 END
 
 (* Modular extraction (one Coq library = one ML module) *)
-VERNAC COMMAND EXTEND ExtractionLibrary
+VERNAC COMMAND EXTEND ExtractionLibrary CLASSIFIED AS QUERY
 | [ "Extraction" "Library" ident(m) ]
   -> [ extraction_library false m ]
 END
 
-VERNAC COMMAND EXTEND RecursiveExtractionLibrary
+VERNAC COMMAND EXTEND RecursiveExtractionLibrary CLASSIFIED AS QUERY
 | [ "Recursive" "Extraction" "Library" ident(m) ]
   -> [ extraction_library true m ]
 END
 
 (* Target Language *)
-VERNAC COMMAND EXTEND ExtractionLanguage
+VERNAC COMMAND EXTEND ExtractionLanguage CLASSIFIED AS SIDEFF
 | [ "Extraction" "Language" language(l) ]
   -> [ extraction_language l ]
 END
 
-VERNAC COMMAND EXTEND ExtractionInline
+VERNAC COMMAND EXTEND ExtractionInline CLASSIFIED AS SIDEFF
 (* Custom inlining directives *)
 | [ "Extraction" "Inline" ne_global_list(l) ]
   -> [ extraction_inline true l ]
 END
 
-VERNAC COMMAND EXTEND ExtractionNoInline
+VERNAC COMMAND EXTEND ExtractionNoInline CLASSIFIED AS SIDEFF
 | [ "Extraction" "NoInline" ne_global_list(l) ]
   -> [ extraction_inline false l ]
 END
 
-VERNAC COMMAND EXTEND PrintExtractionInline
+VERNAC COMMAND EXTEND PrintExtractionInline CLASSIFIED AS QUERY
 | [ "Print" "Extraction" "Inline" ]
-  -> [ print_extraction_inline () ]
+  -> [ msg_info (print_extraction_inline ()) ]
 END
 
-VERNAC COMMAND EXTEND ResetExtractionInline
+VERNAC COMMAND EXTEND ResetExtractionInline CLASSIFIED AS SIDEFF
 | [ "Reset" "Extraction" "Inline" ]
   -> [ reset_extraction_inline () ]
 END
 
-VERNAC COMMAND EXTEND ExtractionImplicit
+VERNAC COMMAND EXTEND ExtractionImplicit CLASSIFIED AS SIDEFF
 (* Custom implicit arguments of some csts/inds/constructors *)
 | [ "Extraction" "Implicit" global(r) "[" int_or_id_list(l) "]" ]
   -> [ extraction_implicit r l ]
 END
 
-VERNAC COMMAND EXTEND ExtractionBlacklist
+VERNAC COMMAND EXTEND ExtractionBlacklist CLASSIFIED AS SIDEFF
 (* Force Extraction to not use some filenames *)
 | [ "Extraction" "Blacklist" ne_ident_list(l) ]
   -> [ extraction_blacklist l ]
 END
 
-VERNAC COMMAND EXTEND PrintExtractionBlacklist
+VERNAC COMMAND EXTEND PrintExtractionBlacklist CLASSIFIED AS QUERY
 | [ "Print" "Extraction" "Blacklist" ]
-  -> [ print_extraction_blacklist () ]
+  -> [ msg_info (print_extraction_blacklist ()) ]
 END
 
-VERNAC COMMAND EXTEND ResetExtractionBlacklist
+VERNAC COMMAND EXTEND ResetExtractionBlacklist CLASSIFIED AS SIDEFF
 | [ "Reset" "Extraction" "Blacklist" ]
   -> [ reset_extraction_blacklist () ]
 END
 
 
 (* Overriding of a Coq object by an ML one *)
-VERNAC COMMAND EXTEND ExtractionConstant
+VERNAC COMMAND EXTEND ExtractionConstant CLASSIFIED AS SIDEFF
 | [ "Extract" "Constant" global(x) string_list(idl) "=>" mlname(y) ]
   -> [ extract_constant_inline false x idl y ]
 END
 
-VERNAC COMMAND EXTEND ExtractionInlinedConstant
+VERNAC COMMAND EXTEND ExtractionInlinedConstant CLASSIFIED AS SIDEFF
 | [ "Extract" "Inlined" "Constant" global(x) "=>" mlname(y) ]
   -> [ extract_constant_inline true x [] y ]
 END
 
-VERNAC COMMAND EXTEND ExtractionInductive
+VERNAC COMMAND EXTEND ExtractionInductive CLASSIFIED AS SIDEFF
 | [ "Extract" "Inductive" global(x) "=>"
     mlname(id) "[" mlname_list(idl) "]" string_opt(o) ]
   -> [ extract_inductive x id idl o ]
diff --git a/plugins/extraction/haskell.ml b/plugins/extraction/haskell.ml
index 4f9c6a71..5e08fef5 100644
--- a/plugins/extraction/haskell.ml
+++ b/plugins/extraction/haskell.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -9,10 +9,11 @@
 (*s Production of Haskell syntax. *)
 
 open Pp
+open Errors
 open Util
 open Names
 open Nameops
-open Libnames
+open Globnames
 open Table
 open Miniml
 open Mlutil
@@ -20,38 +21,47 @@ open Common
 
 (*s Haskell renaming issues. *)
 
-let pr_lower_id id = str (String.uncapitalize (string_of_id id))
-let pr_upper_id id = str (String.capitalize (string_of_id id))
+let pr_lower_id id = str (String.uncapitalize (Id.to_string id))
+let pr_upper_id id = str (String.capitalize (Id.to_string id))
 
 let keywords =
-  List.fold_right (fun s -> Idset.add (id_of_string s))
+  List.fold_right (fun s -> Id.Set.add (Id.of_string s))
   [ "case"; "class"; "data"; "default"; "deriving"; "do"; "else";
     "if"; "import"; "in"; "infix"; "infixl"; "infixr"; "instance";
     "let"; "module"; "newtype"; "of"; "then"; "type"; "where"; "_"; "__";
     "as"; "qualified"; "hiding" ; "unit" ; "unsafeCoerce" ]
-  Idset.empty
+  Id.Set.empty
 
-let preamble mod_name used_modules usf =
+let pp_comment s = str "-- " ++ s ++ fnl ()
+let pp_bracket_comment s = str"{- " ++ hov 0 s ++ str" -}"
+
+let preamble mod_name comment used_modules usf =
   let pp_import mp = str ("import qualified "^ string_of_modfile mp ^"\n")
   in
   (if not usf.magic then mt ()
    else
-     str "{-# OPTIONS_GHC -cpp -fglasgow-exts #-}\n" ++
-     str "{- For Hugs, use the option -F\"cpp -P -traditional\" -}\n\n")
+     str "{-# OPTIONS_GHC -cpp -XMagicHash #-}" ++ fnl () ++
+     str "{- For Hugs, use the option -F\"cpp -P -traditional\" -}")
+  ++ fnl () ++ fnl ()
+  ++
+  (match comment with
+    | None -> mt ()
+    | Some com -> pp_bracket_comment com ++ fnl () ++ fnl ())
   ++
   str "module " ++ pr_upper_id mod_name ++ str " where" ++ fnl2 () ++
   str "import qualified Prelude" ++ fnl () ++
   prlist pp_import used_modules ++ fnl () ++
-  (if used_modules = [] then mt () else fnl ()) ++
+  (if List.is_empty used_modules then mt () else fnl ()) ++
   (if not usf.magic then mt ()
    else str "\
-\nunsafeCoerce :: a -> b\
 \n#ifdef __GLASGOW_HASKELL__\
 \nimport qualified GHC.Base\
+\nunsafeCoerce :: a -> b\
 \nunsafeCoerce = GHC.Base.unsafeCoerce#\
 \n#else\
 \n-- HUGS\
 \nimport qualified IOExts\
+\nunsafeCoerce :: a -> b\
 \nunsafeCoerce = IOExts.unsafeCoerce\
 \n#endif" ++ fnl2 ())
   ++
@@ -74,19 +84,15 @@ let pp_global k r =
 (*s Pretty-printing of types. [par] is a boolean indicating whether parentheses
     are needed or not. *)
 
-let kn_sig =
-  let specif = MPfile (dirpath_of_string "Coq.Init.Specif") in
-  make_mind specif empty_dirpath (mk_label "sig")
-
 let rec pp_type par vl t =
   let rec pp_rec par = function
     | Tmeta _ | Tvar' _ -> assert false
     | Tvar i ->
       (try pr_id (List.nth vl (pred i))
-       with e when Errors.noncritical e -> (str "a" ++ int i))
+       with Failure _ -> (str "a" ++ int i))
     | Tglob (r,[]) -> pp_global Type r
     | Tglob (IndRef(kn,0),l)
-	when not (keep_singleton ()) && kn = mk_ind "Coq.Init.Specif" "sig" ->
+	when not (keep_singleton ()) && MutInd.equal kn (mk_ind "Coq.Init.Specif" "sig") ->
 	  pp_type true vl (List.hd l)
     | Tglob (r,l) ->
 	  pp_par par
@@ -140,7 +146,7 @@ let rec pp_expr par env args =
     | MLglob r ->
 	apply (pp_global Term r)
     | MLcons (_,r,a) as c ->
-        assert (args=[]);
+        assert (List.is_empty args);
         begin match a with
 	  | _ when is_native_char c -> pp_native_char c
 	  | [] -> pp_global Cons r
@@ -151,13 +157,13 @@ let rec pp_expr par env args =
 			prlist_with_sep spc (pp_expr true env []) a)
 	end
     | MLtuple l ->
-        assert (args=[]);
+        assert (List.is_empty args);
         pp_boxed_tuple (pp_expr true env []) l
     | MLcase (_,t, pv) when is_custom_match pv ->
         if not (is_regular_match pv) then
 	  error "Cannot mix yet user-given match and general patterns.";
 	let mkfun (ids,_,e) =
-	  if ids <> [] then named_lams (List.rev ids) e
+	  if not (List.is_empty ids) then named_lams (List.rev ids) e
 	  else dummy_lams (ast_lift 1 e) 1
 	in
 	let pp_branch tr = pp_expr true env [] (mkfun tr) ++ fnl () in
@@ -185,7 +191,7 @@ let rec pp_expr par env args =
 
 and pp_cons_pat par r ppl =
   pp_par par
-    (pp_global Cons r ++ space_if (ppl<>[]) ++ prlist_with_sep spc identity ppl)
+    (pp_global Cons r ++ space_if (not (List.is_empty ppl)) ++ prlist_with_sep spc identity ppl)
 
 and pp_gen_pat par ids env = function
   | Pcons (r,l) -> pp_cons_pat par r (List.map (pp_gen_pat true ids env) l)
@@ -205,7 +211,7 @@ and pp_pat env pv =
   prvecti
     (fun i x ->
        pp_one_pat env pv.(i) ++
-       if i = Array.length pv - 1 then str "}" else
+       if Int.equal i (Array.length pv - 1) then str "}" else
 	 (str ";" ++ fnl ()))
     pv
 
@@ -218,7 +224,7 @@ and pp_fix par env i (ids,bl) args =
        (v 1 (str "let {" ++ fnl () ++
 	     prvect_with_sep (fun () -> str ";" ++ fnl ())
 	       (fun (fi,ti) -> pp_function env (pr_id fi) ti)
-	       (array_map2 (fun a b -> a,b) ids bl) ++
+	       (Array.map2 (fun a b -> a,b) ids bl) ++
 	     str "}") ++
         fnl () ++ str "in " ++ pp_apply (pr_id ids.(i)) false args))
 
@@ -231,8 +237,6 @@ and pp_function env f t =
 
 (*s Pretty-printing of inductive types declaration. *)
 
-let pp_comment s = str "-- " ++ s ++ fnl ()
-
 let pp_logical_ind packet =
   pp_comment (pr_id packet.ip_typename ++ str " : logical inductive") ++
   pp_comment (str "with constructors : " ++
@@ -243,7 +247,7 @@ let pp_singleton kn packet =
   let l' = List.rev l in
   hov 2 (str "type " ++ pp_global Type (IndRef (kn,0)) ++ spc () ++
 	 prlist_with_sep spc pr_id l ++
-	 (if l <> [] then str " " else mt ()) ++ str "=" ++ spc () ++
+	 (if not (List.is_empty l) then str " " else mt ()) ++ str "=" ++ spc () ++
 	 pp_type false l' (List.hd packet.ip_types.(0)) ++ fnl () ++
 	 pp_comment (str "singleton inductive, whose constructor was " ++
 		     pr_id packet.ip_consnames.(0)))
@@ -258,10 +262,10 @@ let pp_one_ind ip pl cv =
       	       	prlist_with_sep
 		  (fun () -> (str " ")) (pp_type true pl) l))
   in
-  str (if Array.length cv = 0 then "type " else "data ") ++
+  str (if Array.is_empty cv then "type " else "data ") ++
   pp_global Type (IndRef ip) ++
   prlist_strict (fun id -> str " " ++ pr_lower_id id) pl ++ str " =" ++
-  if Array.length cv = 0 then str " () -- empty inductive"
+  if Array.is_empty cv then str " () -- empty inductive"
   else
     (fnl () ++ str " " ++
      v 0 (str "  " ++
@@ -286,7 +290,7 @@ let rec pp_ind first kn i ind =
 (*s Pretty-printing of a declaration. *)
 
 let pp_decl = function
-  | Dind (kn,i) when i.ind_kind = Singleton ->
+  | Dind (kn,i) when i.ind_kind == Singleton ->
       pp_singleton kn i.ind_packets.(0) ++ fnl ()
   | Dind (kn,i) -> hov 0 (pp_ind true kn 0 i)
   | Dtype (r, l, t) ->
@@ -299,7 +303,7 @@ let pp_decl = function
 	    prlist (fun id -> str (id^" ")) ids ++ str "=" ++ spc () ++ str s
 	  with Not_found ->
 	    prlist (fun id -> pr_id id ++ str " ") l ++
-	    if t = Taxiom then str "= () -- AXIOM TO BE REALIZED\n"
+	    if t == Taxiom then str "= () -- AXIOM TO BE REALIZED\n"
 	    else str "=" ++ spc () ++ pp_type false l t
 	in
 	hov 2 (str "type " ++ pp_global Type r ++ spc () ++ st) ++ fnl2 ()
@@ -310,7 +314,7 @@ let pp_decl = function
       prvecti
 	(fun i r ->
 	  let void = is_inline_custom r ||
-	    (not (is_custom r) && defs.(i) = MLexn "UNUSED")
+	    (not (is_custom r) && match defs.(i) with MLexn "UNUSED" -> true | _ -> false)
 	  in
 	  if void then mt ()
 	  else
@@ -359,7 +363,7 @@ let haskell_descr = {
   preamble = preamble;
   pp_struct = pp_struct;
   sig_suffix = None;
-  sig_preamble = (fun _ _ _ -> mt ());
+  sig_preamble = (fun _ _ _ _ -> mt ());
   pp_sig = (fun _ -> mt ());
   pp_decl = pp_decl;
 }
diff --git a/plugins/extraction/haskell.mli b/plugins/extraction/haskell.mli
index b00fc42f..99559bce 100644
--- a/plugins/extraction/haskell.mli
+++ b/plugins/extraction/haskell.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/plugins/extraction/miniml.mli b/plugins/extraction/miniml.mli
index fbb1c116..1e491d36 100644
--- a/plugins/extraction/miniml.mli
+++ b/plugins/extraction/miniml.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -9,9 +9,8 @@
 (*s Target language for extraction: a core ML called MiniML. *)
 
 open Pp
-open Util
 open Names
-open Libnames
+open Globnames
 
 (* The [signature] type is used to know how many arguments a CIC
    object expects, and what these arguments will become in the ML
@@ -66,11 +65,11 @@ type inductive_kind =
 *)
 
 type ml_ind_packet = {
-  ip_typename : identifier;
-  ip_consnames : identifier array;
+  ip_typename : Id.t;
+  ip_consnames : Id.t array;
   ip_logical : bool;
   ip_sign : signature;
-  ip_vars : identifier list;
+  ip_vars : Id.t list;
   ip_types : (ml_type list) array
 }
 
@@ -92,8 +91,8 @@ type ml_ind = {
 
 type ml_ident =
   | Dummy
-  | Id of identifier
-  | Tmp of identifier
+  | Id of Id.t
+  | Tmp of Id.t
 
 (** We now store some typing information on constructors
     and cases to avoid type-unsafe optimisations. This will be
@@ -117,7 +116,7 @@ and ml_ast =
   | MLcons   of ml_type * global_reference * ml_ast list
   | MLtuple  of ml_ast list
   | MLcase   of ml_type * ml_ast * ml_branch array
-  | MLfix    of int * identifier array * ml_ast array
+  | MLfix    of int * Id.t array * ml_ast array
   | MLexn    of string
   | MLdummy
   | MLaxiom
@@ -134,13 +133,13 @@ and ml_pattern =
 
 type ml_decl =
   | Dind  of mutual_inductive * ml_ind
-  | Dtype of global_reference * identifier list * ml_type
+  | Dtype of global_reference * Id.t list * ml_type
   | Dterm of global_reference * ml_ast * ml_type
   | Dfix  of global_reference array * ml_ast array * ml_type array
 
 type ml_spec =
   | Sind  of mutual_inductive * ml_ind
-  | Stype of global_reference * identifier list * ml_type option
+  | Stype of global_reference * Id.t list * ml_type option
   | Sval  of global_reference * ml_type
 
 type ml_specif =
@@ -150,15 +149,15 @@ type ml_specif =
 
 and ml_module_type =
   | MTident of module_path
-  | MTfunsig of mod_bound_id * ml_module_type * ml_module_type
+  | MTfunsig of MBId.t * ml_module_type * ml_module_type
   | MTsig of module_path * ml_module_sig
   | MTwith of ml_module_type * ml_with_declaration
 
 and ml_with_declaration =
-  | ML_With_type of identifier list * identifier list * ml_type
-  | ML_With_module of identifier list * module_path
+  | ML_With_type of Id.t list * Id.t list * ml_type
+  | ML_With_module of Id.t list * module_path
 
-and ml_module_sig = (label * ml_specif) list
+and ml_module_sig = (Label.t * ml_specif) list
 
 type ml_structure_elem =
   | SEdecl of ml_decl
@@ -167,11 +166,11 @@ type ml_structure_elem =
 
 and ml_module_expr =
   | MEident of module_path
-  | MEfunctor of mod_bound_id * ml_module_type * ml_module_expr
+  | MEfunctor of MBId.t * ml_module_type * ml_module_expr
   | MEstruct of module_path * ml_module_structure
   | MEapply of ml_module_expr * ml_module_expr
 
-and ml_module_structure = (label * ml_structure_elem) list
+and ml_module_structure = (Label.t * ml_structure_elem) list
 
 and ml_module =
     { ml_mod_expr : ml_module_expr;
@@ -184,6 +183,8 @@ type ml_structure = (module_path * ml_module_structure) list
 
 type ml_signature = (module_path * ml_module_sig) list
 
+type ml_flat_structure = ml_structure_elem list
+
 type unsafe_needs = {
   mldummy : bool;
   tdummy : bool;
@@ -192,16 +193,22 @@ type unsafe_needs = {
 }
 
 type language_descr = {
-  keywords : Idset.t;
+  keywords : Id.Set.t;
 
   (* Concerning the source file *)
   file_suffix : string;
-  preamble : identifier -> module_path list -> unsafe_needs -> std_ppcmds;
+  (* the second argument is a comment to add to the preamble *)
+  preamble :
+    Id.t -> std_ppcmds option -> module_path list -> unsafe_needs ->
+    std_ppcmds;
   pp_struct : ml_structure -> std_ppcmds;
 
   (* Concerning a possible interface file *)
   sig_suffix : string option;
-  sig_preamble : identifier -> module_path list -> unsafe_needs -> std_ppcmds;
+  (* the second argument is a comment to add to the preamble *)
+  sig_preamble :
+    Id.t -> std_ppcmds option -> module_path list -> unsafe_needs ->
+    std_ppcmds;
   pp_sig : ml_signature -> std_ppcmds;
 
   (* for an isolated declaration print *)
diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml
index 1462d3e7..9fdb0205 100644
--- a/plugins/extraction/mlutil.ml
+++ b/plugins/extraction/mlutil.ml
@@ -1,17 +1,16 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
 (*i*)
-open Pp
 open Util
 open Names
 open Libnames
-open Nametab
+open Globnames
 open Table
 open Miniml
 (*i*)
@@ -23,14 +22,14 @@ exception Impossible
 
 (*S Names operations. *)
 
-let anonymous_name = id_of_string "x"
-let dummy_name = id_of_string "_"
+let anonymous_name = Id.of_string "x"
+let dummy_name = Id.of_string "_"
 
 let anonymous = Id anonymous_name
 
 let id_of_name = function
   | Anonymous -> anonymous_name
-  | Name id when id = dummy_name -> anonymous_name
+  | Name id when Id.equal id dummy_name -> anonymous_name
   | Name id -> id
 
 let id_of_mlid = function
@@ -54,6 +53,22 @@ let new_meta _ =
   incr meta_count;
   Tmeta {id = !meta_count; contents = None}
 
+let rec eq_ml_type t1 t2 = match t1, t2 with
+| Tarr (tl1, tr1), Tarr (tl2, tr2) ->
+  eq_ml_type tl1 tl2 && eq_ml_type tr1 tr2
+| Tglob (gr1, t1), Tglob (gr2, t2) ->
+  eq_gr gr1 gr2 && List.equal eq_ml_type t1 t2
+| Tvar i1, Tvar i2 -> Int.equal i1 i2
+| Tvar' i1, Tvar' i2 -> Int.equal i1 i2
+| Tmeta m1, Tmeta m2 -> eq_ml_meta m1 m2
+| Tdummy k1, Tdummy k2 -> k1 == k2
+| Tunknown, Tunknown -> true
+| Taxiom, Taxiom -> true
+| _ -> false
+
+and eq_ml_meta m1 m2 =
+ Int.equal m1.id m2.id && Option.equal eq_ml_type m1.contents m2.contents
+
 (* Simultaneous substitution of [[Tvar 1; ... ; Tvar n]] by [l] in a ML type. *)
 
 let type_subst_list l t =
@@ -86,7 +101,7 @@ let instantiation (nb,t) = type_subst_vect (Array.init nb new_meta) t
 
 let rec type_occurs alpha t =
   match t with
-  | Tmeta {id=beta; contents=None} -> alpha = beta
+  | Tmeta {id=beta; contents=None} -> Int.equal alpha beta
   | Tmeta {contents=Some u} -> type_occurs alpha u
   | Tarr (t1, t2) -> type_occurs alpha t1 || type_occurs alpha t2
   | Tglob (r,l) -> List.exists (type_occurs alpha) l
@@ -95,7 +110,7 @@ let rec type_occurs alpha t =
 (*s Most General Unificator *)
 
 let rec mgu = function
-  | Tmeta m, Tmeta m' when m.id = m'.id -> ()
+  | Tmeta m, Tmeta m' when Int.equal m.id m'.id -> ()
   | Tmeta m, t | t, Tmeta m ->
     (match m.contents with
       | Some u -> mgu (u, t)
@@ -103,21 +118,24 @@ let rec mgu = function
       | None -> m.contents <- Some t)
   | Tarr(a, b), Tarr(a', b') ->
       mgu (a, a'); mgu (b, b')
-  | Tglob (r,l), Tglob (r',l') when r = r' ->
+  | Tglob (r,l), Tglob (r',l') when Globnames.eq_gr r r' ->
        List.iter mgu (List.combine l l')
-  | (Tdummy _, _ | _, Tdummy _) when lang() = Haskell -> ()
+  | (Tdummy _, _ | _, Tdummy _) when lang() == Haskell -> ()
   | Tdummy _, Tdummy _ -> ()
-  | t, u when t = u -> () (* for Tvar, Tvar', Tunknown, Taxiom *)
+  | Tvar i, Tvar j when Int.equal i j -> ()
+  | Tvar' i, Tvar' j when  Int.equal i j -> ()
+  | Tunknown, Tunknown -> ()
+  | Taxiom, Taxiom -> ()
   | _ -> raise Impossible
 
 let needs_magic p = try mgu p; false with Impossible -> true
 
-let put_magic_if b a = if b && lang () <> Scheme then MLmagic a else a
+let put_magic_if b a = if b && lang () != Scheme then MLmagic a else a
 
-let put_magic p a = if needs_magic p && lang () <> Scheme then MLmagic a else a
+let put_magic p a = if needs_magic p && lang () != Scheme then MLmagic a else a
 
 let generalizable a =
-  lang () <> Ocaml ||
+  lang () != Ocaml ||
     match a with
       | MLapp _ -> false
       | _ -> true (* TODO, this is just an approximation for the moment *)
@@ -148,7 +166,7 @@ module Mlenv = struct
   (* [find_free] finds the free meta in a type. *)
 
   let rec find_free set = function
-    | Tmeta m when m.contents = None -> Metaset.add m set
+    | Tmeta m when Option.is_empty m.contents -> Metaset.add m set
     | Tmeta {contents = Some t} -> find_free set t
     | Tarr (a,b) -> find_free (find_free set a) b
     | Tglob (_,l) -> List.fold_left find_free set l
@@ -172,12 +190,12 @@ module Mlenv = struct
 
   let generalization mle t =
     let c = ref 0 in
-    let map = ref (Intmap.empty : int Intmap.t) in
-    let add_new i = incr c; map := Intmap.add i !c !map; !c in
+    let map = ref (Int.Map.empty : int Int.Map.t) in
+    let add_new i = incr c; map := Int.Map.add i !c !map; !c in
     let rec meta2var t = match t with
       | Tmeta {contents=Some u} -> meta2var u
       | Tmeta ({id=i} as m) ->
-	  (try Tvar (Intmap.find i !map)
+	  (try Tvar (Int.Map.find i !map)
 	   with Not_found ->
 	     if Metaset.mem m mle.free then t
 	     else Tvar (add_new i))
@@ -225,21 +243,6 @@ let type_maxvar t =
     | _ -> n
   in parse 0 t
 
-(*s What are the type variables occurring in [t]. *)
-
-let intset_union_map_list f l =
-  List.fold_left (fun s t -> Intset.union s (f t)) Intset.empty l
-
-let intset_union_map_array f a =
-  Array.fold_left (fun s t -> Intset.union s (f t)) Intset.empty a
-
-let rec type_listvar = function
-  | Tmeta {contents = Some t} -> type_listvar t
-  | Tvar i | Tvar' i -> Intset.singleton i
-  | Tarr (a,b) -> Intset.union (type_listvar a) (type_listvar b)
-  | Tglob (_,l) -> intset_union_map_list type_listvar l
-  | _ -> Intset.empty
-
 (*s From [a -> b -> c] to [[a;b],c]. *)
 
 let rec type_decomp = function
@@ -283,13 +286,13 @@ let type_simpl = type_expand (fun _ -> None)
 (*s Generating a signature from a ML type. *)
 
 let type_to_sign env t = match type_expand env t with
-  | Tdummy d -> Kill d
+  | Tdummy d when not (conservative_types ()) -> Kill d
   | _ -> Keep
 
 let type_to_signature env t =
   let rec f = function
     | Tmeta {contents = Some t} -> f t
-    | Tarr (Tdummy d, b) -> Kill d :: f b
+    | Tarr (Tdummy d, b) when not (conservative_types ())  -> Kill d :: f b
     | Tarr (_, b) -> Keep :: f b
     | _ -> []
   in f (type_expand env t)
@@ -318,7 +321,7 @@ let rec sign_kind = function
 	| NonLogicalSig -> NonLogicalSig
 	| UnsafeLogicalSig -> UnsafeLogicalSig
 	| SafeLogicalSig | EmptySig ->
-	    if k = Kother then UnsafeLogicalSig else SafeLogicalSig
+	    if k == Kother then UnsafeLogicalSig else SafeLogicalSig
 
 (* Removing the final [Keep] in a signature *)
 
@@ -326,17 +329,17 @@ let rec sign_no_final_keeps = function
   | [] -> []
   | k :: s ->
       let s' = k :: sign_no_final_keeps s in
-      if s' = [Keep] then [] else s'
+      match s' with [Keep] -> [] | _ -> s'
 
 (*s Removing [Tdummy] from the top level of a ML type. *)
 
 let type_expunge_from_sign env s t =
   let rec expunge s t =
-    if s = [] then t else match t with
+    if List.is_empty s then t else match t with
       | Tmeta {contents = Some t} -> expunge s t
       | Tarr (a,b) ->
 	  let t = expunge (List.tl s) b in
-	  if List.hd s = Keep then Tarr (a, t) else t
+	  if List.hd s == Keep then Tarr (a, t) else t
       | Tglob (r,l) ->
 	  (match env r with
 	     | Some mlt -> expunge s (type_subst_list l mlt)
@@ -344,7 +347,7 @@ let type_expunge_from_sign env s t =
       | _ -> assert false
   in
   let t = expunge (sign_no_final_keeps s) t in
-  if lang () <> Haskell && sign_kind s = UnsafeLogicalSig then
+  if lang () != Haskell && sign_kind s == UnsafeLogicalSig then
     Tarr (Tdummy Kother, t)
   else t
 
@@ -353,7 +356,55 @@ let type_expunge env t =
 
 (*S Generic functions over ML ast terms. *)
 
-let mlapp f a = if a = [] then f else MLapp (f,a)
+let mlapp f a = if List.is_empty a then f else MLapp (f,a)
+
+(** Equality *)
+
+let eq_ml_ident i1 i2 = match i1, i2 with
+| Dummy, Dummy -> true
+| Id id1, Id id2 -> Id.equal id1 id2
+| Tmp id1, Tmp id2 -> Id.equal id1 id2
+| _ -> false
+
+let rec eq_ml_ast t1 t2 = match t1, t2 with
+| MLrel i1, MLrel i2 ->
+  Int.equal i1 i2
+| MLapp (f1, t1), MLapp (f2, t2) ->
+  eq_ml_ast f1 f2 && List.equal eq_ml_ast t1 t2
+| MLlam (na1, t1), MLlam (na2, t2) ->
+  eq_ml_ident na1 na2 && eq_ml_ast t1 t2
+| MLletin (na1, c1, t1), MLletin (na2, c2, t2) ->
+  eq_ml_ident na1 na2 && eq_ml_ast c1 c2 && eq_ml_ast t1 t2
+| MLglob gr1, MLglob gr2 -> eq_gr gr1 gr2
+| MLcons (t1, gr1, c1), MLcons (t2, gr2, c2) ->
+  eq_ml_type t1 t2 && eq_gr gr1 gr2 && List.equal eq_ml_ast c1 c2
+| MLtuple t1, MLtuple t2 ->
+  List.equal eq_ml_ast t1 t2
+| MLcase (t1, c1, p1), MLcase (t2, c2, p2) ->
+  eq_ml_type t1 t2 && eq_ml_ast c1 c2 && Array.equal eq_ml_branch p1 p2
+| MLfix (i1, id1, t1), MLfix (i2, id2, t2) ->
+  Int.equal i1 i2 && Array.equal Id.equal id1 id2 && Array.equal eq_ml_ast t1 t2
+| MLexn e1, MLexn e2 -> String.equal e1 e2
+| MLdummy, MLdummy -> true
+| MLaxiom, MLaxiom -> true
+| MLmagic t1, MLmagic t2 -> eq_ml_ast t1 t2
+| _ -> false
+
+and eq_ml_pattern p1 p2 = match p1, p2 with
+| Pcons (gr1, p1), Pcons (gr2, p2) ->
+  eq_gr gr1 gr2 && List.equal eq_ml_pattern p1 p2
+| Ptuple p1, Ptuple p2 ->
+  List.equal eq_ml_pattern p1 p2
+| Prel i1, Prel i2 ->
+  Int.equal i1 i2
+| Pwild, Pwild -> true
+| Pusual gr1, Pusual gr2 -> eq_gr gr1 gr2
+| _ -> false
+
+and eq_ml_branch (id1, p1, t1) (id2, p2, t2) =
+  List.equal eq_ml_ident id1 id2 &&
+  eq_ml_pattern p1 p2 &&
+  eq_ml_ast t1 t2
 
 (*s [ast_iter_rel f t] applies [f] on every [MLrel] in t. It takes care
    of the number of bingings crossed before reaching the [MLrel]. *)
@@ -428,7 +479,7 @@ let ast_iter f = function
 
 let ast_occurs k t =
   try
-    ast_iter_rel (fun i -> if i = k then raise Found) t; false
+    ast_iter_rel (fun i -> if Int.equal i k then raise Found) t; false
   with Found -> true
 
 (*s [occurs_itvl k k' t] returns [true] if there is a [(Rel i)]
@@ -444,7 +495,7 @@ let ast_occurs_itvl k k' t =
 
 let nb_occur_match =
   let rec nb k = function
-    | MLrel i -> if i = k then 1 else 0
+    | MLrel i -> if Int.equal i k then 1 else 0
     | MLcase(_,a,v) ->
         (nb k a) +
 	Array.fold_left
@@ -466,7 +517,7 @@ let ast_lift k t =
   let rec liftrec n = function
     | MLrel i as a -> if i-n < 1 then a else MLrel (i+k)
     | a -> ast_map_lift liftrec n a
-  in if k = 0 then t else liftrec 0 t
+  in if Int.equal k 0 then t else liftrec 0 t
 
 let ast_pop t = ast_lift (-1) t
 
@@ -490,7 +541,7 @@ let ast_subst e =
   let rec subst n = function
     | MLrel i as a ->
 	let i' = i-n in
-	if i'=1 then ast_lift n e
+	if Int.equal i' 1 then ast_lift n e
 	else if i'<1 then a
 	else MLrel (i-1)
     | a -> ast_map_lift subst n a
@@ -525,17 +576,18 @@ let has_deep_pattern br =
     | Pcons (_,l) | Ptuple l -> not (List.for_all is_basic_pattern l)
     | Pusual _ | Prel _ | Pwild -> false
   in
-  array_exists (function (_,pat,_) -> deep pat) br
+  Array.exists (function (_,pat,_) -> deep pat) br
 
 let is_regular_match br =
-  if Array.length br = 0 then false (* empty match becomes MLexn *)
+  if Array.is_empty br then false (* empty match becomes MLexn *)
   else
     try
       let get_r (ids,pat,c) =
 	match pat with
 	  | Pusual r -> r
 	  | Pcons (r,l) ->
-	    if not (list_for_all_i (fun i -> (=) (Prel i)) 1 (List.rev l))
+            let is_rel i = function Prel j -> Int.equal i j | _ -> false in
+	    if not (List.for_all_i is_rel 1 (List.rev l))
 	    then raise Impossible;
 	    r
 	  | _ -> raise Impossible
@@ -544,7 +596,11 @@ let is_regular_match br =
 	| ConstructRef (ind,_) -> ind
 	| _ -> raise Impossible
       in
-      array_for_all_i (fun i tr -> get_r tr = ConstructRef (ind,i+1)) 0 br
+      let is_ref i tr = match get_r tr with
+      | ConstructRef (ind', j) -> eq_ind ind ind' && Int.equal j (i + 1)
+      | _ -> false
+      in
+      Array.for_all_i is_ref 0 br
     with Impossible -> false
 
 (*S Operations concerning lambdas. *)
@@ -562,7 +618,7 @@ let collect_lams =
 
 let collect_n_lams =
   let rec collect acc n t =
-    if n = 0 then acc,t
+    if Int.equal n 0 then acc,t
     else match t with
       | MLlam(id,t) -> collect (id::acc) (n-1) t
       | _ -> assert false
@@ -571,7 +627,7 @@ let collect_n_lams =
 (*s [remove_n_lams] just removes some [MLlam]. *)
 
 let rec remove_n_lams n t =
-  if n = 0 then t
+  if Int.equal n 0 then t
   else match t with
       | MLlam(_,t) -> remove_n_lams (n-1) t
       | _ -> assert false
@@ -609,7 +665,7 @@ let rec anonym_or_dummy_lams a = function
 (*s The following function creates [MLrel n;...;MLrel 1] *)
 
 let rec eta_args n =
-  if n = 0 then [] else (MLrel n)::(eta_args (pred n))
+  if Int.equal n 0 then [] else (MLrel n)::(eta_args (pred n))
 
 (*s Same, but filtered by a signature. *)
 
@@ -621,25 +677,26 @@ let rec eta_args_sign n = function
 (*s This one tests [MLrel (n+k); ... ;MLrel (1+k)] *)
 
 let rec test_eta_args_lift k n = function
-  | [] -> n=0
-  | a :: q -> (a = (MLrel (k+n))) && (test_eta_args_lift k (pred n) q)
+  | [] -> Int.equal n 0
+  | MLrel m :: q -> Int.equal (k+n) m && (test_eta_args_lift k (pred n) q)
+  | _ -> false
 
 (*s Computes an eta-reduction. *)
 
 let eta_red e =
   let ids,t = collect_lams e in
   let n = List.length ids in
-  if n = 0 then e
+  if Int.equal n 0 then e
   else match t with
     | MLapp (f,a) ->
 	let m = List.length a in
 	let ids,body,args =
-	  if m = n then
+	  if Int.equal m n then
 	    [], f, a
 	  else if m < n then
-	    list_skipn m ids, f, a
+	    List.skipn m ids, f, a
 	  else (* m > n *)
-	    let a1,a2 = list_chop (m-n) a in
+	    let a1,a2 = List.chop (m-n) a in
 	    [], MLapp (f,a1), a2
 	in
 	let p = List.length args in
@@ -715,7 +772,7 @@ let branch_as_fun typ (l,p,c) =
 	if i'<1 then c
 	else if i'>nargs then MLrel (i-nargs+1)
 	else raise Impossible
-    | MLcons _ as cons' when cons' = ast_lift n cons -> MLrel (n+1)
+    | MLcons _ as cons' when eq_ml_ast cons' (ast_lift n cons) -> MLrel (n+1)
     | a -> ast_map_lift genrec n a
   in genrec 0 c
 
@@ -739,27 +796,33 @@ let branch_as_cst (l,_,c) =
    When searching for the best factorisation below, we'll try both.
 *)
 
-(* The following structure allows to record which element occurred
+(* The following structure allows recording which element occurred
    at what position, and then finally return the most frequent
    element and its positions. *)
 
 let census_add, census_max, census_clean =
-  let h = Hashtbl.create 13 in
-  let clear () = Hashtbl.clear h in
-  let add e i =
-    let s = try Hashtbl.find h e with Not_found -> Intset.empty in
-    Hashtbl.replace h e (Intset.add i s)
+  let h = ref [] in
+  let clearf () = h := [] in
+  let rec add k v = function
+  | [] -> raise Not_found
+  | (k', s) as p :: l ->
+    if eq_ml_ast k k' then (k', Int.Set.add v s) :: l
+    else p :: add k v l
+  in
+  let addf k i =
+    try h := add k i !h
+    with Not_found -> h := (k, Int.Set.singleton i) :: !h
   in
-  let max e0 =
-    let len = ref 0 and lst = ref Intset.empty and elm = ref e0 in
-    Hashtbl.iter
-      (fun e s ->
-	 let n = Intset.cardinal s in
+  let maxf k =
+    let len = ref 0 and lst = ref Int.Set.empty and elm = ref k in
+    List.iter
+      (fun (e, s) ->
+	 let n = Int.Set.cardinal s in
 	 if n > !len then begin len := n; lst := s; elm := e end)
-      h;
+      !h;
     (!elm,!lst)
   in
-  (add,max,clear)
+  (addf,maxf,clearf)
 
 (* [factor_branches] return the longest possible list of branches
    that have the same factorization, either as a function or as a
@@ -771,7 +834,7 @@ let is_opt_pat (_,p,_) = match p with
   | _ -> false
 
 let factor_branches o typ br =
-  if array_exists is_opt_pat br then None (* already optimized *)
+  if Array.exists is_opt_pat br then None (* already optimized *)
   else begin
     census_clean ();
     for i = 0 to Array.length br - 1 do
@@ -782,8 +845,8 @@ let factor_branches o typ br =
     done;
     let br_factor, br_set = census_max MLdummy in
     census_clean ();
-    let n = Intset.cardinal br_set in
-    if n = 0 then None
+    let n = Int.Set.cardinal br_set in
+    if Int.equal n 0 then None
     else if Array.length br >= 2 && n < 2 then None
     else Some (br_factor, br_set)
   end
@@ -794,17 +857,17 @@ let rec merge_ids ids ids' = match ids,ids' with
   | [],l -> l
   | l,[] -> l
   | i::ids, i'::ids' ->
-      (if i = Dummy then i' else i) :: (merge_ids ids ids')
+      (if i == Dummy then i' else i) :: (merge_ids ids ids')
 
 let is_exn = function MLexn _ -> true | _ -> false
 
-let rec permut_case_fun br acc =
+let permut_case_fun br acc =
   let nb = ref max_int in
   Array.iter (fun (_,_,t) ->
 		let ids, c = collect_lams t in
 		let n = List.length ids in
 		if (n < !nb) && (not (is_exn c)) then nb := n) br;
-  if !nb = max_int || !nb = 0 then ([],br)
+  if Int.equal !nb  max_int || Int.equal !nb 0 then ([],br)
   else begin
     let br = Array.copy br in
     let ids = ref [] in
@@ -837,16 +900,16 @@ let rec iota_red i lift br ((typ,r,a) as cons) =
   if i >= Array.length br then raise Impossible;
   let (ids,p,c) = br.(i) in
   match p with
-    | Pusual r' | Pcons (r',_) when r'<>r -> iota_red (i+1) lift br cons
+    | Pusual r' | Pcons (r',_) when not (Globnames.eq_gr r' r) -> iota_red (i+1) lift br cons
     | Pusual r' ->
       let c = named_lams (List.rev ids) c in
       let c = ast_lift lift c
       in MLapp (c,a)
-    | Prel 1 when List.length ids = 1 ->
+    | Prel 1 when Int.equal (List.length ids) 1 ->
       let c = MLlam (List.hd ids, c) in
       let c = ast_lift lift c
       in MLapp(c,[MLcons(typ,r,a)])
-    | Pwild when ids = [] -> ast_lift lift c
+    | Pwild when List.is_empty ids -> ast_lift lift c
     | _ -> raise Impossible (* TODO: handle some more cases *)
 
 (* [iota_gen] is an extension of [iota_red] where we allow to
@@ -872,15 +935,11 @@ let is_imm_apply = function MLapp (MLrel 1, _) -> true | _ -> false
     Unfolding them leads to more natural code (and more dummy removal) *)
 
 let is_program_branch = function
-  | Id id ->
-    let s = string_of_id id in
-    let br = "program_branch_" in
-    let n = String.length br in
-    (try
-       ignore (int_of_string (String.sub s n (String.length s - n)));
-       String.sub s 0 n = br
-     with e when Errors.noncritical e -> false)
   | Tmp _ | Dummy -> false
+  | Id id ->
+    let s = Id.to_string id in
+    try Scanf.sscanf s "program_branch_%d%!" (fun _ -> true)
+    with Scanf.Scan_failure _ | End_of_file -> false
 
 let expand_linear_let o id e =
    o.opt_lin_let || is_tmp id || is_program_branch id || is_imm_apply e
@@ -901,7 +960,7 @@ let rec simpl o = function
       if
 	(is_atomic c) || (is_atomic e) ||
 	(let n = nb_occur_match e in
-	 (n = 0 || (n=1 && expand_linear_let o id e)))
+	 (Int.equal n 0 || (Int.equal n 1 && expand_linear_let o id e)))
       then
 	simpl o (ast_subst c e)
       else
@@ -954,14 +1013,14 @@ and simpl_case o typ br e =
     (* Swap the case and the lam if possible *)
     let ids,br = if o.opt_case_fun then permut_case_fun br [] else [],br in
     let n = List.length ids in
-    if n <> 0 then
+    if not (Int.equal n 0) then
       simpl o (named_lams ids (MLcase (typ, ast_lift n e, br)))
     else
       (* Can we merge several branches as the same constant or function ? *)
-      if lang() = Scheme || is_custom_match br
+      if lang() == Scheme || is_custom_match br
       then MLcase (typ, e, br)
       else match factor_branches o typ br with
-	| Some (f,ints) when Intset.cardinal ints = Array.length br ->
+	| Some (f,ints) when Int.equal (Int.Set.cardinal ints) (Array.length br) ->
 	  (* If all branches have been factorized, we remove the match *)
 	  simpl o (MLletin (Tmp anonymous_name, e, f))
 	| Some (f,ints) ->
@@ -970,7 +1029,7 @@ and simpl_case o typ br e =
 	    else ([], Pwild, ast_pop f)
 	  in
 	  let brl = Array.to_list br in
-	  let brl_opt = list_filter_i (fun i _ -> not (Intset.mem i ints)) brl in
+	  let brl_opt = List.filteri (fun i _ -> not (Int.Set.mem i ints)) brl in
 	  let brl_opt = brl_opt @ [last_br] in
 	  MLcase (typ, e, Array.of_list brl_opt)
 	| None -> MLcase (typ, e, br)
@@ -996,9 +1055,9 @@ let rec select_via_bl l args = match l,args with
 
 let kill_some_lams bl (ids,c) =
   let n = List.length bl in
-  let n' = List.fold_left (fun n b -> if b=Keep then (n+1) else n) 0 bl in
-  if n = n' then ids,c
-  else if n' = 0 then [],ast_lift (-n) c
+  let n' = List.fold_left (fun n b -> if b == Keep then (n+1) else n) 0 bl in
+  if Int.equal n n' then ids,c
+  else if Int.equal n' 0 then [],ast_lift (-n) c
   else begin
     let v = Array.make n None in
     let rec parse_ids i j = function
@@ -1016,15 +1075,15 @@ let kill_some_lams bl (ids,c) =
 let kill_dummy_lams c =
   let ids,c = collect_lams c in
   let bl = List.map sign_of_id ids in
-  if not (List.mem Keep bl) then raise Impossible;
+  if not (List.memq Keep bl) then raise Impossible;
   let rec fst_kill n = function
     | [] -> raise Impossible
     | Kill _ :: bl -> n
     | Keep :: bl -> fst_kill (n+1) bl
   in
   let skip = max 0 ((fst_kill 0 bl) - 1) in
-  let ids_skip, ids = list_chop skip ids in
-  let _, bl = list_chop skip bl in
+  let ids_skip, ids = List.chop skip ids in
+  let _, bl = List.chop skip bl in
   let c = named_lams ids_skip c in
   let ids',c = kill_some_lams bl (ids,c) in
   ids, named_lams ids' c
@@ -1052,7 +1111,7 @@ let case_expunge s e =
   let m = List.length s in
   let n = nb_lams e in
   let p = if m <= n then collect_n_lams m e
-  else eta_expansion_sign (list_skipn n s) (collect_lams e) in
+  else eta_expansion_sign (List.skipn n s) (collect_lams e) in
   kill_some_lams (List.rev s) p
 
 (*s [term_expunge] takes a function [fun idn ... id1 -> c]
@@ -1061,10 +1120,10 @@ let case_expunge s e =
   if all lambdas are logical dummy and the target language is strict. *)
 
 let term_expunge s (ids,c) =
-  if s = [] then c
+  if List.is_empty s then c
   else
     let ids,c = kill_some_lams (List.rev s) (ids,c) in
-    if ids = [] && lang () <> Haskell && List.mem (Kill Kother) s then
+    if List.is_empty ids && lang () != Haskell && List.mem (Kill Kother) s then
       MLlam (Dummy, ast_lift 1 c)
     else named_lams ids c
 
@@ -1076,7 +1135,7 @@ let kill_dummy_args ids r t =
   let m = List.length ids in
   let bl = List.rev_map sign_of_id ids in
   let rec found n = function
-    | MLrel r' when r' = r + n -> true
+    | MLrel r' when Int.equal r' (r + n) -> true
     | MLmagic e -> found n e
     | _ -> false
   in
@@ -1086,7 +1145,7 @@ let kill_dummy_args ids r t =
 	let a = List.map (killrec n) a in
 	let a = List.map (ast_lift k) a in
 	let a = select_via_bl bl (a @ (eta_args k)) in
-	named_lams (list_firstn k ids) (MLapp (ast_lift k e, a))
+	named_lams (List.firstn k ids) (MLapp (ast_lift k e, a))
     | e when found n e ->
 	let a = select_via_bl bl (eta_args m) in
 	named_lams ids (MLapp (ast_lift m e, a))
@@ -1153,7 +1212,7 @@ let normalize a =
   let o = optims () in
   let rec norm a =
     let a' = if o.opt_kill_dum then kill_dummy (simpl o a) else simpl o a in
-    if a = a' then a else norm a'
+    if eq_ml_ast a a' then a else norm a'
   in norm a
 
 (*S Special treatment of fixpoint for pretty-printing purpose. *)
@@ -1165,7 +1224,7 @@ let general_optimize_fix f ids n args m c =
     | MLrel j when v.(j-1)>=0 ->
 	if ast_occurs (j+1) c then raise Impossible else v.(j-1)<-(-i-1)
     | _ -> raise Impossible
-  in list_iter_i aux args;
+  in List.iteri aux args;
   let args_f = List.rev_map (fun i -> MLrel (i+m+1)) (Array.to_list v) in
   let new_f = anonym_tmp_lams (MLapp (MLrel (n+m+1),args_f)) m in
   let new_c = named_lams ids (normalize (MLapp ((ast_subst new_f c),args))) in
@@ -1176,7 +1235,7 @@ let optimize_fix a =
   else
     let ids,a' = collect_lams a in
     let n = List.length ids in
-    if n = 0 then a
+    if Int.equal n 0 then a
     else match a' with
       | MLfix(_,[|f|],[|c|]) ->
 	  let new_f = MLapp (MLrel (n+1),eta_args n) in
@@ -1244,7 +1303,7 @@ let rec non_stricts add cand = function
       let cand = if add then 1::cand else cand in
       pop 1 (non_stricts add cand t)
   | MLrel n ->
-      List.filter ((<>) n) cand
+      List.filter (fun m -> not (Int.equal m n)) cand
   | MLapp (t,l)->
       let cand = non_stricts false cand t in
       List.fold_left (non_stricts false) cand l
@@ -1268,7 +1327,7 @@ let rec non_stricts add cand = function
 	   let n = List.length i in
 	   let cand = lift n cand in
 	   let cand = pop n (non_stricts add cand t) in
-	   Sort.merge (<=) cand c) [] v
+	   List.merge Int.compare cand c) [] v
 	(* [merge] may duplicates some indices, but I don't mind. *)
   | MLmagic t ->
       non_stricts add cand t
@@ -1304,7 +1363,7 @@ let is_not_strict t =
    restriction for the moment.
 *)
 
-open Declarations
+open Declareops
 
 let inline_test r t =
   if not (auto_inline ()) then false
@@ -1312,7 +1371,7 @@ let inline_test r t =
     let c = match r with ConstRef c -> c | _ -> assert false in
     let has_body =
       try constant_has_body (Global.lookup_constant c)
-      with e when Errors.noncritical e -> false
+      with Not_found -> false
     in
     has_body &&
       (let t1 = eta_red t in
@@ -1320,10 +1379,8 @@ let inline_test r t =
        not (is_fix t2) && ml_size t < 12 && is_not_strict t)
 
 let con_of_string s =
-  let null = empty_dirpath in
-  match repr_dirpath (dirpath_of_string s) with
-    | id :: d -> make_con (MPfile (make_dirpath d)) null (label_of_id id)
-    | [] -> assert false
+  let d, id = Libnames.split_dirpath (dirpath_of_string s) in
+  Constant.make2 (MPfile d) (Label.of_id id)
 
 let manual_inline_set =
   List.fold_right (fun x -> Cset_env.add (con_of_string x))
@@ -1355,6 +1412,6 @@ let inline r t =
   not (to_keep r) (* The user DOES want to keep it *)
   && not (is_inline_custom r)
   && (to_inline r (* The user DOES want to inline it *)
-     || (lang () <> Haskell && not (is_projection r) &&
+     || (lang () != Haskell && not (is_projection r) &&
          (is_recursor r || manual_inline r || inline_test r t)))
 
diff --git a/plugins/extraction/mlutil.mli b/plugins/extraction/mlutil.mli
index 94e6ae69..0a71d2c8 100644
--- a/plugins/extraction/mlutil.mli
+++ b/plugins/extraction/mlutil.mli
@@ -1,15 +1,13 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Util
 open Names
-open Term
-open Libnames
+open Globnames
 open Miniml
 open Table
 
@@ -68,6 +66,7 @@ val type_to_signature : abbrev_map -> ml_type -> signature
 val type_expunge : abbrev_map -> ml_type -> ml_type
 val type_expunge_from_sign : abbrev_map -> signature -> ml_type -> ml_type
 
+val eq_ml_type : ml_type -> ml_type -> bool
 val isDummy : ml_type -> bool
 val isKill : sign -> bool
 
@@ -78,10 +77,10 @@ val term_expunge : signature -> ml_ident list * ml_ast -> ml_ast
 (*s Special identifiers. [dummy_name] is to be used for dead code
     and will be printed as [_] in concrete (Caml) code. *)
 
-val anonymous_name : identifier
-val dummy_name : identifier
-val id_of_name : name -> identifier
-val id_of_mlid : ml_ident -> identifier
+val anonymous_name : Id.t
+val dummy_name : Id.t
+val id_of_name : Name.t -> Id.t
+val id_of_mlid : ml_ident -> Id.t
 val tmp_id : ml_ident -> ml_ident
 
 (*s [collect_lambda MLlam(id1,...MLlam(idn,t)...)] returns
diff --git a/plugins/extraction/modutil.ml b/plugins/extraction/modutil.ml
index 2c923241..8158ac64 100644
--- a/plugins/extraction/modutil.ml
+++ b/plugins/extraction/modutil.ml
@@ -1,27 +1,25 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
 open Names
-open Declarations
-open Environ
-open Libnames
+open Globnames
+open Errors
 open Util
 open Miniml
 open Table
 open Mlutil
-open Mod_subst
 
 (*S Functions upon ML modules. *)
 
 let rec msid_of_mt = function
   | MTident mp -> mp
   | MTwith(mt,_)-> msid_of_mt mt
-  | _ -> anomaly "Extraction:the With operator isn't applied to a name"
+  | _ -> anomaly ~label:"extraction" (Pp.str "the With operator isn't applied to a name")
 
 (*s Apply some functions upon all [ml_decl] and [ml_spec] found in a
    [ml_structure]. *)
@@ -32,16 +30,16 @@ let se_iter do_decl do_spec do_mp =
     | MTfunsig (_,mt,mt') -> mt_iter mt; mt_iter mt'
     | MTwith (mt,ML_With_type(idl,l,t))->
 	let mp_mt = msid_of_mt mt in
-	let l',idl' = list_sep_last idl in
+	let l',idl' = List.sep_last idl in
 	let mp_w =
-	  List.fold_left (fun mp l -> MPdot(mp,label_of_id l)) mp_mt idl'
+	  List.fold_left (fun mp l -> MPdot(mp,Label.of_id l)) mp_mt idl'
 	in
-	let r = ConstRef (make_con mp_w empty_dirpath (label_of_id l')) in
+	let r = ConstRef (Constant.make2 mp_w (Label.of_id l')) in
 	mt_iter mt; do_decl (Dtype(r,l,t))
     | MTwith (mt,ML_With_module(idl,mp))->
         let mp_mt = msid_of_mt mt in
         let mp_w =
-	  List.fold_left (fun mp l -> MPdot(mp,label_of_id l)) mp_mt idl
+	  List.fold_left (fun mp l -> MPdot(mp,Label.of_id l)) mp_mt idl
 	in
 	mt_iter mt; do_mp mp_w; do_mp mp
     | MTsig (_, sign) -> List.iter spec_iter sign
@@ -110,13 +108,13 @@ let ind_iter_references do_term do_cons do_type kn ind =
   let cons_iter cp l = do_cons (ConstructRef cp); List.iter type_iter l in
   let packet_iter ip p =
     do_type (IndRef ip);
-    if lang () = Ocaml then
+    if lang () == Ocaml then
       (match ind.ind_equiv with
 	 | Miniml.Equiv kne -> do_type (IndRef (mind_of_kn kne, snd ip));
 	 | _ -> ());
     Array.iteri (fun j -> cons_iter (ip,j+1)) p.ip_types
   in
-  if lang () = Ocaml then record_iter_references do_term ind.ind_kind;
+  if lang () == Ocaml then record_iter_references do_term ind.ind_kind;
     Array.iteri (fun i -> packet_iter (kn,i)) ind.ind_packets
 
 let decl_iter_references do_term do_cons do_type =
@@ -199,6 +197,11 @@ let rec msig_of_ms = function
 let signature_of_structure s =
   List.map (fun (mp,ms) -> mp,msig_of_ms ms) s
 
+let rec mtyp_of_mexpr = function
+  | MEfunctor (id,ty,e) -> MTfunsig (id,ty, mtyp_of_mexpr e)
+  | MEstruct (mp,str) -> MTsig (mp, msig_of_ms str)
+  | _ -> assert false
+
 
 (*s Searching one [ml_decl] in a [ml_structure] by its [global_reference] *)
 
@@ -208,18 +211,18 @@ let is_modular = function
 
 let rec search_structure l m = function
   | [] -> raise Not_found
-  | (lab,d)::_ when lab=l && is_modular d = m -> d
+  | (lab,d)::_ when Label.equal lab l && (is_modular d : bool) == m -> d
   | _::fields -> search_structure l m fields
 
 let get_decl_in_structure r struc =
   try
     let base_mp,ll = labels_of_ref r in
     if not (at_toplevel base_mp) then error_not_visible r;
-    let sel = List.assoc base_mp struc in
+    let sel = List.assoc_f ModPath.equal base_mp struc in
     let rec go ll sel = match ll with
       | [] -> assert false
       | l :: ll ->
-	  match search_structure l (ll<>[]) sel with
+	  match search_structure l (not (List.is_empty ll)) sel with
 	    | SEdecl d -> d
 	    | SEmodtype m -> assert false
 	    | SEmodule m ->
@@ -228,7 +231,7 @@ let get_decl_in_structure r struc =
 		  | _ -> error_not_visible r
     in go ll sel
   with Not_found ->
-    anomaly "reference not found in extracted structure"
+    anomaly (Pp.str "reference not found in extracted structure")
 
 
 (*s Optimization of a [ml_structure]. *)
@@ -251,7 +254,7 @@ let dfix_to_mlfix rv av i =
 	(try MLrel (n + (Refmap'.find refe s)) with Not_found -> t)
     | _ -> ast_map_lift subst n t
   in
-  let ids = Array.map (fun r -> id_of_label (label_of_r r)) rv in
+  let ids = Array.map (fun r -> Label.to_id (label_of_r r)) rv in
   let c = Array.map (subst 0) av
   in MLfix(i, ids, c)
 
@@ -297,8 +300,6 @@ and optim_me to_appear s = function
    For non-library extraction, we recompute a minimal set of dependencies
    for first-level definitions (no module pruning yet). *)
 
-exception NoDepCheck
-
 let base_r = function
   | ConstRef c as r -> r
   | IndRef (kn,_) -> IndRef (kn,0)
@@ -353,7 +354,7 @@ let rec depcheck_se = function
     let se' = depcheck_se se in
     let refs = declared_refs d in
     let refs' = List.filter is_needed refs in
-    if refs' = [] then
+    if List.is_empty refs' then
       (List.iter remove_info_axiom refs;
        List.iter remove_opaque refs;
        se')
@@ -362,7 +363,7 @@ let rec depcheck_se = function
       (* Hack to avoid extracting unused part of a Dfix *)
       match d with
 	| Dfix (rv,trms,tys) when (List.for_all is_custom refs') ->
-	  let trms' =  Array.create (Array.length rv) (MLexn "UNUSED") in
+	  let trms' =  Array.make (Array.length rv) (MLexn "UNUSED") in
 	  ((l,SEdecl (Dfix (rv,trms',tys))) :: se')
 	| _ -> (compute_deps_decl d; t::se')
     end
@@ -376,14 +377,22 @@ let rec depcheck_struct = function
   | (mp,lse)::struc ->
       let struc' = depcheck_struct struc in
       let lse' = depcheck_se lse in
-      if lse' = [] then struc' else (mp,lse')::struc'
+      if List.is_empty lse' then struc' else (mp,lse')::struc'
+
+let is_prefix pre s =
+  let len = String.length pre in
+  let rec is_prefix_aux i =
+    if Int.equal i len then true
+    else pre.[i] == s.[i] && is_prefix_aux (succ i)
+  in
+  is_prefix_aux 0
 
 let check_implicits = function
   | MLexn s ->
-      if String.length s > 8 && (s.[0] = 'U' || s.[0] = 'I') then
+      if String.length s > 8 && (s.[0] == 'U' || s.[0] == 'I') then
 	begin
-	  if String.sub s 0 7 = "UNBOUND" then assert false;
-	  if String.sub s 0 8 = "IMPLICIT" then
+	  if is_prefix "UNBOUND" s then assert false;
+	  if is_prefix "IMPLICIT" s then
 	    error_non_implicit (String.sub s 9 (String.length s - 9));
 	end;
       false
@@ -397,7 +406,7 @@ let optimize_struct to_appear struc =
   in
   ignore (struct_ast_search check_implicits opt_struc);
   if library () then
-    List.filter (fun (_,lse) -> lse<>[]) opt_struc
+    List.filter (fun (_,lse) -> not (List.is_empty lse)) opt_struc
   else begin
     reset_needed ();
     List.iter add_needed (fst to_appear);
diff --git a/plugins/extraction/modutil.mli b/plugins/extraction/modutil.mli
index 58d8167d..ca32f029 100644
--- a/plugins/extraction/modutil.mli
+++ b/plugins/extraction/modutil.mli
@@ -1,17 +1,14 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
 open Names
-open Declarations
-open Environ
-open Libnames
+open Globnames
 open Miniml
-open Mod_subst
 
 (*s Functions upon ML modules. *)
 
@@ -20,11 +17,14 @@ val struct_type_search : (ml_type -> bool) -> ml_structure -> bool
 
 type do_ref = global_reference -> unit
 
+val ast_iter_references : do_ref -> do_ref -> do_ref -> ml_ast -> unit
 val decl_iter_references : do_ref -> do_ref -> do_ref -> ml_decl -> unit
 val spec_iter_references : do_ref -> do_ref -> do_ref -> ml_spec -> unit
 
 val signature_of_structure : ml_structure -> ml_signature
 
+val mtyp_of_mexpr : ml_module_expr -> ml_module_type
+
 val msid_of_mt : ml_module_type -> module_path
 
 val get_decl_in_structure : global_reference -> ml_structure -> ml_decl
diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml
index 70e71eeb..30ac3d3f 100644
--- a/plugins/extraction/ocaml.ml
+++ b/plugins/extraction/ocaml.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -9,25 +9,21 @@
 (*s Production of Ocaml syntax. *)
 
 open Pp
+open Errors
 open Util
 open Names
 open Nameops
-open Libnames
+open Globnames
 open Table
 open Miniml
 open Mlutil
 open Modutil
 open Common
-open Declarations
 
 
 (*s Some utility functions. *)
 
-let pp_tvar id =
-  let s = string_of_id id in
-  if String.length s < 2 || s.[1]<>'\''
-  then str ("'"^s)
-  else str ("' "^s)
+let pp_tvar id = str ("'" ^ Id.to_string id)
 
 let pp_abst = function
   | [] -> mt ()
@@ -36,10 +32,10 @@ let pp_abst = function
       str " ->" ++ spc ()
 
 let pp_parameters l =
-  (pp_boxed_tuple pp_tvar l ++ space_if (l<>[]))
+  (pp_boxed_tuple pp_tvar l ++ space_if (not (List.is_empty l)))
 
 let pp_string_parameters l =
-  (pp_boxed_tuple str l ++ space_if (l<>[]))
+  (pp_boxed_tuple str l ++ space_if (not (List.is_empty l)))
 
 let pp_letin pat def body =
   let fstline = str "let " ++ pat ++ str " =" ++ spc () ++ def in
@@ -48,7 +44,7 @@ let pp_letin pat def body =
 (*s Ocaml renaming issues. *)
 
 let keywords =
-  List.fold_right (fun s -> Idset.add (id_of_string s))
+  List.fold_right (fun s -> Id.Set.add (Id.of_string s))
   [ "and"; "as"; "assert"; "begin"; "class"; "constraint"; "do";
     "done"; "downto"; "else"; "end"; "exception"; "external"; "false";
     "for"; "fun"; "function"; "functor"; "if"; "in"; "include";
@@ -57,22 +53,30 @@ let keywords =
     "parser"; "private"; "rec"; "sig"; "struct"; "then"; "to"; "true";
     "try"; "type"; "val"; "virtual"; "when"; "while"; "with"; "mod";
     "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr" ; "unit" ; "_" ; "__" ]
-  Idset.empty
+  Id.Set.empty
 
 let pp_open mp = str ("open "^ string_of_modfile mp ^"\n")
 
-let preamble _ used_modules usf =
+let pp_comment s = str "(* " ++ hov 0 s ++ str " *)"
+
+let pp_header_comment = function
+  | None -> mt ()
+  | Some com -> pp_comment com ++ fnl () ++ fnl ()
+
+let preamble _ comment used_modules usf =
+  pp_header_comment comment ++
   prlist pp_open used_modules ++
-  (if used_modules = [] then mt () else fnl ()) ++
+  (if List.is_empty used_modules then mt () else fnl ()) ++
   (if usf.tdummy || usf.tunknown then str "type __ = Obj.t\n" else mt()) ++
   (if usf.mldummy then
      str "let __ = let rec f _ = Obj.repr f in Obj.repr f\n"
    else mt ()) ++
   (if usf.tdummy || usf.tunknown || usf.mldummy then fnl () else mt ())
 
-let sig_preamble _ used_modules usf =
+let sig_preamble _ comment used_modules usf =
+  pp_header_comment comment ++ fnl () ++ fnl () ++
   prlist pp_open used_modules ++
-  (if used_modules = [] then mt () else fnl ()) ++
+  (if List.is_empty used_modules then mt () else fnl ()) ++
   (if usf.tdummy || usf.tunknown then str "type __ = Obj.t\n\n" else mt())
 
 (*s The pretty-printer for Ocaml syntax*)
@@ -93,7 +97,7 @@ let is_infix r =
   is_inline_custom r &&
   (let s = find_custom r in
    let l = String.length s in
-   l >= 2 && s.[0] = '(' && s.[l-1] = ')')
+   l >= 2 && s.[0] == '(' && s.[l-1] == ')')
 
 let get_infix r =
   let s = find_custom r in
@@ -110,22 +114,21 @@ let pp_one_field r i = function
 
 let pp_field r fields i = pp_one_field r i (List.nth fields i)
 
-let pp_fields r fields = list_map_i (pp_one_field r) 0 fields
+let pp_fields r fields = List.map_i (pp_one_field r) 0 fields
 
 (*s Pretty-printing of types. [par] is a boolean indicating whether parentheses
     are needed or not. *)
 
-let rec pp_type par vl t =
+let pp_type par vl t =
   let rec pp_rec par = function
     | Tmeta _ | Tvar' _ | Taxiom -> assert false
     | Tvar i -> (try pp_tvar (List.nth vl (pred i))
-		 with e when Errors.noncritical e ->
-                   (str "'a" ++ int i))
+                 with Failure _ -> (str "'a" ++ int i))
     | Tglob (r,[a1;a2]) when is_infix r ->
 	pp_par par (pp_rec true a1 ++ str (get_infix r) ++ pp_rec true a2)
     | Tglob (r,[]) -> pp_global Type r
     | Tglob (IndRef(kn,0),l)
-	when not (keep_singleton ()) && kn = mk_ind "Coq.Init.Specif" "sig" ->
+	when not (keep_singleton ()) && MutInd.equal kn (mk_ind "Coq.Init.Specif" "sig") ->
 	pp_tuple_light pp_rec l
     | Tglob (r,l) ->
 	pp_tuple_light pp_rec l ++ spc () ++ pp_global Type r
@@ -149,7 +152,7 @@ let is_bool_patt p s =
       | Pcons (r,[]) -> r
       | _ -> raise Not_found
     in
-    find_custom r = s
+    String.equal (find_custom r) s
   with Not_found -> false
 
 
@@ -186,7 +189,7 @@ let rec pp_expr par env args =
 	hv 0 (apply2 (pp_letin pp_id pp_a1 pp_a2))
     | MLglob r ->
 	(try
-	   let args = list_skipn (projection_arity r) args in
+	   let args = List.skipn (projection_arity r) args in
 	   let record = List.hd args in
 	   pp_apply (record ++ str "." ++ pp_global Term r) par (List.tl args)
 	 with e when Errors.noncritical e -> apply (pp_global Term r))
@@ -203,35 +206,35 @@ let rec pp_expr par env args =
     | MLaxiom ->
 	pp_par par (str "failwith \"AXIOM TO BE REALIZED\"")
     | MLcons (_,r,a) as c ->
-        assert (args=[]);
+        assert (List.is_empty args);
         begin match a with
 	  | _ when is_native_char c -> pp_native_char c
 	  | [a1;a2] when is_infix r ->
 	    let pp = pp_expr true env [] in
 	    pp_par par (pp a1 ++ str (get_infix r) ++ pp a2)
 	  | _ when is_coinductive r ->
-	    let ne = (a<>[]) in
+	    let ne = not (List.is_empty a) in
 	    let tuple = space_if ne ++ pp_tuple (pp_expr true env []) a in
 	    pp_par par (str "lazy " ++ pp_par ne (pp_global Cons r ++ tuple))
 	  | [] -> pp_global Cons r
 	  | _ ->
 	    let fds = get_record_fields r in
-	    if fds <> [] then
+	    if not (List.is_empty fds) then
 	      pp_record_pat (pp_fields r fds, List.map (pp_expr true env []) a)
 	    else
 	      let tuple = pp_tuple (pp_expr true env []) a in
-	      if str_global Cons r = "" (* hack Extract Inductive prod *)
+	      if String.is_empty (str_global Cons r) (* hack Extract Inductive prod *)
 	      then tuple
 	      else pp_par par (pp_global Cons r ++ spc () ++ tuple)
 	end
     | MLtuple l ->
-        assert (args = []);
+        assert (List.is_empty args);
         pp_boxed_tuple (pp_expr true env []) l
     | MLcase (_, t, pv) when is_custom_match pv ->
         if not (is_regular_match pv) then
 	  error "Cannot mix yet user-given match and general patterns.";
 	let mkfun (ids,_,e) =
-	  if ids <> [] then named_lams (List.rev ids) e
+	  if not (List.is_empty ids) then named_lams (List.rev ids) e
 	  else dummy_lams (ast_lift 1 e) 1
 	in
 	let pp_branch tr = pp_expr true env [] (mkfun tr) ++ fnl () in
@@ -250,7 +253,7 @@ let rec pp_expr par env args =
         (try pp_record_proj par env typ t pv args
 	 with Impossible ->
 	   (* Second, can this match be printed as a let-in ? *)
-	   if Array.length pv = 1 then
+	   if Int.equal (Array.length pv) 1 then
 	     let s1,s2 = pp_one_pat env pv.(0) in
 	     hv 0 (apply2 (pp_letin s1 head s2))
 	   else
@@ -265,8 +268,8 @@ let rec pp_expr par env args =
 and pp_record_proj par env typ t pv args =
   (* Can a match be printed as a mere record projection ? *)
   let fields = record_fields_of_type typ in
-  if fields = [] then raise Impossible;
-  if Array.length pv <> 1 then raise Impossible;
+  if List.is_empty fields then raise Impossible;
+  if not (Int.equal (Array.length pv) 1) then raise Impossible;
   if has_deep_pattern pv then raise Impossible;
   let (ids,pat,body) = pv.(0) in
   let n = List.length ids in
@@ -277,7 +280,7 @@ and pp_record_proj par env typ t pv args =
     | _ -> raise Impossible
   in
   let rec lookup_rel i idx = function
-    | Prel j :: l -> if i = j then idx else lookup_rel i (idx+1) l
+    | Prel j :: l -> if Int.equal i j then idx else lookup_rel i (idx+1) l
     | Pwild :: l -> lookup_rel i (idx+1) l
     | _ -> raise Impossible
   in
@@ -301,15 +304,15 @@ and pp_record_pat (fields, args) =
    str " }"
 
 and pp_cons_pat r ppl =
-  if is_infix r && List.length ppl = 2 then
+  if is_infix r && Int.equal (List.length ppl) 2 then
     List.hd ppl ++ str (get_infix r) ++ List.hd (List.tl ppl)
   else
     let fields = get_record_fields r in
-    if fields <> [] then pp_record_pat (pp_fields r fields, ppl)
-    else if str_global Cons r = "" then
+    if not (List.is_empty fields) then pp_record_pat (pp_fields r fields, ppl)
+    else if String.is_empty (str_global Cons r) then
       pp_boxed_tuple identity ppl (* Hack Extract Inductive prod *)
     else
-      pp_global Cons r ++ space_if (ppl<>[]) ++ pp_boxed_tuple identity ppl
+      pp_global Cons r ++ space_if (not (List.is_empty ppl)) ++ pp_boxed_tuple identity ppl
 
 and pp_gen_pat ids env = function
   | Pcons (r, l) -> pp_cons_pat r (List.map (pp_gen_pat ids env) l)
@@ -339,7 +342,7 @@ and pp_pat env pv =
     (fun i x ->
        let s1,s2 = pp_one_pat env x in
        hv 2 (hov 4 (str "| " ++ s1 ++ str " ->") ++ spc () ++ hov 2 s2) ++
-       if i = Array.length pv - 1 then mt () else fnl ())
+       if Int.equal i (Array.length pv - 1) then mt () else fnl ())
     pv
 
 and pp_function env t =
@@ -347,7 +350,7 @@ and pp_function env t =
   let bl,env' = push_vars (List.map id_of_mlid bl) env in
   match t' with
     | MLcase(Tglob(r,_),MLrel 1,pv) when
-	not (is_coinductive r) && get_record_fields r = [] &&
+	not (is_coinductive r) && List.is_empty (get_record_fields r) &&
 	not (is_custom_match pv) ->
 	if not (ast_occurs 1 (MLcase(Tunknown,MLdummy,pv))) then
 	  pr_binding (List.rev (List.tl bl)) ++
@@ -371,7 +374,7 @@ and pp_fix par env i (ids,bl) args =
 	  prvect_with_sep
       	    (fun () -> fnl () ++ str "and ")
 	    (fun (fi,ti) -> pr_id fi ++ pp_function env ti)
-	    (array_map2 (fun id b -> (id,b)) ids bl) ++
+	    (Array.map2 (fun id b -> (id,b)) ids bl) ++
 	  fnl () ++
 	  hov 2 (str "in " ++ pp_apply (pr_id ids.(i)) false args)))
 
@@ -390,7 +393,7 @@ let pp_Dfix (rv,c,t) =
       (if init then failwith "empty phrase" else mt ())
     else
       let void = is_inline_custom rv.(i) ||
-	(not (is_custom rv.(i)) && c.(i) = MLexn "UNUSED")
+	(not (is_custom rv.(i)) && match c.(i) with MLexn "UNUSED" -> true | _ -> false)
       in
       if void then pp init (i+1)
       else
@@ -413,20 +416,19 @@ let pp_equiv param_list name = function
   | RenEquiv ren, _  ->
       str " = " ++ pp_parameters param_list ++ str (ren^".") ++ name
 
-let pp_comment s = str "(* " ++ s ++ str " *)"
 
 let pp_one_ind prefix ip_equiv pl name cnames ctyps =
   let pl = rename_tvars keywords pl in
   let pp_constructor i typs =
-    (if i=0 then mt () else fnl ()) ++
+    (if Int.equal i 0 then mt () else fnl ()) ++
     hov 3 (str "| " ++ cnames.(i) ++
-	   (if typs = [] then mt () else str " of ") ++
+	   (if List.is_empty typs then mt () else str " of ") ++
 	   prlist_with_sep
 	    (fun () -> spc () ++ str "* ") (pp_type true pl) typs)
   in
   pp_parameters pl ++ str prefix ++ name ++
   pp_equiv pl name ip_equiv ++ str " =" ++
-  if Array.length ctyps = 0 then str " unit (* empty inductive *)"
+  if Int.equal (Array.length ctyps) 0 then str " unit (* empty inductive *)"
   else fnl () ++ v 0 (prvecti pp_constructor ctyps)
 
 let pp_logical_ind packet =
@@ -525,7 +527,7 @@ let pp_decl = function
 	    pp_string_parameters ids, str "=" ++ spc () ++ str s
 	  with Not_found ->
 	    pp_parameters l,
-	    if t = Taxiom then str "(* AXIOM TO BE REALIZED *)"
+	    if t == Taxiom then str "(* AXIOM TO BE REALIZED *)"
 	    else str "=" ++ spc () ++ pp_type false l t
 	in
 	hov 2 (str "type " ++ ids ++ name ++ spc () ++ def)
@@ -632,7 +634,7 @@ and pp_module_type params = function
       str "functor (" ++ name ++ str ":" ++ typ ++ str ") ->" ++ fnl () ++ def
   | MTsig (mp, sign) ->
       push_visible mp params;
-      let l = map_succeed pp_specif sign in
+      let l = List.map pp_specif sign in
       pop_visible ();
       str "sig " ++ fnl () ++
       v 1 (str " " ++ prlist_with_sep fnl2 identity l) ++
@@ -640,11 +642,11 @@ and pp_module_type params = function
   | MTwith(mt,ML_With_type(idl,vl,typ)) ->
       let ids = pp_parameters (rename_tvars keywords vl) in
       let mp_mt = msid_of_mt mt in
-      let l,idl' = list_sep_last idl in
+      let l,idl' = List.sep_last idl in
       let mp_w =
-	List.fold_left (fun mp l -> MPdot(mp,label_of_id l)) mp_mt idl'
+	List.fold_left (fun mp l -> MPdot(mp,Label.of_id l)) mp_mt idl'
       in
-      let r = ConstRef (make_con mp_w empty_dirpath (label_of_id l)) in
+      let r = ConstRef (Constant.make2 mp_w (Label.of_id l)) in
       push_visible mp_mt [];
       let pp_w = str " with type " ++ ids ++ pp_global Type r in
       pop_visible();
@@ -652,7 +654,7 @@ and pp_module_type params = function
   | MTwith(mt,ML_With_module(idl,mp)) ->
       let mp_mt = msid_of_mt mt in
       let mp_w =
-	List.fold_left (fun mp id -> MPdot(mp,label_of_id id)) mp_mt idl
+	List.fold_left (fun mp id -> MPdot(mp,Label.of_id id)) mp_mt idl
       in
       push_visible mp_mt [];
       let pp_w = str " with module " ++ pp_modname mp_w in
@@ -672,7 +674,7 @@ let rec pp_structure_elem = function
   | (l,SEmodule m) ->
       let typ =
         (* virtual printing of the type, in order to have a correct mli later*)
-	if Common.get_phase () = Pre then
+	if Common.get_phase () == Pre then
 	  str ": " ++ pp_module_type [] m.ml_mod_type
 	else mt ()
       in
@@ -705,7 +707,7 @@ and pp_module_expr params = function
       str "functor (" ++ name ++ str ":" ++ typ ++ str ") ->" ++ fnl () ++ def
   | MEstruct (mp, sel) ->
       push_visible mp params;
-      let l = map_succeed pp_structure_elem sel in
+      let l = List.map pp_structure_elem sel in
       pop_visible ();
       str "struct " ++ fnl () ++
       v 1 (str " " ++ prlist_with_sep fnl2 identity l) ++
diff --git a/plugins/extraction/ocaml.mli b/plugins/extraction/ocaml.mli
index 36035b5a..4e796792 100644
--- a/plugins/extraction/ocaml.mli
+++ b/plugins/extraction/ocaml.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/plugins/extraction/scheme.ml b/plugins/extraction/scheme.ml
index f7fa3383..69dea25a 100644
--- a/plugins/extraction/scheme.ml
+++ b/plugins/extraction/scheme.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -9,10 +9,9 @@
 (*s Production of Scheme syntax. *)
 
 open Pp
+open Errors
 open Util
 open Names
-open Nameops
-open Libnames
 open Miniml
 open Mlutil
 open Table
@@ -21,22 +20,29 @@ open Common
 (*s Scheme renaming issues. *)
 
 let keywords =
-  List.fold_right (fun s -> Idset.add (id_of_string s))
+  List.fold_right (fun s -> Id.Set.add (Id.of_string s))
     [ "define"; "let"; "lambda"; "lambdas"; "match";
       "apply"; "car"; "cdr";
       "error"; "delay"; "force"; "_"; "__"]
-    Idset.empty
+    Id.Set.empty
 
-let preamble _ _ usf =
+let pp_comment s = str";; "++h 0 s++fnl ()
+
+let pp_header_comment = function
+  | None -> mt ()
+  | Some com -> pp_comment com ++ fnl () ++ fnl ()
+
+let preamble _ comment _ usf =
+  pp_header_comment comment ++
   str ";; This extracted scheme code relies on some additional macros\n" ++
-  str ";; available at http://www.pps.jussieu.fr/~letouzey/scheme\n" ++
+  str ";; available at http://www.pps.univ-paris-diderot.fr/~letouzey/scheme\n" ++
   str "(load \"macros_extr.scm\")\n\n" ++
   (if usf.mldummy then str "(define __ (lambda (_) __))\n\n" else mt ())
 
 let pr_id id =
-  let s = string_of_id id in
+  let s = Id.to_string id in
   for i = 0 to String.length s - 1 do
-    if s.[i] = '\'' then s.[i] <- '~'
+    if s.[i] == '\'' then s.[i] <- '~'
   done;
   str s
 
@@ -86,11 +92,11 @@ let rec pp_expr env args =
     | MLglob r ->
 	apply (pp_global Term r)
     | MLcons (_,r,args') ->
-	assert (args=[]);
+	assert (List.is_empty args);
 	let st =
 	  str "`" ++
 	  paren (pp_global Cons r ++
-		 (if args' = [] then mt () else spc ()) ++
+		 (if List.is_empty args' then mt () else spc ()) ++
 		 prlist_with_sep spc (pp_cons_args env) args')
 	in
 	if is_coinductive r then paren (str "delay " ++ st) else st
@@ -99,7 +105,7 @@ let rec pp_expr env args =
 	error "Cannot handle general patterns in Scheme yet."
     | MLcase (_,t,pv) when is_custom_match pv ->
 	let mkfun (ids,_,e) =
-	  if ids <> [] then named_lams (List.rev ids) e
+	  if not (List.is_empty ids) then named_lams (List.rev ids) e
 	  else dummy_lams (ast_lift 1 e) 1
 	in
 	apply
@@ -129,7 +135,7 @@ let rec pp_expr env args =
 and pp_cons_args env = function
   | MLcons (_,r,args) when is_coinductive r ->
       paren (pp_global Cons r ++
-	     (if args = [] then mt () else spc ()) ++
+	     (if List.is_empty args then mt () else spc ()) ++
 	     prlist_with_sep spc (pp_cons_args env) args)
   | e -> str "," ++ pp_expr env [] e
 
@@ -141,7 +147,7 @@ and pp_one_pat env (ids,p,t) =
   in
   let ids,env' = push_vars (List.rev_map id_of_mlid ids) env in
   let args =
-    if ids = [] then mt ()
+    if List.is_empty ids then mt ()
     else (str " " ++ prlist_with_sep spc pr_id (List.rev ids))
   in
   (pp_global Cons r ++ args), (pp_expr env' [] t)
@@ -161,7 +167,7 @@ and pp_fix env j (ids,bl) args =
 	       (prvect_with_sep fnl
 		  (fun (fi,ti) ->
 		     paren ((pr_id fi) ++ spc () ++ (pp_expr env [] ti)))
-		  (array_map2 (fun id b -> (id,b)) ids bl)) ++
+		  (Array.map2 (fun id b -> (id,b)) ids bl)) ++
 	     fnl () ++
       	     hov 2 (pp_apply (pr_id (ids.(j))) true args))))
 
@@ -177,7 +183,7 @@ let pp_decl = function
       prvecti
 	(fun i r ->
 	  let void = is_inline_custom r ||
-	    (not (is_custom r) && defs.(i) = MLexn "UNUSED")
+	    (not (is_custom r) && match defs.(i) with MLexn "UNUSED" -> true | _ -> false)
 	  in
 	  if void then mt ()
 	  else
@@ -222,7 +228,7 @@ let scheme_descr = {
   preamble = preamble;
   pp_struct = pp_struct;
   sig_suffix = None;
-  sig_preamble = (fun _ _ _ -> mt ());
+  sig_preamble = (fun _ _ _ _ -> mt ());
   pp_sig = (fun _ -> mt ());
   pp_decl = pp_decl;
 }
diff --git a/plugins/extraction/scheme.mli b/plugins/extraction/scheme.mli
index 2a2bf48e..f0e36e09 100644
--- a/plugins/extraction/scheme.mli
+++ b/plugins/extraction/scheme.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml
index eaa64fef..44d760cc 100644
--- a/plugins/extraction/table.ml
+++ b/plugins/extraction/table.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -11,10 +11,11 @@ open Term
 open Declarations
 open Nameops
 open Namegen
-open Summary
 open Libobject
 open Goptions
 open Libnames
+open Globnames
+open Errors
 open Util
 open Pp
 open Miniml
@@ -22,14 +23,14 @@ open Miniml
 (** Sets and maps for [global_reference] that use the "user" [kernel_name]
     instead of the canonical one *)
 
-module Refmap' = Map.Make(RefOrdered_env)
-module Refset' = Set.Make(RefOrdered_env)
+module Refmap' = Refmap_env
+module Refset' = Refset_env
 
 (*S Utilities about [module_path] and [kernel_names] and [global_reference] *)
 
 let occur_kn_in_ref kn = function
   | IndRef (kn',_)
-  | ConstructRef ((kn',_),_) -> kn = kn'
+  | ConstructRef ((kn',_),_) -> Names.eq_mind kn kn'
   | ConstRef _ -> false
   | VarRef _ -> assert false
 
@@ -54,21 +55,19 @@ let is_modfile = function
   | _ -> false
 
 let raw_string_of_modfile = function
-  | MPfile f -> String.capitalize (string_of_id (List.hd (repr_dirpath f)))
+  | MPfile f -> String.capitalize (Id.to_string (List.hd (DirPath.repr f)))
   | _ -> assert false
 
-let current_toplevel () = fst (Lib.current_prefix ())
-
 let is_toplevel mp =
-  mp = initial_path || mp = current_toplevel ()
+  ModPath.equal mp initial_path || ModPath.equal mp (Lib.current_mp ())
 
 let at_toplevel mp =
   is_modfile mp || is_toplevel mp
 
-let rec mp_length mp =
-  let mp0 = current_toplevel () in
+let mp_length mp =
+  let mp0 = Lib.current_mp () in
   let rec len = function
-    | mp when mp = mp0 -> 1
+    | mp when ModPath.equal mp mp0 -> 1
     | MPdot (mp,_) -> 1 + len mp
     | _ -> 1
   in len mp
@@ -80,7 +79,7 @@ let rec prefixes_mp mp = match mp with
   | _ -> MPset.singleton mp
 
 let rec get_nth_label_mp n = function
-  | MPdot (mp,l) -> if n=1 then l else get_nth_label_mp (n-1) mp
+  | MPdot (mp,l) -> if Int.equal n 1 then l else get_nth_label_mp (n-1) mp
   | _ -> failwith "get_nth_label: not enough MPdot"
 
 let common_prefix_from_list mp0 mpl =
@@ -91,12 +90,12 @@ let common_prefix_from_list mp0 mpl =
   in f mpl
 
 let rec parse_labels2 ll mp1 = function
-  | mp when mp1=mp -> mp,ll
+  | mp when ModPath.equal mp1 mp -> mp,ll
   | MPdot (mp,l) -> parse_labels2 (l::ll) mp1 mp
   | mp -> mp,ll
 
 let labels_of_ref r =
-  let mp_top = current_toplevel () in
+  let mp_top = Lib.current_mp () in
   let mp,_,l = repr_of_r r in
   parse_labels2 [l] mp_top mp
 
@@ -138,7 +137,7 @@ let is_coinductive r =
     | IndRef (kn,_) -> kn
     | _ -> assert false
   in
-  try Mindmap_env.find kn !inductive_kinds = Coinductive
+  try Mindmap_env.find kn !inductive_kinds == Coinductive
   with Not_found -> false
 
 let is_coinductive_type = function
@@ -163,40 +162,39 @@ let record_fields_of_type = function
 (*s Recursors table. *)
 
 (* NB: here we can use the equivalence between canonical
-   and user constant names : Cset is fine, no need for [Cset_env] *)
+   and user constant names. *)
 
-let recursors = ref Cset.empty
-let init_recursors () = recursors := Cset.empty
+let recursors = ref KNset.empty
+let init_recursors () = recursors := KNset.empty
 
-let add_recursors env kn =
-  let mk_con id =
-    make_con_equiv
-      (modpath (user_mind kn))
-      (modpath (canonical_mind kn))
-      empty_dirpath (label_of_id id)
+let add_recursors env ind =
+  let kn = MutInd.canonical ind in
+  let mk_kn id =
+    KerName.make (KerName.modpath kn) DirPath.empty (Label.of_id id)
   in
-  let mib = Environ.lookup_mind kn env in
+  let mib = Environ.lookup_mind ind env in
   Array.iter
     (fun mip ->
        let id = mip.mind_typename in
-       let c_rec = mk_con (Nameops.add_suffix id "_rec")
-       and c_rect = mk_con (Nameops.add_suffix id "_rect") in
-       recursors := Cset.add c_rec (Cset.add c_rect !recursors))
+       let kn_rec = mk_kn (Nameops.add_suffix id "_rec")
+       and kn_rect = mk_kn (Nameops.add_suffix id "_rect") in
+       recursors := KNset.add kn_rec (KNset.add kn_rect !recursors))
     mib.mind_packets
 
 let is_recursor = function
-  | ConstRef kn -> Cset.mem kn !recursors
+  | ConstRef c -> KNset.mem (Constant.canonical c) !recursors
   | _ -> false
 
 (*s Record tables. *)
 
 (* NB: here, working modulo name equivalence is ok *)
 
-let projs = ref (Refmap.empty : int Refmap.t)
+let projs = ref (Refmap.empty : (inductive*int) Refmap.t)
 let init_projs () = projs := Refmap.empty
-let add_projection n kn = projs := Refmap.add (ConstRef kn) n !projs
+let add_projection n kn ip = projs := Refmap.add (ConstRef kn) (ip,n) !projs
 let is_projection r = Refmap.mem r !projs
-let projection_arity r = Refmap.find r !projs
+let projection_arity r = snd (Refmap.find r !projs)
+let projection_info r = Refmap.find r !projs
 
 (*s Table of used axioms *)
 
@@ -240,11 +238,11 @@ let safe_basename_of_global r =
   let last_chance r =
     try Nametab.basename_of_global r
     with Not_found ->
-      anomaly "Inductive object unknown to extraction and not globally visible"
+      anomaly (Pp.str "Inductive object unknown to extraction and not globally visible")
   in
   match r with
-    | ConstRef kn -> id_of_label (con_label kn)
-    | IndRef (kn,0) -> id_of_label (mind_label kn)
+    | ConstRef kn -> Label.to_id (con_label kn)
+    | IndRef (kn,0) -> Label.to_id (mind_label kn)
     | IndRef (kn,i) ->
       (try (snd (lookup_ind kn)).ind_packets.(i).ip_typename
        with Not_found -> last_chance r)
@@ -254,8 +252,8 @@ let safe_basename_of_global r =
     | VarRef _ -> assert false
 
 let string_of_global r =
- try string_of_qualid (Nametab.shortest_qualid_of_global Idset.empty r)
- with e when Errors.noncritical e -> string_of_id (safe_basename_of_global r)
+ try string_of_qualid (Nametab.shortest_qualid_of_global Id.Set.empty r)
+ with Not_found -> Id.to_string (safe_basename_of_global r)
 
 let safe_pr_global r = str (string_of_global r)
 
@@ -263,15 +261,15 @@ let safe_pr_global r = str (string_of_global r)
 
 let safe_pr_long_global r =
   try Printer.pr_global r
-  with e when Errors.noncritical e -> match r with
+  with Not_found -> match r with
     | ConstRef kn ->
 	let mp,_,l = repr_con kn in
-	str ((string_of_mp mp)^"."^(string_of_label l))
+	str ((string_of_mp mp)^"."^(Label.to_string l))
     | _ -> assert false
 
 let pr_long_mp mp =
-  let lid = repr_dirpath (Nametab.dirpath_of_module mp) in
-  str (String.concat "." (List.map string_of_id (List.rev lid)))
+  let lid = DirPath.repr (Nametab.dirpath_of_module mp) in
+  str (String.concat "." (List.rev_map Id.to_string lid))
 
 let pr_long_global ref = pr_path (Nametab.path_of_global ref)
 
@@ -281,18 +279,18 @@ let err s = errorlabstrm "Extraction" s
 
 let warning_axioms () =
   let info_axioms = Refset'.elements !info_axioms in
-  if info_axioms = [] then ()
+  if List.is_empty info_axioms then ()
   else begin
-    let s = if List.length info_axioms = 1 then "axiom" else "axioms" in
+    let s = if Int.equal (List.length info_axioms) 1 then "axiom" else "axioms" in
     msg_warning
       (str ("The following "^s^" must be realized in the extracted code:")
        ++ hov 1 (spc () ++ prlist_with_sep spc safe_pr_global info_axioms)
        ++ str "." ++ fnl ())
   end;
   let log_axioms = Refset'.elements !log_axioms in
-  if log_axioms = [] then ()
+  if List.is_empty log_axioms then ()
   else begin
-    let s = if List.length log_axioms = 1 then "axiom was" else "axioms were"
+    let s = if Int.equal (List.length log_axioms) 1 then "axiom was" else "axioms were"
     in
     msg_warning
       (str ("The following logical "^s^" encountered:") ++
@@ -302,14 +300,11 @@ let warning_axioms () =
        str "Having invalid logical axiom in the environment when extracting" ++
        spc () ++ str "may lead to incorrect or non-terminating ML terms." ++
        fnl ())
-  end;
-  if !Flags.load_proofs = Flags.Dont && info_axioms@log_axioms <> [] then
-    msg_warning
-      (str "Some of these axioms might be due to option -dont-load-proofs.")
+  end
 
 let warning_opaques accessed =
   let opaques = Refset'.elements !opaques in
-  if opaques = [] then ()
+  if List.is_empty opaques then ()
   else
     let lst = hov 1 (spc () ++ prlist_with_sep spc safe_pr_global opaques) in
     if accessed then
@@ -337,7 +332,7 @@ let warning_both_mod_and_cst q mp r =
 
 let error_axiom_scheme r i =
   err (str "The type scheme axiom " ++ spc () ++
-       safe_pr_global r ++ spc () ++ str "needs " ++ pr_int i ++
+       safe_pr_global r ++ spc () ++ str "needs " ++ int i ++
        str " type variable(s).")
 
 let check_inside_module () =
@@ -409,9 +404,9 @@ let error_MPfile_as_mod mp b =
 let msg_non_implicit r n id =
   let name = match id with
     | Anonymous -> ""
-    | Name id -> "(" ^ string_of_id id ^ ") "
+    | Name id -> "(" ^ Id.to_string id ^ ") "
   in
-  "The " ^ (ordinal n) ^ " argument " ^ name ^ "of " ^ (string_of_global r)
+  "The " ^ (String.ordinal n) ^ " argument " ^ name ^ "of " ^ (string_of_global r)
 
 let error_non_implicit msg =
   err (str (msg ^ " still occurs after extraction.") ++
@@ -420,16 +415,16 @@ let error_non_implicit msg =
 let check_loaded_modfile mp = match base_mp mp with
   | MPfile dp ->
       if not (Library.library_is_loaded dp) then begin
-	match base_mp (current_toplevel ()) with
-	  | MPfile dp' when dp<>dp' ->
-	      err (str ("Please load library "^(string_of_dirpath dp^" first.")))
+	match base_mp (Lib.current_mp ()) with
+	  | MPfile dp' when not (DirPath.equal dp dp') ->
+	      err (str ("Please load library "^(DirPath.to_string dp^" first.")))
 	  | _ -> ()
       end
   | _ -> ()
 
 let info_file f =
-  Flags.if_verbose message
-    ("The file "^f^" has been created by extraction.")
+  Flags.if_verbose msg_info
+    (str ("The file "^f^" has been created by extraction."))
 
 
 (*S The Extraction auxiliary commands *)
@@ -481,7 +476,7 @@ type opt_flag =
       opt_lin_let : bool;   (* 512 *)
       opt_lin_beta : bool } (* 1024 *)
 
-let kth_digit n k = (n land (1 lsl k) <> 0)
+let kth_digit n k = not (Int.equal (n land (1 lsl k)) 0)
 
 let flag_of_int n =
     { opt_kill_dum = kth_digit n 0;
@@ -518,7 +513,7 @@ let _ = declare_bool_option
            optdepr = false;
 	   optname = "Extraction Optimize";
 	   optkey = ["Extraction"; "Optimize"];
-	   optread = (fun () -> !int_flag_ref <> 0);
+	   optread = (fun () -> not (Int.equal !int_flag_ref 0));
 	   optwrite = (fun b -> chg_flag (if b then int_flag_init else 0))}
 
 let _ = declare_int_option
@@ -531,12 +526,37 @@ let _ = declare_int_option
                           | None -> chg_flag 0
                           | Some i -> chg_flag (max i 0))}
 
+(* This option controls whether "dummy lambda" are removed when a
+   toplevel constant is defined. *)
+let conservative_types_ref = ref false
+let conservative_types () = !conservative_types_ref
+
+let _ = declare_bool_option
+  {optsync = true;
+   optdepr = false;
+   optname = "Extraction Conservative Types";
+   optkey = ["Extraction"; "Conservative"; "Types"];
+   optread = (fun () -> !conservative_types_ref);
+   optwrite = (fun b -> conservative_types_ref := b) }
+
+
+(* Allows to print a comment at the beginning of the output files *)
+let file_comment_ref = ref ""
+let file_comment () = !file_comment_ref
+
+let _ = declare_string_option
+  {optsync = true;
+   optdepr = false;
+   optname = "Extraction File Comment";
+   optkey = ["Extraction"; "File"; "Comment"];
+   optread = (fun () -> !file_comment_ref);
+   optwrite = (fun s -> file_comment_ref := s) }
 
 (*s Extraction Lang *)
 
 type lang = Ocaml | Haskell | Scheme
 
-let lang_ref = ref Ocaml
+let lang_ref = Summary.ref Ocaml ~name:"ExtrLang"
 
 let lang () = !lang_ref
 
@@ -546,18 +566,13 @@ let extr_lang : lang -> obj =
        cache_function = (fun (_,l) -> lang_ref := l);
        load_function = (fun _ (_,l) -> lang_ref := l)}
 
-let _ = declare_summary "Extraction Lang"
-	  { freeze_function = (fun () -> !lang_ref);
-	    unfreeze_function = ((:=) lang_ref);
-	    init_function = (fun () -> lang_ref := Ocaml) }
-
 let extraction_language x = Lib.add_anonymous_leaf (extr_lang x)
 
 (*s Extraction Inline/NoInline *)
 
 let empty_inline_table = (Refset'.empty,Refset'.empty)
 
-let inline_table = ref empty_inline_table
+let inline_table = Summary.ref empty_inline_table ~name:"ExtrInline"
 
 let to_inline r = Refset'.mem r (fst !inline_table)
 
@@ -584,11 +599,6 @@ let inline_extraction : bool * global_reference list -> obj =
         (fun (s,(b,l)) -> (b,(List.map (fun x -> fst (subst_global s x)) l)))
     }
 
-let _ = declare_summary "Extraction Inline"
-	  { freeze_function = (fun () -> !inline_table);
-	    unfreeze_function = ((:=) inline_table);
-	    init_function = (fun () -> inline_table := empty_inline_table) }
-
 (* Grammar entries. *)
 
 let extraction_inline b l =
@@ -604,7 +614,6 @@ let extraction_inline b l =
 let print_extraction_inline () =
   let (i,n)= !inline_table in
   let i'= Refset'.filter (function ConstRef _ -> true | _ -> false) i in
-  msg
     (str "Extraction Inline:" ++ fnl () ++
      Refset'.fold
        (fun r p ->
@@ -626,15 +635,15 @@ let reset_extraction_inline () = Lib.add_anonymous_leaf (reset_inline ())
 
 (*s Extraction Implicit *)
 
-type int_or_id = ArgInt of int | ArgId of identifier
+type int_or_id = ArgInt of int | ArgId of Id.t
 
-let implicits_table = ref Refmap'.empty
+let implicits_table = Summary.ref Refmap'.empty ~name:"ExtrImplicit"
 
 let implicits_of_global r =
  try Refmap'.find r !implicits_table with Not_found -> []
 
 let add_implicits r l =
-  let typ = Global.type_of_global r in
+  let typ = Global.type_of_global_unsafe r in
   let rels,_ =
     decompose_prod (Reduction.whd_betadeltaiota (Global.env ()) typ) in
   let names = List.rev_map fst rels in
@@ -645,7 +654,7 @@ let add_implicits r l =
 	else err (int i ++ str " is not a valid argument number for " ++
 		  safe_pr_global r)
     | ArgId id ->
-	(try list_index (Name id) names
+	(try List.index Name.equal (Name id) names
 	 with Not_found ->
 	   err (str "No argument " ++ pr_id id ++ str " for " ++
 		safe_pr_global r))
@@ -664,11 +673,6 @@ let implicit_extraction : global_reference * int_or_id list -> obj =
        subst_function = (fun (s,(r,l)) -> (fst (subst_global s r), l))
     }
 
-let _ = declare_summary "Extraction Implicit"
-	  { freeze_function = (fun () -> !implicits_table);
-	    unfreeze_function = ((:=) implicits_table);
-	    init_function = (fun () -> implicits_table := Refmap'.empty) }
-
 (* Grammar entries. *)
 
 let extraction_implicit r l =
@@ -678,21 +682,21 @@ let extraction_implicit r l =
 
 (*s Extraction Blacklist of filenames not to use while extracting *)
 
-let blacklist_table = ref Idset.empty
+let blacklist_table = Summary.ref Id.Set.empty ~name:"ExtrBlacklist"
 
 let modfile_ids = ref []
 let modfile_mps = ref MPmap.empty
 
 let reset_modfile () =
-  modfile_ids := Idset.elements !blacklist_table;
+  modfile_ids := Id.Set.elements !blacklist_table;
   modfile_mps := MPmap.empty
 
 let string_of_modfile mp =
   try MPmap.find mp !modfile_mps
   with Not_found ->
-    let id = id_of_string (raw_string_of_modfile mp) in
+    let id = Id.of_string (raw_string_of_modfile mp) in
     let id' = next_ident_away id !modfile_ids in
-    let s' = string_of_id id' in
+    let s' = Id.to_string id' in
     modfile_ids := id' :: !modfile_ids;
     modfile_mps := MPmap.add mp s' !modfile_mps;
     s'
@@ -701,16 +705,16 @@ let string_of_modfile mp =
 
 let file_of_modfile mp =
   let s0 = match mp with
-    | MPfile f -> string_of_id (List.hd (repr_dirpath f))
+    | MPfile f -> Id.to_string (List.hd (DirPath.repr f))
     | _ -> assert false
   in
   let s = String.copy (string_of_modfile mp) in
-  if s.[0] <> s0.[0] then s.[0] <- s0.[0];
+  if s.[0] != s0.[0] then s.[0] <- s0.[0];
   s
 
 let add_blacklist_entries l =
   blacklist_table :=
-    List.fold_right (fun s -> Idset.add (id_of_string (String.capitalize s)))
+    List.fold_right (fun s -> Id.Set.add (Id.of_string (String.capitalize s)))
       l !blacklist_table
 
 (* Registration of operations for rollback. *)
@@ -723,40 +727,33 @@ let blacklist_extraction : string list -> obj =
        subst_function = (fun (_,x) -> x)
     }
 
-let _ = declare_summary "Extraction Blacklist"
-	  { freeze_function = (fun () -> !blacklist_table);
-	    unfreeze_function = ((:=) blacklist_table);
-	    init_function = (fun () -> blacklist_table := Idset.empty) }
-
 (* Grammar entries. *)
 
 let extraction_blacklist l =
-  let l = List.rev_map string_of_id l in
+  let l = List.rev_map Id.to_string l in
   Lib.add_anonymous_leaf (blacklist_extraction l)
 
 (* Printing part *)
 
 let print_extraction_blacklist () =
-  msgnl
-    (prlist_with_sep fnl pr_id (Idset.elements !blacklist_table))
+  prlist_with_sep fnl pr_id (Id.Set.elements !blacklist_table)
 
 (* Reset part *)
 
 let reset_blacklist : unit -> obj =
   declare_object
     {(default_object "Reset Extraction Blacklist") with
-       cache_function = (fun (_,_)-> blacklist_table := Idset.empty);
-       load_function = (fun _ (_,_)-> blacklist_table := Idset.empty)}
+       cache_function = (fun (_,_)-> blacklist_table := Id.Set.empty);
+       load_function = (fun _ (_,_)-> blacklist_table := Id.Set.empty)}
 
 let reset_extraction_blacklist () = Lib.add_anonymous_leaf (reset_blacklist ())
 
 (*s Extract Constant/Inductive. *)
 
 (* UGLY HACK: to be defined in [extraction.ml] *)
-let use_type_scheme_nb_args, register_type_scheme_nb_args =
-  let r = ref (fun _ _ -> 0) in (fun x y -> !r x y), (:=) r
+let (use_type_scheme_nb_args, type_scheme_nb_args_hook) = Hook.make ()
 
-let customs = ref Refmap'.empty
+let customs = Summary.ref Refmap'.empty ~name:"ExtrCustom"
 
 let add_custom r ids s = customs := Refmap'.add r (ids,s) !customs
 
@@ -768,13 +765,13 @@ let find_custom r = snd (Refmap'.find r !customs)
 
 let find_type_custom r = Refmap'.find r !customs
 
-let custom_matchs = ref Refmap'.empty
+let custom_matchs = Summary.ref Refmap'.empty ~name:"ExtrCustomMatchs"
 
 let add_custom_match r s =
   custom_matchs := Refmap'.add r s !custom_matchs
 
 let indref_of_match pv =
-  if Array.length pv = 0 then raise Not_found;
+  if Array.is_empty pv then raise Not_found;
   let (_,pat,_) = pv.(0) in
   match pat with
     | Pusual (ConstructRef (ip,_)) -> IndRef ip
@@ -800,11 +797,6 @@ let in_customs : global_reference * string list * string -> obj =
         (fun (s,(r,ids,str)) -> (fst (subst_global s r), ids, str))
     }
 
-let _ = declare_summary "ML extractions"
-	  { freeze_function = (fun () -> !customs);
-	    unfreeze_function = ((:=) customs);
-	    init_function = (fun () -> customs := Refmap'.empty) }
-
 let in_custom_matchs : global_reference * string -> obj =
   declare_object
     {(default_object "ML extractions custom matchs") with
@@ -814,11 +806,6 @@ let in_custom_matchs : global_reference * string -> obj =
        subst_function = (fun (subs,(r,s)) -> (fst (subst_global subs r), s))
     }
 
-let _ = declare_summary "ML extractions custom match"
-	  { freeze_function = (fun () -> !custom_matchs);
-	    unfreeze_function = ((:=) custom_matchs);
-	    init_function = (fun () -> custom_matchs := Refmap'.empty) }
-
 (* Grammar entries. *)
 
 let extract_constant_inline inline r ids s =
@@ -827,12 +814,12 @@ let extract_constant_inline inline r ids s =
   match g with
     | ConstRef kn ->
 	let env = Global.env () in
-	let typ = Typeops.type_of_constant env kn in
+	let typ = Global.type_of_global_unsafe (ConstRef kn) in
 	let typ = Reduction.whd_betadeltaiota env typ in
 	if Reduction.is_arity env typ
 	  then begin
-	    let nargs = use_type_scheme_nb_args env typ in
-	    if List.length ids <> nargs then error_axiom_scheme g nargs
+	    let nargs = Hook.get use_type_scheme_nb_args env typ in
+	    if not (Int.equal (List.length ids) nargs) then error_axiom_scheme g nargs
 	  end;
 	Lib.add_anonymous_leaf (inline_extraction (inline,[g]));
 	Lib.add_anonymous_leaf (in_customs (g,ids,s))
@@ -847,12 +834,12 @@ let extract_inductive r s l optstr =
     | IndRef ((kn,i) as ip) ->
 	let mib = Global.lookup_mind kn in
 	let n = Array.length mib.mind_packets.(i).mind_consnames in
-	if n <> List.length l then error_nb_cons ();
+	if not (Int.equal n (List.length l)) then error_nb_cons ();
 	Lib.add_anonymous_leaf (inline_extraction (true,[g]));
 	Lib.add_anonymous_leaf (in_customs (g,[],s));
 	Option.iter (fun s -> Lib.add_anonymous_leaf (in_custom_matchs (g,s)))
 	  optstr;
-	list_iter_i
+	List.iteri
 	  (fun j s ->
 	     let g = ConstructRef (ip,succ j) in
 	     Lib.add_anonymous_leaf (inline_extraction (true,[g]));
diff --git a/plugins/extraction/table.mli b/plugins/extraction/table.mli
index 14792f8f..1acbe355 100644
--- a/plugins/extraction/table.mli
+++ b/plugins/extraction/table.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,13 +8,14 @@
 
 open Names
 open Libnames
+open Globnames
 open Miniml
 open Declarations
 
-module Refset' : Set.S with type elt = global_reference
+module Refset' : CSig.SetS with type elt = global_reference
 module Refmap' : Map.S with type key = global_reference
 
-val safe_basename_of_global : global_reference -> identifier
+val safe_basename_of_global : global_reference -> Id.t
 
 (*s Warning and Error messages. *)
 
@@ -29,7 +30,7 @@ val error_inductive : global_reference -> 'a
 val error_nb_cons : unit -> 'a
 val error_module_clash : module_path -> module_path -> 'a
 val error_no_module_expr : module_path -> 'a
-val error_singleton_become_prop : identifier -> 'a
+val error_singleton_become_prop : Id.t -> 'a
 val error_unknown_module : qualid -> 'a
 val error_scheme : unit -> 'a
 val error_not_visible : global_reference -> 'a
@@ -37,7 +38,7 @@ val error_MPfile_as_mod : module_path -> bool -> 'a
 val check_inside_module : unit -> unit
 val check_inside_section : unit -> unit
 val check_loaded_modfile : module_path -> unit
-val msg_non_implicit : global_reference -> int -> name -> string
+val msg_non_implicit : global_reference -> int -> Name.t -> string
 val error_non_implicit : string -> 'a
 
 val info_file : string -> unit
@@ -45,10 +46,9 @@ val info_file : string -> unit
 (*s utilities about [module_path] and [kernel_names] and [global_reference] *)
 
 val occur_kn_in_ref : mutual_inductive -> global_reference -> bool
-val repr_of_r : global_reference -> module_path * dir_path * label
+val repr_of_r : global_reference -> module_path * DirPath.t * Label.t
 val modpath_of_r : global_reference -> module_path
-val label_of_r : global_reference -> label
-val current_toplevel : unit -> module_path
+val label_of_r : global_reference -> Label.t
 val base_mp : module_path -> module_path
 val is_modfile : module_path -> bool
 val string_of_modfile : module_path -> string
@@ -60,8 +60,8 @@ val mp_length : module_path -> int
 val prefixes_mp : module_path -> MPset.t
 val common_prefix_from_list :
   module_path -> module_path list -> module_path option
-val get_nth_label_mp : int -> module_path -> label
-val labels_of_ref : global_reference -> module_path * label list
+val get_nth_label_mp : int -> module_path -> Label.t
+val labels_of_ref : global_reference -> module_path * Label.t list
 
 (*s Some table-related operations *)
 
@@ -85,9 +85,10 @@ val record_fields_of_type : ml_type -> global_reference option list
 val add_recursors : Environ.env -> mutual_inductive -> unit
 val is_recursor : global_reference -> bool
 
-val add_projection : int -> constant -> unit
+val add_projection : int -> constant -> inductive -> unit
 val is_projection : global_reference -> bool
 val projection_arity : global_reference -> int
+val projection_info : global_reference -> inductive * int (* arity *)
 
 val add_info_axiom : global_reference -> unit
 val remove_info_axiom : global_reference -> unit
@@ -131,6 +132,14 @@ type opt_flag =
 
 val optims :  unit -> opt_flag
 
+(*s Controls whether dummy lambda are removed *)
+
+val conservative_types : unit -> bool
+
+(*s A comment to print at the beginning of the files *)
+
+val file_comment : unit -> string
+
 (*s Target language. *)
 
 type lang = Ocaml | Haskell | Scheme
@@ -162,7 +171,7 @@ val implicits_of_global : global_reference -> int list
 (*s Table for user-given custom ML extractions. *)
 
 (* UGLY HACK: registration of a function defined in [extraction.ml] *)
-val register_type_scheme_nb_args : (Environ.env -> Term.constr -> int) -> unit
+val type_scheme_nb_args_hook : (Environ.env -> Term.constr -> int) Hook.t
 
 val is_custom : global_reference -> bool
 val is_inline_custom : global_reference -> bool
@@ -176,7 +185,7 @@ val find_custom_match : ml_branch array -> string
 
 val extraction_language : lang -> unit
 val extraction_inline : bool -> reference list -> unit
-val print_extraction_inline : unit -> unit
+val print_extraction_inline : unit -> Pp.std_ppcmds
 val reset_extraction_inline : unit -> unit
 val extract_constant_inline :
   bool -> reference -> string list -> string -> unit
@@ -184,14 +193,14 @@ val extract_inductive :
   reference -> string -> string list -> string option -> unit
 
 
-type int_or_id = ArgInt of int | ArgId of identifier
+type int_or_id = ArgInt of int | ArgId of Id.t
 val extraction_implicit : reference -> int_or_id list -> unit
 
 (*s Table of blacklisted filenames *)
 
-val extraction_blacklist : identifier list -> unit
+val extraction_blacklist : Id.t list -> unit
 val reset_extraction_blacklist : unit -> unit
-val print_extraction_blacklist : unit -> unit
+val print_extraction_blacklist : unit -> Pp.std_ppcmds
 
 
 
diff --git a/plugins/field/LegacyField_Compl.v b/plugins/field/LegacyField_Compl.v
deleted file mode 100644
index 89f824e5..00000000
--- a/plugins/field/LegacyField_Compl.v
+++ /dev/null
@@ -1,36 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-Require Import List.
-
-Definition assoc_2nd :=
-  (fix assoc_2nd_rec (A:Type) (B:Set)
-                     (eq_dec:forall e1 e2:B, {e1 = e2} + {e1 <> e2})
-                     (lst:list (prod A B)) {struct lst} :
-   B -> A -> A :=
-     fun (key:B) (default:A) =>
-       match lst with
-       | nil => default
-       | (v,e) :: l =>
-           match eq_dec e key with
-           | left _ => v
-           | right _ => assoc_2nd_rec A B eq_dec l key default
-           end
-       end).
-
-Definition mem :=
-  (fix mem (A:Set) (eq_dec:forall e1 e2:A, {e1 = e2} + {e1 <> e2})
-           (a:A) (l:list A) {struct l} : bool :=
-     match l with
-     | nil => false
-     | a1 :: l1 =>
-         match eq_dec a a1 with
-         | left _ => true
-         | right _ => mem A eq_dec a l1
-         end
-     end).
diff --git a/plugins/field/LegacyField_Tactic.v b/plugins/field/LegacyField_Tactic.v
deleted file mode 100644
index 8a55d582..00000000
--- a/plugins/field/LegacyField_Tactic.v
+++ /dev/null
@@ -1,431 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-Require Import List.
-Require Import LegacyRing.
-Require Export LegacyField_Compl.
-Require Export LegacyField_Theory.
-
-(**** Interpretation A --> ExprA ****)
-
-Ltac get_component a s := eval cbv beta iota delta [a] in (a s).
-
-Ltac body_of s := eval cbv beta iota delta [s] in s.
-
-Ltac mem_assoc var lvar :=
-  match constr:lvar with
-  | nil => constr:false
-  | ?X1 :: ?X2 =>
-      match constr:(X1 = var) with
-      | (?X1 = ?X1) => constr:true
-      | _ => mem_assoc var X2
-      end
-  end.
-
-Ltac number lvar :=
-  let rec number_aux lvar cpt :=
-    match constr:lvar with
-    | (@nil ?X1) => constr:(@nil (prod X1 nat))
-    | ?X2 :: ?X3 =>
-        let l2 := number_aux X3 (S cpt) in
-        constr:((X2,cpt) :: l2)
-    end
-  in number_aux lvar 0.
-
-Ltac build_varlist FT trm :=
-  let rec seek_var lvar trm :=
-    let AT := get_component A FT
-    with AzeroT := get_component Azero FT
-    with AoneT := get_component Aone FT
-    with AplusT := get_component Aplus FT
-    with AmultT := get_component Amult FT
-    with AoppT := get_component Aopp FT
-    with AinvT := get_component Ainv FT in
-    match constr:trm with
-    | AzeroT => lvar
-    | AoneT => lvar
-    | (AplusT ?X1 ?X2) =>
-        let l1 := seek_var lvar X1 in
-        seek_var l1 X2
-    | (AmultT ?X1 ?X2) =>
-        let l1 := seek_var lvar X1 in
-        seek_var l1 X2
-    | (AoppT ?X1) => seek_var lvar X1
-    | (AinvT ?X1) => seek_var lvar X1
-    | ?X1 =>
-        let res := mem_assoc X1 lvar in
-        match constr:res with
-        | true => lvar
-        | false => constr:(X1 :: lvar)
-        end
-    end in
-  let AT := get_component A FT in
-  let lvar := seek_var (@nil AT) trm in
-  number lvar.
-
-Ltac assoc elt lst :=
-  match constr:lst with
-  | nil => fail
-  | (?X1,?X2) :: ?X3 =>
-      match constr:(elt = X1) with
-      | (?X1 = ?X1) => constr:X2
-      | _ => assoc elt X3
-      end
-  end.
-
-Ltac interp_A FT lvar trm :=
-  let AT := get_component A FT
-  with AzeroT := get_component Azero FT
-  with AoneT := get_component Aone FT
-  with AplusT := get_component Aplus FT
-  with AmultT := get_component Amult FT
-  with AoppT := get_component Aopp FT
-  with AinvT := get_component Ainv FT in
-  match constr:trm with
-  | AzeroT => constr:EAzero
-  | AoneT => constr:EAone
-  | (AplusT ?X1 ?X2) =>
-      let e1 := interp_A FT lvar X1 with e2 := interp_A FT lvar X2 in
-      constr:(EAplus e1 e2)
-  | (AmultT ?X1 ?X2) =>
-      let e1 := interp_A FT lvar X1 with e2 := interp_A FT lvar X2 in
-      constr:(EAmult e1 e2)
-  | (AoppT ?X1) =>
-      let e := interp_A FT lvar X1 in
-      constr:(EAopp e)
-  | (AinvT ?X1) => let e := interp_A FT lvar X1 in
-                   constr:(EAinv e)
-  | ?X1 => let idx := assoc X1 lvar in
-           constr:(EAvar idx)
-  end.
-
-(************************)
-(*    Simplification    *)
-(************************)
-
-(**** Generation of the multiplier ****)
-
-Ltac remove e l :=
-  match constr:l with
-  | nil => l
-  | e :: ?X2 => constr:X2
-  | ?X2 :: ?X3 => let nl := remove e X3 in constr:(X2 :: nl)
-  end.
-
-Ltac union l1 l2 :=
-  match constr:l1 with
-  | nil => l2
-  | ?X2 :: ?X3 =>
-      let nl2 := remove X2 l2 in
-      let nl := union X3 nl2 in
-      constr:(X2 :: nl)
-  end.
-
-Ltac raw_give_mult trm :=
-  match constr:trm with
-  | (EAinv ?X1) => constr:(X1 :: nil)
-  | (EAopp ?X1) => raw_give_mult X1
-  | (EAplus ?X1 ?X2) =>
-      let l1 := raw_give_mult X1 with l2 := raw_give_mult X2 in
-      union l1 l2
-  | (EAmult ?X1 ?X2) =>
-      let l1 := raw_give_mult X1 with l2 := raw_give_mult X2 in
-      eval compute in (app l1 l2)
-  | _ => constr:(@nil ExprA)
-  end.
-
-Ltac give_mult trm :=
-  let ltrm := raw_give_mult trm in
-  constr:(mult_of_list ltrm).
-
-(**** Associativity ****)
-
-Ltac apply_assoc FT lvar trm :=
-  let t := eval compute in (assoc trm) in
-  match constr:(t = trm) with
-  | (?X1 = ?X1) => idtac
-  | _ =>
-      rewrite <- (assoc_correct FT trm); change (assoc trm) with t
-  end.
-
-(**** Distribution *****)
-
-Ltac apply_distrib FT lvar trm :=
-  let t := eval compute in (distrib trm) in
-  match constr:(t = trm) with
-  | (?X1 = ?X1) => idtac
-  | _ =>
-      rewrite <- (distrib_correct FT trm);
-       change (distrib trm) with t
-  end.
-
-(**** Multiplication by the inverse product ****)
-
-Ltac grep_mult := match goal with
-                  | id:(interp_ExprA _ _ _ <> _) |- _ => id
-                  end.
-
-Ltac weak_reduce :=
-  match goal with
-  |  |- context [(interp_ExprA ?X1 ?X2 _)] =>
-      cbv beta iota zeta
-       delta [interp_ExprA assoc_2nd eq_nat_dec mult_of_list X1 X2 A Azero
-             Aone Aplus Amult Aopp Ainv]
-  end.
-
-Ltac multiply mul :=
-  match goal with
-  |  |- (interp_ExprA ?FT ?X2 ?X3 = interp_ExprA ?FT ?X2 ?X4) =>
-      let AzeroT := get_component Azero FT in
-      cut (interp_ExprA FT X2 mul <> AzeroT);
-       [ intro; (let id := grep_mult in apply (mult_eq FT X3 X4 mul X2 id))
-       | weak_reduce;
-          (let AoneT := get_component Aone ltac:(body_of FT)
-           with AmultT := get_component Amult ltac:(body_of FT) in
-           try
-             match goal with
-             |  |- context [(AmultT _ AoneT)] => rewrite (AmultT_1r FT)
-             end; clear FT X2) ]
-  end.
-
-Ltac apply_multiply FT lvar trm :=
-  let t := eval compute in (multiply trm) in
-  match constr:(t = trm) with
-  | (?X1 = ?X1) => idtac
-  | _ =>
-      rewrite <- (multiply_correct FT trm);
-       change (multiply trm) with t
-  end.
-
-(**** Permutations and simplification ****)
-
-Ltac apply_inverse mul FT lvar trm :=
-  let t := eval compute in (inverse_simplif mul trm) in
-  match constr:(t = trm) with
-  | (?X1 = ?X1) => idtac
-  | _ =>
-      rewrite <- (inverse_correct FT trm mul);
-       [ change (inverse_simplif mul trm) with t | assumption ]
-  end.
-(**** Inverse test ****)
-
-Ltac strong_fail tac := first [ tac | fail 2 ].
-
-Ltac inverse_test_aux FT trm :=
-  let AplusT := get_component Aplus FT
-  with AmultT := get_component Amult FT
-  with AoppT := get_component Aopp FT
-  with AinvT := get_component Ainv FT in
-  match constr:trm with
-  | (AinvT _) => fail 1
-  | (AoppT ?X1) =>
-      strong_fail ltac:(inverse_test_aux FT X1; idtac)
-  | (AplusT ?X1 ?X2) =>
-      strong_fail ltac:(inverse_test_aux FT X1; inverse_test_aux FT X2)
-  | (AmultT ?X1 ?X2) =>
-      strong_fail ltac:(inverse_test_aux FT X1; inverse_test_aux FT X2)
-  | _ => idtac
-  end.
-
-Ltac inverse_test FT :=
-  let AplusT := get_component Aplus FT in
-  match goal with
-  |  |- (?X1 = ?X2) => inverse_test_aux FT (AplusT X1 X2)
-  end.
-
-(**** Field itself ****)
-
-Ltac apply_simplif sfun :=
-  match goal with
-  |  |- (interp_ExprA ?X1 ?X2 ?X3 = interp_ExprA _ _ _) =>
-  sfun X1 X2 X3
-  end;
-   match goal with
-   |  |- (interp_ExprA _ _ _ = interp_ExprA ?X1 ?X2 ?X3) =>
-   sfun X1 X2 X3
-   end.
-
-Ltac unfolds FT :=
-  match get_component Aminus FT with
-  | Some ?X1 => unfold X1
-  | _ => idtac
-  end;
-  match get_component Adiv FT with
-  | Some ?X1 => unfold X1
-  | _ => idtac
-  end.
-
-Ltac reduce FT :=
-  let AzeroT := get_component Azero FT
-  with AoneT := get_component Aone FT
-  with AplusT := get_component Aplus FT
-  with AmultT := get_component Amult FT
-  with AoppT := get_component Aopp FT
-  with AinvT := get_component Ainv FT in
-  (cbv beta iota zeta delta -[AzeroT AoneT AplusT AmultT AoppT AinvT] ||
-     compute).
-
-Ltac field_gen_aux FT :=
-  let AplusT := get_component Aplus FT in
-  match goal with
-  |  |- (?X1 = ?X2) =>
-      let lvar := build_varlist FT (AplusT X1 X2) in
-      let trm1 := interp_A FT lvar X1 with trm2 := interp_A FT lvar X2 in
-      let mul := give_mult (EAplus trm1 trm2) in
-      cut
-        (let ft := FT in
-         let vm := lvar in interp_ExprA ft vm trm1 = interp_ExprA ft vm trm2);
-        [ compute; auto
-        | intros ft vm; apply_simplif apply_distrib;
-           apply_simplif apply_assoc; multiply mul;
-           [ apply_simplif apply_multiply;
-              apply_simplif ltac:(apply_inverse mul);
-              (let id := grep_mult in
-               clear id; weak_reduce; clear ft vm; first
-              [ inverse_test FT; legacy ring | field_gen_aux FT ])
-           | idtac ] ]
-  end.
-
-Ltac field_gen FT :=
-  unfolds FT; (inverse_test FT; legacy ring) || field_gen_aux FT.
-
-(*****************************)
-(*    Term Simplification    *)
-(*****************************)
-
-(**** Minus and division expansions ****)
-
-Ltac init_exp FT trm :=
-  let e :=
-   (match get_component Aminus FT with
-    | Some ?X1 => eval cbv beta delta [X1] in trm
-    | _ => trm
-    end) in
-  match get_component Adiv FT with
-  | Some ?X1 => eval cbv beta delta [X1] in e
-  | _ => e
-  end.
-
-(**** Inverses simplification ****)
-
-Ltac simpl_inv trm :=
-  match constr:trm with
-  | (EAplus ?X1 ?X2) =>
-      let e1 := simpl_inv X1 with e2 := simpl_inv X2 in
-      constr:(EAplus e1 e2)
-  | (EAmult ?X1 ?X2) =>
-      let e1 := simpl_inv X1 with e2 := simpl_inv X2 in
-      constr:(EAmult e1 e2)
-  | (EAopp ?X1) => let e := simpl_inv X1 in
-                   constr:(EAopp e)
-  | (EAinv ?X1) => SimplInvAux X1
-  | ?X1 => constr:X1
-  end
- with SimplInvAux trm :=
-  match constr:trm with
-  | (EAinv ?X1) => simpl_inv X1
-  | (EAmult ?X1 ?X2) =>
-      let e1 := simpl_inv (EAinv X1) with e2 := simpl_inv (EAinv X2) in
-      constr:(EAmult e1 e2)
-  | ?X1 => let e := simpl_inv X1 in
-           constr:(EAinv e)
-  end.
-
-(**** Monom simplification ****)
-
-Ltac map_tactic fcn lst :=
-  match constr:lst with
-  | nil => lst
-  | ?X2 :: ?X3 =>
-      let r := fcn X2 with t := map_tactic fcn X3 in
-      constr:(r :: t)
-  end.
-
-Ltac build_monom_aux lst trm :=
-  match constr:lst with
-  | nil => eval compute in (assoc trm)
-  | ?X1 :: ?X2 => build_monom_aux X2 (EAmult trm X1)
-  end.
-
-Ltac build_monom lnum lden :=
-  let ildn := map_tactic ltac:(fun e => constr:(EAinv e)) lden in
-  let ltot := eval compute in (app lnum ildn) in
-  let trm := build_monom_aux ltot EAone in
-  match constr:trm with
-  | (EAmult _ ?X1) => constr:X1
-  | ?X1 => constr:X1
-  end.
-
-Ltac simpl_monom_aux lnum lden trm :=
-  match constr:trm with
-  | (EAmult (EAinv ?X1) ?X2) =>
-      let mma := mem_assoc X1 lnum in
-      match constr:mma with
-      | true =>
-          let newlnum := remove X1 lnum in
-          simpl_monom_aux newlnum lden X2
-      | false => simpl_monom_aux lnum (X1 :: lden) X2
-      end
-  | (EAmult ?X1 ?X2) =>
-      let mma := mem_assoc X1 lden in
-      match constr:mma with
-      | true =>
-          let newlden := remove X1 lden in
-          simpl_monom_aux lnum newlden X2
-      | false => simpl_monom_aux (X1 :: lnum) lden X2
-      end
-  | (EAinv ?X1) =>
-      let mma := mem_assoc X1 lnum in
-      match constr:mma with
-      | true =>
-          let newlnum := remove X1 lnum in
-          build_monom newlnum lden
-      | false => build_monom lnum (X1 :: lden)
-      end
-  | ?X1 =>
-      let mma := mem_assoc X1 lden in
-      match constr:mma with
-      | true =>
-          let newlden := remove X1 lden in
-          build_monom lnum newlden
-      | false => build_monom (X1 :: lnum) lden
-      end
-  end.
-
-Ltac simpl_monom trm := simpl_monom_aux (@nil ExprA) (@nil ExprA) trm.
-
-Ltac simpl_all_monomials trm :=
-  match constr:trm with
-  | (EAplus ?X1 ?X2) =>
-      let e1 := simpl_monom X1 with e2 := simpl_all_monomials X2 in
-      constr:(EAplus e1 e2)
-  | ?X1 => simpl_monom X1
-  end.
-
-(**** Associativity and distribution ****)
-
-Ltac assoc_distrib trm := eval compute in (assoc (distrib trm)).
-
-(**** The tactic Field_Term ****)
-
-Ltac eval_weak_reduce trm :=
-  eval
-   cbv beta iota zeta
-    delta [interp_ExprA assoc_2nd eq_nat_dec mult_of_list A Azero Aone Aplus
-          Amult Aopp Ainv] in trm.
-
-Ltac field_term FT exp :=
-  let newexp := init_exp FT exp in
-  let lvar := build_varlist FT newexp in
-  let trm := interp_A FT lvar newexp in
-  let tma := eval compute in (assoc trm) in
-  let tsmp :=
-   simpl_all_monomials
-    ltac:(assoc_distrib ltac:(simpl_all_monomials ltac:(simpl_inv tma))) in
-  let trep := eval_weak_reduce (interp_ExprA FT lvar tsmp) in
-  (replace exp with trep; [ legacy ring trep | field_gen FT ]).
diff --git a/plugins/field/LegacyField_Theory.v b/plugins/field/LegacyField_Theory.v
deleted file mode 100644
index 39926f65..00000000
--- a/plugins/field/LegacyField_Theory.v
+++ /dev/null
@@ -1,648 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-Require Import List.
-Require Import Peano_dec.
-Require Import LegacyRing.
-Require Import LegacyField_Compl.
-
-Record Field_Theory : Type :=
-  {A : Type;
-   Aplus : A -> A -> A;
-   Amult : A -> A -> A;
-   Aone : A;
-   Azero : A;
-   Aopp : A -> A;
-   Aeq : A -> A -> bool;
-   Ainv : A -> A;
-   Aminus : option (A -> A -> A);
-   Adiv : option (A -> A -> A);
-   RT : Ring_Theory Aplus Amult Aone Azero Aopp Aeq;
-   Th_inv_def : forall n:A, n <> Azero -> Amult (Ainv n) n = Aone}.
-
-(* The reflexion structure *)
-Inductive ExprA : Set :=
-  | EAzero : ExprA
-  | EAone : ExprA
-  | EAplus : ExprA -> ExprA -> ExprA
-  | EAmult : ExprA -> ExprA -> ExprA
-  | EAopp : ExprA -> ExprA
-  | EAinv : ExprA -> ExprA
-  | EAvar : nat -> ExprA.
-
-(**** Decidability of equality ****)
-
-Lemma eqExprA_O : forall e1 e2:ExprA, {e1 = e2} + {e1 <> e2}.
-Proof.
-  double induction e1 e2; try intros;
-   try (left; reflexivity) || (try (right; discriminate)).
-  elim (H1 e0); intro y; elim (H2 e); intro y0;
-   try
-    (left; rewrite y; rewrite y0; auto) ||
-      (right; red; intro; inversion H3; auto).
-  elim (H1 e0); intro y; elim (H2 e); intro y0;
-   try
-    (left; rewrite y; rewrite y0; auto) ||
-      (right; red; intro; inversion H3; auto).
-  elim (H0 e); intro y.
-  left; rewrite y; auto.
-  right; red; intro; inversion H1; auto.
-  elim (H0 e); intro y.
-  left; rewrite y; auto.
-  right; red; intro; inversion H1; auto.
-  elim (eq_nat_dec n n0); intro y.
-  left; rewrite y; auto.
-  right; red; intro; inversion H; auto.
-Defined.
-
-Definition eq_nat_dec := Eval compute in eq_nat_dec.
-Definition eqExprA := Eval compute in eqExprA_O.
-
-(**** Generation of the multiplier ****)
-
-Fixpoint mult_of_list (e:list ExprA) : ExprA :=
-  match e with
-  | nil => EAone
-  | e1 :: l1 => EAmult e1 (mult_of_list l1)
-  end.
-
-Section Theory_of_fields.
-
-Variable T : Field_Theory.
-
-Let AT := A T.
-Let AplusT := Aplus T.
-Let AmultT := Amult T.
-Let AoneT := Aone T.
-Let AzeroT := Azero T.
-Let AoppT := Aopp T.
-Let AeqT := Aeq T.
-Let AinvT := Ainv T.
-Let RTT := RT T.
-Let Th_inv_defT := Th_inv_def T.
-
-Add Legacy Abstract Ring (A T) (Aplus T) (Amult T) (Aone T) (
- Azero T) (Aopp T) (Aeq T) (RT T).
-
-Add Legacy Abstract Ring AT AplusT AmultT AoneT AzeroT AoppT AeqT RTT.
-
-(***************************)
-(*    Lemmas to be used    *)
-(***************************)
-
-Lemma AplusT_comm : forall r1 r2:AT, AplusT r1 r2 = AplusT r2 r1.
-Proof.
-  intros; legacy ring.
-Qed.
-
-Lemma AplusT_assoc :
- forall r1 r2 r3:AT, AplusT (AplusT r1 r2) r3 = AplusT r1 (AplusT r2 r3).
-Proof.
-  intros; legacy ring.
-Qed.
-
-Lemma AmultT_comm : forall r1 r2:AT, AmultT r1 r2 = AmultT r2 r1.
-Proof.
-  intros; legacy ring.
-Qed.
-
-Lemma AmultT_assoc :
- forall r1 r2 r3:AT, AmultT (AmultT r1 r2) r3 = AmultT r1 (AmultT r2 r3).
-Proof.
-  intros; legacy ring.
-Qed.
-
-Lemma AplusT_Ol : forall r:AT, AplusT AzeroT r = r.
-Proof.
-  intros; legacy ring.
-Qed.
-
-Lemma AmultT_1l : forall r:AT, AmultT AoneT r = r.
-Proof.
-  intros; legacy ring.
-Qed.
-
-Lemma AplusT_AoppT_r : forall r:AT, AplusT r (AoppT r) = AzeroT.
-Proof.
-  intros; legacy ring.
-Qed.
-
-Lemma AmultT_AplusT_distr :
- forall r1 r2 r3:AT,
-   AmultT r1 (AplusT r2 r3) = AplusT (AmultT r1 r2) (AmultT r1 r3).
-Proof.
-  intros; legacy ring.
-Qed.
-
-Lemma r_AplusT_plus : forall r r1 r2:AT, AplusT r r1 = AplusT r r2 -> r1 = r2.
-Proof.
-  intros; transitivity (AplusT (AplusT (AoppT r) r) r1).
-  legacy ring.
-  transitivity (AplusT (AplusT (AoppT r) r) r2).
-  repeat rewrite AplusT_assoc; rewrite <- H; reflexivity.
-  legacy ring.
-Qed.
-
-Lemma r_AmultT_mult :
- forall r r1 r2:AT, AmultT r r1 = AmultT r r2 -> r <> AzeroT -> r1 = r2.
-Proof.
-  intros; transitivity (AmultT (AmultT (AinvT r) r) r1).
-  rewrite Th_inv_defT; [ symmetry ; apply AmultT_1l; auto | auto ].
-  transitivity (AmultT (AmultT (AinvT r) r) r2).
-  repeat rewrite AmultT_assoc; rewrite H; trivial.
-  rewrite Th_inv_defT; [ apply AmultT_1l; auto | auto ].
-Qed.
-
-Lemma AmultT_Or : forall r:AT, AmultT r AzeroT = AzeroT.
-Proof.
-  intro; legacy ring.
-Qed.
-
-Lemma AmultT_Ol : forall r:AT, AmultT AzeroT r = AzeroT.
-Proof.
-  intro; legacy ring.
-Qed.
-
-Lemma AmultT_1r : forall r:AT, AmultT r AoneT = r.
-Proof.
-  intro; legacy ring.
-Qed.
-
-Lemma AinvT_r : forall r:AT, r <> AzeroT -> AmultT r (AinvT r) = AoneT.
-Proof.
-  intros; rewrite AmultT_comm; apply Th_inv_defT; auto.
-Qed.
-
-Lemma Rmult_neq_0_reg :
- forall r1 r2:AT, AmultT r1 r2 <> AzeroT -> r1 <> AzeroT /\ r2 <> AzeroT.
-Proof.
-  intros r1 r2 H; split; red; intro; apply H; rewrite H0; legacy ring.
-Qed.
-
-(************************)
-(*    Interpretation    *)
-(************************)
-
-(**** ExprA --> A ****)
-
-Fixpoint interp_ExprA (lvar:list (AT * nat)) (e:ExprA) {struct e} :
- AT :=
-  match e with
-  | EAzero => AzeroT
-  | EAone => AoneT
-  | EAplus e1 e2 => AplusT (interp_ExprA lvar e1) (interp_ExprA lvar e2)
-  | EAmult e1 e2 => AmultT (interp_ExprA lvar e1) (interp_ExprA lvar e2)
-  | EAopp e => Aopp T (interp_ExprA lvar e)
-  | EAinv e => Ainv T (interp_ExprA lvar e)
-  | EAvar n => assoc_2nd AT nat eq_nat_dec lvar n AzeroT
-  end.
-
-(************************)
-(*    Simplification    *)
-(************************)
-
-(**** Associativity ****)
-
-Definition merge_mult :=
-  (fix merge_mult (e1:ExprA) : ExprA -> ExprA :=
-     fun e2:ExprA =>
-       match e1 with
-       | EAmult t1 t2 =>
-           match t2 with
-           | EAmult t2 t3 => EAmult t1 (EAmult t2 (merge_mult t3 e2))
-           | _ => EAmult t1 (EAmult t2 e2)
-           end
-       | _ => EAmult e1 e2
-       end).
-
-Fixpoint assoc_mult (e:ExprA) : ExprA :=
-  match e with
-  | EAmult e1 e3 =>
-      match e1 with
-      | EAmult e1 e2 =>
-          merge_mult (merge_mult (assoc_mult e1) (assoc_mult e2))
-            (assoc_mult e3)
-      | _ => EAmult e1 (assoc_mult e3)
-      end
-  | _ => e
-  end.
-
-Definition merge_plus :=
-  (fix merge_plus (e1:ExprA) : ExprA -> ExprA :=
-     fun e2:ExprA =>
-       match e1 with
-       | EAplus t1 t2 =>
-           match t2 with
-           | EAplus t2 t3 => EAplus t1 (EAplus t2 (merge_plus t3 e2))
-           | _ => EAplus t1 (EAplus t2 e2)
-           end
-       | _ => EAplus e1 e2
-       end).
-
-Fixpoint assoc (e:ExprA) : ExprA :=
-  match e with
-  | EAplus e1 e3 =>
-      match e1 with
-      | EAplus e1 e2 =>
-          merge_plus (merge_plus (assoc e1) (assoc e2)) (assoc e3)
-      | _ => EAplus (assoc_mult e1) (assoc e3)
-      end
-  | _ => assoc_mult e
-  end.
-
-Lemma merge_mult_correct1 :
- forall (e1 e2 e3:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar (merge_mult (EAmult e1 e2) e3) =
-   interp_ExprA lvar (EAmult e1 (merge_mult e2 e3)).
-Proof.
-intros e1 e2; generalize e1; generalize e2; clear e1 e2.
-simple induction e2; auto; intros.
-unfold merge_mult at 1; fold merge_mult;
- unfold interp_ExprA at 2; fold interp_ExprA;
- rewrite (H0 e e3 lvar); unfold interp_ExprA at 1;
- fold interp_ExprA; unfold interp_ExprA at 5;
- fold interp_ExprA; auto.
-Qed.
-
-Lemma merge_mult_correct :
- forall (e1 e2:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar (merge_mult e1 e2) = interp_ExprA lvar (EAmult e1 e2).
-Proof.
-simple induction e1; auto; intros.
-elim e0; try (intros; simpl; legacy ring).
-unfold interp_ExprA in H2; fold interp_ExprA in H2;
- cut
-  (AmultT (interp_ExprA lvar e2)
-     (AmultT (interp_ExprA lvar e4)
-        (AmultT (interp_ExprA lvar e) (interp_ExprA lvar e3))) =
-   AmultT
-     (AmultT (AmultT (interp_ExprA lvar e) (interp_ExprA lvar e4))
-        (interp_ExprA lvar e2)) (interp_ExprA lvar e3)).
-intro H3; rewrite H3; rewrite <- H2; rewrite merge_mult_correct1;
- simpl; legacy ring.
-legacy ring.
-Qed.
-
-Lemma assoc_mult_correct1 :
- forall (e1 e2:ExprA) (lvar:list (AT * nat)),
-   AmultT (interp_ExprA lvar (assoc_mult e1))
-     (interp_ExprA lvar (assoc_mult e2)) =
-   interp_ExprA lvar (assoc_mult (EAmult e1 e2)).
-Proof.
-simple induction e1; auto; intros.
-rewrite <- (H e0 lvar); simpl; rewrite merge_mult_correct;
- simpl; rewrite merge_mult_correct; simpl;
- auto.
-Qed.
-
-Lemma assoc_mult_correct :
- forall (e:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar (assoc_mult e) = interp_ExprA lvar e.
-Proof.
-simple induction e; auto; intros.
-elim e0; intros.
-intros; simpl; legacy ring.
-simpl; rewrite (AmultT_1l (interp_ExprA lvar (assoc_mult e1)));
- rewrite (AmultT_1l (interp_ExprA lvar e1)); apply H0.
-simpl; rewrite (H0 lvar); auto.
-simpl; rewrite merge_mult_correct; simpl;
- rewrite merge_mult_correct; simpl; rewrite AmultT_assoc;
- rewrite assoc_mult_correct1; rewrite H2; simpl;
- rewrite <- assoc_mult_correct1 in H1; unfold interp_ExprA at 3 in H1;
- fold interp_ExprA in H1; rewrite (H0 lvar) in H1;
- rewrite (AmultT_comm (interp_ExprA lvar e3) (interp_ExprA lvar e1));
- rewrite <- AmultT_assoc; rewrite H1; rewrite AmultT_assoc;
- legacy ring.
-simpl; rewrite (H0 lvar); auto.
-simpl; rewrite (H0 lvar); auto.
-simpl; rewrite (H0 lvar); auto.
-Qed.
-
-Lemma merge_plus_correct1 :
- forall (e1 e2 e3:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar (merge_plus (EAplus e1 e2) e3) =
-   interp_ExprA lvar (EAplus e1 (merge_plus e2 e3)).
-Proof.
-intros e1 e2; generalize e1; generalize e2; clear e1 e2.
-simple induction e2; auto; intros.
-unfold merge_plus at 1; fold merge_plus;
- unfold interp_ExprA at 2; fold interp_ExprA;
- rewrite (H0 e e3 lvar); unfold interp_ExprA at 1;
- fold interp_ExprA; unfold interp_ExprA at 5;
- fold interp_ExprA; auto.
-Qed.
-
-Lemma merge_plus_correct :
- forall (e1 e2:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar (merge_plus e1 e2) = interp_ExprA lvar (EAplus e1 e2).
-Proof.
-simple induction e1; auto; intros.
-elim e0; try intros; try (simpl; legacy ring).
-unfold interp_ExprA in H2; fold interp_ExprA in H2;
- cut
-  (AplusT (interp_ExprA lvar e2)
-     (AplusT (interp_ExprA lvar e4)
-        (AplusT (interp_ExprA lvar e) (interp_ExprA lvar e3))) =
-   AplusT
-     (AplusT (AplusT (interp_ExprA lvar e) (interp_ExprA lvar e4))
-        (interp_ExprA lvar e2)) (interp_ExprA lvar e3)).
-intro H3; rewrite H3; rewrite <- H2; rewrite merge_plus_correct1;
- simpl; legacy ring.
-legacy ring.
-Qed.
-
-Lemma assoc_plus_correct :
- forall (e1 e2:ExprA) (lvar:list (AT * nat)),
-   AplusT (interp_ExprA lvar (assoc e1)) (interp_ExprA lvar (assoc e2)) =
-   interp_ExprA lvar (assoc (EAplus e1 e2)).
-Proof.
-simple induction e1; auto; intros.
-rewrite <- (H e0 lvar); simpl; rewrite merge_plus_correct;
- simpl; rewrite merge_plus_correct; simpl;
- auto.
-Qed.
-
-Lemma assoc_correct :
- forall (e:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar (assoc e) = interp_ExprA lvar e.
-Proof.
-simple induction e; auto; intros.
-elim e0; intros.
-simpl; rewrite (H0 lvar); auto.
-simpl; rewrite (H0 lvar); auto.
-simpl; rewrite merge_plus_correct; simpl;
- rewrite merge_plus_correct; simpl; rewrite AplusT_assoc;
- rewrite assoc_plus_correct; rewrite H2; simpl;
- apply
-  (r_AplusT_plus (interp_ExprA lvar (assoc e1))
-     (AplusT (interp_ExprA lvar (assoc e2))
-        (AplusT (interp_ExprA lvar e3) (interp_ExprA lvar e1)))
-     (AplusT (AplusT (interp_ExprA lvar e2) (interp_ExprA lvar e3))
-        (interp_ExprA lvar e1))); rewrite <- AplusT_assoc;
- rewrite
-  (AplusT_comm (interp_ExprA lvar (assoc e1)) (interp_ExprA lvar (assoc e2)))
-  ; rewrite assoc_plus_correct; rewrite H1; simpl;
- rewrite (H0 lvar);
- rewrite <-
-  (AplusT_assoc (AplusT (interp_ExprA lvar e2) (interp_ExprA lvar e1))
-     (interp_ExprA lvar e3) (interp_ExprA lvar e1))
-  ;
- rewrite
-  (AplusT_assoc (interp_ExprA lvar e2) (interp_ExprA lvar e1)
-     (interp_ExprA lvar e3));
- rewrite (AplusT_comm (interp_ExprA lvar e1) (interp_ExprA lvar e3));
- rewrite <-
-  (AplusT_assoc (interp_ExprA lvar e2) (interp_ExprA lvar e3)
-     (interp_ExprA lvar e1)); apply AplusT_comm.
-unfold assoc; fold assoc; unfold interp_ExprA;
- fold interp_ExprA; rewrite assoc_mult_correct;
- rewrite (H0 lvar); simpl; auto.
-simpl; rewrite (H0 lvar); auto.
-simpl; rewrite (H0 lvar); auto.
-simpl; rewrite (H0 lvar); auto.
-unfold assoc; fold assoc; unfold interp_ExprA;
- fold interp_ExprA; rewrite assoc_mult_correct;
- simpl; auto.
-Qed.
-
-(**** Distribution *****)
-
-Fixpoint distrib_EAopp (e:ExprA) : ExprA :=
-  match e with
-  | EAplus e1 e2 => EAplus (distrib_EAopp e1) (distrib_EAopp e2)
-  | EAmult e1 e2 => EAmult (distrib_EAopp e1) (distrib_EAopp e2)
-  | EAopp e => EAmult (EAopp EAone) (distrib_EAopp e)
-  | e => e
-  end.
-
-Definition distrib_mult_right :=
-  (fix distrib_mult_right (e1:ExprA) : ExprA -> ExprA :=
-     fun e2:ExprA =>
-       match e1 with
-       | EAplus t1 t2 =>
-           EAplus (distrib_mult_right t1 e2) (distrib_mult_right t2 e2)
-       | _ => EAmult e1 e2
-       end).
-
-Fixpoint distrib_mult_left (e1 e2:ExprA) {struct e1} : ExprA :=
-  match e1 with
-  | EAplus t1 t2 =>
-      EAplus (distrib_mult_left t1 e2) (distrib_mult_left t2 e2)
-  | _ => distrib_mult_right e2 e1
-  end.
-
-Fixpoint distrib_main (e:ExprA) : ExprA :=
-  match e with
-  | EAmult e1 e2 => distrib_mult_left (distrib_main e1) (distrib_main e2)
-  | EAplus e1 e2 => EAplus (distrib_main e1) (distrib_main e2)
-  | EAopp e => EAopp (distrib_main e)
-  | _ => e
-  end.
-
-Definition distrib (e:ExprA) : ExprA := distrib_main (distrib_EAopp e).
-
-Lemma distrib_mult_right_correct :
- forall (e1 e2:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar (distrib_mult_right e1 e2) =
-   AmultT (interp_ExprA lvar e1) (interp_ExprA lvar e2).
-Proof.
-simple induction e1; try intros; simpl; auto.
-rewrite AmultT_comm; rewrite AmultT_AplusT_distr; rewrite (H e2 lvar);
- rewrite (H0 e2 lvar); legacy ring.
-Qed.
-
-Lemma distrib_mult_left_correct :
- forall (e1 e2:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar (distrib_mult_left e1 e2) =
-   AmultT (interp_ExprA lvar e1) (interp_ExprA lvar e2).
-Proof.
-simple induction e1; try intros; simpl.
-rewrite AmultT_Ol; rewrite distrib_mult_right_correct; simpl;
- apply AmultT_Or.
-rewrite distrib_mult_right_correct; simpl; apply AmultT_comm.
-rewrite AmultT_comm;
- rewrite
-  (AmultT_AplusT_distr (interp_ExprA lvar e2) (interp_ExprA lvar e)
-     (interp_ExprA lvar e0));
- rewrite (AmultT_comm (interp_ExprA lvar e2) (interp_ExprA lvar e));
- rewrite (AmultT_comm (interp_ExprA lvar e2) (interp_ExprA lvar e0));
- rewrite (H e2 lvar); rewrite (H0 e2 lvar); auto.
-rewrite distrib_mult_right_correct; simpl; apply AmultT_comm.
-rewrite distrib_mult_right_correct; simpl; apply AmultT_comm.
-rewrite distrib_mult_right_correct; simpl; apply AmultT_comm.
-rewrite distrib_mult_right_correct; simpl; apply AmultT_comm.
-Qed.
-
-Lemma distrib_correct :
- forall (e:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar (distrib e) = interp_ExprA lvar e.
-Proof.
-simple induction e; intros; auto.
-simpl; rewrite <- (H lvar); rewrite <- (H0 lvar);
- unfold distrib; simpl; auto.
-simpl; rewrite <- (H lvar); rewrite <- (H0 lvar);
- unfold distrib; simpl; apply distrib_mult_left_correct.
-simpl; fold AoppT; rewrite <- (H lvar);
- unfold distrib; simpl; rewrite distrib_mult_right_correct;
- simpl; fold AoppT; legacy ring.
-Qed.
-
-(**** Multiplication by the inverse product ****)
-
-Lemma mult_eq :
- forall (e1 e2 a:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar a <> AzeroT ->
-   interp_ExprA lvar (EAmult a e1) = interp_ExprA lvar (EAmult a e2) ->
-   interp_ExprA lvar e1 = interp_ExprA lvar e2.
-Proof.
-  simpl; intros;
-   apply
-    (r_AmultT_mult (interp_ExprA lvar a) (interp_ExprA lvar e1)
-       (interp_ExprA lvar e2)); assumption.
-Qed.
-
-Fixpoint multiply_aux (a e:ExprA) {struct e} : ExprA :=
-  match e with
-  | EAplus e1 e2 => EAplus (EAmult a e1) (multiply_aux a e2)
-  | _ => EAmult a e
-  end.
-
-Definition multiply (e:ExprA) : ExprA :=
-  match e with
-  | EAmult a e1 => multiply_aux a e1
-  | _ => e
-  end.
-
-Lemma multiply_aux_correct :
- forall (a e:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar (multiply_aux a e) =
-   AmultT (interp_ExprA lvar a) (interp_ExprA lvar e).
-Proof.
-simple induction e; simpl; intros; try rewrite merge_mult_correct;
- auto.
-  simpl; rewrite (H0 lvar); legacy ring.
-Qed.
-
-Lemma multiply_correct :
- forall (e:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar (multiply e) = interp_ExprA lvar e.
-Proof.
-  simple induction e; simpl; auto.
-  intros; apply multiply_aux_correct.
-Qed.
-
-(**** Permutations and simplification ****)
-
-Fixpoint monom_remove (a m:ExprA) {struct m} : ExprA :=
-  match m with
-  | EAmult m0 m1 =>
-      match eqExprA m0 (EAinv a) with
-      | left _ => m1
-      | right _ => EAmult m0 (monom_remove a m1)
-      end
-  | _ =>
-      match eqExprA m (EAinv a) with
-      | left _ => EAone
-      | right _ => EAmult a m
-      end
-  end.
-
-Definition monom_simplif_rem :=
-  (fix monom_simplif_rem (a:ExprA) : ExprA -> ExprA :=
-     fun m:ExprA =>
-       match a with
-       | EAmult a0 a1 => monom_simplif_rem a1 (monom_remove a0 m)
-       | _ => monom_remove a m
-       end).
-
-Definition monom_simplif (a m:ExprA) : ExprA :=
-  match m with
-  | EAmult a' m' =>
-      match eqExprA a a' with
-      | left _ => monom_simplif_rem a m'
-      | right _ => m
-      end
-  | _ => m
-  end.
-
-Fixpoint inverse_simplif (a e:ExprA) {struct e} : ExprA :=
-  match e with
-  | EAplus e1 e2 => EAplus (monom_simplif a e1) (inverse_simplif a e2)
-  | _ => monom_simplif a e
-  end.
-
-Lemma monom_remove_correct :
- forall (e a:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar a <> AzeroT ->
-   interp_ExprA lvar (monom_remove a e) =
-   AmultT (interp_ExprA lvar a) (interp_ExprA lvar e).
-Proof.
-simple induction e; intros.
-simpl; case (eqExprA EAzero (EAinv a)); intros;
- [ inversion e0 | simpl; trivial ].
-simpl; case (eqExprA EAone (EAinv a)); intros;
- [ inversion e0 | simpl; trivial ].
-simpl; case (eqExprA (EAplus e0 e1) (EAinv a)); intros;
- [ inversion e2 | simpl; trivial ].
-simpl; case (eqExprA e0 (EAinv a)); intros.
-rewrite e2; simpl; fold AinvT.
-rewrite <-
- (AmultT_assoc (interp_ExprA lvar a) (AinvT (interp_ExprA lvar a))
-    (interp_ExprA lvar e1)); rewrite AinvT_r; [ legacy ring | assumption ].
-simpl; rewrite H0; auto; legacy ring.
-simpl; fold AoppT; case (eqExprA (EAopp e0) (EAinv a));
- intros; [ inversion e1 | simpl; trivial ].
-unfold monom_remove; case (eqExprA (EAinv e0) (EAinv a)); intros.
-case (eqExprA e0 a); intros.
-rewrite e2; simpl; fold AinvT; rewrite AinvT_r; auto.
-inversion e1; simpl; exfalso; auto.
-simpl; trivial.
-unfold monom_remove; case (eqExprA (EAvar n) (EAinv a)); intros;
- [ inversion e0 | simpl; trivial ].
-Qed.
-
-Lemma monom_simplif_rem_correct :
- forall (a e:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar a <> AzeroT ->
-   interp_ExprA lvar (monom_simplif_rem a e) =
-   AmultT (interp_ExprA lvar a) (interp_ExprA lvar e).
-Proof.
-simple induction a; simpl; intros; try rewrite monom_remove_correct;
- auto.
-elim (Rmult_neq_0_reg (interp_ExprA lvar e) (interp_ExprA lvar e0) H1);
- intros.
-rewrite (H0 (monom_remove e e1) lvar H3); rewrite monom_remove_correct; auto.
-legacy ring.
-Qed.
-
-Lemma monom_simplif_correct :
- forall (e a:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar a <> AzeroT ->
-   interp_ExprA lvar (monom_simplif a e) = interp_ExprA lvar e.
-Proof.
-simple induction e; intros; auto.
-simpl; case (eqExprA a e0); intros.
-rewrite <- e2; apply monom_simplif_rem_correct; auto.
-simpl; trivial.
-Qed.
-
-Lemma inverse_correct :
- forall (e a:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar a <> AzeroT ->
-   interp_ExprA lvar (inverse_simplif a e) = interp_ExprA lvar e.
-Proof.
-simple induction e; intros; auto.
-simpl; rewrite (H0 a lvar H1); rewrite monom_simplif_correct; auto.
-unfold inverse_simplif; rewrite monom_simplif_correct; auto.
-Qed.
-
-End Theory_of_fields.
-
-(* Compatibility *)
-Notation AplusT_sym := AplusT_comm (only parsing).
-Notation AmultT_sym := AmultT_comm (only parsing).
diff --git a/plugins/field/field.ml4 b/plugins/field/field.ml4
deleted file mode 100644
index 089ff1e8..00000000
--- a/plugins/field/field.ml4
+++ /dev/null
@@ -1,191 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(*i camlp4deps: "parsing/grammar.cma" i*)
-
-open Names
-open Pp
-open Proof_type
-open Tacinterp
-open Tacmach
-open Term
-open Typing
-open Util
-open Vernacinterp
-open Vernacexpr
-open Tacexpr
-open Mod_subst
-open Coqlib
-
-(* Interpretation of constr's *)
-let constr_of c = Constrintern.interp_constr Evd.empty (Global.env()) c
-
-(* Construction of constants *)
-let constant dir s = gen_constant "Field" ("field"::dir) s
-let init_constant s = gen_constant_in_modules "Field" init_modules s
-
-(* To deal with the optional arguments *)
-let constr_of_opt a opt =
-  let ac = constr_of a in
-  let ac3 = mkArrow ac (mkArrow ac ac) in
-  match opt with
-  | None -> mkApp (init_constant "None",[|ac3|])
-  | Some f -> mkApp (init_constant "Some",[|ac3;constr_of f|])
-
-module Cmap = Map.Make(struct type t = constr let compare = constr_ord end)
-
-(* Table of theories *)
-let th_tab = ref (Cmap.empty : constr Cmap.t)
-
-let lookup env typ =
-  try Cmap.find typ !th_tab
-  with Not_found ->
-    errorlabstrm "field"
-      (str "No field is declared for type" ++ spc() ++
-      Printer.pr_lconstr_env env typ)
-
-let _ =
-  let init () = th_tab := Cmap.empty in
-  let freeze () = !th_tab in
-  let unfreeze fs = th_tab := fs in
-  Summary.declare_summary "field"
-    { Summary.freeze_function   = freeze;
-      Summary.unfreeze_function = unfreeze;
-      Summary.init_function     = init }
-
-let load_addfield _ = ()
-let cache_addfield (_,(typ,th)) = th_tab := Cmap.add typ th !th_tab
-let subst_addfield (subst,(typ,th as obj)) =
-  let typ' = subst_mps subst typ in
-  let th' = subst_mps subst th in
-    if typ' == typ && th' == th then obj else
-      (typ',th')
-
-(* Declaration of the Add Field library object *)
-let in_addfield : types * constr -> Libobject.obj =
-  Libobject.declare_object {(Libobject.default_object "ADD_FIELD") with
-       Libobject.open_function = (fun i o -> if i=1 then cache_addfield o);
-       Libobject.cache_function = cache_addfield;
-       Libobject.subst_function = subst_addfield;
-       Libobject.classify_function = (fun a -> Libobject.Substitute a)}
-
-(* Adds a theory to the table *)
-let add_field a aplus amult aone azero aopp aeq ainv aminus_o adiv_o rth
-  ainv_l =
-  begin
-    (try
-      Ring.add_theory true true false a None None None aplus amult aone azero
-        (Some aopp) aeq rth Quote.ConstrSet.empty
-     with | UserError("Add Semi Ring",_) -> ());
-    let th = mkApp ((constant ["LegacyField_Theory"] "Build_Field_Theory"),
-      [|a;aplus;amult;aone;azero;aopp;aeq;ainv;aminus_o;adiv_o;rth;ainv_l|]) in
-    begin
-      let _ = type_of (Global.env ()) Evd.empty th in ();
-      Lib.add_anonymous_leaf (in_addfield (a,th))
-    end
-  end
-
-(* Vernac command declaration *)
-open Extend
-open Pcoq
-open Genarg
-
-VERNAC ARGUMENT EXTEND divarg
-| [ "div" ":=" constr(adiv) ] -> [ adiv ]
-END
-
-VERNAC ARGUMENT EXTEND minusarg
-| [ "minus" ":=" constr(aminus) ] -> [ aminus ]
-END
-
-(*
-(* The v7->v8 translator needs printers, then temporary use ARGUMENT EXTEND...*)
-VERNAC ARGUMENT EXTEND minus_div_arg
-| [ "with" minusarg(m) divarg_opt(d) ] -> [ Some m, d ]
-| [ "with" divarg(d) minusarg_opt(m) ] -> [ m, Some d ]
-| [ ] -> [ None, None ]
-END
-*)
-
-(* For the translator, otherwise the code above is OK *)
-open Ppconstr
-let pp_minus_div_arg _prc _prlc _prt (omin,odiv) =
-  if omin=None && odiv=None then mt() else
-    spc() ++ str "with" ++
-    pr_opt (fun c -> str "minus := " ++ _prc c) omin ++
-    pr_opt (fun c -> str "div := " ++ _prc c) odiv
-(*
-let () =
-  Pptactic.declare_extra_genarg_pprule true
-    (rawwit_minus_div_arg,pp_minus_div_arg)
-    (globwit_minus_div_arg,pp_minus_div_arg)
-    (wit_minus_div_arg,pp_minus_div_arg)
-*)
-ARGUMENT EXTEND minus_div_arg
-  TYPED AS constr_opt * constr_opt
-  PRINTED BY pp_minus_div_arg
-| [ "with" minusarg(m) divarg_opt(d) ] -> [ Some m, d ]
-| [ "with" divarg(d) minusarg_opt(m) ] -> [ m, Some d ]
-| [ ] -> [ None, None ]
-END
-
-VERNAC COMMAND EXTEND Field
-  [ "Add" "Legacy" "Field"
-      constr(a) constr(aplus) constr(amult) constr(aone)
-      constr(azero) constr(aopp) constr(aeq)
-      constr(ainv) constr(rth) constr(ainv_l) minus_div_arg(md) ]
-    -> [ let (aminus_o, adiv_o) = md in
-         add_field
-           (constr_of a) (constr_of aplus) (constr_of amult)
-           (constr_of aone) (constr_of azero) (constr_of aopp)
-           (constr_of aeq) (constr_of ainv) (constr_of_opt a aminus_o)
-           (constr_of_opt a adiv_o) (constr_of rth) (constr_of ainv_l) ]
-END
-
-(* Guesses the type and calls field_gen with the right theory *)
-let field g =
-  Coqlib.check_required_library ["Coq";"field";"LegacyField"];
-  let typ =
-    try match Hipattern.match_with_equation (pf_concl g) with
-      | _,_,Hipattern.PolymorphicLeibnizEq (t,_,_) -> t
-      | _ -> raise Exit
-    with Hipattern.NoEquationFound | Exit ->
-      error "The statement is not built from Leibniz' equality" in
-  let th = VConstr ([],lookup (pf_env g) typ) in
-  (interp_tac_gen [(id_of_string "FT",th)] [] (get_debug ())
-    <:tactic< match goal with |- (@eq _ _ _) => field_gen FT end >>) g
-
-(* Verifies that all the terms have the same type and gives the right theory *)
-let guess_theory env evc = function
-  | c::tl ->
-    let t = type_of env evc c in
-    if List.exists (fun c1 ->
-      not (Reductionops.is_conv env evc t (type_of env evc c1))) tl then
-      errorlabstrm "Field:" (str" All the terms must have the same type")
-    else
-      lookup env t
-  | [] -> anomaly "Field: must have a non-empty constr list here"
-
-(* Guesses the type and calls Field_Term with the right theory *)
-let field_term l g =
-  Coqlib.check_required_library ["Coq";"field";"LegacyField"];
-  let env = (pf_env g)
-  and evc = (project g) in
-  let th = valueIn (VConstr ([],guess_theory env evc l))
-  and nl = List.map (fun x -> valueIn (VConstr ([],x))) (Quote.sort_subterm g l) in
-  (List.fold_right
-    (fun c a ->
-     let tac = (Tacinterp.interp <:tactic<(Field_Term $th $c)>>) in
-     Tacticals.tclTHENFIRSTn tac [|a|]) nl Tacticals.tclIDTAC) g
-
-(* Declaration of Field *)
-
-TACTIC EXTEND legacy_field
-| [ "legacy" "field" ] -> [ field ]
-| [ "legacy" "field" ne_constr_list(l) ] -> [ field_term l ]
-END
diff --git a/plugins/field/field_plugin.mllib b/plugins/field/field_plugin.mllib
deleted file mode 100644
index 3c3e87af..00000000
--- a/plugins/field/field_plugin.mllib
+++ /dev/null
@@ -1,2 +0,0 @@
-Field
-Field_plugin_mod
diff --git a/plugins/field/vo.itarget b/plugins/field/vo.itarget
deleted file mode 100644
index 22b56f33..00000000
--- a/plugins/field/vo.itarget
+++ /dev/null
@@ -1,4 +0,0 @@
-LegacyField_Compl.vo
-LegacyField_Tactic.vo
-LegacyField_Theory.vo
-LegacyField.vo
diff --git a/plugins/firstorder/formula.ml b/plugins/firstorder/formula.ml
index 79d4c5b5..62a8605a 100644
--- a/plugins/firstorder/formula.ml
+++ b/plugins/firstorder/formula.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -9,13 +9,12 @@
 open Hipattern
 open Names
 open Term
+open Vars
 open Termops
-open Reductionops
 open Tacmach
 open Util
 open Declarations
-open Libnames
-open Inductiveops
+open Globnames
 
 let qflag=ref true
 
@@ -23,11 +22,11 @@ let red_flags=ref Closure.betaiotazeta
 
 let (=?) f g i1 i2 j1 j2=
   let c=f i1 i2 in
-    if c=0 then g j1 j2 else c
+    if Int.equal c 0 then g j1 j2 else c
 
 let (==?) fg h i1 i2 j1 j2 k1 k2=
   let c=fg i1 i2 j1 j2 in
-    if c=0 then h k1 k2 else c
+    if Int.equal c 0 then h k1 k2 else c
 
 type ('a,'b) sum = Left of 'a | Right of 'b
 
@@ -44,7 +43,7 @@ let rec nb_prod_after n c=
     | _ -> 0
 
 let construct_nhyps ind gls =
-  let nparams = (fst (Global.lookup_inductive ind)).mind_nparams in
+  let nparams = (fst (Global.lookup_inductive (fst ind))).mind_nparams in
   let constr_types = Inductiveops.arities_of_constructors (pf_env gls) ind in
   let hyp = nb_prod_after nparams in
     Array.map hyp constr_types
@@ -52,12 +51,11 @@ let construct_nhyps ind gls =
 (* indhyps builds the array of arrays of constructor hyps for (ind largs)*)
 let ind_hyps nevar ind largs gls=
   let types= Inductiveops.arities_of_constructors (pf_env gls) ind in
-  let lp=Array.length types in
-  let myhyps i=
-    let t1=Term.prod_applist types.(i) largs in
+  let myhyps t =
+    let t1=prod_applist t largs in
     let t2=snd (decompose_prod_n_assum nevar t1) in
       fst (decompose_prod_assum t2) in
-    Array.init lp myhyps
+    Array.map myhyps types
 
 let special_nf gl=
   let infos=Closure.create_clos_infos !red_flags (pf_env gl) in
@@ -69,14 +67,14 @@ let special_whd gl=
 
 type kind_of_formula=
     Arrow of constr*constr
-  | False of inductive*constr list
-  | And of inductive*constr list*bool
-  | Or of inductive*constr list*bool
-  | Exists of inductive*constr list
+  | False of pinductive*constr list
+  | And of pinductive*constr list*bool
+  | Or of pinductive*constr list*bool
+  | Exists of pinductive*constr list
   | Forall of constr*constr
   | Atom of constr
 
-let rec kind_of_formula gl term =
+let kind_of_formula gl term =
   let normalize=special_nf gl in
   let cciterm=special_whd gl term in
     match match_with_imp_term cciterm with
@@ -87,26 +85,26 @@ let rec kind_of_formula gl term =
 	   |_->
 	      match match_with_nodep_ind cciterm with
 		  Some (i,l,n)->
-		    let ind=destInd i in
+		    let ind,u=destInd i in
 		    let (mib,mip) = Global.lookup_inductive ind in
 		    let nconstr=Array.length mip.mind_consnames in
-		      if nconstr=0 then
-			False(ind,l)
+		      if Int.equal nconstr 0 then
+			False((ind,u),l)
 		      else
 			let has_realargs=(n>0) in
 			let is_trivial=
 			  let is_constant c =
-			    nb_prod c = mib.mind_nparams in
-			    array_exists is_constant mip.mind_nf_lc in
+			    Int.equal (nb_prod c) mib.mind_nparams in
+			    Array.exists is_constant mip.mind_nf_lc in
 			  if Inductiveops.mis_is_recursive (ind,mib,mip) ||
 			    (has_realargs && not is_trivial)
 			  then
 			    Atom cciterm
 			  else
-			    if nconstr=1 then
-			      And(ind,l,is_trivial)
+			    if Int.equal nconstr 1 then
+			      And((ind,u),l,is_trivial)
 			    else
-			      Or(ind,l,is_trivial)
+			      Or((ind,u),l,is_trivial)
 		| _ ->
 		    match match_with_sigma_type cciterm with
 			Some (i,l)-> Exists((destInd i),l)
@@ -118,7 +116,7 @@ type side = Hyp | Concl | Hint
 
 let no_atoms = (false,{positive=[];negative=[]})
 
-let dummy_id=VarRef (id_of_string "_") (* "_" cannot be parsed *)
+let dummy_id=VarRef (Id.of_string "_") (* "_" cannot be parsed *)
 
 let build_atoms gl metagen side cciterm =
   let trivial =ref false
@@ -144,9 +142,9 @@ let build_atoms gl metagen side cciterm =
 	  let g i _ (_,_,t) =
 	    build_rec env polarity (lift i t) in
 	  let f l =
-	    list_fold_left_i g (1-(List.length l)) () l in
+	    List.fold_left_i g (1-(List.length l)) () l in
 	    if polarity && (* we have a constant constructor *)
-	      array_exists (function []->true|_->false) v
+	      Array.exists (function []->true|_->false) v
 	    then trivial:=true;
 	    Array.iter f v
       | Exists(i,l)->
@@ -154,7 +152,7 @@ let build_atoms gl metagen side cciterm =
 	  let v =(ind_hyps 1 i l gl).(0) in
 	  let g i _ (_,_,t) =
 	    build_rec (var::env) polarity (lift i t) in
-	    list_fold_left_i g (2-(List.length l)) () v
+	    List.fold_left_i g (2-(List.length l)) () v
       | Forall(_,b)->
 	  let var=mkMeta (metagen true) in
 	    build_rec (var::env) polarity b
@@ -171,7 +169,7 @@ let build_atoms gl metagen side cciterm =
 	| Hyp      -> build_rec [] false cciterm
 	| Hint     ->
 	    let rels,head=decompose_prod cciterm in
-	    let env=List.rev (List.map (fun _->mkMeta (metagen true)) rels) in
+	    let env=List.rev_map (fun _->mkMeta (metagen true)) rels in
 	      build_rec env false head;trivial:=false (* special for hints *)
     end;
     (!trivial,
@@ -188,19 +186,19 @@ type right_pattern =
 
 type left_arrow_pattern=
     LLatom
-  | LLfalse of inductive*constr list
-  | LLand of inductive*constr list
-  | LLor of inductive*constr list
+  | LLfalse of pinductive*constr list
+  | LLand of pinductive*constr list
+  | LLor of pinductive*constr list
   | LLforall of constr
-  | LLexists of inductive*constr list
+  | LLexists of pinductive*constr list
   | LLarrow of constr*constr*constr
 
 type left_pattern=
     Lfalse
-  | Land of inductive
-  | Lor of inductive
+  | Land of pinductive
+  | Lor of pinductive
   | Lforall of metavariable*constr*bool
-  | Lexists of inductive
+  | Lexists of pinductive
   | LA of constr*left_arrow_pattern
 
 type t={id:global_reference;
@@ -226,7 +224,7 @@ let build_formula side nam typ gl metagen=
 		  | And(_,_,_)        -> Rand
 		  | Or(_,_,_)         -> Ror
 		  | Exists (i,l) ->
-		      let (_,_,d)=list_last (ind_hyps 0 i l gl).(0) in
+		      let (_,_,d)=List.last (ind_hyps 0 i l gl).(0) in
 			Rexists(m,d,trivial)
 		  | Forall (_,a) -> Rforall
 		  | Arrow (a,b) -> Rarrow in
diff --git a/plugins/firstorder/formula.mli b/plugins/firstorder/formula.mli
index 44bbb335..29ea1e77 100644
--- a/plugins/firstorder/formula.mli
+++ b/plugins/firstorder/formula.mli
@@ -1,14 +1,15 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Term
 open Names
-open Libnames
+open Term
+open Context
+open Globnames
 
 val qflag : bool ref
 
@@ -24,9 +25,9 @@ type ('a,'b) sum = Left of 'a | Right of 'b
 
 type counter = bool -> metavariable
 
-val construct_nhyps : inductive -> Proof_type.goal Tacmach.sigma -> int array
+val construct_nhyps : pinductive -> Proof_type.goal Tacmach.sigma -> int array
 
-val ind_hyps : int -> inductive -> constr list ->
+val ind_hyps : int -> pinductive -> constr list ->
   Proof_type.goal Tacmach.sigma -> rel_context array
 
 type atoms = {positive:constr list;negative:constr list}
@@ -48,19 +49,19 @@ type right_pattern =
 
 type left_arrow_pattern=
     LLatom
-  | LLfalse of inductive*constr list
-  | LLand of inductive*constr list
-  | LLor of inductive*constr list
+  | LLfalse of pinductive*constr list
+  | LLand of pinductive*constr list
+  | LLor of pinductive*constr list
   | LLforall of constr
-  | LLexists of inductive*constr list
+  | LLexists of pinductive*constr list
   | LLarrow of constr*constr*constr
 
 type left_pattern=
     Lfalse
-  | Land of inductive
-  | Lor of inductive
+  | Land of pinductive
+  | Lor of pinductive
   | Lforall of metavariable*constr*bool
-  | Lexists of inductive
+  | Lexists of pinductive
   | LA of constr*left_arrow_pattern
 
 type t={id: global_reference;
diff --git a/plugins/firstorder/g_ground.ml4 b/plugins/firstorder/g_ground.ml4
index 5b882036..c28da42a 100644
--- a/plugins/firstorder/g_ground.ml4
+++ b/plugins/firstorder/g_ground.ml4
@@ -1,25 +1,23 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i camlp4deps: "parsing/grammar.cma"  i*)
+(*i camlp4deps: "grammar/grammar.cma"  i*)
 
 open Formula
 open Sequent
 open Ground
 open Goptions
-open Tactics
 open Tacticals
 open Tacinterp
-open Term
-open Names
-open Util
 open Libnames
 
+DECLARE PLUGIN "ground_plugin"
+
 (* declaring search depth as a global option *)
 
 let ground_depth=ref 3
@@ -57,16 +55,16 @@ let _=
 let (set_default_solver, default_solver, print_default_solver) = 
   Tactic_option.declare_tactic_option ~default:(<:tactic<auto with *>>) "Firstorder default solver"
 
-VERNAC COMMAND EXTEND Firstorder_Set_Solver
+VERNAC COMMAND EXTEND Firstorder_Set_Solver CLASSIFIED AS SIDEFF
 | [ "Set" "Firstorder" "Solver" tactic(t) ] -> [
     set_default_solver 
-      (Vernacexpr.use_section_locality ())
-      (Tacinterp.glob_tactic t) ]
+      (Locality.make_section_locality (Locality.LocalityFixme.consume ()))
+      (Tacintern.glob_tactic t) ]
 END
 
-VERNAC COMMAND EXTEND Firstorder_Print_Solver
+VERNAC COMMAND EXTEND Firstorder_Print_Solver CLASSIFIED AS QUERY
 | [ "Print" "Firstorder" "Solver" ] -> [
-    Pp.msgnl
+    Pp.msg_info
       (Pp.(++) (Pp.str"Firstorder solver tactic is ") (print_default_solver ())) ]
 END
 
@@ -82,10 +80,11 @@ let gen_ground_tac flag taco ids bases gl=
 	  | None-> snd (default_solver ()) in
       let startseq gl=
 	let seq=empty_seq !ground_depth in
-	extend_with_auto_hints bases (extend_with_ref_list ids seq gl) gl in
-      let result=ground_tac solver startseq gl in
+        let seq,gl = extend_with_ref_list ids seq gl in
+        extend_with_auto_hints bases seq gl in
+      let result=ground_tac (Proofview.V82.of_tactic solver) startseq gl in
 	qflag:=backup;result
-    with reraise ->qflag:=backup;raise reraise
+    with reraise -> qflag:=backup;raise reraise
 
 (* special for compatibility with Intuition
 
@@ -103,12 +102,13 @@ let normalize_evaluables=
 	   unfold_in_hyp (Lazy.force defined_connectives)
 	   (Tacexpr.InHypType id)) *)
 
+open Pp
 open Genarg
 open Ppconstr
 open Printer
-let pr_firstorder_using_raw _ _ _ = prlist_with_sep pr_comma pr_reference
-let pr_firstorder_using_glob _ _ _ = prlist_with_sep pr_comma (pr_or_var (pr_located pr_global))
-let pr_firstorder_using_typed _ _ _ = prlist_with_sep pr_comma pr_global
+let pr_firstorder_using_raw _ _ _ l = str "using " ++ prlist_with_sep pr_comma pr_reference l
+let pr_firstorder_using_glob _ _ _ l = str "using " ++ prlist_with_sep pr_comma (pr_or_var (fun x -> (pr_global (snd x)))) l
+let pr_firstorder_using_typed _ _ _ l = str "using " ++ prlist_with_sep pr_comma pr_global l
 
 ARGUMENT EXTEND firstorder_using
   PRINTED BY pr_firstorder_using_typed
@@ -128,29 +128,31 @@ END
 
 TACTIC EXTEND firstorder
     [ "firstorder" tactic_opt(t) firstorder_using(l) ] ->
-      [ gen_ground_tac true (Option.map eval_tactic t) l [] ]
+      [ Proofview.V82.tactic (gen_ground_tac true (Option.map eval_tactic t) l []) ]
 |   [ "firstorder" tactic_opt(t) "with" ne_preident_list(l) ] ->
-      [ gen_ground_tac true (Option.map eval_tactic t) [] l ]
+      [ Proofview.V82.tactic (gen_ground_tac true (Option.map eval_tactic t) [] l) ]
 |   [ "firstorder" tactic_opt(t) firstorder_using(l)
        "with" ne_preident_list(l') ] ->
-      [ gen_ground_tac true (Option.map eval_tactic t) l l' ]
+      [ Proofview.V82.tactic (gen_ground_tac true (Option.map eval_tactic t) l l') ]
 END
 
 TACTIC EXTEND gintuition
   [ "gintuition" tactic_opt(t) ] ->
-     [ gen_ground_tac false (Option.map eval_tactic t) [] [] ]
+     [ Proofview.V82.tactic (gen_ground_tac false (Option.map eval_tactic t) [] []) ]
 END
 
+open Proofview.Notations
 
-let default_declarative_automation gls =
-  tclORELSE
-    (tclORELSE (Auto.h_trivial [] None)
+let default_declarative_automation =
+  Proofview.tclUNIT () >>= fun () -> (* delay for [congruence_depth] *)
+  Tacticals.New.tclORELSE
+    (Tacticals.New.tclORELSE (Auto.h_trivial [] None)
     (Cctac.congruence_tac !congruence_depth []))
-    (gen_ground_tac true
-       (Some (tclTHEN
+    (Proofview.V82.tactic (gen_ground_tac true
+       (Some (Tacticals.New.tclTHEN
 		(snd (default_solver ()))
 		(Cctac.congruence_tac !congruence_depth [])))
-       [] []) gls
+       [] []))
 
 
 
diff --git a/plugins/firstorder/ground.ml b/plugins/firstorder/ground.ml
index 7c80b9bb..2248b669 100644
--- a/plugins/firstorder/ground.ml
+++ b/plugins/firstorder/ground.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -12,28 +12,27 @@ open Rules
 open Instances
 open Term
 open Tacmach
-open Tactics
 open Tacticals
-open Libnames
 
 let update_flags ()=
   let predref=ref Names.Cpred.empty in
   let f coe=
     try
-      let kn=destConst (Classops.get_coercion_value coe) in
+      let kn= fst (destConst (Classops.get_coercion_value coe)) in
 	predref:=Names.Cpred.add kn !predref
-    with Invalid_argument "destConst"-> () in
+    with DestKO -> ()
+  in
     List.iter f (Classops.coercions ());
     red_flags:=
     Closure.RedFlags.red_add_transparent
       Closure.betaiotazeta
-      (Names.Idpred.full,Names.Cpred.complement !predref)
+      (Names.Id.Pred.full,Names.Cpred.complement !predref)
 
 let ground_tac solver startseq gl=
   update_flags ();
   let rec toptac skipped seq gl=
     if Tacinterp.get_debug()=Tactic_debug.DebugOn 0
-    then Pp.msgnl (Printer.pr_goal gl);
+    then Pp.msg_debug (Printer.pr_goal gl);
     tclORELSE (axiom_tac seq.gl seq)
       begin
 	try
@@ -120,5 +119,6 @@ let ground_tac solver startseq gl=
 		  end
 	    with Heap.EmptyHeap->solver
       end gl in
-    wrap (List.length (pf_hyps gl)) true (toptac []) (startseq gl) gl
+    let seq, gl' = startseq gl in
+    wrap (List.length (pf_hyps gl)) true (toptac []) seq gl'
 
diff --git a/plugins/firstorder/ground.mli b/plugins/firstorder/ground.mli
index 380326e7..5b320786 100644
--- a/plugins/firstorder/ground.mli
+++ b/plugins/firstorder/ground.mli
@@ -1,11 +1,11 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
 val ground_tac:     Tacmach.tactic ->
-  (Proof_type.goal Tacmach.sigma -> Sequent.t) -> Tacmach.tactic
+  (Proof_type.goal Tacmach.sigma -> Sequent.t * Proof_type.goal Tacmach.sigma) -> Tacmach.tactic
 
diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml
index d45ab0c3..a88778c7 100644
--- a/plugins/firstorder/instances.ml
+++ b/plugins/firstorder/instances.ml
@@ -1,28 +1,27 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Formula
-open Sequent
 open Unify
 open Rules
+open Errors
 open Util
 open Term
+open Vars
 open Glob_term
 open Tacmach
 open Tactics
 open Tacticals
 open Termops
 open Reductionops
-open Declarations
 open Formula
 open Sequent
 open Names
-open Libnames
+open Misctypes
 
 let compare_instance inst1 inst2=
 	match inst1,inst2 with
@@ -30,18 +29,18 @@ let compare_instance inst1 inst2=
 	      (OrderedConstr.compare d1 d2)
 	  | Real((m1,c1),n1),Real((m2,c2),n2)->
 	      ((-) =? (-) ==? OrderedConstr.compare) m2 m1 n1 n2 c1 c2
-	  | Phantom(_),Real((m,_),_)-> if m=0 then -1 else 1
-	  | Real((m,_),_),Phantom(_)-> if m=0 then 1 else -1
+	  | Phantom(_),Real((m,_),_)-> if Int.equal m 0 then -1 else 1
+	  | Real((m,_),_),Phantom(_)-> if Int.equal m 0 then 1 else -1
 
 let compare_gr id1 id2 =
   if id1==id2 then 0 else
     if id1==dummy_id then 1
     else if id2==dummy_id then -1
-    else Libnames.RefOrdered.compare id1 id2
+    else Globnames.RefOrdered.compare id1 id2
 
 module OrderedInstance=
 struct
-  type t=instance * Libnames.global_reference
+  type t=instance * Globnames.global_reference
   let compare (inst1,id1) (inst2,id2)=
     (compare_instance =? compare_gr) inst2 inst1 id2 id1
     (* we want a __decreasing__ total order *)
@@ -76,7 +75,7 @@ let match_one_quantified_hyp setref seq lf=
       Left(Lforall(i,dom,triv))|Right(Rexists(i,dom,triv))->
 	if do_sequent setref triv lf.id seq i dom lf.atoms then
 	  setref:=IS.add ((Phantom dom),lf.id) !setref
-    | _ ->anomaly "can't happen"
+    | _ -> anomaly (Pp.str "can't happen")
 
 let give_instances lf seq=
   let setref=ref IS.empty in
@@ -99,36 +98,36 @@ let rec collect_quantified seq=
 
 let dummy_constr=mkMeta (-1)
 
-let dummy_bvid=id_of_string "x"
+let dummy_bvid=Id.of_string "x"
 
-let mk_open_instance id gl m t=
+let mk_open_instance id idc gl m t=
   let env=pf_env gl in
   let evmap=Refiner.project gl in
   let var_id=
     if id==dummy_id then dummy_bvid else
-      let typ=pf_type_of gl (constr_of_global id) in
+      let typ=pf_type_of gl idc in
 	(* since we know we will get a product,
 	   reduction is not too expensive *)
       let (nam,_,_)=destProd (whd_betadeltaiota env evmap typ) in
 	match nam with
 	    Name id -> id
 	  | Anonymous ->  dummy_bvid in
-  let revt=substl (list_tabulate (fun i->mkRel (m-i)) m) t in
+  let revt=substl (List.init m (fun i->mkRel (m-i))) t in
   let rec aux n avoid=
-    if n=0 then [] else
+    if Int.equal n 0 then [] else
       let nid=(fresh_id avoid var_id gl) in
 	(Name nid,None,dummy_constr)::(aux (n-1) (nid::avoid)) in
   let nt=it_mkLambda_or_LetIn revt (aux m []) in
-  let rawt=Detyping.detype false [] [] nt in
+  let rawt=Detyping.detype false [] env evmap nt in
   let rec raux n t=
-    if n=0 then t else
+    if Int.equal n 0 then t else
       match t with
 	  GLambda(loc,name,k,_,t0)->
 	    let t1=raux (n-1) t0 in
-	      GLambda(loc,name,k,GHole (dummy_loc,Evd.BinderType name),t1)
-	| _-> anomaly "can't happen" in
+	      GLambda(loc,name,k,GHole (Loc.ghost,Evar_kinds.BinderType name,Misctypes.IntroAnonymous,None),t1)
+	| _-> anomaly (Pp.str "can't happen") in
   let ntt=try
-    Pretyping.Default.understand evmap env (raux m rawt)
+    fst (Pretyping.understand env evmap (raux m rawt))(*FIXME*)
   with e when Errors.noncritical e ->
     error "Untypable instance, maybe higher-order non-prenex quantification" in
     decompose_lam_n_assum m ntt
@@ -141,50 +140,53 @@ let left_instance_tac (inst,id) continue seq=
 	if lookup (id,None) seq then
 	  tclFAIL 0 (Pp.str "already done")
 	else
-	  tclTHENS (cut dom)
+	  tclTHENS (Proofview.V82.of_tactic (cut dom))
 	    [tclTHENLIST
-	       [introf;
+	       [Proofview.V82.of_tactic introf;
+                pf_constr_of_global id (fun idc ->
 		(fun gls->generalize
-		   [mkApp(constr_of_global id,
-			  [|mkVar (Tacmach.pf_nth_hyp_id gls 1)|])] gls);
-		introf;
+		   [mkApp(idc,
+			  [|mkVar (Tacmach.pf_nth_hyp_id gls 1)|])] gls));
+		Proofview.V82.of_tactic introf;
 		tclSOLVE [wrap 1 false continue
 			    (deepen (record (id,None) seq))]];
-	    tclTRY assumption]
+	    tclTRY (Proofview.V82.of_tactic assumption)]
     | Real((m,t) as c,_)->
 	if lookup (id,Some c) seq then
 	  tclFAIL 0 (Pp.str "already done")
 	else
 	  let special_generalize=
 	    if m>0 then
-	      fun gl->
-		let (rc,ot)= mk_open_instance id gl m t in
-		let gt=
-		  it_mkLambda_or_LetIn
-		    (mkApp(constr_of_global id,[|ot|])) rc in
-		  generalize [gt] gl
+	      pf_constr_of_global id (fun idc ->
+		fun gl->
+		  let (rc,ot) = mk_open_instance id idc gl m t in
+		  let gt=
+		    it_mkLambda_or_LetIn
+		      (mkApp(idc,[|ot|])) rc in
+		    generalize [gt] gl)
 	    else
-	      generalize [mkApp(constr_of_global id,[|t|])]
+	      pf_constr_of_global id (fun idc ->
+		generalize [mkApp(idc,[|t|])])
 	  in
 	    tclTHENLIST
 	      [special_generalize;
-	       introf;
+	       Proofview.V82.of_tactic introf;
 	       tclSOLVE
 		 [wrap 1 false continue (deepen (record (id,Some c) seq))]]
 
 let right_instance_tac inst continue seq=
   match inst with
       Phantom dom ->
-	tclTHENS (cut dom)
+	tclTHENS (Proofview.V82.of_tactic (cut dom))
 	[tclTHENLIST
-	   [introf;
+	   [Proofview.V82.of_tactic introf;
 	    (fun gls->
-	       split (Glob_term.ImplicitBindings
-			[mkVar (Tacmach.pf_nth_hyp_id gls 1)]) gls);
+	       Proofview.V82.of_tactic (split (ImplicitBindings
+			[mkVar (Tacmach.pf_nth_hyp_id gls 1)])) gls);
 	    tclSOLVE [wrap 0 true continue (deepen seq)]];
-	 tclTRY assumption]
+	 tclTRY (Proofview.V82.of_tactic assumption)]
     | Real ((0,t),_) ->
-	(tclTHEN (split (Glob_term.ImplicitBindings [t]))
+	(tclTHEN (Proofview.V82.of_tactic (split (ImplicitBindings [t])))
 	   (tclSOLVE [wrap 0 true continue (deepen seq)]))
     | Real ((m,t),_) ->
 	tclFAIL 0 (Pp.str "not implemented ... yet")
diff --git a/plugins/firstorder/instances.mli b/plugins/firstorder/instances.mli
index 709eb96f..2f69ad7b 100644
--- a/plugins/firstorder/instances.mli
+++ b/plugins/firstorder/instances.mli
@@ -1,15 +1,12 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Term
-open Tacmach
-open Names
-open Libnames
+open Globnames
 open Rules
 
 val collect_quantified : Sequent.t -> Formula.t list * Sequent.t
diff --git a/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml
index b043ba5f..382d5409 100644
--- a/plugins/firstorder/rules.ml
+++ b/plugins/firstorder/rules.ml
@@ -1,22 +1,24 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+open Errors
 open Util
 open Names
 open Term
+open Vars
 open Tacmach
 open Tactics
 open Tacticals
 open Termops
-open Declarations
 open Formula
 open Sequent
-open Libnames
+open Globnames
+open Locus
 
 type seqtac= (Sequent.t -> tactic) -> Sequent.t -> tactic
 
@@ -25,13 +27,13 @@ type lseqtac= global_reference -> seqtac
 type 'a with_backtracking = tactic -> 'a
 
 let wrap n b continue seq gls=
-  check_for_interrupt ();
+  Control.check_for_interrupt ();
   let nc=pf_hyps gls in
   let env=pf_env gls in
   let rec aux i nc ctx=
     if i<=0 then seq else
       match nc with
-	  []->anomaly "Not the expected number of hyps"
+	  []->anomaly (Pp.str "Not the expected number of hyps")
 	| ((id,_,typ) as nd)::q->
 	    if occur_var env id (pf_concl gls) ||
 	      List.exists (occur_var_in_decl env id) ctx then
@@ -51,38 +53,38 @@ let clear_global=function
     VarRef id->clear [id]
   | _->tclIDTAC
 
-
 (* connection rules *)
 
 let axiom_tac t seq=
-  try exact_no_check (constr_of_global (find_left t seq))
+  try pf_constr_of_global (find_left t seq) exact_no_check
   with Not_found->tclFAIL 0 (Pp.str "No axiom link")
 
 let ll_atom_tac a backtrack id continue seq=
   tclIFTHENELSE
     (try
       tclTHENLIST
-	[generalize [mkApp(constr_of_global id,
-			   [|constr_of_global (find_left a seq)|])];
+	[pf_constr_of_global (find_left a seq) (fun left ->
+	  pf_constr_of_global id (fun id -> 
+	    generalize [mkApp(id, [|left|])]));
 	 clear_global id;
-	 intro]
+	 Proofview.V82.of_tactic intro]
     with Not_found->tclFAIL 0 (Pp.str "No link"))
     (wrap 1 false continue seq) backtrack
 
 (* right connectives rules *)
 
 let and_tac backtrack continue seq=
-  tclIFTHENELSE simplest_split (wrap 0 true continue seq) backtrack
+  tclIFTHENELSE (Proofview.V82.of_tactic simplest_split) (wrap 0 true continue seq) backtrack
 
 let or_tac backtrack continue seq=
   tclORELSE
-    (any_constructor false (Some (tclCOMPLETE (wrap 0 true continue seq))))
+    (Proofview.V82.of_tactic (any_constructor false (Some (Proofview.V82.tactic (tclCOMPLETE (wrap 0 true continue seq))))))
     backtrack
 
 let arrow_tac backtrack continue seq=
-  tclIFTHENELSE intro (wrap 1 true continue seq)
+  tclIFTHENELSE (Proofview.V82.of_tactic intro) (wrap 1 true continue seq)
     (tclORELSE
-       (tclTHEN introf (tclCOMPLETE (wrap 1 true continue seq)))
+       (tclTHEN (Proofview.V82.of_tactic introf) (tclCOMPLETE (wrap 1 true continue seq)))
        backtrack)
 (* left connectives rules *)
 
@@ -90,9 +92,9 @@ let left_and_tac ind backtrack id continue seq gls=
  let n=(construct_nhyps ind gls).(0) in
    tclIFTHENELSE
      (tclTHENLIST
-      [simplest_elim (constr_of_global id);
+      [Proofview.V82.of_tactic (Tacticals.New.pf_constr_of_global id simplest_elim);
        clear_global id;
-       tclDO n intro])
+       tclDO n (Proofview.V82.of_tactic intro)])
      (wrap n false continue seq)
      backtrack gls
 
@@ -101,59 +103,58 @@ let left_or_tac ind backtrack id continue seq gls=
   let f n=
     tclTHENLIST
       [clear_global id;
-       tclDO n intro;
+       tclDO n (Proofview.V82.of_tactic intro);
        wrap n false continue seq] in
     tclIFTHENSVELSE
-      (simplest_elim (constr_of_global id))
+      (Proofview.V82.of_tactic (Tacticals.New.pf_constr_of_global id simplest_elim))
       (Array.map f v)
       backtrack gls
 
 let left_false_tac id=
-  simplest_elim (constr_of_global id)
+  Proofview.V82.of_tactic (Tacticals.New.pf_constr_of_global id simplest_elim)
 
 (* left arrow connective rules *)
 
 (* We use this function for false, and, or, exists *)
 
-let ll_ind_tac ind largs backtrack id continue seq gl=
-     let rcs=ind_hyps 0 ind largs gl in
+let ll_ind_tac (ind,u as indu) largs backtrack id continue seq gl=
+     let rcs=ind_hyps 0 indu largs gl in
      let vargs=Array.of_list largs in
-	     (* construire le terme  H->B, le generaliser etc *)
-     let myterm i=
+             (* construire le terme  H->B, le generaliser etc *)
+     let myterm idc i=
        let rc=rcs.(i) in
        let p=List.length rc in
-       let cstr=mkApp ((mkConstruct (ind,(i+1))),vargs) in
+       let cstr=mkApp ((mkConstructU ((ind,(i+1)),u)),vargs) in
        let vars=Array.init p (fun j->mkRel (p-j)) in
        let capply=mkApp ((lift p cstr),vars) in
-       let head=mkApp ((lift p (constr_of_global id)),[|capply|]) in
-	 it_mkLambda_or_LetIn head rc in
+       let head=mkApp ((lift p idc),[|capply|]) in
+         it_mkLambda_or_LetIn head rc in
        let lp=Array.length rcs in
-       let newhyps=list_tabulate myterm lp in
+       let newhyps idc =List.init lp (myterm idc) in
 	 tclIFTHENELSE
 	   (tclTHENLIST
-	      [generalize newhyps;
+	      [pf_constr_of_global id (fun idc -> generalize (newhyps idc));
 	       clear_global id;
-	       tclDO lp intro])
+	       tclDO lp (Proofview.V82.of_tactic intro)])
 	   (wrap lp false continue seq) backtrack gl
 
 let ll_arrow_tac a b c backtrack id continue seq=
   let cc=mkProd(Anonymous,a,(lift 1 b)) in
-  let d=mkLambda (Anonymous,b,
-		  mkApp ((constr_of_global id),
-			 [|mkLambda (Anonymous,(lift 1 a),(mkRel 2))|])) in
+  let d idc =mkLambda (Anonymous,b,
+		  mkApp (idc, [|mkLambda (Anonymous,(lift 1 a),(mkRel 2))|])) in
     tclORELSE
-      (tclTHENS (cut c)
+      (tclTHENS (Proofview.V82.of_tactic (cut c))
 	 [tclTHENLIST
-	    [introf;
+	    [Proofview.V82.of_tactic introf;
 	     clear_global id;
 	     wrap 1 false continue seq];
-	  tclTHENS (cut cc)
-            [exact_no_check (constr_of_global id);
+	  tclTHENS (Proofview.V82.of_tactic (cut cc))
+            [pf_constr_of_global id exact_no_check;
 	     tclTHENLIST
-	       [generalize [d];
+	       [pf_constr_of_global id (fun idc -> generalize [d idc]);
 		clear_global id;
-		introf;
-		introf;
+		Proofview.V82.of_tactic introf;
+		Proofview.V82.of_tactic introf;
 		tclCOMPLETE (wrap 2 true continue seq)]]])
       backtrack
 
@@ -161,9 +162,9 @@ let ll_arrow_tac a b c backtrack id continue seq=
 
 let forall_tac backtrack continue seq=
   tclORELSE
-    (tclIFTHENELSE intro (wrap 0 true continue seq)
+    (tclIFTHENELSE (Proofview.V82.of_tactic intro) (wrap 0 true continue seq)
        (tclORELSE
-	  (tclTHEN introf (tclCOMPLETE (wrap 0 true continue seq)))
+	  (tclTHEN (Proofview.V82.of_tactic introf) (tclCOMPLETE (wrap 0 true continue seq)))
 	  backtrack))
     (if !qflag then
        tclFAIL 0 (Pp.str "reversible in 1st order mode")
@@ -173,24 +174,25 @@ let forall_tac backtrack continue seq=
 let left_exists_tac ind backtrack id continue seq gls=
   let n=(construct_nhyps ind gls).(0) in
     tclIFTHENELSE
-      (simplest_elim (constr_of_global id))
+      (Proofview.V82.of_tactic (Tacticals.New.pf_constr_of_global id simplest_elim))
       (tclTHENLIST [clear_global id;
-                    tclDO n intro;
+                    tclDO n (Proofview.V82.of_tactic intro);
                     (wrap (n-1) false continue seq)])
       backtrack
       gls
 
 let ll_forall_tac prod backtrack id continue seq=
   tclORELSE
-    (tclTHENS (cut prod)
+    (tclTHENS (Proofview.V82.of_tactic (cut prod))
        [tclTHENLIST
-	  [intro;
+	  [Proofview.V82.of_tactic intro;
+           pf_constr_of_global id (fun idc ->
 	   (fun gls->
 	      let id0=pf_nth_hyp_id gls 1 in
-	      let term=mkApp((constr_of_global id),[|mkVar(id0)|]) in
-		tclTHEN (generalize [term]) (clear [id0]) gls);
+              let term=mkApp(idc,[|mkVar(id0)|]) in
+		tclTHEN (generalize [term]) (clear [id0]) gls));
 	   clear_global id;
-	   intro;
+	   Proofview.V82.of_tactic intro;
 	   tclCOMPLETE (wrap 1 false continue (deepen seq))];
 	tclCOMPLETE (wrap 0 true continue (deepen seq))])
     backtrack
@@ -202,8 +204,8 @@ let ll_forall_tac prod backtrack id continue seq=
 let constant str = Coqlib.gen_constant "User" ["Init";"Logic"] str
 
 let defined_connectives=lazy
-  [all_occurrences,EvalConstRef (destConst (constant "not"));
-   all_occurrences,EvalConstRef (destConst (constant "iff"))]
+  [AllOccurrences,EvalConstRef (fst (destConst (constant "not")));
+   AllOccurrences,EvalConstRef (fst (destConst (constant "iff")))]
 
 let normalize_evaluables=
   onAllHypsAndConcl
diff --git a/plugins/firstorder/rules.mli b/plugins/firstorder/rules.mli
index d5fe398f..596e8535 100644
--- a/plugins/firstorder/rules.mli
+++ b/plugins/firstorder/rules.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -9,7 +9,7 @@
 open Term
 open Tacmach
 open Names
-open Libnames
+open Globnames
 
 type seqtac= (Sequent.t -> tactic) -> Sequent.t -> tactic
 
@@ -19,7 +19,7 @@ type 'a with_backtracking = tactic -> 'a
 
 val wrap : int -> bool -> seqtac
 
-val basename_of_global: global_reference -> identifier
+val basename_of_global: global_reference -> Id.t
 
 val clear_global: global_reference -> tactic
 
@@ -33,19 +33,19 @@ val or_tac : seqtac with_backtracking
 
 val arrow_tac : seqtac with_backtracking
 
-val left_and_tac : inductive -> lseqtac with_backtracking
+val left_and_tac : pinductive -> lseqtac with_backtracking
 
-val left_or_tac : inductive -> lseqtac with_backtracking
+val left_or_tac : pinductive -> lseqtac with_backtracking
 
 val left_false_tac : global_reference -> tactic
 
-val ll_ind_tac : inductive -> constr list -> lseqtac with_backtracking
+val ll_ind_tac : pinductive -> constr list -> lseqtac with_backtracking
 
 val ll_arrow_tac : constr -> constr -> constr -> lseqtac with_backtracking
 
 val forall_tac : seqtac with_backtracking
 
-val left_exists_tac : inductive -> lseqtac with_backtracking
+val left_exists_tac : pinductive -> lseqtac with_backtracking
 
 val ll_forall_tac : types -> lseqtac with_backtracking
 
diff --git a/plugins/firstorder/sequent.ml b/plugins/firstorder/sequent.ml
index 50cf14a9..2f7f21e4 100644
--- a/plugins/firstorder/sequent.ml
+++ b/plugins/firstorder/sequent.ml
@@ -1,18 +1,18 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
 open Term
+open Errors
 open Util
 open Formula
 open Unify
 open Tacmach
-open Names
-open Libnames
+open Globnames
 open Pp
 
 let newcnt ()=
@@ -48,8 +48,6 @@ let priority = (* pure heuristics, <=0 for non reversible *)
 		| LLexists (_,_)   ->  50
 		| LLarrow  (_,_,_) -> -10
 
-let left_reversible lpat=(priority lpat)>0
-
 module OrderedFormula=
 struct
   type t=Formula.t
@@ -69,12 +67,14 @@ module Hitem=
 struct
   type t = h_item
   let compare (id1,co1) (id2,co2)=
-    (Libnames.RefOrdered.compare
-     =? (fun oc1 oc2 ->
-	   match oc1,oc2 with
-	       Some (m1,c1),Some (m2,c2) ->
-		 ((-) =? OrderedConstr.compare) m1 m2 c1 c2
-	     | _,_->Pervasives.compare oc1 oc2)) id1 id2 co1 co2
+    let c = Globnames.RefOrdered.compare id1 id2 in
+    if c = 0 then
+      let cmp (i1, c1) (i2, c2) =
+        let c = Int.compare i1 i2 in
+        if c = 0 then OrderedConstr.compare c1 c2 else c
+      in
+      Option.compare cmp co1 co2
+    else c
 end
 
 module CM=Map.Make(OrderedConstr)
@@ -90,7 +90,7 @@ let cm_add typ nam cm=
 let cm_remove typ nam cm=
   try
     let l=CM.find typ cm in
-    let l0=List.filter (fun id->id<>nam) l in
+    let l0=List.filter (fun id-> not (Globnames.eq_gr id nam)) l in
       match l0 with
 	  []->CM.remove typ cm
 	| _ ->CM.add typ l0 cm
@@ -120,10 +120,10 @@ let lookup item seq=
 	let p (id2,o)=
 	  match o with
 	      None -> false
-	    | Some ((m2,t2) as c2)->id=id2 && m2>m && more_general c2 c in
+	    | Some ((m2,t2) as c2)-> Globnames.eq_gr id id2 && m2>m && more_general c2 c in
 	  History.exists p seq.history
 
-let rec add_formula side nam t seq gl=
+let add_formula side nam t seq gl=
   match build_formula side nam t gl seq.cnt with
       Left f->
 	begin
@@ -163,8 +163,6 @@ let find_left t seq=List.hd (CM.find t seq.context)
       left_reversible lpat
   with Heap.EmptyHeap -> false
 *)
-let no_formula seq=
-  seq.redexes=HP.empty
 
 let rec take_formula seq=
   let hd=HP.maximum seq.redexes
@@ -191,36 +189,36 @@ let empty_seq depth=
    depth=depth}
 
 let expand_constructor_hints =
-  list_map_append (function
+  List.map_append (function
     | IndRef ind ->
-	list_tabulate (fun i -> ConstructRef (ind,i+1))
-	  (Inductiveops.nconstructors ind)
+        List.init (Inductiveops.nconstructors ind)
+          (fun i -> ConstructRef (ind,i+1))
     | gr ->
 	[gr])
 
-let extend_with_ref_list l seq gl=
+let extend_with_ref_list l seq gl =
   let l = expand_constructor_hints l in
-  let f gr seq=
-    let c=constr_of_global gr in
+  let f gr (seq,gl) =
+    let gl, c = pf_eapply Evd.fresh_global gl gr in
     let typ=(pf_type_of gl c) in
-      add_formula Hyp gr typ seq gl in
-    List.fold_right f l seq
+      (add_formula Hyp gr typ seq gl,gl) in
+    List.fold_right f l (seq,gl)
 
-open Auto
+open Hints
 
 let extend_with_auto_hints l seq gl=
   let seqref=ref seq in
   let f p_a_t =
     match p_a_t.code with
-	Res_pf (c,_) | Give_exact c
+	Res_pf (c,_) | Give_exact (c,_)
       | Res_pf_THEN_trivial_fail (c,_) ->
 	  (try
-	     let gr=global_of_constr c in
+	     let gr = global_of_constr c in
 	     let typ=(pf_type_of gl c) in
 	       seqref:=add_formula Hint gr typ !seqref gl
 	   with Not_found->())
       | _-> () in
-  let g _ l = List.iter f l in
+  let g _ _ l = List.iter f l in
   let h dbname=
     let hdb=
       try
@@ -229,18 +227,18 @@ let extend_with_auto_hints l seq gl=
 	error ("Firstorder: "^dbname^" : No such Hint database") in
       Hint_db.iter g hdb in
     List.iter h l;
-    !seqref
+    !seqref, gl (*FIXME: forgetting about universes*)
 
 let print_cmap map=
   let print_entry c l s=
-    let xc=Constrextern.extern_constr false (Global.env ()) c in
+    let xc=Constrextern.extern_constr false (Global.env ()) Evd.empty c in
       str "| " ++
-      Util.prlist Printer.pr_global l ++
+      prlist Printer.pr_global l ++
       str " : " ++
       Ppconstr.pr_constr_expr xc ++
       cut () ++
       s in
-    msgnl (v 0
+    (v 0
 	     (str "-----" ++
 	      cut () ++
 	      CM.fold print_entry map (mt ()) ++
diff --git a/plugins/firstorder/sequent.mli b/plugins/firstorder/sequent.mli
index 44b5ed3e..dc3f05be 100644
--- a/plugins/firstorder/sequent.mli
+++ b/plugins/firstorder/sequent.mli
@@ -1,17 +1,15 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
 open Term
-open Util
 open Formula
 open Tacmach
-open Names
-open Libnames
+open Globnames
 
 module OrderedConstr: Set.OrderedType with type t=constr
 
@@ -56,9 +54,9 @@ val take_formula : t -> Formula.t * t
 val empty_seq : int -> t
 
 val extend_with_ref_list : global_reference list ->
-  t -> Proof_type.goal sigma -> t
+  t -> Proof_type.goal sigma -> t * Proof_type.goal sigma
 
-val extend_with_auto_hints : Auto.hint_db_name list ->
-  t -> Proof_type.goal sigma -> t
+val extend_with_auto_hints : Hints.hint_db_name list ->
+  t -> Proof_type.goal sigma -> t * Proof_type.goal sigma
 
-val print_cmap: global_reference list CM.t -> unit
+val print_cmap: global_reference list CM.t -> Pp.std_ppcmds
diff --git a/plugins/firstorder/unify.ml b/plugins/firstorder/unify.ml
index 00eb9981..0a172034 100644
--- a/plugins/firstorder/unify.ml
+++ b/plugins/firstorder/unify.ml
@@ -1,16 +1,14 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
 open Util
-open Formula
-open Tacmach
 open Term
-open Names
+open Vars
 open Termops
 open Reductionops
 
@@ -34,7 +32,7 @@ let unif t1 t2=
     match kind_of_term t with
 	Meta i->
 	  (try
-	     head_reduce (List.assoc i !sigma)
+	     head_reduce (Int.List.assoc i !sigma)
 	   with Not_found->t)
       | _->t in
     Queue.add (t1,t2) bige;
@@ -44,17 +42,17 @@ let unif t1 t2=
       and nt2=head_reduce (whd_betaiotazeta Evd.empty t2) in
 	match (kind_of_term nt1),(kind_of_term nt2) with
 	    Meta i,Meta j->
-	      if i<>j then
+	      if not (Int.equal i j) then
 		if i<j then bind j nt1
 		else bind i nt2
 	  | Meta i,_ ->
 	      let t=subst_meta !sigma nt2 in
-		if Intset.is_empty (free_rels t) &&
+		if Int.Set.is_empty (free_rels t) &&
 		  not (occur_term (mkMeta i) t) then
 		    bind i t else raise (UFAIL(nt1,nt2))
 	  | _,Meta i ->
 	      let t=subst_meta !sigma nt1 in
-		if Intset.is_empty (free_rels t) &&
+		if Int.Set.is_empty (free_rels t) &&
 		  not (occur_term (mkMeta i) t) then
 		    bind i t else raise (UFAIL(nt1,nt2))
 	  | Cast(_,_,_),_->Queue.add (strip_outer_cast nt1,nt2) bige
@@ -65,7 +63,7 @@ let unif t1 t2=
 	      Queue.add (pa,pb) bige;
 	      Queue.add (ca,cb) bige;
 	      let l=Array.length va in
-		if l<>(Array.length vb) then
+		if not (Int.equal l (Array.length vb)) then
 		  raise (UFAIL (nt1,nt2))
 		else
 		  for i=0 to l-1 do
@@ -74,13 +72,13 @@ let unif t1 t2=
 	  | App(ha,va),App(hb,vb)->
 	      Queue.add (ha,hb) bige;
 	      let l=Array.length va in
-		if l<>(Array.length vb) then
+		if not (Int.equal l (Array.length vb)) then
 		  raise (UFAIL (nt1,nt2))
 		else
 		  for i=0 to l-1 do
 		    Queue.add (va.(i),vb.(i)) bige
 		  done
-	  | _->if not (eq_constr nt1 nt2) then raise (UFAIL (nt1,nt2))
+	  | _->if not (eq_constr_nounivs nt1 nt2) then raise (UFAIL (nt1,nt2))
     done;
       assert false
 	(* this place is unreachable but needed for the sake of typing *)
@@ -90,7 +88,7 @@ let value i t=
   let add x y=
     if x<0 then y else if y<0 then x else x+y in
   let rec vaux term=
-    if isMeta term && destMeta term = i then 0 else
+    if isMeta term && Int.equal (destMeta term) i then 0 else
       let f v t=add v (vaux t) in
       let vr=fold_constr f (-1) term in
 	if vr<0 then -1 else vr+1 in
@@ -107,7 +105,7 @@ let mk_rel_inst t=
     match kind_of_term t with
 	Meta n->
 	  (try
-	     mkRel (d+(List.assoc n !rel_env))
+	     mkRel (d+(Int.List.assoc n !rel_env))
 	   with Not_found->
 	     let m= !new_rel in
 	       incr new_rel;
@@ -119,7 +117,7 @@ let mk_rel_inst t=
 
 let unif_atoms i dom t1 t2=
   try
-    let t=List.assoc i (unif t1 t2) in
+    let t=Int.List.assoc i (unif t1 t2) in
       if isMeta t then Some (Phantom dom)
       else Some (Real(mk_rel_inst t,value i t1))
   with
@@ -127,7 +125,7 @@ let unif_atoms i dom t1 t2=
     | Not_found ->Some (Phantom dom)
 
 let renum_metas_from k n t= (* requires n = max (free_rels t) *)
-  let l=list_tabulate (fun i->mkMeta (k+i)) n in
+  let l=List.init n (fun i->mkMeta (k+i)) in
     substl l t
 
 let more_general (m1,t1) (m2,t2)=
diff --git a/plugins/firstorder/unify.mli b/plugins/firstorder/unify.mli
index 697548be..15318546 100644
--- a/plugins/firstorder/unify.mli
+++ b/plugins/firstorder/unify.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/plugins/fourier/Fourier.v b/plugins/fourier/Fourier.v
index 9c788788..1832de85 100644
--- a/plugins/fourier/Fourier.v
+++ b/plugins/fourier/Fourier.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,8 +8,7 @@
 
 (* "Fourier's method to solve linear inequations/equations systems.".*)
 
-Require Export LegacyRing.
-Require Export LegacyField.
+Require Export Field.
 Require Export DiscrR.
 Require Export Fourier_util.
 Declare ML Module "fourier_plugin".
diff --git a/plugins/fourier/Fourier_util.v b/plugins/fourier/Fourier_util.v
index af2812c4..284d220a 100644
--- a/plugins/fourier/Fourier_util.v
+++ b/plugins/fourier/Fourier_util.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -164,7 +164,7 @@ Qed.
 Lemma Rnot_lt_lt : forall x y:R, ~ 0 < y - x -> ~ x < y.
 unfold not; intros.
 apply H.
-apply Rplus_lt_reg_r with x.
+apply Rplus_lt_reg_l with x.
 replace (x + 0) with x.
 replace (x + (y - x)) with y.
 try exact H0.
@@ -177,7 +177,7 @@ unfold not; intros.
 apply H.
 case H0; intros.
 left.
-apply Rplus_lt_reg_r with x.
+apply Rplus_lt_reg_l with x.
 replace (x + 0) with x.
 replace (x + (y - x)) with y.
 try exact H1.
diff --git a/plugins/fourier/fourier.ml b/plugins/fourier/fourier.ml
index c39c2387..50a5150d 100644
--- a/plugins/fourier/fourier.ml
+++ b/plugins/fourier/fourier.ml
@@ -1,18 +1,18 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(* Méthode d'élimination de Fourier *)
-(* Référence:
+(* Méthode d'élimination de Fourier *)
+(* Référence:
 Auteur(s) : Fourier, Jean-Baptiste-Joseph
 
-Titre(s) : Oeuvres de Fourier [Document électronique]. Tome second. Mémoires publiés dans divers recueils / publ. par les soins de M. Gaston Darboux,...
+Titre(s) : Oeuvres de Fourier [Document électronique]. Tome second. Mémoires publiés dans divers recueils / publ. par les soins de M. Gaston Darboux,...
 
-Publication : Numérisation BnF de l'édition de Paris : Gauthier-Villars, 1890
+Publication : Numérisation BnF de l'édition de Paris : Gauthier-Villars, 1890
 
 Pages: 326-327
 
@@ -20,8 +20,8 @@ http://gallica.bnf.fr/
 *)
 
 (* Un peu de calcul sur les rationnels...
-Les opérations rendent des rationnels normalisés,
-i.e. le numérateur et le dénominateur sont premiers entre eux.
+Les opérations rendent des rationnels normalisés,
+i.e. le numérateur et le dénominateur sont premiers entre eux.
 *)
 type rational = {num:int;
                  den:int}
@@ -59,9 +59,9 @@ let rdiv x y = rnorm {num=x.num*y.den;den=x.den*y.num};;
 let rinf x y = x.num*y.den < y.num*x.den;;
 let rinfeq x y = x.num*y.den <= y.num*x.den;;
 
-(* {coef;hist;strict}, où coef=[c1; ...; cn; d], représente l'inéquation
+(* {coef;hist;strict}, où coef=[c1; ...; cn; d], représente l'inéquation
 c1x1+...+cnxn < d si strict=true, <= sinon,
-hist donnant les coefficients (positifs) d'une combinaison linéaire qui permet d'obtenir l'inéquation à partir de celles du départ.
+hist donnant les coefficients (positifs) d'une combinaison linéaire qui permet d'obtenir l'inéquation à partir de celles du départ.
 *)
 
 type ineq = {coef:rational list;
@@ -70,8 +70,8 @@ type ineq = {coef:rational list;
 
 let pop x l = l:=x::(!l);;
 
-(* sépare la liste d'inéquations s selon que leur premier coefficient est
-négatif, nul ou positif. *)
+(* sépare la liste d'inéquations s selon que leur premier coefficient est
+négatif, nul ou positif. *)
 let partitionne s =
    let lpos=ref [] in
    let lneg=ref [] in
@@ -85,44 +85,44 @@ let partitionne s =
              s;
    [!lneg;!lnul;!lpos]
 ;;
-(* initialise les histoires d'une liste d'inéquations données par leurs listes de coefficients et leurs strictitudes (!):
-(add_hist [(equation 1, s1);...;(équation n, sn)])
+(* initialise les histoires d'une liste d'inéquations données par leurs listes de coefficients et leurs strictitudes (!):
+(add_hist [(equation 1, s1);...;(équation n, sn)])
 =
-[{équation 1, [1;0;...;0], s1};
- {équation 2, [0;1;...;0], s2};
+[{équation 1, [1;0;...;0], s1};
+ {équation 2, [0;1;...;0], s2};
  ...
- {équation n, [0;0;...;1], sn}]
+ {équation n, [0;0;...;1], sn}]
 *)
 let add_hist le =
    let n = List.length le in
-   let i=ref 0 in
+   let i = ref 0 in
    List.map (fun (ie,s) ->
-              let h =ref [] in
-              for k=1 to (n-(!i)-1) do pop r0 h; done;
+              let h = ref [] in
+              for _k = 1 to (n - (!i) - 1) do pop r0 h; done;
               pop r1 h;
-              for k=1 to !i do pop r0 h; done;
+              for _k = 1 to !i do pop r0 h; done;
               i:=!i+1;
               {coef=ie;hist=(!h);strict=s})
              le
 ;;
-(* additionne deux inéquations *)
+(* additionne deux inéquations *)
 let ie_add ie1 ie2 = {coef=List.map2 rplus ie1.coef ie2.coef;
                       hist=List.map2 rplus ie1.hist ie2.hist;
 		      strict=ie1.strict || ie2.strict}
 ;;
-(* multiplication d'une inéquation par un rationnel (positif) *)
+(* multiplication d'une inéquation par un rationnel (positif) *)
 let ie_emult a ie = {coef=List.map (fun x -> rmult a x) ie.coef;
                      hist=List.map (fun x -> rmult a x) ie.hist;
 		     strict= ie.strict}
 ;;
-(* on enlève le premier coefficient *)
+(* on enlève le premier coefficient *)
 let ie_tl ie = {coef=List.tl ie.coef;hist=ie.hist;strict=ie.strict}
 ;;
-(* le premier coefficient: "tête" de l'inéquation *)
+(* le premier coefficient: "tête" de l'inéquation *)
 let hd_coef ie = List.hd ie.coef
 ;;
 
-(* calcule toutes les combinaisons entre inéquations de tête négative et inéquations de tête positive qui annulent le premier coefficient.
+(* calcule toutes les combinaisons entre inéquations de tête négative et inéquations de tête positive qui annulent le premier coefficient.
 *)
 let deduce_add lneg lpos =
    let res=ref [] in
@@ -136,8 +136,8 @@ let deduce_add lneg lpos =
              lneg;
    !res
 ;;
-(* élimination de la première variable à partir d'une liste d'inéquations:
-opération qu'on itère dans l'algorithme de Fourier.
+(* élimination de la première variable à partir d'une liste d'inéquations:
+opération qu'on itère dans l'algorithme de Fourier.
 *)
 let deduce1 s =
     match (partitionne s) with
@@ -146,38 +146,37 @@ let deduce1 s =
     (List.map ie_tl lnul)@lnew
      |_->assert false
 ;;
-(* algorithme de Fourier: on élimine successivement toutes les variables.
+(* algorithme de Fourier: on élimine successivement toutes les variables.
 *)
 let deduce lie =
    let n = List.length (fst (List.hd lie)) in
    let lie=ref (add_hist lie) in
-   for i=1 to n-1 do
+   for _i = 1 to n - 1 do
       lie:= deduce1 !lie;
    done;
    !lie
 ;;
 
-(* donne [] si le système a des solutions,
+(* donne [] si le système a des solutions,
 sinon donne [c,s,lc]
-où lc est la combinaison linéaire des inéquations de départ
+où lc est la combinaison linéaire des inéquations de départ
 qui donne 0 < c si s=true
        ou 0 <= c sinon
-cette inéquation étant absurde.
+cette inéquation étant absurde.
 *)
+
+exception Contradiction of (rational * bool * rational list) list
+
 let unsolvable lie =
    let lr = deduce lie in
-   let res = ref [] in
-   (try (List.iter (fun e ->
-         match e with
-           {coef=[c];hist=lc;strict=s} ->
-		  if (rinf c r0 && (not s)) || (rinfeq c r0 && s)
-                  then (res := [c,s,lc];
-			raise (Failure "contradiction found"))
-          |_->assert false)
-			     lr)
-   with e when Errors.noncritical e -> ());
-   !res
-;;
+   let check = function
+     | {coef=[c];hist=lc;strict=s} ->
+       if (rinf c r0 && (not s)) || (rinfeq c r0 && s)
+       then raise (Contradiction [c,s,lc])
+     |_->assert false
+   in
+   try List.iter check lr; []
+   with Contradiction l -> l
 
 (* Exemples:
 
diff --git a/plugins/fourier/fourierR.ml b/plugins/fourier/fourierR.ml
index 763383dd..8006a3e1 100644
--- a/plugins/fourier/fourierR.ml
+++ b/plugins/fourier/fourierR.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,25 +8,24 @@
 
 
 
-(* La tactique Fourier ne fonctionne de manière sûre que si les coefficients
-des inéquations et équations sont entiers. En attendant la tactique Field.
+(* La tactique Fourier ne fonctionne de manière sûre que si les coefficients
+des inéquations et équations sont entiers. En attendant la tactique Field.
 *)
 
 open Term
 open Tactics
-open Clenv
 open Names
-open Libnames
+open Globnames
 open Tacticals
 open Tacmach
 open Fourier
 open Contradiction
 
 (******************************************************************************
-Opérations sur les combinaisons linéaires affines.
-La partie homogène d'une combinaison linéaire est en fait une table de hash
+Opérations sur les combinaisons linéaires affines.
+La partie homogène d'une combinaison linéaire est en fait une table de hash
 qui donne le coefficient d'un terme du calcul des constructions,
-qui est zéro si le terme n'y est pas.
+qui est zéro si le terme n'y est pas.
 *)
 
 module Constrhash = Hashtbl.Make
@@ -40,12 +39,11 @@ type flin = {fhom: rational Constrhash.t;
 
 let flin_zero () = {fhom=Constrhash.create 50;fcste=r0};;
 
-let flin_coef f x = try (Constrhash.find f.fhom x) with Not_found -> r0;;
+let flin_coef f x = try Constrhash.find f.fhom x with Not_found -> r0;;
 
 let flin_add f x c =
     let cx = flin_coef f x in
-    Constrhash.remove f.fhom x;
-    Constrhash.add f.fhom x (rplus cx c);
+    Constrhash.replace f.fhom x (rplus cx c);
     f
 ;;
 let flin_add_cste f c =
@@ -75,24 +73,25 @@ let flin_emult a f =
 ;;
 
 (*****************************************************************************)
-open Vernacexpr
 
 type ineq = Rlt | Rle | Rgt | Rge
 
 let string_of_R_constant kn =
   match Names.repr_con kn with
     | MPfile dir, sec_dir, id when
-	sec_dir = empty_dirpath &&
-	string_of_dirpath dir = "Coq.Reals.Rdefinitions"
-	-> string_of_label id
+	sec_dir = DirPath.empty &&
+	DirPath.to_string dir = "Coq.Reals.Rdefinitions"
+	-> Label.to_string id
     | _ -> "constant_not_of_R"
 
 let rec string_of_R_constr c =
  match kind_of_term c with
    Cast (c,_,_) -> string_of_R_constr c
-  |Const c -> string_of_R_constant c
+  |Const (c,_) -> string_of_R_constant c
   | _ -> "not_of_constant"
 
+exception NoRational
+
 let rec rational_of_constr c =
   match kind_of_term c with
   | Cast (c,_,_) -> (rational_of_constr c)
@@ -114,15 +113,17 @@ let rec rational_of_constr c =
 	 | "Rminus" ->
 	     rminus (rational_of_constr args.(0))
                     (rational_of_constr args.(1))
-	 | _ -> failwith "not a rational")
-  | Const kn ->
+	 | _ -> raise NoRational)
+  | Const (kn,_) ->
       (match (string_of_R_constant kn) with
 	       "R1" -> r1
               |"R0" -> r0
-              |  _ -> failwith "not a rational")
-  |  _ -> failwith "not a rational"
+              |  _ -> raise NoRational)
+  |  _ -> raise NoRational
 ;;
 
+exception NoLinear
+
 let rec flin_of_constr c =
   try(
     match kind_of_term c with
@@ -138,39 +139,34 @@ let rec flin_of_constr c =
              flin_minus (flin_of_constr args.(0))
 	                (flin_of_constr args.(1))
 	 | "Rmult"->
-	     (try (let a=(rational_of_constr args.(0)) in
-                     try (let b = (rational_of_constr args.(1)) in
-			    (flin_add_cste (flin_zero()) (rmult a b)))
-		     with e when Errors.noncritical e ->
-                       (flin_add (flin_zero())
-				 args.(1)
-				 a))
-	      with e when Errors.noncritical e ->
-                (flin_add (flin_zero())
-			  args.(0)
-			  (rational_of_constr args.(1))))
+	     (try
+                let a = rational_of_constr args.(0) in
+                try
+                  let b = rational_of_constr args.(1) in
+		  flin_add_cste (flin_zero()) (rmult a b)
+		with NoRational ->
+                  flin_add (flin_zero()) args.(1) a
+	      with NoRational ->
+                flin_add (flin_zero()) args.(0)
+		  (rational_of_constr args.(1)))
 	 | "Rinv"->
-	     let a=(rational_of_constr args.(0)) in
-	       flin_add_cste (flin_zero()) (rinv a)
+	     let a = rational_of_constr args.(0) in
+	     flin_add_cste (flin_zero()) (rinv a)
 	 | "Rdiv"->
-	     (let b=(rational_of_constr args.(1)) in
-		try (let a = (rational_of_constr args.(0)) in
-		       (flin_add_cste (flin_zero()) (rdiv a b)))
-		with e when Errors.noncritical e ->
-                  (flin_add (flin_zero())
-		            args.(0)
-                            (rinv b)))
-         |_->assert false)
-  | Const c ->
+	     (let b = rational_of_constr args.(1) in
+	      try
+                let a = rational_of_constr args.(0) in
+	        flin_add_cste (flin_zero()) (rdiv a b)
+	      with NoRational ->
+                flin_add (flin_zero()) args.(0) (rinv b))
+         |_-> raise NoLinear)
+  | Const (c,_) ->
         (match (string_of_R_constant c) with
 	       "R1" -> flin_one ()
               |"R0" -> flin_zero ()
-              |_-> assert false)
-  |_-> assert false)
-  with e when Errors.noncritical e ->
-    flin_add (flin_zero())
-                     c
-	             r1
+              |_-> raise NoLinear)
+  |_-> raise NoLinear)
+  with NoRational | NoLinear -> flin_add (flin_zero()) c r1
 ;;
 
 let flin_to_alist f =
@@ -179,9 +175,9 @@ let flin_to_alist f =
     !res
 ;;
 
-(* Représentation des hypothèses qui sont des inéquations ou des équations.
+(* Représentation des hypothèses qui sont des inéquations ou des équations.
 *)
-type hineq={hname:constr; (* le nom de l'hypothèse *)
+type hineq={hname:constr; (* le nom de l'hypothèse *)
             htype:string; (* Rlt, Rgt, Rle, Rge, eqTLR ou eqTRL *)
             hleft:constr;
             hright:constr;
@@ -189,54 +185,57 @@ type hineq={hname:constr; (* le nom de l'hypothèse *)
             hstrict:bool}
 ;;
 
-(* Transforme une hypothese h:t en inéquation flin<0 ou flin<=0
+(* Transforme une hypothese h:t en inéquation flin<0 ou flin<=0
 *)
+
+exception NoIneq
+
 let ineq1_of_constr (h,t) =
     match (kind_of_term t) with
-       App (f,args) ->
-         (match kind_of_term f with
-           Const c when Array.length args = 2 ->
-             let t1= args.(0) in
-             let t2= args.(1) in
+      | App (f,args) ->
+        (match kind_of_term f with
+          | Const (c,_) when Array.length args = 2 ->
+            let t1= args.(0) in
+            let t2= args.(1) in
             (match (string_of_R_constant c) with
-		 "Rlt" -> [{hname=h;
+	      |"Rlt" -> [{hname=h;
                            htype="Rlt";
 		           hleft=t1;
 			   hright=t2;
 			   hflin= flin_minus (flin_of_constr t1)
                                              (flin_of_constr t2);
 			   hstrict=true}]
-		|"Rgt" -> [{hname=h;
+	      |"Rgt" -> [{hname=h;
                            htype="Rgt";
 		           hleft=t2;
 			   hright=t1;
 			   hflin= flin_minus (flin_of_constr t2)
                                              (flin_of_constr t1);
 			   hstrict=true}]
-		|"Rle" -> [{hname=h;
+	      |"Rle" -> [{hname=h;
                            htype="Rle";
 		           hleft=t1;
 			   hright=t2;
 			   hflin= flin_minus (flin_of_constr t1)
                                              (flin_of_constr t2);
 			   hstrict=false}]
-		|"Rge" -> [{hname=h;
+	      |"Rge" -> [{hname=h;
                            htype="Rge";
 		           hleft=t2;
 			   hright=t1;
 			   hflin= flin_minus (flin_of_constr t2)
                                              (flin_of_constr t1);
 			   hstrict=false}]
-                |_->assert false)
-          | Ind (kn,i) ->
-	      if IndRef(kn,i) = Coqlib.glob_eq then
-		           let t0= args.(0) in
-                           let t1= args.(1) in
-                           let t2= args.(2) in
-		    (match (kind_of_term t0) with
-                         Const c ->
-			   (match (string_of_R_constant c) with
-			      "R"->
+              |_-> raise NoIneq)
+          | Ind ((kn,i),_) ->
+            if not (eq_gr (IndRef(kn,i)) Coqlib.glob_eq) then raise NoIneq;
+            let t0= args.(0) in
+            let t1= args.(1) in
+            let t2= args.(2) in
+	    (match (kind_of_term t0) with
+              | Const (c,_) ->
+		(match (string_of_R_constant c) with
+		  | "R"->
                          [{hname=h;
                            htype="eqTLR";
 		           hleft=t1;
@@ -251,20 +250,18 @@ let ineq1_of_constr (h,t) =
 			   hflin= flin_minus (flin_of_constr t2)
                                              (flin_of_constr t1);
 			   hstrict=false}]
-                           |_-> assert false)
-                         |_-> assert false)
-	      else
-		assert false
-          |_-> assert false)
-        |_-> assert false
+                  |_-> raise NoIneq)
+              |_-> raise NoIneq)
+          |_-> raise NoIneq)
+      |_-> raise NoIneq
 ;;
 
-(* Applique la méthode de Fourier à une liste d'hypothèses (type hineq)
+(* Applique la méthode de Fourier à une liste d'hypothèses (type hineq)
 *)
 
 let fourier_lineq lineq1 =
    let nvar=ref (-1) in
-   let hvar=Constrhash.create 50 in (* la table des variables des inéquations *)
+   let hvar=Constrhash.create 50 in (* la table des variables des inéquations *)
    List.iter (fun f ->
 		Constrhash.iter (fun x _ -> if not (Constrhash.mem hvar x) then begin
 				nvar:=(!nvar)+1;
@@ -273,7 +270,7 @@ let fourier_lineq lineq1 =
                   f.hflin.fhom)
              lineq1;
    let sys= List.map (fun h->
-               let v=Array.create ((!nvar)+1) r0 in
+               let v=Array.make ((!nvar)+1) r0 in
                Constrhash.iter (fun x c -> v.(Constrhash.find hvar x)<-c)
                   h.hflin.fhom;
                ((Array.to_list v)@[rop h.hflin.fcste],h.hstrict))
@@ -345,14 +342,14 @@ let coq_Rnot_le_le = lazy (constant_fourier "Rnot_le_le")
 let coq_Rlt_not_le_frac_opp = lazy (constant_fourier "Rlt_not_le_frac_opp")
 
 (******************************************************************************
-Construction de la preuve en cas de succès de la méthode de Fourier,
+Construction de la preuve en cas de succès de la méthode de Fourier,
 i.e. on obtient une contradiction.
 *)
 let is_int x = (x.den)=1
 ;;
 
 (* fraction = couple (num,den) *)
-let rec rational_to_fraction x= (x.num,x.den)
+let rational_to_fraction x= (x.num,x.den)
 ;;
 
 (* traduction -3 -> (Ropp (Rplus R1 (Rplus R1 R1)))
@@ -363,7 +360,7 @@ let int_to_real n =
    then get coq_R0
    else
      (let s=ref (get coq_R1) in
-      for i=1 to (nn-1) do s:=mkApp (get coq_Rplus,[|get coq_R1;!s|]) done;
+      for _i = 1 to (nn-1) do s:=mkApp (get coq_Rplus,[|get coq_R1;!s|]) done;
       if n<0 then mkApp (get coq_Ropp, [|!s|]) else !s)
 ;;
 (* -1/2 -> (Rmult (Ropp R1) (Rinv (Rplus R1 R1)))
@@ -379,11 +376,11 @@ let rational_to_real x =
 let tac_zero_inf_pos gl (n,d) =
    let tacn=ref (apply (get coq_Rlt_zero_1)) in
    let tacd=ref (apply (get coq_Rlt_zero_1)) in
-   for i=1 to n-1 do
-       tacn:=(tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacn); done;
-   for i=1 to d-1 do
-       tacd:=(tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacd); done;
-   (tclTHENS (apply (get coq_Rlt_mult_inv_pos)) [!tacn;!tacd])
+   for _i = 1 to n - 1 do
+       tacn:=(Tacticals.New.tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacn); done;
+   for _i = 1 to d - 1 do
+       tacd:=(Tacticals.New.tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacd); done;
+   (Tacticals.New.tclTHENS (apply (get coq_Rlt_mult_inv_pos)) [!tacn;!tacd])
 ;;
 
 (* preuve que 0<=n*1/d
@@ -393,11 +390,11 @@ let tac_zero_infeq_pos gl (n,d)=
                  then (apply (get coq_Rle_zero_zero))
                  else (apply (get coq_Rle_zero_1))) in
    let tacd=ref (apply (get coq_Rlt_zero_1)) in
-   for i=1 to n-1 do
-       tacn:=(tclTHEN (apply (get coq_Rle_zero_pos_plus1)) !tacn); done;
-   for i=1 to d-1 do
-       tacd:=(tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacd); done;
-   (tclTHENS (apply (get coq_Rle_mult_inv_pos)) [!tacn;!tacd])
+   for  _i = 1 to n - 1 do
+       tacn:=(Tacticals.New.tclTHEN (apply (get coq_Rle_zero_pos_plus1)) !tacn); done;
+   for _i = 1 to d - 1 do
+       tacd:=(Tacticals.New.tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacd); done;
+   (Tacticals.New.tclTHENS (apply (get coq_Rle_mult_inv_pos)) [!tacn;!tacd])
 ;;
 
 (* preuve que 0<(-n)*(1/d) => False
@@ -405,14 +402,14 @@ let tac_zero_infeq_pos gl (n,d)=
 let tac_zero_inf_false gl (n,d) =
     if n=0 then (apply (get coq_Rnot_lt0))
     else
-     (tclTHEN (apply (get coq_Rle_not_lt))
+     (Tacticals.New.tclTHEN (apply (get coq_Rle_not_lt))
 	      (tac_zero_infeq_pos gl (-n,d)))
 ;;
 
 (* preuve que 0<=(-n)*(1/d) => False
 *)
 let tac_zero_infeq_false gl (n,d) =
-     (tclTHEN (apply (get coq_Rlt_not_le_frac_opp))
+     (Tacticals.New.tclTHEN (apply (get coq_Rlt_not_le_frac_opp))
 	      (tac_zero_inf_pos gl (-n,d)))
 ;;
 
@@ -425,18 +422,16 @@ let my_cut c gl=
 
 let exact = exact_check;;
 
-let tac_use h = match h.htype with
-               "Rlt" -> exact h.hname
-              |"Rle" -> exact h.hname
-              |"Rgt" -> (tclTHEN (apply (get coq_Rfourier_gt_to_lt))
-                                (exact h.hname))
-              |"Rge" -> (tclTHEN (apply (get coq_Rfourier_ge_to_le))
-                                (exact h.hname))
-              |"eqTLR" -> (tclTHEN (apply (get coq_Rfourier_eqLR_to_le))
-                                (exact h.hname))
-              |"eqTRL" -> (tclTHEN (apply (get coq_Rfourier_eqRL_to_le))
-                                (exact h.hname))
-              |_->assert false
+let tac_use h =
+  let tac = exact h.hname in
+  match h.htype with
+    "Rlt" -> tac
+  |"Rle" -> tac
+  |"Rgt" -> (Tacticals.New.tclTHEN (apply (get coq_Rfourier_gt_to_lt)) tac)
+  |"Rge" -> (Tacticals.New.tclTHEN (apply (get coq_Rfourier_ge_to_le)) tac)
+  |"eqTLR" -> (Tacticals.New.tclTHEN (apply (get coq_Rfourier_eqLR_to_le)) tac)
+  |"eqTRL" -> (Tacticals.New.tclTHEN (apply (get coq_Rfourier_eqRL_to_le)) tac)
+  |_->assert false
 ;;
 
 (*
@@ -464,58 +459,61 @@ let mkAppL a =
    mkApp(List.hd l, Array.of_list (List.tl l))
 ;;
 
-(* Résolution d'inéquations linéaires dans R *)
-let rec fourier gl=
+exception GoalDone
+
+(* Résolution d'inéquations linéaires dans R *)
+let rec fourier () =
+  Proofview.Goal.nf_enter begin fun gl ->
+    let concl = Proofview.Goal.concl gl in
     Coqlib.check_required_library ["Coq";"fourier";"Fourier"];
-    let goal = strip_outer_cast (pf_concl gl) in
-    let fhyp=id_of_string "new_hyp_for_fourier" in
-    (* si le but est une inéquation, on introduit son contraire,
-       et le but à prouver devient False *)
-    try (let tac =
-     match (kind_of_term goal) with
+    let goal = strip_outer_cast concl in
+    let fhyp=Id.of_string "new_hyp_for_fourier" in
+    (* si le but est une inéquation, on introduit son contraire,
+       et le but à prouver devient False *)
+    try 
+      match (kind_of_term goal) with
       App (f,args) ->
       (match (string_of_R_constr f) with
 	     "Rlt" ->
-	       (tclTHEN
-	         (tclTHEN (apply (get coq_Rfourier_not_ge_lt))
+	       (Tacticals.New.tclTHEN
+	         (Tacticals.New.tclTHEN (apply (get coq_Rfourier_not_ge_lt))
 			  (intro_using  fhyp))
-		 fourier)
+		 (fourier ()))
 	    |"Rle" ->
-	     (tclTHEN
-	      (tclTHEN (apply (get coq_Rfourier_not_gt_le))
+	     (Tacticals.New.tclTHEN
+	      (Tacticals.New.tclTHEN (apply (get coq_Rfourier_not_gt_le))
 		       (intro_using  fhyp))
-			fourier)
+			(fourier ()))
 	    |"Rgt" ->
-	     (tclTHEN
-	      (tclTHEN (apply (get coq_Rfourier_not_le_gt))
+	     (Tacticals.New.tclTHEN
+	      (Tacticals.New.tclTHEN (apply (get coq_Rfourier_not_le_gt))
 		       (intro_using  fhyp))
-	      fourier)
+	      (fourier ()))
 	    |"Rge" ->
-	     (tclTHEN
-	      (tclTHEN (apply (get coq_Rfourier_not_lt_ge))
+	     (Tacticals.New.tclTHEN
+	      (Tacticals.New.tclTHEN (apply (get coq_Rfourier_not_lt_ge))
 		       (intro_using  fhyp))
-	      fourier)
-	    |_->assert false)
-        |_->assert false
-      in tac gl)
-     with e when Errors.noncritical e ->
-    (* les hypothèses *)
+	      (fourier ()))
+	    |_-> raise GoalDone)
+        |_-> raise GoalDone
+     with GoalDone ->
+    (* les hypothèses *)
     let hyps = List.map (fun (h,t)-> (mkVar h,t))
-                        (list_of_sign (pf_hyps gl)) in
+                        (list_of_sign (Proofview.Goal.hyps gl)) in
     let lineq =ref [] in
     List.iter (fun h -> try (lineq:=(ineq1_of_constr h)@(!lineq))
-		        with e when Errors.noncritical e -> ())
+		        with NoIneq -> ())
               hyps;
-    (* lineq = les inéquations découlant des hypothèses *)
-    if !lineq=[] then Util.error "No inequalities";
+    (* lineq = les inéquations découlant des hypothèses *)
+    if !lineq=[] then Errors.error "No inequalities";
     let res=fourier_lineq (!lineq) in
-    let tac=ref tclIDTAC in
+    let tac=ref (Proofview.tclUNIT ()) in
     if res=[]
-    then Util.error "fourier failed"
-    (* l'algorithme de Fourier a réussi: on va en tirer une preuve Coq *)
+    then Errors.error "fourier failed"
+    (* l'algorithme de Fourier a réussi: on va en tirer une preuve Coq *)
     else (match res with
         [(cres,sres,lc)]->
-    (* lc=coefficients multiplicateurs des inéquations
+    (* lc=coefficients multiplicateurs des inéquations
        qui donnent 0<cres ou 0<=cres selon sres *)
 	(*print_string "Fourier's method can prove the goal...";flush stdout;*)
           let lutil=ref [] in
@@ -525,7 +523,7 @@ let rec fourier gl=
         		  then (lutil:=(h,c)::(!lutil)(*;
 				print_rational(c);print_string " "*)))
                     (List.combine (!lineq) lc);
-       (* on construit la combinaison linéaire des inéquation *)
+       (* on construit la combinaison linéaire des inéquation *)
              (match (!lutil) with
           (h1,c1)::lutil ->
 	  let s=ref (h1.hstrict) in
@@ -554,11 +552,11 @@ let rec fourier gl=
 	   let tc=rational_to_real cres in
        (* puis sa preuve *)
            let tac1=ref (if h1.hstrict
-                         then (tclTHENS (apply (get coq_Rfourier_lt))
+                         then (Tacticals.New.tclTHENS (apply (get coq_Rfourier_lt))
                                  [tac_use h1;
                                   tac_zero_inf_pos  gl
                                       (rational_to_fraction c1)])
-                         else (tclTHENS (apply (get coq_Rfourier_le))
+                         else (Tacticals.New.tclTHENS (apply (get coq_Rfourier_le))
                                  [tac_use h1;
 				  tac_zero_inf_pos  gl
                                       (rational_to_fraction c1)])) in
@@ -566,20 +564,20 @@ let rec fourier gl=
            List.iter (fun (h,c)->
              (if (!s)
 	      then (if h.hstrict
-	            then tac1:=(tclTHENS (apply (get coq_Rfourier_lt_lt))
+	            then tac1:=(Tacticals.New.tclTHENS (apply (get coq_Rfourier_lt_lt))
 			       [!tac1;tac_use h;
 			        tac_zero_inf_pos  gl
                                       (rational_to_fraction c)])
-	            else tac1:=(tclTHENS (apply (get coq_Rfourier_lt_le))
+	            else tac1:=(Tacticals.New.tclTHENS (apply (get coq_Rfourier_lt_le))
 			       [!tac1;tac_use h;
 			        tac_zero_inf_pos  gl
                                       (rational_to_fraction c)]))
 	      else (if h.hstrict
-	            then tac1:=(tclTHENS (apply (get coq_Rfourier_le_lt))
+	            then tac1:=(Tacticals.New.tclTHENS (apply (get coq_Rfourier_le_lt))
 			       [!tac1;tac_use h;
 			        tac_zero_inf_pos  gl
                                       (rational_to_fraction c)])
-	            else tac1:=(tclTHENS (apply (get coq_Rfourier_le_le))
+	            else tac1:=(Tacticals.New.tclTHENS (apply (get coq_Rfourier_le_le))
 			       [!tac1;tac_use h;
 			        tac_zero_inf_pos  gl
                                       (rational_to_fraction c)])));
@@ -589,42 +587,43 @@ let rec fourier gl=
                       then tac_zero_inf_false gl (rational_to_fraction cres)
                       else tac_zero_infeq_false gl (rational_to_fraction cres)
            in
-           tac:=(tclTHENS (my_cut ineq)
-                     [tclTHEN (change_in_concl None
+           tac:=(Tacticals.New.tclTHENS (Proofview.V82.tactic (my_cut ineq))
+                     [Tacticals.New.tclTHEN (change_concl
 			       (mkAppL [| get coq_not; ineq|]
 				       ))
-		      (tclTHEN (apply (if sres then get coq_Rnot_lt_lt
+		      (Tacticals.New.tclTHEN (apply (if sres then get coq_Rnot_lt_lt
 					       else get coq_Rnot_le_le))
-			    (tclTHENS (Equality.replace
+			    (Tacticals.New.tclTHENS (Equality.replace
 				       (mkAppL [|get coq_Rminus;!t2;!t1|]
 					       )
 				       tc)
 		 	       [tac2;
-                                (tclTHENS
+                                (Tacticals.New.tclTHENS
 				  (Equality.replace
 				    (mkApp (get coq_Rinv,
 				      [|get coq_R1|]))
 				    (get coq_R1))
-(* en attendant Field, ça peut aider Ring de remplacer 1/1 par 1 ... *)
+(* en attendant Field, ça peut aider Ring de remplacer 1/1 par 1 ... *)
 
-      			        [tclORELSE
-                                   (Ring.polynom [])
-                                   tclIDTAC;
-					  (tclTHEN (apply (get coq_sym_eqT))
-						(apply (get coq_Rinv_1)))]
+      			        [Tacticals.New.tclORELSE
+                                   (* TODO : Ring.polynom []*) (Proofview.tclUNIT ())
+                                   (Proofview.tclUNIT ());
+				 Tacticals.New.pf_constr_of_global (get coq_sym_eqT) (fun symeq ->
+					  (Tacticals.New.tclTHEN (apply symeq)
+						(apply (get coq_Rinv_1))))]
 
 					 )
 				]));
                        !tac1]);
-	   tac:=(tclTHENS (cut (get coq_False))
-				  [tclTHEN intro (contradiction None);
+	   tac:=(Tacticals.New.tclTHENS (cut (get coq_False))
+				  [Tacticals.New.tclTHEN intro (contradiction None);
 				   !tac])
       |_-> assert false) |_-> assert false
 	  );
 (*    ((tclTHEN !tac (tclFAIL 1 (* 1 au hasard... *))) gl) *)
-      (!tac gl)
+      !tac
 (*      ((tclABSTRACT None !tac) gl) *)
-
+  end
 ;;
 
 (*
diff --git a/plugins/fourier/g_fourier.ml4 b/plugins/fourier/g_fourier.ml4
index c6c4d68f..d00f0564 100644
--- a/plugins/fourier/g_fourier.ml4
+++ b/plugins/fourier/g_fourier.ml4
@@ -1,15 +1,17 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i camlp4deps: "parsing/grammar.cma" i*)
+(*i camlp4deps: "grammar/grammar.cma" i*)
 
 open FourierR
 
+DECLARE PLUGIN "fourier_plugin"
+
 TACTIC EXTEND fourier
-  [ "fourierz" ] -> [ fourier ]
+  [ "fourierz" ] -> [ fourier () ]
 END
diff --git a/plugins/funind/Recdef.v b/plugins/funind/Recdef.v
index 51ede26e..a63941f0 100644
--- a/plugins/funind/Recdef.v
+++ b/plugins/funind/Recdef.v
@@ -1,10 +1,13 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
+
+Require Import PeanoNat.
+
 Require Compare_dec.
 Require Wf_nat.
 
@@ -19,30 +22,29 @@ Fixpoint iter (n : nat) : (A -> A) -> A -> A :=
   end.
 End Iter.
 
-Theorem SSplus_lt : forall p p' : nat, p < S (S (p + p')).
-  intro p; intro p'; change (S p <= S (S (p + p')));
-    apply le_S; apply Gt.gt_le_S; change (p < S (p + p'));
-    apply Lt.le_lt_n_Sm; apply Plus.le_plus_l.
+Theorem le_lt_SS x y : x <= y -> x < S (S y).
+Proof.
+ intros. now apply Nat.lt_succ_r, Nat.le_le_succ_r.
 Qed.
 
-
-Theorem Splus_lt : forall p p' : nat, p' < S (p + p').
-  intro p; intro p'; change (S p' <= S (p + p'));
-    apply Gt.gt_le_S; change (p' < S (p + p')); apply Lt.le_lt_n_Sm;
-       apply Plus.le_plus_r.
+Theorem Splus_lt x y : y < S (x + y).
+Proof.
+ apply Nat.lt_succ_r. rewrite Nat.add_comm. apply Nat.le_add_r.
 Qed.
 
-Theorem le_lt_SS : forall x y, x <= y -> x < S (S y).
-intro x; intro y; intro H; change (S x <= S (S y));
-    apply le_S; apply Gt.gt_le_S; change (x < S y);
-    apply Lt.le_lt_n_Sm; exact H.
+Theorem SSplus_lt x y : x < S (S (x + y)).
+Proof.
+ apply le_lt_SS, Nat.le_add_r.
 Qed.
 
 Inductive max_type (m n:nat) : Set :=
   cmt : forall v, m <= v -> n <= v -> max_type m n.
 
-Definition max : forall m n:nat, max_type m n.
-intros m n; case (Compare_dec.le_gt_dec m n).
-intros h; exists n; [exact h | apply le_n].
-intros h; exists m; [apply le_n | apply Lt.lt_le_weak; exact h].
+Definition max m n : max_type m n.
+Proof.
+ destruct (Compare_dec.le_gt_dec m n) as [h|h].
+ - exists n; [exact h | apply le_n].
+ - exists m; [apply le_n | apply Nat.lt_le_incl; exact h].
 Defined.
+
+Definition Acc_intro_generator_function := fun A R => @Acc_intro_generator A R 100.
diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml
index b5876ffa..c8214ada 100644
--- a/plugins/funind/functional_principles_proofs.ml
+++ b/plugins/funind/functional_principles_proofs.ml
@@ -1,45 +1,37 @@
 open Printer
+open Errors
 open Util
 open Term
+open Vars
+open Context
 open Namegen
 open Names
 open Declarations
+open Declareops
 open Pp
-open Entries
-open Hiddentac
-open Evd
 open Tacmach
 open Proof_type
 open Tacticals
 open Tactics
 open Indfun_common
 open Libnames
+open Globnames
+open Misctypes
 
-let msgnl = Pp.msgnl
-
+(* let msgnl = Pp.msgnl *)
 
+(*
 let observe strm =
   if do_observe ()
-  then Pp.msgnl strm
-  else ()
-
-let observennl strm =
-  if do_observe ()
-  then begin Pp.msg strm;Pp.pp_flush () end
+  then Pp.msg_debug strm
   else ()
 
-
-
-
 let do_observe_tac s tac g =
  try let v = tac g in (* msgnl (goal ++ fnl () ++ (str s)++(str " ")++(str "finished")); *) v
- with reraise ->
-   let e = Cerrors.process_vernac_interp_error reraise in
-   let goal =
-     try (Printer.pr_goal g)
-     with e when Errors.noncritical e -> assert false
-   in
-   msgnl (str "observation "++ s++str " raised exception " ++
+ with e ->
+   let e = Cerrors.process_vernac_interp_error e in
+   let goal = begin try (Printer.pr_goal g) with _ -> assert false end in
+   msg_debug (str "observation "++ s++str " raised exception " ++
 	    Errors.print e ++ str " on goal " ++ goal );
    raise e;;
 
@@ -49,16 +41,55 @@ let observe_tac_stream s tac g =
   else tac g
 
 let observe_tac s tac g = observe_tac_stream (str s) tac g
+  *)
+
+
+let debug_queue = Stack.create ()
+
+let rec print_debug_queue b e = 
+  if  not (Stack.is_empty debug_queue) 
+  then
+    begin
+      let lmsg,goal = Stack.pop debug_queue in 
+      if b then 
+	Pp.msg_debug (lmsg ++ (str " raised exception " ++ Errors.print e) ++ str " on goal " ++ goal)
+      else
+	begin
+	  Pp.msg_debug (str " from " ++ lmsg ++ str " on goal " ++ goal);
+	end;
+      print_debug_queue false e;
+    end
 
-(* let tclTRYD tac =  *)
-(*   if  !Flags.debug  || do_observe () *)
-(*   then (fun g -> try (\* do_observe_tac ""  *\)tac g with _ -> tclIDTAC g) *)
-(*   else tac *)
+let observe strm =
+  if do_observe ()
+  then Pp.msg_debug strm
+  else ()
+
+let do_observe_tac s tac g = 
+  let goal = Printer.pr_goal g in
+  let lmsg = (str "observation : ") ++ s in 
+  Stack.push (lmsg,goal) debug_queue;
+  try 
+    let v = tac g in 
+    ignore(Stack.pop debug_queue);
+    v
+  with reraise ->
+    let reraise = Errors.push reraise in
+    if not (Stack.is_empty debug_queue)
+    then print_debug_queue true (fst (Cerrors.process_vernac_interp_error reraise));
+    iraise reraise
+
+let observe_tac_stream s tac g =
+  if do_observe ()
+  then do_observe_tac s tac g
+  else tac g
 
+let observe_tac s = observe_tac_stream (str s)
+  
 
 let list_chop ?(msg="") n l =
   try
-    list_chop n l
+    List.chop n l
   with Failure (msg') ->
     failwith (msg ^ msg')
 
@@ -70,17 +101,17 @@ let make_refl_eq constructor type_of_t t  =
 
 type pte_info =
     {
-      proving_tac : (identifier list ->  Tacmach.tactic);
+      proving_tac : (Id.t list ->  Tacmach.tactic);
       is_valid : constr -> bool
     }
 
-type ptes_info = pte_info Idmap.t
+type ptes_info = pte_info Id.Map.t
 
 type 'a dynamic_info =
     {
       nb_rec_hyps : int;
-      rec_hyps : identifier list ;
-      eq_hyps : identifier list;
+      rec_hyps : Id.t list ;
+      eq_hyps : Id.t list;
       info : 'a
     }
 
@@ -89,28 +120,17 @@ type body_info = constr dynamic_info
 
 let finish_proof dynamic_infos g =
   observe_tac "finish"
-    ( h_assumption)
+    (Proofview.V82.of_tactic assumption)
     g
 
 
 let refine c =
-  Tacmach.refine_no_check c
+  Tacmach.refine c
 
 let thin l =
   Tacmach.thin_no_check l
 
-
-let cut_replacing id t tac :tactic=
-  tclTHENS (cut t)
-    [ tclTHEN (thin_no_check [id]) (introduction_no_check id);
-      tac
-    ]
-
-let intro_erasing id = tclTHEN (thin [id]) (introduction id)
-
-
-
-let rec_hyp_id = id_of_string "rec_hyp"
+let eq_constr u v = eq_constr_nounivs u v
 
 let is_trivial_eq t =
   let res =   try
@@ -157,11 +177,11 @@ let change_hyp_with_using msg hyp_id t tac : tactic =
   fun g ->
     let prov_id = pf_get_new_id hyp_id g in
     tclTHENS
-      ((* observe_tac msg *) (assert_by (Name prov_id) t (tclCOMPLETE tac)))
+      ((* observe_tac msg *) Proofview.V82.of_tactic (assert_by (Name prov_id) t (Proofview.V82.tactic (tclCOMPLETE tac))))
       [tclTHENLIST
       [
 	(* observe_tac "change_hyp_with_using thin" *) (thin [hyp_id]);
-	(* observe_tac "change_hyp_with_using rename " *) (h_rename [prov_id,hyp_id])
+	(* observe_tac "change_hyp_with_using rename " *) (Proofview.V82.of_tactic (rename_hyp [prov_id,hyp_id]))
       ]] g
 
 exception TOREMOVE
@@ -171,7 +191,7 @@ let prove_trivial_eq h_id context (constructor,type_of_term,term) =
   let nb_intros = List.length context in
   tclTHENLIST
     [
-      tclDO nb_intros intro; (* introducing context *)
+      tclDO nb_intros (Proofview.V82.of_tactic intro); (* introducing context *)
       (fun g ->
 	 let context_hyps =
 	   fst (list_chop ~msg:"prove_trivial_eq : " nb_intros (pf_ids_of_hyps g))
@@ -188,7 +208,7 @@ let prove_trivial_eq h_id context (constructor,type_of_term,term) =
 
 
 let find_rectype env c =
-  let (t, l) = decompose_app (Reduction.whd_betaiotazeta c) in
+  let (t, l) = decompose_app (Reduction.whd_betaiotazeta env c) in
   match kind_of_term t with
   | Ind ind -> (t, l)
   | Construct _ -> (t,l)
@@ -216,7 +236,7 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type  =
       failwith "NoChange";
     end
   in
-  let eq_constr = Reductionops.is_conv env sigma in
+  let eq_constr = Evarconv.e_conv env (ref sigma) in
   if not (noccurn 1 end_of_type)
   then nochange "dependent"; (* if end_of_type depends on this term we don't touch it  *)
     if not (isApp t) then nochange "not an equality";
@@ -245,12 +265,12 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type  =
 	let t2 = destRel t2  in
 	begin
 	  try
-	    let t1' = Intmap.find t2 sub in
+	    let t1' = Int.Map.find t2 sub in
 	    if not (eq_constr t1 t1') then nochange "twice bound variable";
 	    sub
 	  with Not_found ->
 	    assert (closed0 t1);
-	    Intmap.add t2 t1 sub
+	    Int.Map.add t2 t1 sub
 	end
       else if isAppConstruct t1 && isAppConstruct t2
       then
@@ -264,18 +284,17 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type  =
       else
 	if (eq_constr t1 t2) then sub else nochange ~t':(make_refl_eq constructor (Reduction.whd_betadeltaiota env t1) t2)  "cannot solve (diff)"
     in
-    let sub = compute_substitution Intmap.empty (snd t1) (snd t2) in
+    let sub = compute_substitution Int.Map.empty (snd t1) (snd t2) in
     let sub = compute_substitution sub (fst t1) (fst t2) in
     let end_of_type_with_pop = Termops.pop end_of_type in (*the equation will be removed *)
     let new_end_of_type =
       (* Ugly hack to prevent Map.fold order change between ocaml-3.08.3 and ocaml-3.08.4
 	 Can be safely replaced by the next comment for Ocaml >= 3.08.4
       *)
-      let sub' = Intmap.fold (fun i t acc -> (i,t)::acc) sub [] in
-      let sub'' = List.sort (fun (x,_) (y,_) -> Pervasives.compare x y) sub' in
+      let sub = Int.Map.bindings sub in
       List.fold_left (fun end_of_type (i,t)  -> lift 1 (substnl  [t] (i-1) end_of_type))
 	end_of_type_with_pop
-	sub''
+	sub
     in
     let old_context_length = List.length context + 1 in
     let witness_fun =
@@ -284,11 +303,11 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type  =
 	      )
     in
     let new_type_of_hyp,ctxt_size,witness_fun =
-      list_fold_left_i
+      List.fold_left_i
 	(fun i (end_of_type,ctxt_size,witness_fun) ((x',b',t') as decl) ->
 	   try
-	     let witness = Intmap.find i sub in
-	     if b' <> None then anomaly "can not redefine a rel!";
+	     let witness = Int.Map.find i sub in
+	     if not (Option.is_empty b') then anomaly (Pp.str "can not redefine a rel!");
 	     (Termops.pop end_of_type,ctxt_size,mkLetIn(x',witness,t',witness_fun))
 	   with Not_found  ->
 	     (mkProd_or_LetIn decl end_of_type, ctxt_size + 1, mkLambda_or_LetIn decl witness_fun)
@@ -304,12 +323,13 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type  =
     in
     let prove_new_hyp : tactic =
       tclTHEN
-	(tclDO ctxt_size intro)
+	(tclDO ctxt_size (Proofview.V82.of_tactic intro))
 	(fun g ->
 	   let all_ids = pf_ids_of_hyps g in
 	   let new_ids,_  = list_chop ctxt_size all_ids in
 	   let to_refine = applist(witness_fun,List.rev_map mkVar new_ids) in
-	   refine to_refine g
+	   let evm, _ = pf_apply Typing.e_type_of g to_refine in
+	     tclTHEN (Refiner.tclEVARS evm) (refine to_refine) g
 	)
     in
     let simpl_eq_tac =
@@ -332,14 +352,14 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type  =
     new_ctxt,new_end_of_type,simpl_eq_tac
 
 
-let is_property ptes_info t_x full_type_of_hyp =
+let is_property (ptes_info:ptes_info) t_x full_type_of_hyp =
   if isApp t_x
   then
     let pte,args = destApp t_x in
-    if isVar pte && array_for_all closed0 args
+    if isVar pte && Array.for_all closed0 args
     then
       try
-	let info = Idmap.find (destVar pte) ptes_info in
+	let info = Id.Map.find (destVar pte) ptes_info in
 	info.is_valid full_type_of_hyp
       with Not_found -> false
     else false
@@ -352,10 +372,10 @@ let isLetIn t =
 
 
 let h_reduce_with_zeta =
-  h_reduce
-    (Glob_term.Cbv
-       {Glob_term.all_flags
-	with Glob_term.rDelta = false;
+  reduce
+    (Genredexpr.Cbv
+       {Redops.all_flags
+	with Genredexpr.rDelta = false;
        })
 
 
@@ -374,17 +394,17 @@ let rewrite_until_var arg_num eq_ids : tactic =
     then tclIDTAC g
     else
       match eq_ids with
-	| [] -> anomaly "Cannot find a way to prove recursive property";
+	| [] -> anomaly (Pp.str "Cannot find a way to prove recursive property");
 	| eq_id::eq_ids ->
 	    tclTHEN
-	      (tclTRY (Equality.rewriteRL (mkVar eq_id)))
+	      (tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar eq_id))))
 	      (do_rewrite eq_ids)
 	      g
   in
   do_rewrite eq_ids
 
 
-let rec_pte_id = id_of_string "Hrec"
+let rec_pte_id = Id.of_string "Hrec"
 let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma =
   let coq_False = Coqlib.build_coq_False () in
   let coq_True = Coqlib.build_coq_True () in
@@ -398,13 +418,8 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma =
 	 decompose_prod_n_assum (List.length context) reduced_type_of_hyp
       in
         tclTHENLIST
-	[
-	  h_reduce_with_zeta
-	    (Tacticals.onHyp hyp_id)
-	  ;
-	  scan_type new_context new_typ_of_hyp
-
-	]
+	[ h_reduce_with_zeta (Locusops.onHyp hyp_id);
+	  scan_type new_context new_typ_of_hyp ]
     else if isProd type_of_hyp
     then
       begin
@@ -413,14 +428,14 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma =
 	if is_property ptes_infos t_x actual_real_type_of_hyp then
 	  begin
 	    let pte,pte_args =  (destApp t_x) in
-	    let (* fix_info *) prove_rec_hyp = (Idmap.find (destVar pte) ptes_infos).proving_tac in
+	    let (* fix_info *) prove_rec_hyp = (Id.Map.find (destVar pte) ptes_infos).proving_tac in
 	    let popped_t' = Termops.pop t' in
 	    let real_type_of_hyp = it_mkProd_or_LetIn popped_t' context in
 	    let prove_new_type_of_hyp =
 	      let context_length = List.length context in
 	      tclTHENLIST
 		[
-		  tclDO context_length intro;
+		  tclDO context_length (Proofview.V82.of_tactic intro);
 		  (fun g ->
 		     let context_hyps_ids =
 		       fst (list_chop ~msg:"rec hyp : context_hyps"
@@ -434,7 +449,7 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma =
 		     in
 (* 		     observe_tac "rec hyp " *)
 		       (tclTHENS
-		       (assert_tac (Name rec_pte_id) t_x)
+		       (Proofview.V82.of_tactic (assert_before (Name rec_pte_id) t_x))
 		       [
 			 (* observe_tac "prove rec hyp" *) (prove_rec_hyp eq_hyps);
 (* 			observe_tac "prove rec hyp" *)
@@ -471,7 +486,7 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma =
 	  let prove_trivial =
 	    let nb_intro = List.length context in
 	    tclTHENLIST [
-	      tclDO nb_intro intro;
+	      tclDO nb_intro (Proofview.V82.of_tactic intro);
 	      (fun g ->
 		 let context_hyps =
 		   fst (list_chop ~msg:"removing True : context_hyps "nb_intro (pf_ids_of_hyps g))
@@ -533,7 +548,7 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma =
     thin [hyp_id],[]
 
 
-let clean_goal_with_heq ptes_infos continue_tac dyn_infos  =
+let clean_goal_with_heq ptes_infos continue_tac (dyn_infos:body_info) =
   fun g ->
     let env = pf_env g
     and sigma = project g
@@ -562,7 +577,7 @@ let clean_goal_with_heq ptes_infos continue_tac dyn_infos  =
       ]
       g
 
-let heq_id = id_of_string "Heq"
+let heq_id = Id.of_string "Heq"
 
 let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos =
   fun g ->
@@ -570,12 +585,12 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos =
     tclTHENLIST
       [
 	(* We first introduce the variables *)
-	tclDO nb_first_intro (intro_avoiding dyn_infos.rec_hyps);
+	tclDO nb_first_intro (Proofview.V82.of_tactic (intro_avoiding dyn_infos.rec_hyps));
 	(* Then the equation itself *)
-	intro_using heq_id;
+	Proofview.V82.of_tactic (intro_using heq_id);
 	onLastHypId (fun heq_id -> tclTHENLIST [
 	(* Then the new hypothesis *)
-	tclMAP introduction_no_check dyn_infos.rec_hyps;
+	tclMAP (fun id -> Proofview.V82.of_tactic (introduction ~check:false id)) dyn_infos.rec_hyps;
 	observe_tac "after_introduction" (fun g' ->
 	   (* We get infos on the equations introduced*)
 	   let new_term_value_eq = pf_type_of g' (mkVar heq_id) in
@@ -585,9 +600,9 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos =
 	       | App(f,[| _;_;args2 |]) -> args2
 	       | _ ->
 		   observe (str "cannot compute new term value : " ++ pr_gls g' ++ fnl () ++ str "last hyp is" ++
-			      pr_lconstr_env (pf_env g') new_term_value_eq
+			      pr_lconstr_env (pf_env g') Evd.empty new_term_value_eq
 			   );
-		   anomaly "cannot compute new term value"
+		   anomaly (Pp.str "cannot compute new term value")
 	   in
 	 let fun_body =
 	   mkLambda(Anonymous,
@@ -615,17 +630,20 @@ let my_orelse tac1 tac2 g =
 (*     observe (str "using snd tac since : " ++ Errors.print e); *)
     tac2 g
 
-let instanciate_hyps_with_args (do_prove:identifier list -> tactic) hyps args_id =
+let instanciate_hyps_with_args (do_prove:Id.t list -> tactic) hyps args_id =
   let args = Array.of_list (List.map mkVar  args_id) in
   let instanciate_one_hyp hid =
     my_orelse
       ( (* we instanciate the hyp if possible  *)
 	fun g ->
 	  let prov_hid = pf_get_new_id hid g in
+	  let c = mkApp(mkVar hid,args) in
+	  let evm, _ = pf_apply Typing.e_type_of g c in
 	  tclTHENLIST[
-	    pose_proof (Name prov_hid) (mkApp(mkVar hid,args));
+            Refiner.tclEVARS evm;
+	    Proofview.V82.of_tactic (pose_proof (Name prov_hid) c);
 	    thin [hid];
-	    h_rename [prov_hid,hid]
+	    Proofview.V82.of_tactic (rename_hyp [prov_hid,hid])
 	  ] g
       )
       ( (*
@@ -642,23 +660,23 @@ let instanciate_hyps_with_args (do_prove:identifier list -> tactic) hyps args_id
 	)
       )
   in
-  if args_id = []
+  if List.is_empty args_id
   then
     tclTHENLIST [
-      tclMAP (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) hyps;
+      tclMAP (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) hyps;
       do_prove hyps
     ]
   else
     tclTHENLIST
       [
-	tclMAP (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) hyps;
+	tclMAP (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) hyps;
 	tclMAP instanciate_one_hyp hyps;
 	(fun g ->
 	   let all_g_hyps_id =
-	     List.fold_right Idset.add (pf_ids_of_hyps g) Idset.empty
+	     List.fold_right Id.Set.add (pf_ids_of_hyps g) Id.Set.empty
 	   in
 	   let remaining_hyps =
-	     List.filter (fun id -> Idset.mem id all_g_hyps_id) hyps
+	     List.filter (fun id -> Id.Set.mem id all_g_hyps_id) hyps
 	   in
 	   do_prove remaining_hyps g
 	  )
@@ -687,11 +705,11 @@ let build_proof
 		  in
 		  tclTHENSEQ
 		    [
-		      h_generalize (term_eq::(List.map mkVar dyn_infos.rec_hyps));
+		      Simple.generalize (term_eq::(List.map mkVar dyn_infos.rec_hyps));
 		      thin dyn_infos.rec_hyps;
-		      pattern_option [(false,[1]),t] None;
+		      pattern_option [Locus.AllOccurrencesBut [1],t] None;
 		      (fun g -> observe_tac "toto" (
-			 tclTHENSEQ [h_simplest_case t;
+			 tclTHENSEQ [Proofview.V82.of_tactic (Simple.case t);
 				     (fun g' ->
 					let g'_nb_prod = nb_prod (pf_concl g') in
 					let nb_instanciate_partial = g'_nb_prod - g_nb_prod in
@@ -716,7 +734,7 @@ let build_proof
 		match kind_of_term( pf_concl g) with
 		  | Prod _ ->
 		      tclTHEN
-			intro
+			(Proofview.V82.of_tactic intro)
 			(fun g' ->
 			   let (id,_,_) = pf_last_hyp g' in
 			   let new_term =
@@ -746,6 +764,7 @@ let build_proof
 	      begin
 		match kind_of_term f with
 		  | App _ -> assert false (* we have collected all the app in decompose_app *)
+		  | Proj _ -> assert false (*FIXME*)
 		  | Var _ | Construct _ | Rel _ | Evar _ | Meta _  | Ind _ | Sort _ | Prod _ ->
 		      let new_infos =
 			{ dyn_infos with
@@ -753,7 +772,7 @@ let build_proof
 			}
 		      in
 		      build_proof_args do_finalize new_infos  g
-		  | Const c when not (List.mem c fnames) ->
+		  | Const (c,_) when not (List.mem_f Constant.equal c fnames) ->
 		      let new_infos =
 			{ dyn_infos with
 			    info = (f,args)
@@ -775,9 +794,10 @@ let build_proof
 
 		      tclTHENLIST
 			[tclMAP
-			   (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id))
+			   (fun hyp_id ->
+			     h_reduce_with_zeta (Locusops.onHyp hyp_id))
 			   dyn_infos.rec_hyps;
-			 h_reduce_with_zeta Tacticals.onConcl;
+			 h_reduce_with_zeta Locusops.onConcl;
 			 build_proof do_finalize new_infos
 			]
 			g
@@ -797,6 +817,7 @@ let build_proof
 	  | Fix _ | CoFix _ ->
 	      error ( "Anonymous local (co)fixpoints are not handled yet")
 
+	  | Proj _ -> error "Prod"
 	  | Prod _ -> error "Prod"
 	  | LetIn _ ->
 	      let new_infos =
@@ -807,28 +828,28 @@ let build_proof
 
 	      tclTHENLIST
 		[tclMAP
-		   (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id))
+		   (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id))
 		   dyn_infos.rec_hyps;
-		 h_reduce_with_zeta Tacticals.onConcl;
+		 h_reduce_with_zeta Locusops.onConcl;
 		 build_proof do_finalize new_infos
 		] g
-	  | Rel _ -> anomaly "Free var in goal conclusion !"
+	  | Rel _ -> anomaly (Pp.str "Free var in goal conclusion !")
   and build_proof do_finalize dyn_infos g =
 (*     observe (str "proving with "++Printer.pr_lconstr dyn_infos.info++ str " on goal " ++ pr_gls g); *)
-    observe_tac "build_proof" (build_proof_aux do_finalize dyn_infos) g
+    observe_tac_stream (str "build_proof with " ++ Printer.pr_lconstr dyn_infos.info ) (build_proof_aux do_finalize dyn_infos) g
   and build_proof_args do_finalize dyn_infos (* f_args'  args *) :tactic =
     fun g ->
       let (f_args',args) = dyn_infos.info in
       let tac : tactic =
 	fun g ->
-	match args with
-	  | []  ->
+	  match args with
+	    | []  ->
 	      do_finalize {dyn_infos with info = f_args'} g
-	  | arg::args ->
-(* 		observe (str "build_proof_args with arg := "++ pr_lconstr_env (pf_env g) arg++ *)
-(* 			fnl () ++  *)
-(* 			pr_goal (Tacmach.sig_it g) *)
-(* 			); *)
+	    | arg::args ->
+	      (* 		observe (str "build_proof_args with arg := "++ pr_lconstr_env (pf_env g) arg++ *)
+	      (* 			fnl () ++  *)
+	      (* 			pr_goal (Tacmach.sig_it g) *)
+	      (* 			); *)
 	      let do_finalize dyn_infos =
 		let new_arg = dyn_infos.info in
 		(* 		tclTRYD *)
@@ -842,14 +863,14 @@ let build_proof
 		g
       in
       (* observe_tac "build_proof_args" *) (tac ) g
-   in
-   let do_finish_proof dyn_infos =
+  in
+  let do_finish_proof dyn_infos =
      (* tclTRYD *) (clean_goal_with_heq
-      ptes_infos
-      finish_proof dyn_infos)
+		      ptes_infos
+		      finish_proof dyn_infos)
   in
-  (* observe_tac "build_proof" *)
-    (build_proof (clean_goal_with_heq ptes_infos do_finish_proof) dyn_infos)
+    (* observe_tac "build_proof" *)
+  (build_proof (clean_goal_with_heq ptes_infos do_finish_proof) dyn_infos)
 
 
 
@@ -863,18 +884,11 @@ let build_proof
 
 
 (* Proof of principles from structural functions *)
-let is_pte_type t =
-  isSort ((strip_prod t))
-
-let is_pte (_,_,t) = is_pte_type t
-
-
-
 
 type static_fix_info =
     {
       idx : int;
-      name : identifier;
+      name : Id.t;
       types : types;
       offset : int;
       nb_realargs : int;
@@ -901,9 +915,6 @@ let prove_rec_hyp fix_info  =
     is_valid = fun _ -> true
   }
 
-
-exception Not_Rec
-
 let generalize_non_dep hyp g =
 (*   observe (str "rec id := " ++ Ppconstr.pr_id hyp); *)
   let hyps = [hyp] in
@@ -911,17 +922,17 @@ let generalize_non_dep hyp g =
   let hyp_typ = pf_type_of g (mkVar hyp) in
   let to_revert,_ =
     Environ.fold_named_context_reverse (fun (clear,keep) (hyp,_,_ as decl) ->
-      if List.mem hyp hyps
-	or List.exists (Termops.occur_var_in_decl env hyp) keep
-	or Termops.occur_var env hyp hyp_typ
-	or Termops.is_section_variable hyp (* should be dangerous *)
+      if Id.List.mem hyp hyps
+        || List.exists (Termops.occur_var_in_decl env hyp) keep
+	|| Termops.occur_var env hyp hyp_typ
+	|| Termops.is_section_variable hyp (* should be dangerous *)
       then (clear,decl::keep)
       else (hyp::clear,keep))
       ~init:([],[]) (pf_env g)
   in
 (*   observe (str "to_revert := " ++ prlist_with_sep spc Ppconstr.pr_id to_revert); *)
   tclTHEN
-    ((* observe_tac "h_generalize" *) (h_generalize  (List.map mkVar to_revert) ))
+    ((* observe_tac "h_generalize" *) (Simple.generalize  (List.map mkVar to_revert) ))
     ((* observe_tac "thin" *) (thin to_revert))
     g
 
@@ -936,11 +947,9 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num =
 (*   observe (str "nb_args := " ++ str (string_of_int nb_args)); *)
 (*   observe (str "nb_params := " ++ str (string_of_int nb_params)); *)
 (*   observe (str "rec_args_num := " ++ str (string_of_int (rec_args_num + 1) )); *)
-  let f_def = Global.lookup_constant (destConst f) in
+  let f_def = Global.lookup_constant (fst (destConst f)) in
   let eq_lhs = mkApp(f,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i))) in
-  let f_body =
-    force (Option.get (body_of_constant f_def))
-  in
+  let f_body = Option.get (Global.body_of_constant_body f_def)in
   let params,f_body_with_params = decompose_lam_n nb_params f_body in
   let (_,num),(_,_,bodies) = destFix f_body_with_params in
   let fnames_with_params =
@@ -955,20 +964,20 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num =
   let eq_rhs = nf_betaiotazeta (mkApp(compose_lam params f_body_with_params_and_other_fun,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i)))) in
 (*   observe (str "eq_rhs " ++  pr_lconstr eq_rhs); *)
   let type_ctxt,type_of_f = decompose_prod_n_assum (nb_params + nb_args)
-    (Typeops.type_of_constant_type (Global.env()) f_def.const_type) in
+    (Typeops.type_of_constant_type (Global.env ()) (*FIXME*)f_def.const_type) in
   let eqn = mkApp(Lazy.force eq,[|type_of_f;eq_lhs;eq_rhs|]) in
   let lemma_type = it_mkProd_or_LetIn eqn type_ctxt in
-  let f_id = id_of_label (con_label (destConst f)) in
+  let f_id = Label.to_id (con_label (fst (destConst f))) in
   let prove_replacement =
     tclTHENSEQ
       [
-	tclDO (nb_params + rec_args_num + 1) intro;
+	tclDO (nb_params + rec_args_num + 1) (Proofview.V82.of_tactic intro);
 	(* observe_tac "" *) (fun g ->
 	   let rec_id = pf_nth_hyp_id g 1 in
 	   tclTHENSEQ
 	     [(* observe_tac "generalize_non_dep in generate_equation_lemma" *) (generalize_non_dep rec_id);
-	      (* observe_tac "h_case" *) (h_case false (mkVar rec_id,Glob_term.NoBindings));
-	      intros_reflexivity] g
+	      (* observe_tac "h_case" *) (Proofview.V82.of_tactic (simplest_case (mkVar rec_id)));
+	      (Proofview.V82.of_tactic intros_reflexivity)] g
 	)
       ]
   in
@@ -977,11 +986,12 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num =
       Ensures by: obvious
       i*)
     (mk_equation_id f_id)
-    (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem))
-    lemma_type
-    (fun _ _ -> ());
-  Pfedit.by (prove_replacement);
-  Lemmas.save_named false
+    (Decl_kinds.Global, false, (Decl_kinds.Proof Decl_kinds.Theorem))
+  Evd.empty
+  lemma_type
+  (Lemmas.mk_hook (fun _ _ -> ()));
+  ignore (Pfedit.by (Proofview.V82.tactic prove_replacement));
+  Lemmas.save_proof (Vernacexpr.Proved(false,None))
 
 
 
@@ -989,10 +999,10 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num =
 let do_replace params rec_arg_num rev_args_id f fun_num all_funs g =
   let equation_lemma =
     try
-      let finfos = find_Function_infos (destConst f) in
+      let finfos = find_Function_infos (fst (destConst f)) (*FIXME*) in
       mkConst (Option.get finfos.equation_lemma)
     with (Not_found | Option.IsNone as e) ->
-      let f_id = id_of_label (con_label (destConst f)) in
+      let f_id = Label.to_id (con_label (fst (destConst f))) in
       (*i The next call to mk_equation_id is valid since we will construct the lemma
 	Ensures by: obvious
 	i*)
@@ -1001,12 +1011,12 @@ let do_replace params rec_arg_num rev_args_id f fun_num all_funs g =
       let _ =
 	match e with
 	  | Option.IsNone ->
-	      let finfos = find_Function_infos (destConst f) in
+	      let finfos = find_Function_infos (fst (destConst f)) in
 	      update_Function
 		{finfos with
 		   equation_lemma = Some (match Nametab.locate (qualid_of_ident equation_lemma_id) with
 					      ConstRef c -> c
-					    | _ -> Util.anomaly "Not a constant"
+					    | _ -> Errors.anomaly (Pp.str "Not a constant")
 					 )
 		}
 	  | _ -> ()
@@ -1016,12 +1026,12 @@ let do_replace params rec_arg_num rev_args_id f fun_num all_funs g =
   in
   let nb_intro_to_do = nb_prod (pf_concl g) in
     tclTHEN
-      (tclDO nb_intro_to_do intro)
+      (tclDO nb_intro_to_do (Proofview.V82.of_tactic intro))
       (
 	fun g' ->
 	  let just_introduced = nLastDecls nb_intro_to_do g' in
 	  let just_introduced_id = List.map (fun (id,_,_) -> id) just_introduced in
-	  tclTHEN (Equality.rewriteLR equation_lemma) (revert just_introduced_id) g'
+	  tclTHEN (Proofview.V82.of_tactic (Equality.rewriteLR equation_lemma)) (revert just_introduced_id) g'
       )
       g
 
@@ -1034,7 +1044,7 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams :
       (fun na ->
 	 let new_id =
 	   match na with
-	       Name id -> fresh_id !avoid (string_of_id id)
+	       Name id -> fresh_id !avoid (Id.to_string id)
 	     | Anonymous -> fresh_id !avoid "H"
 	 in
 	 avoid := new_id :: !avoid;
@@ -1055,9 +1065,8 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams :
       }
     in
     let get_body const =
-      match body_of_constant (Global.lookup_constant const) with
-	| Some b ->
-	     let body = force b in
+      match Global.body_of_constant const with
+	| Some body ->
 	     Tacred.cbv_norm_flags
 	       (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA])
 	       (Global.env ())
@@ -1137,7 +1146,7 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams :
 		typess
 	    in
 	    let pte_to_fix,rev_info =
-	      list_fold_left_i
+	      List.fold_left_i
 		(fun i (acc_map,acc_info) (pte,_,_) ->
 		   let infos = info_array.(i) in
 		   let type_args,_ = decompose_prod infos.types in
@@ -1175,14 +1184,14 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams :
 		   in
 (* 		   observe (str "binding " ++ Ppconstr.pr_id (Nameops.out_name pte) ++  *)
 (* 			      str " to " ++ Ppconstr.pr_id info.name); *)
-		   (Idmap.add (Nameops.out_name pte) info acc_map,info::acc_info)
+		   (Id.Map.add (Nameops.out_name pte) info acc_map,info::acc_info)
 		   )
 		0
-		(Idmap.empty,[])
+		(Id.Map.empty,[])
 		(List.rev princ_info.predicates)
 	    in
 	    pte_to_fix,List.rev rev_info
-	| _ -> Idmap.empty,[]
+	| _ -> Id.Map.empty,[]
     in
     let mk_fixes : tactic =
       let pre_info,infos = list_chop fun_num infos in
@@ -1194,19 +1203,19 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams :
 		(fun fi -> fi.name,fi.idx + 1 ,fi.types)
 		(pre_info@others_infos)
 	    in
-	    if other_fix_infos = []
+	    if List.is_empty other_fix_infos
 	    then
-	      (* observe_tac ("h_fix") *) (h_fix (Some this_fix_info.name) (this_fix_info.idx +1))
+	      (* observe_tac ("h_fix") *) (fix (Some this_fix_info.name) (this_fix_info.idx +1))
 	    else
-	      h_mutual_fix false this_fix_info.name (this_fix_info.idx + 1)
-		other_fix_infos
-	| _ -> anomaly "Not a valid information"
+	      Tactics.mutual_fix this_fix_info.name (this_fix_info.idx + 1)
+		other_fix_infos 0
+	| _ -> anomaly (Pp.str "Not a valid information")
     in
     let first_tac : tactic = (* every operations until fix creations *)
       tclTHENSEQ
-	[ (* observe_tac "introducing params" *) (intros_using (List.rev_map id_of_decl princ_info.params));
-	  (* observe_tac "introducing predictes" *) (intros_using (List.rev_map id_of_decl princ_info.predicates));
-	  (* observe_tac "introducing branches" *) (intros_using (List.rev_map id_of_decl princ_info.branches));
+	[ (* observe_tac "introducing params" *) Proofview.V82.of_tactic (intros_using (List.rev_map id_of_decl princ_info.params));
+	  (* observe_tac "introducing predictes" *) Proofview.V82.of_tactic (intros_using (List.rev_map id_of_decl princ_info.predicates));
+	  (* observe_tac "introducing branches" *) Proofview.V82.of_tactic (intros_using (List.rev_map id_of_decl princ_info.branches));
 	  (* observe_tac "building fixes" *) mk_fixes;
 	]
     in
@@ -1217,14 +1226,13 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams :
 	try
 	  let pte =
             try destVar pte
-            with e when Errors.noncritical e ->
-              anomaly "Property is not a variable"
+            with DestKO -> anomaly (Pp.str "Property is not a variable")
           in
-	  let fix_info = Idmap.find  pte ptes_to_fix in
+	  let fix_info = Id.Map.find  pte ptes_to_fix in
 	  let nb_args = fix_info.nb_realargs in
 	  tclTHENSEQ
 	    [
-	      (* observe_tac ("introducing args") *) (tclDO nb_args intro);
+	      (* observe_tac ("introducing args") *) (tclDO nb_args (Proofview.V82.of_tactic intro));
 	      (fun g -> (* replacement of the function by its body *)
 		 let args = nLastDecls nb_args g in
 		 let fix_body = fix_info.body_with_param in
@@ -1258,7 +1266,7 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams :
 		       build_proof
 			 interactive_proof
 			 (Array.to_list fnames)
-			 (Idmap.map prove_rec_hyp ptes_to_fix)
+			 (Id.Map.map prove_rec_hyp ptes_to_fix)
 		     in
 		     let prove_tac branches  =
 		       let dyn_infos =
@@ -1268,7 +1276,7 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams :
 			 }
 		       in
 		       observe_tac "cleaning" (clean_goal_with_heq
-			 (Idmap.map prove_rec_hyp ptes_to_fix)
+			 (Id.Map.map prove_rec_hyp ptes_to_fix)
 			 do_prove
 			 dyn_infos)
 		     in
@@ -1288,7 +1296,7 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams :
 	  let nb_args = min (princ_info.nargs) (List.length ctxt) in
 	  tclTHENSEQ
 	    [
-	      tclDO nb_args intro;
+	      tclDO nb_args (Proofview.V82.of_tactic intro);
 	      (fun g -> (* replacement of the function by its body *)
 		 let args = nLastDecls nb_args g in
 		 let args_id = List.map (fun (id,_,_) -> id) args in
@@ -1307,12 +1315,12 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams :
 		 in
 		 let fname = destConst (fst (decompose_app (List.hd (List.rev pte_args)))) in
 		 tclTHENSEQ
-		   [unfold_in_concl [(Termops.all_occurrences, Names.EvalConstRef fname)];
+		   [unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst fname))];
 		    let do_prove =
 		      build_proof
 			interactive_proof
 			(Array.to_list fnames)
-			 (Idmap.map prove_rec_hyp ptes_to_fix)
+			 (Id.Map.map prove_rec_hyp ptes_to_fix)
 		    in
 		    let prove_tac branches  =
 		      let dyn_infos =
@@ -1322,7 +1330,7 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams :
 			 }
 		      in
 		       clean_goal_with_heq
-			 (Idmap.map prove_rec_hyp ptes_to_fix)
+			 (Id.Map.map prove_rec_hyp ptes_to_fix)
 			 do_prove
 			 dyn_infos
 		    in
@@ -1346,15 +1354,13 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams :
 
 
 (* Proof of principles of general functions *)
-let h_id = Recdef.h_id
-and hrec_id = Recdef.hrec_id
-and acc_inv_id = Recdef.acc_inv_id
-and ltof_ref = Recdef.ltof_ref
-and acc_rel = Recdef.acc_rel
-and well_founded = Recdef.well_founded
-and h_intros = Recdef.h_intros
-and list_rewrite = Recdef.list_rewrite
-and evaluable_of_global_reference = Recdef.evaluable_of_global_reference
+(* let  hrec_id =

+(* and acc_inv_id = Recdef.acc_inv_id *)
+(* and ltof_ref = Recdef.ltof_ref *)
+(* and acc_rel = Recdef.acc_rel *)
+(* and well_founded = Recdef.well_founded *)
+(* and list_rewrite = Recdef.list_rewrite *)
+(* and evaluable_of_global_reference = Recdef.evaluable_of_global_reference *)
 
 
 
@@ -1362,7 +1368,7 @@ and evaluable_of_global_reference = Recdef.evaluable_of_global_reference
 
 let prove_with_tcc tcc_lemma_constr eqs : tactic =
   match !tcc_lemma_constr with
-    | None -> anomaly "No tcc proof !!"
+    | None -> anomaly (Pp.str "No tcc proof !!")
     | Some lemma ->
 	fun gls ->
 (* 	  let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in *)
@@ -1387,14 +1393,14 @@ let backtrack_eqs_until_hrec hrec eqs : tactic =
   fun gls ->
     let eqs = List.map mkVar eqs in
     let rewrite =
-      tclFIRST (List.map Equality.rewriteRL eqs )
+      tclFIRST (List.map (fun x -> Proofview.V82.of_tactic (Equality.rewriteRL x)) eqs )
     in
     let _,hrec_concl  = decompose_prod (pf_type_of gls (mkVar hrec)) in
-    let f_app = array_last (snd (destApp hrec_concl)) in
+    let f_app = Array.last (snd (destApp hrec_concl)) in
     let f =  (fst (destApp f_app)) in
     let rec backtrack : tactic =
       fun g ->
-	let f_app = array_last (snd (destApp (pf_concl g))) in
+	let f_app = Array.last (snd (destApp (pf_concl g))) in
 	match kind_of_term f_app with
 	  | App(f',_) when eq_constr f' f -> tclIDTAC g
 	  | _ -> tclTHEN rewrite backtrack g
@@ -1402,17 +1408,6 @@ let backtrack_eqs_until_hrec hrec eqs : tactic =
     backtrack gls
 
 
-
-let build_clause eqs =
-  {
-    Tacexpr.onhyps =
-      Some (List.map
-	      (fun id -> (Glob_term.all_occurrences_expr, id), Termops.InHyp)
-	      eqs
-	   );
-    Tacexpr.concl_occs = Glob_term.no_occurrences_expr
-  }
-
 let rec rewrite_eqs_in_eqs eqs =
   match eqs with
     | [] -> tclIDTAC
@@ -1422,8 +1417,9 @@ let rec rewrite_eqs_in_eqs eqs =
 	    (tclMAP
 	       (fun id gl ->
 		  observe_tac
-		    (Format.sprintf "rewrite %s in %s " (string_of_id eq) (string_of_id id))
-		    (tclTRY (Equality.general_rewrite_in true Termops.all_occurrences true (* dep proofs also: *) true id (mkVar eq) false))
+		    (Format.sprintf "rewrite %s in %s " (Id.to_string eq) (Id.to_string id))
+		    (tclTRY (Proofview.V82.of_tactic (Equality.general_rewrite_in true Locus.AllOccurrences
+			       true (* dep proofs also: *) true id (mkVar eq) false)))
 		    gl
 	       )
 	       eqs
@@ -1435,22 +1431,22 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic =
     (tclTHENSEQ
        [
 	 backtrack_eqs_until_hrec hrec eqs;
-	 (* observe_tac ("new_prove_with_tcc ( applying "^(string_of_id hrec)^" )" ) *)
+	 (* observe_tac ("new_prove_with_tcc ( applying "^(Id.to_string hrec)^" )" ) *)
 	 (tclTHENS  (* We must have exactly ONE subgoal !*)
-	    (apply (mkVar hrec))
+	    (Proofview.V82.of_tactic (apply (mkVar hrec)))
 	    [ tclTHENSEQ
 		[
-		  keep (tcc_hyps@eqs);
-		  apply (Lazy.force acc_inv);
+		  (Proofview.V82.of_tactic (keep (tcc_hyps@eqs)));
+		  (Proofview.V82.of_tactic (apply (Lazy.force acc_inv)));
 		  (fun g ->
 		     if is_mes
 		     then
-		       unfold_in_concl [(Termops.all_occurrences, evaluable_of_global_reference (delayed_force ltof_ref))] g
+		       unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference (delayed_force ltof_ref))] g
 		     else tclIDTAC g
 		  );
 		  observe_tac "rew_and_finish"
 		    (tclTHENLIST
-		       [tclTRY(Recdef.list_rewrite false (List.map mkVar eqs));
+		       [tclTRY(list_rewrite false (List.map (fun v -> (mkVar v,true)) eqs));
 			observe_tac "rewrite_eqs_in_eqs" (rewrite_eqs_in_eqs eqs);
 			 (observe_tac "finishing using"
 			   (
@@ -1458,7 +1454,7 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic =
 				    Eauto.eauto_with_bases
 				      (true,5)
 				      [Evd.empty,Lazy.force refl_equal]
-				      [Auto.Hint_db.empty empty_transparent_state false]
+				      [Hints.Hint_db.empty empty_transparent_state false]
 				  )
 			   )
 			)
@@ -1471,13 +1467,13 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic =
 
 
 let is_valid_hypothesis predicates_name =
-  let predicates_name = List.fold_right Idset.add predicates_name Idset.empty in
+  let predicates_name = List.fold_right Id.Set.add predicates_name Id.Set.empty in
   let is_pte typ =
     if isApp typ
     then
       let pte,_ = destApp typ in
       if isVar pte
-      then Idset.mem (destVar pte) predicates_name
+      then Id.Set.mem (destVar pte) predicates_name
       else false
     else false
   in
@@ -1499,7 +1495,7 @@ let prove_principle_for_gen
     fun na ->
       let new_id =
 	  match na with
-	    | Name id -> fresh_id !avoid (string_of_id id)
+	    | Name id -> fresh_id !avoid (Id.to_string id)
 	    | Anonymous -> fresh_id !avoid "H"
       in
       avoid := new_id :: !avoid;
@@ -1531,7 +1527,7 @@ let prove_principle_for_gen
 (* 	     str "real_rec_arg_num := " ++ int real_rec_arg_num ++ fnl () ++ *)
 (* 	     str "npost_rec_arg := " ++ int npost_rec_arg ); *)
   let (post_rec_arg,pre_rec_arg) =
-    Util.list_chop npost_rec_arg princ_info.args
+    Util.List.chop npost_rec_arg princ_info.args
   in
   let rec_arg_id =
     match List.rev post_rec_arg with
@@ -1542,25 +1538,25 @@ let prove_principle_for_gen
   let subst_constrs = List.map (fun (na,_,_) -> mkVar (Nameops.out_name na)) (pre_rec_arg@princ_info.params) in
   let relation = substl subst_constrs relation in
   let input_type = substl subst_constrs rec_arg_type in
-  let wf_thm_id = Nameops.out_name (fresh_id (Name (id_of_string "wf_R"))) in
+  let wf_thm_id = Nameops.out_name (fresh_id (Name (Id.of_string "wf_R"))) in
   let acc_rec_arg_id =
-    Nameops.out_name (fresh_id (Name (id_of_string ("Acc_"^(string_of_id rec_arg_id)))))
+    Nameops.out_name (fresh_id (Name (Id.of_string ("Acc_"^(Id.to_string rec_arg_id)))))
   in
   let revert l =
-    tclTHEN (h_generalize (List.map mkVar l)) (clear l)
+    tclTHEN (Tactics.Simple.generalize (List.map mkVar l)) (clear l)
   in
   let fix_id = Nameops.out_name (fresh_id (Name hrec_id)) in
   let prove_rec_arg_acc g =
       ((* observe_tac "prove_rec_arg_acc"  *)
 	 (tclCOMPLETE
 	    (tclTHEN
-	       (assert_by (Name wf_thm_id)
+	       (Proofview.V82.of_tactic (assert_by (Name wf_thm_id)
 		  (mkApp (delayed_force well_founded,[|input_type;relation|]))
-		  (fun g -> (* observe_tac "prove wf" *) (tclCOMPLETE (wf_tac is_mes)) g))
+		  (Proofview.V82.tactic (fun g -> (* observe_tac "prove wf" *) (tclCOMPLETE (wf_tac is_mes)) g))))
 	       (
 		 (* observe_tac  *)
 (* 		   "apply wf_thm"  *)
-		 h_simplest_apply (mkApp(mkVar wf_thm_id,[|mkVar rec_arg_id|]))
+		 Proofview.V82.of_tactic (Tactics.Simple.apply (mkApp(mkVar wf_thm_id,[|mkVar rec_arg_id|])))
 	       )
 	    )
 	 )
@@ -1570,7 +1566,7 @@ let prove_principle_for_gen
   let args_ids = List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.args in
   let lemma =
     match !tcc_lemma_ref with
-     | None -> anomaly ( "No tcc proof !!")
+     | None -> error "No tcc proof !!"
      | Some lemma -> lemma
   in
 (*   let rec list_diff del_list check_list = *)
@@ -1588,18 +1584,18 @@ let prove_principle_for_gen
     let hyps = pf_ids_of_hyps gls in
       let hid =
 	next_ident_away_in_goal
-	  (id_of_string "prov")
+	  (Id.of_string "prov")
 	  hyps
       in
       tclTHENSEQ
 	[
 	  generalize [lemma];
-	  h_intro hid;
-	  Elim.h_decompose_and (mkVar hid);
+	  Proofview.V82.of_tactic (Simple.intro hid);
+	  Proofview.V82.of_tactic (Elim.h_decompose_and (mkVar hid));
 	  (fun g ->
 	     let new_hyps = pf_ids_of_hyps g in
-	     tcc_list := List.rev (list_subtract new_hyps (hid::hyps));
-	     if !tcc_list = []
+	     tcc_list := List.rev (List.subtract Id.equal new_hyps (hid::hyps));
+	     if List.is_empty !tcc_list
 	     then
 	       begin
 		 tcc_list := [hid];
@@ -1617,22 +1613,22 @@ let prove_principle_for_gen
 	(List.rev_map (fun (na,_,_) -> Nameops.out_name na)
 	   (princ_info.args@princ_info.branches@princ_info.predicates@princ_info.params)
 	);
-      (* observe_tac "" *) (assert_by
+      (* observe_tac "" *) Proofview.V82.of_tactic (assert_by
 	 (Name acc_rec_arg_id)
  	 (mkApp (delayed_force acc_rel,[|input_type;relation;mkVar rec_arg_id|]))
-	 (prove_rec_arg_acc)
+	 (Proofview.V82.tactic prove_rec_arg_acc)
       );
 (*       observe_tac "reverting" *) (revert (List.rev (acc_rec_arg_id::args_ids)));
 (*       (fun g -> observe (Printer.pr_goal (sig_it g) ++ fnl () ++  *)
 (* 			   str "fix arg num" ++ int (List.length args_ids + 1) ); tclIDTAC g); *)
-      (* observe_tac "h_fix " *) (h_fix (Some fix_id) (List.length args_ids + 1));
+      (* observe_tac "h_fix " *) (fix (Some fix_id) (List.length args_ids + 1));
 (*       (fun g -> observe (Printer.pr_goal (sig_it g) ++ fnl() ++ pr_lconstr_env (pf_env g ) (pf_type_of g (mkVar fix_id) )); tclIDTAC g); *)
       h_intros (List.rev (acc_rec_arg_id::args_ids));
-      Equality.rewriteLR (mkConst eq_ref);
+      Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_ref));
       (* observe_tac "finish" *) (fun gl' ->
 	 let body =
 	   let _,args = destApp (pf_concl gl') in
-	   array_last args
+	   Array.last args
 	 in
 	 let body_info rec_hyps =
 	   {
@@ -1677,14 +1673,14 @@ let prove_principle_for_gen
 	     is_valid = is_valid_hypothesis predicates_names
 	   }
 	 in
-	 let ptes_info : pte_info Idmap.t =
+	 let ptes_info : pte_info Id.Map.t =
 	   List.fold_left
 	     (fun map pte_id ->
-		Idmap.add pte_id
+		Id.Map.add pte_id
 		  pte_info
 		  map
 	     )
-	     Idmap.empty
+	     Id.Map.empty
 	     predicates_names
 	 in
 	 let make_proof rec_hyps =
diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml
index 04fcc8d4..545f8931 100644
--- a/plugins/funind/functional_principles_types.ml
+++ b/plugins/funind/functional_principles_types.ml
@@ -1,58 +1,25 @@
 open Printer
+open Errors
 open Util
 open Term
+open Vars
+open Context
 open Namegen
 open Names
-open Declarations
+open Declareops
 open Pp
 open Entries
-open Hiddentac
-open Evd
-open Tacmach
-open Proof_type
-open Tacticals
 open Tactics
 open Indfun_common
 open Functional_principles_proofs
+open Misctypes
 
 exception Toberemoved_with_rel of int*constr
 exception Toberemoved
 
-
-let pr_elim_scheme el =
-  let env = Global.env () in
-  let msg = str "params := " ++ Printer.pr_rel_context env el.params in
-  let env = Environ.push_rel_context el.params env in
-  let msg = msg ++ fnl () ++ str "predicates := "++ Printer.pr_rel_context env el.predicates in
-  let env = Environ.push_rel_context el.predicates env in
-  let msg = msg ++ fnl () ++ str "branches := " ++ Printer.pr_rel_context env el.branches in
-  let env = Environ.push_rel_context el.branches env in
-  let msg = msg ++ fnl () ++ str "args := " ++ Printer.pr_rel_context env el.args in
-  let env = Environ.push_rel_context el.args env in
-  msg ++ fnl () ++ str "concl := " ++ pr_lconstr_env env el.concl
-
-
 let observe s =
   if do_observe ()
-  then Pp.msgnl s
-
-
-let pr_elim_scheme el =
-  let env = Global.env () in
-  let msg = str "params := " ++ Printer.pr_rel_context env el.params in
-  let env = Environ.push_rel_context el.params env in
-  let msg = msg ++ fnl () ++ str "predicates := "++ Printer.pr_rel_context env el.predicates in
-  let env = Environ.push_rel_context el.predicates env in
-  let msg = msg ++ fnl () ++ str "branches := " ++ Printer.pr_rel_context env el.branches in
-  let env = Environ.push_rel_context el.branches env in
-  let msg = msg ++ fnl () ++ str "args := " ++ Printer.pr_rel_context env el.args in
-  let env = Environ.push_rel_context el.args env in
-  msg ++ fnl () ++ str "concl := " ++ pr_lconstr_env env el.concl
-
-
-let observe s =
-  if do_observe ()
-  then Pp.msgnl s
+  then Pp.msg_debug s
 
 (*
    Transform an inductive induction principle into
@@ -63,14 +30,14 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
   let env = Global.env () in
   let env_with_params = Environ.push_rel_context princ_type_info.params env in
   let tbl = Hashtbl.create 792 in
-  let rec change_predicates_names (avoid:identifier list) (predicates:rel_context)  : rel_context =
+  let rec change_predicates_names (avoid:Id.t list) (predicates:rel_context)  : rel_context =
     match predicates with
     | [] -> []
     |(Name x,v,t)::predicates ->
        let id =  Namegen.next_ident_away x avoid in
        Hashtbl.add tbl id x;
        (Name id,v,t)::(change_predicates_names (id::avoid) predicates)
-    | (Anonymous,_,_)::_ -> anomaly "Anonymous property binder "
+    | (Anonymous,_,_)::_ -> anomaly (Pp.str "Anonymous property binder ")
   in
   let avoid = (Termops.ids_of_context env_with_params ) in
   let princ_type_info =
@@ -91,7 +58,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
     Nameops.out_name x,None,compose_prod real_args (mkSort new_sort)
   in
   let new_predicates =
-    list_map_i
+    List.map_i
       change_predicate_sort
       0
       princ_type_info.predicates
@@ -99,16 +66,16 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
   let env_with_params_and_predicates = List.fold_right Environ.push_named new_predicates env_with_params in
   let rel_as_kn =
     fst (match princ_type_info.indref with
-	   | Some (Libnames.IndRef ind) -> ind
+	   | Some (Globnames.IndRef ind) -> ind
 	   | _ -> error "Not a valid predicate"
 	)
   in
   let ptes_vars = List.map (fun (id,_,_) -> id) new_predicates in
   let is_pte =
-    let set = List.fold_right Idset.add ptes_vars Idset.empty in
+    let set = List.fold_right Id.Set.add ptes_vars Id.Set.empty in
     fun t ->
       match kind_of_term t with
-	| Var id -> Idset.mem id set
+	| Var id -> Id.Set.mem id set
 	| _ -> false
   in
   let pre_princ =
@@ -126,17 +93,17 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
   let pre_princ = substl (List.map mkVar ptes_vars) pre_princ in
   let is_dom c =
     match kind_of_term c with
-      | Ind((u,_)) -> u = rel_as_kn
-      | Construct((u,_),_) -> u = rel_as_kn
+      | Ind((u,_),_) -> MutInd.equal u rel_as_kn
+      | Construct(((u,_),_),_) -> MutInd.equal u rel_as_kn
       | _ -> false
   in
   let get_fun_num c =
     match kind_of_term c with
-      | Ind(_,num) -> num
-      | Construct((_,num),_) -> num
+      | Ind((_,num),_) -> num
+      | Construct(((_,num),_),_) -> num
       | _ -> assert false
   in
-  let dummy_var = mkVar (id_of_string "________") in
+  let dummy_var = mkVar (Id.of_string "________") in
   let mk_replacement c i args =
     let res = mkApp(rel_to_fun.(i), Array.map Termops.pop (array_get_start args)) in
 (*     observe (str "replacing " ++ pr_lconstr c ++ str " by "  ++ pr_lconstr res); *)
@@ -157,7 +124,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
 	    compute_new_princ_type_for_binder  remove mkLambda env x t b
 	| Ind _ | Construct _ when is_dom pre_princ -> raise Toberemoved
 	| App(f,args) when is_dom f ->
-	    let var_to_be_removed = destRel (array_last args) in
+	    let var_to_be_removed = destRel (Array.last args) in
 	    let num = get_fun_num f in
 	    raise (Toberemoved_with_rel (var_to_be_removed,mk_replacement pre_princ num args))
 	| App(f,args) ->
@@ -191,7 +158,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
     begin
       try
 	let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in
-	let new_x : name = get_name (Termops.ids_of_context env) x in
+	let new_x : Name.t = get_name (Termops.ids_of_context env) x in
 	let new_env = Environ.push_rel (x,None,t) env in
 	let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in
 	 if List.exists (eq_constr (mkRel 1)) binders_to_remove_from_b
@@ -220,7 +187,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
       try
 	let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in
 	let new_v,binders_to_remove_from_v = compute_new_princ_type remove env v in
-	let new_x : name = get_name (Termops.ids_of_context env) x in
+	let new_x : Name.t = get_name (Termops.ids_of_context env) x in
 	let new_env = Environ.push_rel (x,Some v,t) env in
 	let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in
 	if List.exists (eq_constr (mkRel 1)) binders_to_remove_from_b
@@ -255,7 +222,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
   in
   let pre_res =
     replace_vars
-      (list_map_i (fun i id -> (id, mkRel i)) 1 ptes_vars)
+      (List.map_i (fun i id -> (id, mkRel i)) 1 ptes_vars)
       (lift (List.length ptes_vars) pre_res)
   in
   it_mkProd_or_LetIn
@@ -271,8 +238,10 @@ let change_property_sort toSort princ princName =
   let princ_info = compute_elim_sig princ in
   let change_sort_in_predicate (x,v,t) =
     (x,None,
-     let args,_ = decompose_prod t in
-     compose_prod args (mkSort toSort)
+     let args,ty = decompose_prod t in
+     let s = destSort ty in
+       Global.add_constraints (Univ.enforce_leq (univ_of_sort toSort) (univ_of_sort s) Univ.Constraint.empty);
+       compose_prod args (mkSort toSort)
     )
   in
   let princName_as_constr = Constrintern.global_reference princName in
@@ -288,23 +257,6 @@ let change_property_sort toSort princ princName =
     )
     princ_info.params
 
-
-let pp_dur time time' =
-  str (string_of_float (System.time_difference time time'))
-
-(* let qed () = save_named true  *)
-let defined () =
-  try
-    Lemmas.save_named false
-  with
-    | UserError("extract_proof",msg) ->
-	Util.errorlabstrm
-	  "defined"
-	  ((try
-	      str "On goal : " ++ fnl () ++  pr_open_subgoals () ++ fnl ()
-	    with e when Errors.noncritical e -> mt ()
-	   ) ++msg)
-
 let build_functional_principle interactive_proof old_princ_type sorts funs i proof_tac hook =
   (* First we get the type of the old graph principle *)
   let mutr_nparams = (compute_elim_sig old_princ_type).nparams in
@@ -319,23 +271,25 @@ let build_functional_principle interactive_proof old_princ_type sorts funs i pro
   (*    Pp.msgnl (str "computing principle type := " ++ System.fmt_time_difference time1 time2); *)
      observe (str "new_principle_type : " ++ pr_lconstr new_principle_type);
   let new_princ_name =
-    next_ident_away_in_goal (id_of_string "___________princ_________") []
+    next_ident_away_in_goal (Id.of_string "___________princ_________") []
   in
+  let hook = Lemmas.mk_hook (hook new_principle_type) in
   begin
     Lemmas.start_proof
       new_princ_name
-      (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem))
-      new_principle_type
-      (hook new_principle_type)
+      (Decl_kinds.Global,false,(Decl_kinds.Proof Decl_kinds.Theorem))
+      (*FIXME*) Evd.empty
+    new_principle_type
+      hook
     ;
     (*       let _tim1 = System.get_time ()  in *)
-    Pfedit.by  (proof_tac (Array.map mkConst funs) mutr_nparams);
+    ignore (Pfedit.by  (Proofview.V82.tactic (proof_tac (Array.map mkConst funs) mutr_nparams)));
     (*       let _tim2 =  System.get_time ()  in *)
     (* 	begin *)
     (* 	  let dur1 = System.time_difference tim1 tim2 in *)
     (* 	  Pp.msgnl (str ("Time to compute proof: ") ++ str (string_of_float dur1)); *)
     (* 	end; *)
-    get_proof_clean true
+    get_proof_clean true, Ephemeron.create hook
   end
 
 
@@ -347,7 +301,7 @@ let generate_functional_principle
   try
 
   let f = funs.(i) in
-  let type_sort = Termops.new_sort_in_family InType in
+  let type_sort = Universes.new_sort_in_family InType in
   let new_sorts =
     match sorts with
       | None -> Array.make (Array.length funs) (type_sort)
@@ -357,42 +311,35 @@ let generate_functional_principle
     match new_princ_name with
       | Some (id) -> id,id
       | None ->
-	  let id_of_f = id_of_label (con_label f) in
+	  let id_of_f = Label.to_id (con_label f) in
 	  id_of_f,Indrec.make_elimination_ident id_of_f (family_of_sort type_sort)
   in
   let names = ref [new_princ_name] in
-  let hook new_principle_type _ _  =
-    if sorts = None
+  let hook new_principle_type _ _ =
+    if Option.is_empty sorts
     then
-      (*     let id_of_f = id_of_label (con_label f) in *)
+      (*     let id_of_f = Label.to_id (con_label f) in *)
       let register_with_sort fam_sort =
-	let s = Termops.new_sort_in_family fam_sort in
+	let s = Universes.new_sort_in_family fam_sort in
 	let name = Indrec.make_elimination_ident base_new_princ_name fam_sort in
 	let value = change_property_sort s new_principle_type new_princ_name in
 	(*       Pp.msgnl (str "new principle := " ++ pr_lconstr value); *)
-	let ce =
-	  { const_entry_body = value;
-            const_entry_secctx = None;
-	    const_entry_type = None;
-	    const_entry_opaque = false }
-	in
+	let ce = Declare.definition_entry value in (*FIXME, no poly, nothing *)
 	ignore(
 	  Declare.declare_constant
 	    name
 	    (Entries.DefinitionEntry ce,
-	     Decl_kinds.IsDefinition (Decl_kinds.Scheme)
-	    )
+	     Decl_kinds.IsDefinition (Decl_kinds.Scheme))
 	);
-	Flags.if_verbose
-	  (fun id -> Pp.msgnl (Ppconstr.pr_id id ++ str " is defined"))
-	  name;
+	Declare.definition_message name;
 	names := name :: !names
       in
       register_with_sort InProp;
       register_with_sort InSet
   in
-  let (id,(entry,g_kind,hook)) =
-    build_functional_principle interactive_proof old_princ_type new_sorts funs i proof_tac hook
+  let ((id,(entry,g_kind)),hook) =
+    build_functional_principle interactive_proof old_princ_type new_sorts funs i
+    proof_tac hook
   in
   (* Pr  1278 :
      Don't forget to close the goal if an error is raised !!!!
@@ -403,10 +350,10 @@ let generate_functional_principle
       begin
 	try
 	  let id = Pfedit.get_current_proof_name () in
-	  let s = string_of_id id in
+	  let s = Id.to_string id in
 	  let n = String.length "___________princ_________" in
 	  if String.length s >= n
-	  then if String.sub s 0 n = "___________princ_________"
+	  then if String.equal (String.sub s 0 n) "___________princ_________"
 	  then Pfedit.delete_current_proof ()
 	  else ()
 	  else ()
@@ -420,26 +367,25 @@ let generate_functional_principle
 exception Not_Rec
 
 let get_funs_constant mp dp =
-  let rec get_funs_constant const e : (Names.constant*int) array =
+  let get_funs_constant const e : (Names.constant*int) array =
     match kind_of_term ((strip_lam e)) with
       | Fix((_,(na,_,_))) ->
 	  Array.mapi
 	    (fun i na ->
 	       match na with
 		 | Name id ->
-		     let const = make_con mp dp (label_of_id id) in
+		     let const = make_con mp dp (Label.of_id id) in
 		     const,i
 		 | Anonymous ->
-		     anomaly "Anonymous fix"
+		     anomaly (Pp.str "Anonymous fix")
 	    )
 	    na
       | _ -> [|const,0|]
   in
   function const ->
     let find_constant_body const =
-      match body_of_constant (Global.lookup_constant const) with
-	| Some b ->
-	    let body = force b in
+      match Global.body_of_constant const with
+	| Some body ->
 	    let body = Tacred.cbv_norm_flags
 	      (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA])
 	      (Global.env ())
@@ -462,7 +408,7 @@ let get_funs_constant mp dp =
       let first_params = List.hd l_params  in
       List.iter
 	(fun params ->
-	   if not (list_equal (fun (n1, c1) (n2, c2) -> n1 = n2 && eq_constr c1 c2) first_params params)
+	   if not (List.equal (fun (n1, c1) (n2, c2) -> Name.equal n1 n2 && eq_constr c1 c2) first_params params)
 	   then error "Not a mutal recursive block"
 	)
 	l_params
@@ -474,14 +420,15 @@ let get_funs_constant mp dp =
 	  match kind_of_term body with
 	    | Fix((idxs,_),(na,ta,ca)) -> (idxs,na,ta,ca)
 	    | _ ->
-		if is_first && (List.length l_bodies = 1)
+		if is_first && Int.equal (List.length l_bodies) 1
 		then raise Not_Rec
 		else error "Not a mutal recursive block"
 	in
 	let first_infos = extract_info true (List.hd l_bodies) in
 	let check body  = (* Hope this is correct *)
 	  let eq_infos (ia1, na1, ta1, ca1) (ia2, na2, ta2, ca2) =
-	    ia1 = ia2 && na1 = na2 && array_equal eq_constr ta1 ta2 && array_equal eq_constr ca1 ca2
+            Array.equal Int.equal ia1 ia2 && Array.equal Name.equal na1 na2 &&
+            Array.equal eq_constr ta1 ta2 && Array.equal eq_constr ca1 ca2
 	  in
 	  if not (eq_infos first_infos (extract_info false body))
 	  then  error "Not a mutal recursive block"
@@ -494,7 +441,7 @@ let get_funs_constant mp dp =
 exception No_graph_found
 exception Found_type of int
 
-let make_scheme (fas : (constant*Glob_term.glob_sort) list) : Entries.definition_entry list =
+let make_scheme (fas : (constant*glob_sort) list) : Entries.definition_entry list =
   let env = Global.env ()
   and sigma = Evd.empty in
   let funs = List.map fst fas in
@@ -513,26 +460,27 @@ let make_scheme (fas : (constant*Glob_term.glob_sort) list) : Entries.definition
   let funs_indexes =
     let this_block_funs_indexes = Array.to_list this_block_funs_indexes in
     List.map
-      (function const -> List.assoc const this_block_funs_indexes)
+      (function cst -> List.assoc_f Constant.equal cst this_block_funs_indexes)
       funs
   in
   let ind_list =
     List.map
       (fun (idx) ->
 	 let ind = first_fun_kn,idx in
-	 ind,true,prop_sort
+	   (ind,Univ.Instance.empty)(*FIXME*),true,prop_sort
       )
       funs_indexes
   in
+  let sigma, schemes = 
+    Indrec.build_mutual_induction_scheme env sigma ind_list
+  in
   let l_schemes =
-    List.map
-      (Typing.type_of env sigma)
-      (Indrec.build_mutual_induction_scheme env sigma ind_list)
+    List.map (Typing.type_of env sigma) schemes
   in
   let i = ref (-1) in
   let sorts =
     List.rev_map (fun (_,x) ->
-		Termops.new_sort_in_family (Pretyping.interp_elimination_sort x)
+		Universes.new_sort_in_family (Pretyping.interp_elimination_sort x)
 	     )
       fas
   in
@@ -540,9 +488,9 @@ let make_scheme (fas : (constant*Glob_term.glob_sort) list) : Entries.definition
   let first_type,other_princ_types =
     match l_schemes with
 	s::l_schemes -> s,l_schemes
-      | _ -> anomaly ""
+      | _ -> anomaly (Pp.str "")
   in
-  let (_,(const,_,_)) =
+  let ((_,(const,_)),_) =
     try
       build_functional_principle false
 	first_type
@@ -556,10 +504,10 @@ let make_scheme (fas : (constant*Glob_term.glob_sort) list) : Entries.definition
       begin
 	try
 	  let id = Pfedit.get_current_proof_name () in
-	  let s = string_of_id id in
+	  let s = Id.to_string id in
 	  let n = String.length "___________princ_________" in
 	  if String.length s >= n
-	  then if String.sub s 0 n = "___________princ_________"
+	  then if String.equal (String.sub s 0 n) "___________princ_________"
 	  then Pfedit.delete_current_proof ()
 	  else ()
 	  else ()
@@ -574,13 +522,13 @@ let make_scheme (fas : (constant*Glob_term.glob_sort) list) : Entries.definition
     let finfos = find_Function_infos this_block_funs.(0) in
     try
       let equation =  Option.get finfos.equation_lemma in
-      Declarations.is_opaque (Global.lookup_constant equation)
+      Declareops.is_opaque (Global.lookup_constant equation)
     with Option.IsNone -> (* non recursive definition *)
       false
   in
   let const = {const with const_entry_opaque = opacity } in
   (* The others are just deduced *)
-  if other_princ_types = []
+  if List.is_empty other_princ_types
   then
     [const]
   else
@@ -590,7 +538,7 @@ let make_scheme (fas : (constant*Glob_term.glob_sort) list) : Entries.definition
       List.map (compute_new_princ_type_from_rel funs sorts) other_princ_types
     in
     let first_princ_body,first_princ_type = const.Entries.const_entry_body, const.Entries.const_entry_type in
-    let ctxt,fix = decompose_lam_assum first_princ_body in (* the principle has for forall ...., fix .*)
+    let ctxt,fix = decompose_lam_assum (fst(fst(Future.force first_princ_body))) in (* the principle has for forall ...., fix .*)
     let (idxs,_),(_,ta,_ as decl) = destFix fix in
     let other_result =
       List.map (* we can now compute the other principles *)
@@ -616,7 +564,7 @@ let make_scheme (fas : (constant*Glob_term.glob_sort) list) : Entries.definition
 	   (* If we reach this point, the two principle are not mutually recursive
 	      We fall back to the previous method
 	   *)
-	     let (_,(const,_,_)) =
+	     let ((_,(const,_)),_) =
 	       build_functional_principle
 		 false
 		 (List.nth other_princ_types (!i - 1))
@@ -632,7 +580,8 @@ let make_scheme (fas : (constant*Glob_term.glob_sort) list) : Entries.definition
 	     Termops.it_mkLambda_or_LetIn (mkFix((idxs,i),decl)) ctxt
 	   in
 	   {const with
-	      Entries.const_entry_body = princ_body;
+	      Entries.const_entry_body = 
+                (Future.from_val (Term_typing.mk_pure_proof princ_body));
 	      Entries.const_entry_type = Some scheme_type
 	   }
       )
@@ -648,11 +597,11 @@ let build_scheme fas =
 	 (fun (_,f,sort) ->
 	    let f_as_constant =
 	      try
-		match Nametab.global f with
-		  | Libnames.ConstRef c -> c
-		  | _ -> Util.error "Functional Scheme can only be used with functions"
+		match Smartlocate.global_with_alias f with
+		  | Globnames.ConstRef c -> c
+		  | _ -> Errors.error "Functional Scheme can only be used with functions"
 	      with Not_found ->
-	      	Util.error ("Cannot find "^ Libnames.string_of_reference f)
+	      	Errors.error ("Cannot find "^ Libnames.string_of_reference f)
 	    in
 	    (f_as_constant,sort)
 	 )
@@ -665,8 +614,7 @@ let build_scheme fas =
 	 (Declare.declare_constant
 	    princ_id
 	    (Entries.DefinitionEntry def_entry,Decl_kinds.IsProof Decl_kinds.Theorem));
-       Flags.if_verbose
-	 (fun id -> Pp.msgnl (Ppconstr.pr_id id ++ str " is defined")) princ_id
+       Declare.definition_message princ_id
     )
     fas
     bodies_types;
@@ -681,10 +629,10 @@ let build_case_scheme fa =
 (*     Constrintern.global_reference  id *)
 (*   in  *)
   let funs =  (fun (_,f,_) ->
-		 try Libnames.constr_of_global (Nametab.global f)
+		 try fst (Universes.unsafe_constr_of_global (Smartlocate.global_with_alias f))
 		 with Not_found ->
-		   Util.error ("Cannot find "^ Libnames.string_of_reference f)) fa in
-  let first_fun = destConst  funs in
+		   Errors.error ("Cannot find "^ Libnames.string_of_reference f)) fa in
+  let first_fun,u = destConst  funs in
 
   let funs_mp,funs_dp,_ = Names.repr_con first_fun in
   let first_fun_kn = try fst (find_Function_infos  first_fun).graph_ind with Not_found -> raise No_graph_found in
@@ -696,16 +644,18 @@ let build_case_scheme fa =
   let prop_sort = InProp in
   let funs_indexes =
     let this_block_funs_indexes = Array.to_list this_block_funs_indexes in
-    List.assoc (destConst funs) this_block_funs_indexes
+    List.assoc_f Constant.equal (fst (destConst funs)) this_block_funs_indexes
   in
   let ind_fun =
 	 let ind = first_fun_kn,funs_indexes in
-	 ind,prop_sort
+	   (ind,Univ.Instance.empty)(*FIXME*),prop_sort
   in
-  let scheme_type =  (Typing.type_of env sigma ) ((fun (ind,sf) -> Indrec.build_case_analysis_scheme_default env sigma ind sf)  ind_fun) in
+  let sigma, scheme = 
+    (fun (ind,sf) -> Indrec.build_case_analysis_scheme_default env sigma ind sf)  ind_fun in
+  let scheme_type =  (Typing.type_of env sigma ) scheme in
   let sorts =
     (fun (_,_,x) ->
-       Termops.new_sort_in_family (Pretyping.interp_elimination_sort x)
+       Universes.new_sort_in_family (Pretyping.interp_elimination_sort x)
     )
       fa
   in
@@ -722,6 +672,6 @@ let build_case_scheme fa =
       (Some princ_name)
       this_block_funs
       0
-      (prove_princ_for_struct false 0 [|destConst funs|])
+      (prove_princ_for_struct false 0 [|fst (destConst funs)|])
   in
   ()
diff --git a/plugins/funind/functional_principles_types.mli b/plugins/funind/functional_principles_types.mli
index 1c02c16e..a16b834f 100644
--- a/plugins/funind/functional_principles_types.mli
+++ b/plugins/funind/functional_principles_types.mli
@@ -1,6 +1,6 @@
 open Names
 open Term
-
+open Misctypes
 
 val generate_functional_principle :
   (* do we accept interactive proving *)
@@ -10,7 +10,7 @@ val generate_functional_principle :
   (* *)
   sorts array option ->
   (* Name of the new principle *)
-  (identifier) option ->
+  (Id.t) option ->
   (* the compute functions to use   *)
   constant array ->
   (* We prove the nth- principle *)
@@ -27,8 +27,8 @@ val compute_new_princ_type_from_rel : constr array -> sorts array ->
 
 exception No_graph_found
 
-val make_scheme : (constant*Glob_term.glob_sort) list -> Entries.definition_entry list
+val make_scheme : (constant*glob_sort) list -> Entries.definition_entry list
 
-val build_scheme : (identifier*Libnames.reference*Glob_term.glob_sort) list ->  unit
-val build_case_scheme : (identifier*Libnames.reference*Glob_term.glob_sort)  ->  unit
+val build_scheme : (Id.t*Libnames.reference*glob_sort) list ->  unit
+val build_case_scheme : (Id.t*Libnames.reference*glob_sort)  ->  unit
 
diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4
index ffaa2208..fd48ab59 100644
--- a/plugins/funind/g_indfun.ml4
+++ b/plugins/funind/g_indfun.ml4
@@ -1,35 +1,38 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
-(*i camlp4deps: "parsing/grammar.cma" i*)
+(*i camlp4deps: "grammar/grammar.cma" i*)
+open Compat
 open Util
 open Term
+open Vars
 open Names
 open Pp
-open Topconstr
+open Constrexpr
 open Indfun_common
 open Indfun
 open Genarg
-open Pcoq
 open Tacticals
-open Constr
+open Misctypes
+
+DECLARE PLUGIN "recdef_plugin"
 
 let pr_binding prc = function
-  | loc, Glob_term.NamedHyp id, c -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ cut () ++ prc c)
-  | loc, Glob_term.AnonHyp n, c -> hov 1 (int n ++ str " := " ++ cut () ++ prc c)
+  | loc, NamedHyp id, c -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ cut () ++ prc c)
+  | loc, AnonHyp n, c -> hov 1 (int n ++ str " := " ++ cut () ++ prc c)
 
 let pr_bindings prc prlc = function
-  | Glob_term.ImplicitBindings l ->
+  | ImplicitBindings l ->
       brk (1,1) ++ str "with" ++ brk (1,1) ++
-      Util.prlist_with_sep spc prc l
-  | Glob_term.ExplicitBindings l ->
+      pr_sequence prc l
+  | ExplicitBindings l ->
       brk (1,1) ++ str "with" ++ brk (1,1) ++
-        Util.prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l
-  | Glob_term.NoBindings -> mt ()
+        pr_sequence (fun b -> str"(" ++ pr_binding prlc b ++ str")") l
+  | NoBindings -> mt ()
 
 let pr_with_bindings prc prlc (c,bl) =
   prc c ++ hv 0 (pr_bindings prc prlc bl)
@@ -69,18 +72,23 @@ END
 TACTIC EXTEND newfuninv
    [ "functional" "inversion"  quantified_hypothesis(hyp) reference_opt(fname) ] ->
      [
-       Invfun.invfun hyp fname
+       Proofview.V82.tactic (Invfun.invfun hyp fname)
      ]
 END
 
 
-let pr_intro_as_pat prc _ _ pat =
+let pr_intro_as_pat _prc _ _ pat =
   match pat with
-    | Some pat -> spc () ++ str "as" ++ spc () ++ pr_intro_pattern pat
+    | Some pat ->
+      spc () ++ str "as" ++ spc () ++ (* Miscprint.pr_intro_pattern prc  pat *)
+        str"<simple_intropattern>"
     | None -> mt ()
 
+let out_disjunctive = function
+  | loc, IntroAction (IntroOrAndPattern l) -> (loc,l)
+  | _ -> Errors.error "Disjunctive or conjunctive intro pattern expected."
 
-ARGUMENT EXTEND with_names TYPED AS intro_pattern_opt PRINTED BY pr_intro_as_pat
+ARGUMENT EXTEND with_names TYPED AS simple_intropattern_opt PRINTED BY pr_intro_as_pat
 |   [ "as"  simple_intropattern(ipat) ] -> [ Some ipat ]
 | []  ->[ None ]
 END
@@ -96,7 +104,7 @@ TACTIC EXTEND newfunind
 	 | [c] -> c
 	 | c::cl -> applist(c,cl)
        in
-       Extratactics.onSomeWithHoles (fun x -> functional_induction true c x pat) princl ]
+       Extratactics.onSomeWithHoles (fun x -> Proofview.V82.tactic (functional_induction true c x (Option.map out_disjunctive pat))) princl ]
 END
 (***** debug only ***)
 TACTIC EXTEND snewfunind
@@ -107,11 +115,11 @@ TACTIC EXTEND snewfunind
 	 | [c] -> c
 	 | c::cl -> applist(c,cl)
        in
-       Extratactics.onSomeWithHoles (fun x -> functional_induction false c x pat) princl ]
+       Extratactics.onSomeWithHoles (fun x -> Proofview.V82.tactic (functional_induction false c x (Option.map out_disjunctive pat))) princl ]
 END
 
 
-let pr_constr_coma_sequence prc _ _ = Util.prlist_with_sep Util.pr_comma prc
+let pr_constr_coma_sequence prc _ _ = prlist_with_sep pr_comma prc
 
 ARGUMENT EXTEND constr_coma_sequence'
   TYPED AS constr_list
@@ -133,34 +141,37 @@ module Gram = Pcoq.Gram
 module Vernac = Pcoq.Vernac_
 module Tactic = Pcoq.Tactic
 
-module FunctionGram =
-struct
-  let gec s = Gram.entry_create ("Function."^s)
-		(* types *)
-  let function_rec_definition_loc : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) located Gram.entry = gec "function_rec_definition_loc"
-end
-open FunctionGram
+type function_rec_definition_loc_argtype = (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) Loc.located
+
+let (wit_function_rec_definition_loc : function_rec_definition_loc_argtype Genarg.uniform_genarg_type) =
+  Genarg.create_arg None "function_rec_definition_loc"
+
+let function_rec_definition_loc =
+  Pcoq.create_generic_entry "function_rec_definition_loc" (Genarg.rawwit wit_function_rec_definition_loc)
 
 GEXTEND Gram
   GLOBAL: function_rec_definition_loc ;
 
   function_rec_definition_loc:
-    [ [ g = Vernac.rec_definition -> loc, g ]]
+    [ [ g = Vernac.rec_definition -> !@loc, g ]]
     ;
 
-  END
-type 'a function_rec_definition_loc_argtype = ((Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) located, 'a) Genarg.abstract_argument_type
+END
 
-let (wit_function_rec_definition_loc : Genarg.tlevel function_rec_definition_loc_argtype),
-  (globwit_function_rec_definition_loc : Genarg.glevel function_rec_definition_loc_argtype),
-  (rawwit_function_rec_definition_loc : Genarg.rlevel function_rec_definition_loc_argtype) =
-  Genarg.create_arg None "function_rec_definition_loc"
+(* TASSI: n'importe quoi ! *)
 VERNAC COMMAND EXTEND Function
-   ["Function" ne_function_rec_definition_loc_list_sep(recsl,"with")] ->
-	[
-	  do_generate_principle false (List.map snd recsl);
-
-	]
+   ["Function" ne_function_rec_definition_loc_list_sep(recsl,"with")]
+    => [ let hard = List.exists (function
+           | _,((_,(_,(CMeasureRec _|CWfRec _)),_,_,_),_) -> true
+           | _,((_,(_,CStructRec),_,_,_),_) -> false) recsl in
+         match
+           Vernac_classifier.classify_vernac
+             (Vernacexpr.VernacFixpoint(None, List.map snd recsl))
+         with
+         | Vernacexpr.VtSideff ids, _ when hard ->
+             Vernacexpr.(VtStartProof ("Classic", GuaranteesOpacity, ids), VtLater)
+         | x -> x ]
+    -> [ do_generate_principle false (List.map snd recsl) ]
 END
 
 let pr_fun_scheme_arg (princ_name,fun_name,s) =
@@ -175,23 +186,25 @@ END
 
 
 let warning_error names e =
-  let e = Cerrors.process_vernac_interp_error e in
+  let (e, _) = Cerrors.process_vernac_interp_error (e, Exninfo.null) in
   match e with
     | Building_graph e ->
 	Pp.msg_warning
 	  (str "Cannot define graph(s) for " ++
-	     h 1 (prlist_with_sep (fun _ -> str","++spc ()) Libnames.pr_reference names) ++
+	     h 1 (pr_enum Libnames.pr_reference names) ++
 	     if do_observe () then (spc () ++ Errors.print e) else mt ())
     | Defining_principle e ->
 	Pp.msg_warning
 	  (str "Cannot define principle(s) for "++
-	     h 1 (prlist_with_sep (fun _ -> str","++spc ()) Libnames.pr_reference names) ++
+	     h 1 (pr_enum Libnames.pr_reference names) ++
 	     if do_observe () then Errors.print e else mt ())
     | _ -> raise e
 
 
 VERNAC COMMAND EXTEND NewFunctionalScheme
-   ["Functional" "Scheme" ne_fun_scheme_arg_list_sep(fas,"with") ] ->
+   ["Functional" "Scheme" ne_fun_scheme_arg_list_sep(fas,"with") ]
+   => [ Vernacexpr.VtSideff(List.map pi1 fas), Vernacexpr.VtLater ]
+   ->
     [
       begin
 	try
@@ -202,13 +215,13 @@ VERNAC COMMAND EXTEND NewFunctionalScheme
 	      | (_,fun_name,_)::_ ->
 		  begin
 		    begin
-		      make_graph (Nametab.global fun_name)
+		      make_graph (Smartlocate.global_with_alias fun_name)
 		    end
 		    ;
 		    try Functional_principles_types.build_scheme fas
 		    with Functional_principles_types.No_graph_found ->
-		      Util.error ("Cannot generate induction principle(s)")
-    		      | e when Errors.noncritical e ->
+		      Errors.error ("Cannot generate induction principle(s)")
+		      | e when Errors.noncritical e ->
 			  let names = List.map (fun (_,na,_) -> na) fas in
 			  warning_error names e
 
@@ -225,15 +238,14 @@ END
 (***** debug only ***)
 
 VERNAC COMMAND EXTEND NewFunctionalCase
-   ["Functional" "Case" fun_scheme_arg(fas) ] ->
-    [
-      Functional_principles_types.build_case_scheme fas
-    ]
+  ["Functional" "Case" fun_scheme_arg(fas) ]
+  => [ Vernacexpr.VtSideff[pi1 fas], Vernacexpr.VtLater ]
+  -> [ Functional_principles_types.build_case_scheme fas ]
 END
 
 (***** debug only ***)
-VERNAC COMMAND EXTEND GenerateGraph
-["Generate" "graph" "for" reference(c)] -> [ make_graph (Nametab.global c) ]
+VERNAC COMMAND EXTEND GenerateGraph CLASSIFIED AS QUERY
+["Generate" "graph" "for" reference(c)] -> [ make_graph (Smartlocate.global_with_alias c) ]
 END
 
 
@@ -273,7 +285,7 @@ let constr_head_match u t=
   if isApp u
   then
     let uhd,args= destApp u in
-    uhd=t
+    Constr.equal uhd t
   else false
 
 (** [hdMatchSub inu t] returns the list of occurrences of [t] in
@@ -296,22 +308,25 @@ let rec hdMatchSub inu (test: constr -> bool) : fapp_info list =
   else
     let f,args = decompose_app inu in
     let freeset = Termops.free_rels inu in
-    let max_rel = try Util.Intset.max_elt freeset with Not_found -> -1 in
-    {fname = f; largs = args; free = Util.Intset.is_empty freeset;
+    let max_rel = try Int.Set.max_elt freeset with Not_found -> -1 in
+    {fname = f; largs = args; free = Int.Set.is_empty freeset;
     max_rel = max_rel; onlyvars = List.for_all isVar args }
     ::subres
 
+let make_eq () =
+(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq ())
+
 let mkEq typ c1 c2 =
-  mkApp (Coqlib.build_coq_eq(),[| typ; c1; c2|])
+  mkApp (make_eq(),[| typ; c1; c2|])
 
 
 let poseq_unsafe idunsafe cstr gl =
   let typ = Tacmach.pf_type_of gl cstr in
   tclTHEN
-    (Tactics.letin_tac None (Name idunsafe) cstr None allHypsAndConcl)
+    (Proofview.V82.of_tactic (Tactics.letin_tac None (Name idunsafe) cstr None Locusops.allHypsAndConcl))
     (tclTHENFIRST
-      (Tactics.assert_tac Anonymous (mkEq typ (mkVar idunsafe) cstr))
-      Tactics.reflexivity)
+      (Proofview.V82.of_tactic (Tactics.assert_before Anonymous (mkEq typ (mkVar idunsafe) cstr)))
+      (Proofview.V82.of_tactic Tactics.reflexivity))
     gl
 
 
@@ -357,7 +372,7 @@ let poseq_list_ids lcstr gl =
 let find_fapp (test:constr -> bool) g : fapp_info list =
   let pre_res = hdMatchSub (Tacmach.pf_concl g) test in
   let res =
-    List.fold_right (fun x acc -> if List.mem x acc then acc else x::acc) pre_res [] in
+    List.fold_right (List.add_set Pervasives.(=)) pre_res [] in
   (prlistconstr (List.map (fun x -> applist (x.fname,x.largs)) res);
   res)
 
@@ -367,7 +382,7 @@ let find_fapp (test:constr -> bool) g : fapp_info list =
     an occurence of function [id] in the conclusion of goal [g]. If
     [id]=[None] then calls to any function are selected. In any case
     [heuristic] is used to select the most pertinent occurrence. *)
-let finduction (oid:identifier option) (heuristic: fapp_info list -> fapp_info list)
+let finduction (oid:Id.t option) (heuristic: fapp_info list -> fapp_info list)
     (nexttac:Proof_type.tactic) g =
   let test = match oid with
     | Some id ->
@@ -377,7 +392,7 @@ let finduction (oid:identifier option) (heuristic: fapp_info list -> fapp_info l
   let info_list = find_fapp test g in
   let ordered_info_list = heuristic info_list in
   prlistconstr (List.map (fun x -> applist (x.fname,x.largs)) ordered_info_list);
-  if List.length ordered_info_list = 0 then Util.error "function not found in goal\n";
+  if List.is_empty ordered_info_list then Errors.error "function not found in goal\n";
   let taclist: Proof_type.tactic list =
     List.map
       (fun info ->
@@ -419,10 +434,10 @@ TACTIC EXTEND finduction
     ["finduction" ident(id) natural_opt(oi)] ->
       [
 	match oi with
-	  | Some(n) when n<=0 -> Util.error "numerical argument must be > 0"
+	  | Some(n) when n<=0 -> Errors.error "numerical argument must be > 0"
 	  | _ ->
 	      let heuristic = chose_heuristic oi in
-	      finduction (Some id) heuristic tclIDTAC
+	      Proofview.V82.tactic (finduction (Some id) heuristic tclIDTAC)
       ]
 END
 
@@ -432,13 +447,13 @@ TACTIC EXTEND fauto
     [ "fauto" tactic(tac)] ->
       [
 	let heuristic = chose_heuristic None in
-	finduction None heuristic (Tacinterp.eval_tactic tac)
+	Proofview.V82.tactic (finduction None heuristic (Proofview.V82.of_tactic (Tacinterp.eval_tactic tac)))
       ]
   |
     [ "fauto" ] ->
       [
 	let heuristic = chose_heuristic None in
-	finduction None heuristic tclIDTAC
+	Proofview.V82.tactic (finduction None heuristic tclIDTAC)
       ]
 
 END
@@ -446,31 +461,31 @@ END
 
 TACTIC EXTEND poseq
   [ "poseq" ident(x) constr(c) ] ->
-      [ poseq x c ]
+      [ Proofview.V82.tactic (poseq x c) ]
 END
 
-VERNAC COMMAND EXTEND Showindinfo
+VERNAC COMMAND EXTEND Showindinfo CLASSIFIED AS QUERY
   [ "showindinfo" ident(x) ] -> [ Merge.showind x ]
 END
 
-VERNAC COMMAND EXTEND MergeFunind
+VERNAC COMMAND EXTEND MergeFunind CLASSIFIED AS SIDEFF
   [ "Mergeschemes" "(" ident(id1) ne_ident_list(cl1) ")"
       "with" "(" ident(id2) ne_ident_list(cl2)  ")" "using" ident(id) ] ->
      [
-       let f1 = Constrintern.interp_constr Evd.empty (Global.env())
-	 (CRef (Libnames.Ident (Util.dummy_loc,id1))) in
-       let f2 = Constrintern.interp_constr Evd.empty (Global.env())
-	 (CRef (Libnames.Ident (Util.dummy_loc,id2))) in
+       let f1,ctx = Constrintern.interp_constr (Global.env()) Evd.empty
+	 (CRef (Libnames.Ident (Loc.ghost,id1),None)) in
+       let f2,ctx' = Constrintern.interp_constr (Global.env()) Evd.empty
+	 (CRef (Libnames.Ident (Loc.ghost,id2),None)) in
        let f1type = Typing.type_of (Global.env()) Evd.empty f1 in
        let f2type = Typing.type_of (Global.env()) Evd.empty f2 in
        let ar1 = List.length (fst (decompose_prod f1type)) in
        let ar2 = List.length (fst (decompose_prod f2type)) in
        let _ =
-	 if ar1 <> List.length cl1 then
-	   Util.error ("not the right number of arguments for " ^ string_of_id id1) in
+	 if not (Int.equal ar1 (List.length cl1)) then
+	   Errors.error ("not the right number of arguments for " ^ Id.to_string id1) in
        let _ =
-	 if ar2 <> List.length cl2 then
-	   Util.error ("not the right number of arguments for " ^ string_of_id id2) in
+	 if not (Int.equal ar2 (List.length cl2)) then
+	   Errors.error ("not the right number of arguments for " ^ Id.to_string id2) in
        Merge.merge id1 id2 (Array.of_list cl1) (Array.of_list cl2)  id
      ]
 END
diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml
index b9e0e62a..a2577e2b 100644
--- a/plugins/funind/glob_term_to_relation.ml
+++ b/plugins/funind/glob_term_to_relation.ml
@@ -2,26 +2,30 @@ open Printer
 open Pp
 open Names
 open Term
+open Vars
 open Glob_term
-open Libnames
+open Glob_ops
+open Globnames
 open Indfun_common
+open Errors
 open Util
 open Glob_termops
+open Misctypes
 
 let observe strm =
   if do_observe ()
-  then Pp.msgnl strm
+  then Pp.msg_debug strm
   else ()
-let observennl strm =
+(*let observennl strm =
   if do_observe ()
   then Pp.msg strm
-  else ()
+  else ()*)
 
 
 type binder_type =
-  | Lambda of name
-  | Prod of name
-  | LetIn of name
+  | Lambda of Name.t
+  | Prod of Name.t
+  | LetIn of Name.t
 
 type glob_context = (binder_type*glob_constr) list
 
@@ -54,7 +58,7 @@ type 'a build_entry_pre_return =
 type 'a build_entry_return =
     {
       result : 'a build_entry_pre_return list;
-      to_avoid : identifier list
+      to_avoid : Id.t list
     }
 
 (*
@@ -86,7 +90,7 @@ let combine_results
   in (* and then we flatten the map *)
   {
     result = List.concat pre_result;
-    to_avoid = list_union res1.to_avoid res2.to_avoid
+    to_avoid = List.union Id.equal res1.to_avoid res2.to_avoid
   }
 
 
@@ -111,9 +115,9 @@ let ids_of_binder =  function
 let rec change_vars_in_binder mapping = function
     [] -> []
   | (bt,t)::l ->
-      let new_mapping = List.fold_right Idmap.remove (ids_of_binder bt) mapping in
+      let new_mapping = List.fold_right Id.Map.remove (ids_of_binder bt) mapping in
       (bt,change_vars mapping t)::
-	(if idmap_is_empty new_mapping
+	(if Id.Map.is_empty new_mapping
 	 then l
 	 else change_vars_in_binder new_mapping l
 	)
@@ -122,7 +126,7 @@ let rec replace_var_by_term_in_binder x_id term = function
   | [] -> []
   | (bt,t)::l ->
       (bt,replace_var_by_term x_id term t)::
-	if List.mem x_id (ids_of_binder bt)
+	if Id.List.mem x_id (ids_of_binder bt)
 	then l
 	else replace_var_by_term_in_binder x_id term l
 
@@ -130,28 +134,28 @@ let add_bt_names bt = List.append (ids_of_binder bt)
 
 let apply_args ctxt body args =
   let need_convert_id avoid id =
-    List.exists (is_free_in id) args || List.mem id avoid
+    List.exists (is_free_in id) args || Id.List.mem id avoid
   in
   let need_convert avoid  bt =
     List.exists (need_convert_id avoid) (ids_of_binder bt)
   in
-  let next_name_away (na:name) (mapping: identifier Idmap.t) (avoid: identifier list) =
+  let next_name_away (na:Name.t) (mapping: Id.t Id.Map.t) (avoid: Id.t list) =
     match na with
-       | Name id when List.mem id avoid ->
+       | Name id when Id.List.mem id avoid ->
 	   let new_id = Namegen.next_ident_away id avoid in
-	   Name new_id,Idmap.add id new_id mapping,new_id::avoid
+	   Name new_id,Id.Map.add id new_id mapping,new_id::avoid
        | _ -> na,mapping,avoid
   in
-  let next_bt_away bt (avoid:identifier list) =
+  let next_bt_away bt (avoid:Id.t list) =
     match bt with
       | LetIn na ->
-	  let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid  in
+	  let new_na,mapping,new_avoid = next_name_away na Id.Map.empty avoid  in
 	  LetIn new_na,mapping,new_avoid
       | Prod na ->
-	  let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid  in
+	  let new_na,mapping,new_avoid = next_name_away na Id.Map.empty avoid  in
 	  Prod new_na,mapping,new_avoid
       | Lambda na ->
-	  let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid  in
+	  let new_na,mapping,new_avoid = next_name_away na Id.Map.empty avoid  in
 	  Lambda new_na,mapping,new_avoid
   in
   let rec do_apply avoid ctxt body args =
@@ -170,7 +174,7 @@ let apply_args ctxt body args =
 	      let new_avoid =  id::avoid in
 	      let new_id = Namegen.next_ident_away id new_avoid in
 	      let new_avoid' = new_id :: new_avoid in
-	      let mapping = Idmap.add id new_id Idmap.empty in
+	      let mapping = Id.Map.add id new_id Id.Map.empty in
 	      let new_ctxt' = change_vars_in_binder mapping ctxt' in
 	      let new_body = change_vars mapping body in
 	      new_avoid',new_ctxt',new_body,new_id
@@ -266,11 +270,11 @@ let make_discr_match_el  =
   end
 *)
 let make_discr_match_brl i =
-  list_map_i
+  List.map_i
     (fun j (_,idl,patl,_) ->
-       if j=i
-       then (dummy_loc,idl,patl, mkGRef (Lazy.force coq_True_ref))
-       else (dummy_loc,idl,patl, mkGRef (Lazy.force coq_False_ref))
+       if Int.equal j i
+       then (Loc.ghost,idl,patl, mkGRef (Lazy.force coq_True_ref))
+       else (Loc.ghost,idl,patl, mkGRef (Lazy.force coq_False_ref))
     )
     0
 (*
@@ -285,10 +289,6 @@ let make_discr_match brl =
 	   make_discr_match_el el,
 	   make_discr_match_brl i brl)
 
-let pr_name = function
-  | Name id -> Ppconstr.pr_id id
-  | Anonymous -> str "_"
-
 (**********************************************************************)
 (*  functions used to build case expression from lettuple and if ones *)
 (**********************************************************************)
@@ -304,18 +304,17 @@ let build_constructors_of_type ind' argl =
 		  Impargs.implicits_of_global constructref
 		in
 		let cst_narg =
-		  Inductiveops.mis_constructor_nargs_env
+		  Inductiveops.constructor_nallargs_env
 		    (Global.env ())
 		    construct
 		in
-		let argl = match argl with
-                | None ->
+		let argl =
+		  if List.is_empty argl
+		  then
  		    Array.to_list
-		      (Array.init cst_narg (fun _ -> mkGHole ())
+		      (Array.init (cst_narg - npar) (fun _ -> mkGHole ())
 		      )
-                | Some l ->
-	            Array.to_list
-		      (Array.init npar (fun _ -> mkGHole ()))@l
+		  else argl
 		in
 		let pat_as_term =
 		  mkGApp(mkGRef (ConstructRef(ind',i+1)),argl)
@@ -324,40 +323,6 @@ let build_constructors_of_type ind' argl =
 	     )
     ind.Declarations.mind_consnames
 
-(* [find_type_of] very naive attempts to discover the type of an if or a letin *)
-let rec find_type_of nb b =
-  let f,_ = glob_decompose_app b in
-  match f with
-    | GRef(_,ref) ->
-	begin
-	  let ind_type  =
-	    match ref with
-	      | VarRef _ | ConstRef _ ->
-		  let constr_of_ref = constr_of_global ref in
-		  let type_of_ref = Typing.type_of (Global.env ()) Evd.empty constr_of_ref in
-		  let (_,ret_type) = Reduction.dest_prod (Global.env ()) type_of_ref in
-		  let ret_type,_ = decompose_app ret_type in
-		  if not (isInd ret_type) then
-		    begin
-(* 		      Pp.msgnl (str "not an inductive" ++ pr_lconstr ret_type); *)
-		      raise (Invalid_argument "not an inductive")
-		    end;
-		  destInd ret_type
-	      | IndRef ind -> ind
-	      | ConstructRef c -> fst c
-	  in
-	  let _,ind_type_info = Inductive.lookup_mind_specif (Global.env()) ind_type in
-	  if not (Array.length ind_type_info.Declarations.mind_consnames = nb )
-	  then raise (Invalid_argument "find_type_of : not a valid inductive");
-	  ind_type
-	end
-    | GCast(_,b,_) -> find_type_of nb b
-    | GApp _ -> assert false (* we have decomposed any application via glob_decompose_app *)
-    | _ -> raise (Invalid_argument "not a ref")
-
-
-
-
 (******************)
 (* Main functions *)
 (******************)
@@ -368,14 +333,14 @@ let raw_push_named (na,raw_value,raw_typ) env =
   match na with
     | Anonymous -> env
     | Name id ->
-	let value = Option.map (Pretyping.Default.understand Evd.empty env) raw_value in
-	let typ = Pretyping.Default.understand_type Evd.empty env raw_typ in
+	let value = Option.map (fun x-> fst (Pretyping.understand env Evd.empty x)) raw_value in
+	let typ,ctx = Pretyping.understand env Evd.empty ~expected_type:Pretyping.IsType raw_typ in
 	Environ.push_named (id,value,typ) env
 
 
 let add_pat_variables pat typ env : Environ.env =
   let rec add_pat_variables env pat typ  : Environ.env =
-    observe (str "new rel env := " ++ Printer.pr_rel_context_of env);
+    observe (str "new rel env := " ++ Printer.pr_rel_context_of env Evd.empty);
 
     match pat with
       | PatVar(_,na) -> Environ.push_rel (na,None,typ) env
@@ -385,14 +350,14 @@ let add_pat_variables pat typ env : Environ.env =
 	    with Not_found -> assert false
 	  in
 	  let constructors = Inductiveops.get_constructors env indf in
-	  let constructor : Inductiveops.constructor_summary = List.find (fun cs -> cs.Inductiveops.cs_cstr = c) (Array.to_list constructors) in
+	  let constructor : Inductiveops.constructor_summary = List.find (fun cs -> eq_constructor c (fst cs.Inductiveops.cs_cstr)) (Array.to_list constructors) in
 	  let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in
 	  List.fold_left2 add_pat_variables env patl (List.rev cs_args_types)
   in
   let new_env = add_pat_variables  env pat typ in
   let res =
     fst (
-      Sign.fold_rel_context
+      Context.fold_rel_context
 	(fun (na,v,t) (env,ctxt) ->
 	 match na with
 	   | Anonymous -> assert false
@@ -411,7 +376,7 @@ let add_pat_variables pat typ env : Environ.env =
 	~init:(env,[])
     )
   in
-  observe (str "new var env := " ++ Printer.pr_named_context_of res);
+  observe (str "new var env := " ++ Printer.pr_named_context_of res Evd.empty);
   res
 
 
@@ -423,7 +388,7 @@ let rec pattern_to_term_and_type env typ  = function
 	mkGVar id
   | PatCstr(loc,constr,patternl,_) ->
       let cst_narg =
-	Inductiveops.mis_constructor_nargs_env
+	Inductiveops.constructor_nallargs_env
 	  (Global.env ())
 	  constr
       in
@@ -432,7 +397,7 @@ let rec pattern_to_term_and_type env typ  = function
 	with Not_found -> assert false
       in
       let constructors = Inductiveops.get_constructors env indf in
-      let constructor  = List.find (fun cs -> cs.Inductiveops.cs_cstr = constr) (Array.to_list constructors) in
+      let constructor  = List.find (fun cs -> eq_constructor (fst cs.Inductiveops.cs_cstr) constr) (Array.to_list constructors) in
       let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in
       let _,cstl = Inductiveops.dest_ind_family indf in
       let csta = Array.of_list cstl in
@@ -440,7 +405,7 @@ let rec pattern_to_term_and_type env typ  = function
 	Array.to_list
 	  (Array.init
 	     (cst_narg - List.length patternl)
-	     (fun i -> Detyping.detype false [] (Termops.names_of_rel_context env) csta.(i))
+	     (fun i -> Detyping.detype false [] env Evd.empty csta.(i))
 	  )
       in
       let patl_as_term =
@@ -508,12 +473,12 @@ let rec build_entry_lc env funnames avoid rt  : glob_constr build_entry_return =
 		    | u::l -> 
 			match t with 
 			  | GLambda(loc,na,_,nat,b) -> 
-			      GLetIn(dummy_loc,na,u,aux b l)
+			      GLetIn(Loc.ghost,na,u,aux b l)
 			  | _ -> 
-			      GApp(dummy_loc,t,l)
+			      GApp(Loc.ghost,t,l)
 		in
 		build_entry_lc env funnames avoid (aux f args)
-	    | GVar(_,id) when Idset.mem id funnames ->
+	    | GVar(_,id) when Id.Set.mem id funnames ->
 		(* if we have [f t1 ... tn] with [f]$\in$[fnames]
 		   then we create a fresh variable [res],
 		   add [res] and its "value" (i.e. [res v1 ... vn]) to each
@@ -521,10 +486,10 @@ let rec build_entry_lc env funnames avoid rt  : glob_constr build_entry_return =
 		   a pseudo value "v1 ... vn".
 		   The "value" of this branch is then simply [res]
 		*)
-		let rt_as_constr = Pretyping.Default.understand Evd.empty env rt in
+		let rt_as_constr,ctx = Pretyping.understand env Evd.empty rt in
 		let rt_typ = Typing.type_of env Evd.empty rt_as_constr in
-		let res_raw_type = Detyping.detype false [] (Termops.names_of_rel_context env) rt_typ in
-		let res = fresh_id args_res.to_avoid "res" in
+		let res_raw_type = Detyping.detype false [] env Evd.empty rt_typ in
+		let res = fresh_id args_res.to_avoid "_res" in
 		let new_avoid = res::args_res.to_avoid in
 		let res_rt = mkGVar res in
 		let new_result =
@@ -568,7 +533,7 @@ let rec build_entry_lc env funnames avoid rt  : glob_constr build_entry_return =
 			let new_b =
 			  replace_var_by_term
 			    id
-			    (GVar(dummy_loc,id))
+			    (GVar(Loc.ghost,id))
 			    b
 			in
 			(Name new_id,new_b,new_avoid)
@@ -629,7 +594,7 @@ let rec build_entry_lc env funnames avoid rt  : glob_constr build_entry_return =
 	   and combine the two result
 	*)
 	let v_res = build_entry_lc env funnames avoid v in
-	let v_as_constr = Pretyping.Default.understand Evd.empty env v in
+	let v_as_constr,ctx = Pretyping.understand env Evd.empty v in
 	let v_type = Typing.type_of env Evd.empty v_as_constr in
 	let new_env =
 	  match n with
@@ -645,7 +610,7 @@ let rec build_entry_lc env funnames avoid rt  : glob_constr build_entry_return =
 	let make_discr = make_discr_match brl in
 	build_entry_lc_from_case env funnames make_discr el brl avoid
     | GIf(_,b,(na,e_option),lhs,rhs) ->
-	let b_as_constr = Pretyping.Default.understand Evd.empty env b in
+	let b_as_constr,ctx = Pretyping.understand env Evd.empty b in
 	let b_typ = Typing.type_of env Evd.empty b_as_constr in
 	let (ind,_) =
 	  try Inductiveops.find_inductive env Evd.empty b_typ
@@ -654,11 +619,11 @@ let rec build_entry_lc env funnames avoid rt  : glob_constr build_entry_return =
 			       Printer.pr_glob_constr b ++ str " in " ++
 			       Printer.pr_glob_constr rt ++ str ". try again with a cast")
 	in
-	let case_pats = build_constructors_of_type ind None in
-	assert (Array.length case_pats = 2);
+	let case_pats = build_constructors_of_type (fst ind) [] in
+	assert (Int.equal (Array.length case_pats) 2);
 	let brl =
-	  list_map_i
-	    (fun i x -> (dummy_loc,[],[case_pats.(i)],x))
+	  List.map_i
+	    (fun i x -> (Loc.ghost,[],[case_pats.(i)],x))
 	    0
 	    [lhs;rhs]
 	in
@@ -670,14 +635,14 @@ let rec build_entry_lc env funnames avoid rt  : glob_constr build_entry_return =
     | GLetTuple(_,nal,_,b,e) ->
 	begin
 	  let nal_as_glob_constr =
-	    Some (List.map
+	    List.map
 	      (function
 		   Name id -> mkGVar id
 		 | Anonymous -> mkGHole ()
 	      )
-	      nal)
+	      nal
 	  in
-	  let b_as_constr = Pretyping.Default.understand Evd.empty env b in
+	  let b_as_constr,ctx = Pretyping.understand env Evd.empty b in
 	  let b_typ = Typing.type_of env Evd.empty b_as_constr in
 	  let (ind,_) =
 	    try Inductiveops.find_inductive env Evd.empty b_typ
@@ -686,10 +651,10 @@ let rec build_entry_lc env funnames avoid rt  : glob_constr build_entry_return =
 				 Printer.pr_glob_constr b ++ str " in " ++
 				 Printer.pr_glob_constr rt ++ str ". try again with a cast")
 	  in
-	  let case_pats = build_constructors_of_type ind nal_as_glob_constr in
-	  assert (Array.length case_pats = 1);
+	  let case_pats = build_constructors_of_type (fst ind) nal_as_glob_constr in
+	  assert (Int.equal (Array.length case_pats) 1);
 	  let br =
-	    (dummy_loc,[],[case_pats.(0)],e)
+	    (Loc.ghost,[],[case_pats.(0)],e)
 	  in
 	  let match_expr = mkGCases(None,[b,(Anonymous,None)],[br]) in
 	  build_entry_lc env funnames avoid match_expr
@@ -724,7 +689,7 @@ and build_entry_lc_from_case env funname make_discr
 	in
 	let types =
 	  List.map (fun (case_arg,_) ->
-		      let case_arg_as_constr = Pretyping.Default.understand Evd.empty env case_arg in
+		      let case_arg_as_constr,ctx = Pretyping.understand env Evd.empty case_arg in
 		      Typing.type_of env Evd.empty case_arg_as_constr
 		   ) el
 	in
@@ -746,7 +711,8 @@ and build_entry_lc_from_case env funname make_discr
 	{
 	  result = List.concat (List.map (fun r -> r.result) results);
 	  to_avoid =
-	    List.fold_left (fun acc r -> list_union acc r.to_avoid) [] results
+	    List.fold_left (fun acc r -> List.union Id.equal acc r.to_avoid)
+              [] results
 	}
 
 and build_entry_lc_from_case_term env types funname make_discr patterns_to_prevent brl avoid
@@ -761,7 +727,7 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve
 	   (will be used in the following recursive calls)
 	*)
 	let new_env = List.fold_right2 add_pat_variables patl types env in
-	let not_those_patterns : (identifier list -> glob_constr -> glob_constr) list =
+	let not_those_patterns : (Id.t list -> glob_constr -> glob_constr) list =
 	  List.map2
 	    (fun pat typ ->
 	       fun avoid pat'_as_term ->
@@ -775,7 +741,7 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve
 			in
 			let raw_typ_of_id =
 			  Detyping.detype false []
-			    (Termops.names_of_rel_context env_with_pat_ids) typ_of_id
+			    env_with_pat_ids Evd.empty typ_of_id
 			in
 			mkGProd (Name id,raw_typ_of_id,acc))
 		     pat_ids
@@ -816,18 +782,18 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve
       	let those_pattern_preconds =
 	  (List.flatten
 	    (
-	      list_map3
+	      List.map3
 	      (fun pat e typ_as_constr ->
 		 let this_pat_ids = ids_of_pat pat in
-		 let typ = Detyping.detype false [] (Termops.names_of_rel_context new_env) typ_as_constr in
+		 let typ = Detyping.detype false [] new_env Evd.empty typ_as_constr in
 		 let pat_as_term = pattern_to_term pat in
 		 List.fold_right
 		   (fun id  acc ->
-		      if Idset.mem id this_pat_ids
+		      if Id.Set.mem id this_pat_ids
 		      then (Prod (Name id),
 		      let typ_of_id = Typing.type_of new_env Evd.empty (mkVar id) in
 		      let raw_typ_of_id =
-			Detyping.detype false [] (Termops.names_of_rel_context new_env) typ_of_id
+			Detyping.detype false [] new_env Evd.empty typ_of_id
 		      in
 		      raw_typ_of_id
 			   )::acc
@@ -871,14 +837,14 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve
 
 let is_res id =
   try
-    String.sub (string_of_id id) 0 3 = "res"
+    String.equal (String.sub (Id.to_string id) 0 4) "_res"
   with Invalid_argument _ -> false
 
 
 
 let same_raw_term rt1 rt2 = 
   match rt1,rt2 with 
-    | GRef(_,r1), GRef (_,r2) -> r1=r2
+    | GRef(_,r1,_), GRef (_,r2,_) -> Globnames.eq_gr r1 r2
     | GHole _, GHole _ -> true
     | _ -> false
 let decompose_raw_eq lhs rhs = 
@@ -892,7 +858,7 @@ let decompose_raw_eq lhs rhs =
     observe (str "lrhs := " ++ int (List.length lrhs));
     let sllhs = List.length llhs in 
     let slrhs = List.length lrhs in 
-    if same_raw_term lhd rhd && sllhs = slrhs 
+    if same_raw_term lhd rhd && Int.equal sllhs slrhs 
     then
       (* let _ = assert false in  *)
       List.fold_right2 decompose_raw_eq	llhs lrhs acc
@@ -928,7 +894,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 			let new_t =
 			  mkGApp(mkGVar(mk_rel_id this_relname),args'@[res_rt])
 			in
-			let t' = Pretyping.Default.understand Evd.empty env new_t in
+			let t',ctx = Pretyping.understand env Evd.empty new_t in
 			let new_env = Environ.push_rel (n,None,t') env in
 			let new_b,id_to_exclude =
 			  rebuild_cons new_env
@@ -937,18 +903,18 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 			    (depth + 1) b
 			in
 			mkGProd(n,new_t,new_b),
-			Idset.filter not_free_in_t id_to_exclude
+			Id.Set.filter not_free_in_t id_to_exclude
 		    | _ -> (* the first args is the name of the function! *)
 			assert false
 		end
-	    | GApp(loc1,GRef(loc2,eq_as_ref),[ty;GVar(loc3,id);rt])
-		when  eq_as_ref = Lazy.force Coqlib.coq_eq_ref  && n = Anonymous
+	    | GApp(loc1,GRef(loc2,eq_as_ref,_),[ty;GVar(loc3,id);rt])
+		when Globnames.eq_gr eq_as_ref (Lazy.force Coqlib.coq_eq_ref)  && n == Anonymous
 		  ->
 		begin
 		  try
 		    observe (str "computing new type for eq : " ++ pr_glob_constr rt);
 		    let t' =
-		      try Pretyping.Default.understand Evd.empty env t
+		      try fst (Pretyping.understand env Evd.empty t)(*FIXME*)
                       with e when Errors.noncritical e -> raise Continue
 		    in
 		    let is_in_b = is_free_in id b in
@@ -970,36 +936,36 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 		    in
 		    mkGProd(n,t,new_b),id_to_exclude
 		  with Continue ->
-		    let jmeq = Libnames.IndRef (destInd (jmeq ())) in
-		    let ty' = Pretyping.Default.understand Evd.empty env ty in
+		    let jmeq = Globnames.IndRef (fst (destInd (jmeq ()))) in
+		    let ty',ctx = Pretyping.understand env Evd.empty ty in
 		    let ind,args' = Inductive.find_inductive env ty' in
-		    let mib,_ = Global.lookup_inductive ind in
+		    let mib,_ = Global.lookup_inductive (fst ind) in
 		    let nparam = mib.Declarations.mind_nparams in
 		    let params,arg' =
-		      ((Util.list_chop nparam args'))
+		      ((Util.List.chop nparam args'))
 		    in
 		    let rt_typ =
-		       GApp(Util.dummy_loc,
-			    GRef (Util.dummy_loc,Libnames.IndRef ind),
+		       GApp(Loc.ghost,
+			    GRef (Loc.ghost,Globnames.IndRef (fst ind),None),
 			    (List.map
 			      (fun p -> Detyping.detype false []
-				 (Termops.names_of_rel_context env)
+				 env Evd.empty
 				 p) params)@(Array.to_list
 				      (Array.make
 					 (List.length args' - nparam)
 					 (mkGHole ()))))
 		    in
 		    let eq' =
-		      GApp(loc1,GRef(loc2,jmeq),[ty;GVar(loc3,id);rt_typ;rt])
+		      GApp(loc1,GRef(loc2,jmeq,None),[ty;GVar(loc3,id);rt_typ;rt])
 		    in
 		    observe (str "computing new type for jmeq : " ++ pr_glob_constr eq');
-		    let eq'_as_constr = Pretyping.Default.understand Evd.empty env eq' in
+		    let eq'_as_constr,ctx = Pretyping.understand env Evd.empty eq' in
 		    observe (str " computing new type for jmeq : done") ;
 		    let new_args =
 		      match kind_of_term eq'_as_constr with
 			| App(_,[|_;_;ty;_|]) ->
 			    let ty = Array.to_list (snd (destApp ty)) in
-			    let ty' = snd (Util.list_chop nparam ty) in
+			    let ty' = snd (Util.List.chop nparam ty) in
 			    List.fold_left2
 			      (fun acc var_as_constr arg ->
 				 if isRel var_as_constr
@@ -1011,11 +977,13 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 				     | Anonymous -> acc
 				     | Name id' ->
 					 (id',Detyping.detype false []
-					    (Termops.names_of_rel_context env)
+					    env
+                                            Evd.empty
 					    arg)::acc
 				 else if isVar var_as_constr
 				 then (destVar var_as_constr,Detyping.detype false []
-					 (Termops.names_of_rel_context env)
+					 env
+                                         Evd.empty
 					 arg)::acc
 				 else acc
 			      )
@@ -1041,7 +1009,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 		     if is_in_b then b else  replace_var_by_term id rt b
 		    in
 		    let new_env =
-		      let t' = Pretyping.Default.understand Evd.empty env eq' in
+		      let t',ctx = Pretyping.understand env Evd.empty eq' in
 		      Environ.push_rel (n,None,t') env
 		    in
 		    let new_b,id_to_exclude =
@@ -1056,10 +1024,10 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 		  (* J.F:. keep this comment  it explain how to remove some meaningless equalities
 		     if keep_eq then
 		     mkGProd(n,t,new_b),id_to_exclude
-		     else new_b, Idset.add id id_to_exclude
+		     else new_b, Id.Set.add id id_to_exclude
 		  *)
-	    | GApp(loc1,GRef(loc2,eq_as_ref),[ty;rt1;rt2])
-		when  eq_as_ref = Lazy.force Coqlib.coq_eq_ref  && n = Anonymous
+	    | GApp(loc1,GRef(loc2,eq_as_ref,_),[ty;rt1;rt2])
+		when Globnames.eq_gr eq_as_ref (Lazy.force Coqlib.coq_eq_ref) && n == Anonymous
 		  ->
 	      begin
 		try 
@@ -1079,7 +1047,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 		  else raise Continue
 	      with Continue -> 
 		observe (str "computing new type for prod : " ++ pr_glob_constr rt);
-		let t' = Pretyping.Default.understand Evd.empty env t in
+		let t',ctx = Pretyping.understand env Evd.empty t in
 		let new_env = Environ.push_rel (n,None,t') env in
 		let new_b,id_to_exclude =
 		  rebuild_cons new_env
@@ -1088,14 +1056,14 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 		    (depth + 1) b
 		in
 		match n with
-		  | Name id when Idset.mem id id_to_exclude && depth >= nb_args ->
-		      new_b,Idset.remove id
-			(Idset.filter not_free_in_t id_to_exclude)
-		  | _ -> mkGProd(n,t,new_b),Idset.filter not_free_in_t id_to_exclude
+		  | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args ->
+		      new_b,Id.Set.remove id
+			(Id.Set.filter not_free_in_t id_to_exclude)
+		  | _ -> mkGProd(n,t,new_b),Id.Set.filter not_free_in_t id_to_exclude
 	      end
 	    | _ ->
 		observe (str "computing new type for prod : " ++ pr_glob_constr rt);
-		let t' = Pretyping.Default.understand Evd.empty env t in
+		let t',ctx = Pretyping.understand env Evd.empty t in
 		let new_env = Environ.push_rel (n,None,t') env in
 		let new_b,id_to_exclude =
 		  rebuild_cons new_env
@@ -1104,17 +1072,17 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 		    (depth + 1) b
 		in
 		match n with
-		  | Name id when Idset.mem id id_to_exclude && depth >= nb_args ->
-		      new_b,Idset.remove id
-			(Idset.filter not_free_in_t id_to_exclude)
-		  | _ -> mkGProd(n,t,new_b),Idset.filter not_free_in_t id_to_exclude
+		  | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args ->
+		      new_b,Id.Set.remove id
+			(Id.Set.filter not_free_in_t id_to_exclude)
+		  | _ -> mkGProd(n,t,new_b),Id.Set.filter not_free_in_t id_to_exclude
 	end
     | GLambda(_,n,k,t,b) ->
 	begin
 	  let not_free_in_t id = not (is_free_in id t) in
 	  let new_crossed_types = t :: crossed_types in
 	  observe (str "computing new type for lambda : " ++ pr_glob_constr rt);
-	  let t' = Pretyping.Default.understand Evd.empty env t in
+	  let t',ctx = Pretyping.understand env Evd.empty t in
 	  match n with
 	    | Name id ->
 		let new_env = Environ.push_rel (n,None,t') env in
@@ -1124,19 +1092,19 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 		    (args@[mkGVar id])new_crossed_types
 		    (depth + 1 ) b
 		in
-		if Idset.mem id id_to_exclude && depth >= nb_args
+		if Id.Set.mem id id_to_exclude && depth >= nb_args
 		then
-		  new_b, Idset.remove id (Idset.filter not_free_in_t id_to_exclude)
+		  new_b, Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude)
 		else
-		  GProd(dummy_loc,n,k,t,new_b),Idset.filter not_free_in_t id_to_exclude
-	    | _ -> anomaly "Should not have an anonymous function here"
+		  GProd(Loc.ghost,n,k,t,new_b),Id.Set.filter not_free_in_t id_to_exclude
+	    | _ -> anomaly (Pp.str "Should not have an anonymous function here")
 		(* We have renamed all the anonymous functions during alpha_renaming phase *)
 
 	end
     | GLetIn(_,n,t,b) ->
 	begin
 	  let not_free_in_t id = not (is_free_in id t) in
-	  let t' = Pretyping.Default.understand Evd.empty env t in
+	  let t',ctx = Pretyping.understand env Evd.empty t in
 	  let type_t' = Typing.type_of env Evd.empty t' in
 	  let new_env = Environ.push_rel (n,Some t',type_t') env in
 	  let new_b,id_to_exclude =
@@ -1145,13 +1113,13 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 	      args (t::crossed_types)
 	      (depth + 1 ) b in
 	  match n with
-	    | Name id when Idset.mem id id_to_exclude && depth >= nb_args  ->
-		new_b,Idset.remove id (Idset.filter not_free_in_t id_to_exclude)
-	    | _ -> GLetIn(dummy_loc,n,t,new_b),
-		Idset.filter not_free_in_t id_to_exclude
+	    | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args  ->
+		new_b,Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude)
+	    | _ -> GLetIn(Loc.ghost,n,t,new_b),
+		Id.Set.filter not_free_in_t id_to_exclude
 	end
     | GLetTuple(_,nal,(na,rto),t,b) ->
-	assert (rto=None);
+	assert (Option.is_empty rto);
 	begin
 	  let not_free_in_t id = not (is_free_in id t) in
 	  let new_t,id_to_exclude' =
@@ -1161,7 +1129,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 	      args (crossed_types)
 	      depth t
 	  in
-	  let t' = Pretyping.Default.understand Evd.empty env new_t in
+	  let t',ctx = Pretyping.understand env Evd.empty new_t in
 	  let new_env = Environ.push_rel (na,None,t') env in
 	  let new_b,id_to_exclude =
 	    rebuild_cons new_env
@@ -1170,15 +1138,15 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 	      (depth + 1) b
 	  in
 (* 	  match n with  *)
-(* 	    | Name id when Idset.mem id id_to_exclude ->  *)
-(* 		new_b,Idset.remove id (Idset.filter not_free_in_t id_to_exclude) *)
+(* 	    | Name id when Id.Set.mem id id_to_exclude ->  *)
+(* 		new_b,Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) *)
 (* 	    | _ -> *)
-	  GLetTuple(dummy_loc,nal,(na,None),t,new_b),
-		Idset.filter not_free_in_t (Idset.union id_to_exclude id_to_exclude')
+	  GLetTuple(Loc.ghost,nal,(na,None),t,new_b),
+		Id.Set.filter not_free_in_t (Id.Set.union id_to_exclude id_to_exclude')
 
 	end
 
-    | _ -> mkGApp(mkGVar  relname,args@[rt]),Idset.empty
+    | _ -> mkGApp(mkGVar  relname,args@[rt]),Id.Set.empty
 
 
 (* debuging wrapper *)
@@ -1201,7 +1169,7 @@ let rebuild_cons env nb_args relname args crossed_types rt =
 *)
 let rec compute_cst_params relnames params = function
   | GRef _ | GVar _ | GEvar _ | GPatVar _ -> params
-  | GApp(_,GVar(_,relname'),rtl) when Idset.mem relname' relnames ->
+  | GApp(_,GVar(_,relname'),rtl) when Id.Set.mem relname' relnames ->
       compute_cst_params_from_app [] (params,rtl)
   | GApp(_,f,args) ->
       List.fold_left (compute_cst_params relnames) params (f::args)
@@ -1219,11 +1187,11 @@ and compute_cst_params_from_app acc (params,rtl) =
   match params,rtl with
     | _::_,[] -> assert false (* the rel has at least nargs + 1 arguments ! *)
     | ((Name id,_,is_defined) as param)::params',(GVar(_,id'))::rtl'
-	when id_ord id id' == 0 && not is_defined ->
+	when Id.compare id id' == 0 && not is_defined ->
 	compute_cst_params_from_app (param::acc) (params',rtl')
     | _  -> List.rev acc
 
-let compute_params_name relnames (args : (Names.name * Glob_term.glob_constr * bool) list array) csts =
+let compute_params_name relnames (args : (Name.t * Glob_term.glob_constr * bool) list array) csts =
   let rels_params =
     Array.mapi
       (fun i args ->
@@ -1237,12 +1205,12 @@ let compute_params_name relnames (args : (Names.name * Glob_term.glob_constr * b
   let l = ref [] in
   let _ =
     try
-      list_iter_i
+      List.iteri
 	(fun i ((n,nt,is_defined) as param) ->
-	   if array_for_all
+	   if Array.for_all
 	     (fun l ->
 		let (n',nt',is_defined') = List.nth l i in
-		n = n' && Topconstr.eq_glob_constr nt nt' && is_defined = is_defined')
+		Name.equal n n' && Notation_ops.eq_glob_constr nt nt' && (is_defined : bool) == is_defined')
 	     rels_params
 	   then
 	     l := param::!l
@@ -1255,22 +1223,23 @@ let compute_params_name relnames (args : (Names.name * Glob_term.glob_constr * b
 
 let rec rebuild_return_type rt =
   match rt with
-    | Topconstr.CProdN(loc,n,t') ->
-	Topconstr.CProdN(loc,n,rebuild_return_type t')
-    | Topconstr.CArrow(loc,t,t') ->
-	Topconstr.CArrow(loc,t,rebuild_return_type t')
-    | Topconstr.CLetIn(loc,na,t,t') ->
-	Topconstr.CLetIn(loc,na,t,rebuild_return_type t')
-    | _ -> Topconstr.CArrow(dummy_loc,rt,Topconstr.CSort(dummy_loc,GType None))
+    | Constrexpr.CProdN(loc,n,t') ->
+	Constrexpr.CProdN(loc,n,rebuild_return_type t')
+    | Constrexpr.CLetIn(loc,na,t,t') ->
+	Constrexpr.CLetIn(loc,na,t,rebuild_return_type t')
+    | _ -> Constrexpr.CProdN(Loc.ghost,[[Loc.ghost,Anonymous],
+				       Constrexpr.Default Decl_kinds.Explicit,rt],
+			    Constrexpr.CSort(Loc.ghost,GType []))
 
 
 let do_build_inductive
-    funnames (funsargs: (Names.name * glob_constr * bool) list list)
-    returned_types
-    (rtl:glob_constr list) =
+      mp_dp
+      funnames (funsargs: (Name.t * glob_constr * bool) list list)
+      returned_types
+      (rtl:glob_constr list) =
   let _time1 = System.get_time () in
-(*   Pp.msgnl (prlist_with_sep fnl Printer.pr_glob_constr rtl); *)
-  let funnames_as_set = List.fold_right Idset.add funnames Idset.empty in
+  (*   Pp.msgnl (prlist_with_sep fnl Printer.pr_glob_constr rtl); *)
+  let funnames_as_set = List.fold_right Id.Set.add funnames Id.Set.empty in
   let funnames = Array.of_list funnames in
   let funsargs = Array.of_list funsargs in
   let returned_types = Array.of_list returned_types in
@@ -1281,12 +1250,22 @@ let do_build_inductive
     Ensures by: obvious
     i*)
   let relnames = Array.map mk_rel_id funnames in
-  let relnames_as_set = Array.fold_right Idset.add relnames Idset.empty in
+  let relnames_as_set = Array.fold_right Id.Set.add relnames Id.Set.empty in
   (* Construction of the pseudo constructors *)
   let env =
     Array.fold_right
       (fun id env ->
-	 Environ.push_named (id,None,Typing.type_of env Evd.empty (Constrintern.global_reference id))  env
+       let c =
+	 match mp_dp with
+	 | None -> (Constrintern.global_reference id)
+	 | Some(mp,dp) -> mkConst (make_con mp dp (Label.of_id id))
+       in
+       Environ.push_named (id,None,
+			   try
+			     Typing.type_of env Evd.empty c
+			   with Not_found ->
+			     raise (UserError("do_build_inductive", str "Cannot handle partial fixpoint"))
+			  )  env
       )
       funnames
       (Global.env ())
@@ -1294,19 +1273,19 @@ let do_build_inductive
   let resa = Array.map (build_entry_lc env  funnames_as_set []) rta in
   let env_with_graphs =
     let rel_arity i funargs =  (* Reduilding arities (with parameters) *)
-      let rel_first_args :(Names.name * Glob_term.glob_constr * bool ) list  =
+      let rel_first_args :(Name.t * Glob_term.glob_constr * bool ) list  =
 	funargs
       in
       List.fold_right
 	(fun (n,t,is_defined) acc ->
 	   if is_defined
 	   then
-	     Topconstr.CLetIn(dummy_loc,(dummy_loc, n),Constrextern.extern_glob_constr Idset.empty t,
+	     Constrexpr.CLetIn(Loc.ghost,(Loc.ghost, n),with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t,
 			      acc)
 	   else
-	     Topconstr.CProdN
-	       (dummy_loc,
-		[[(dummy_loc,n)],Topconstr.default_binder_kind,Constrextern.extern_glob_constr Idset.empty t],
+	     Constrexpr.CProdN
+	       (Loc.ghost,
+		[[(Loc.ghost,n)],Constrexpr_ops.default_binder_kind,with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t],
 		acc
 	       )
 	)
@@ -1318,8 +1297,9 @@ let do_build_inductive
        Then save the graphs and reset Printing options to their primitive values
     *)
     let rel_arities = Array.mapi rel_arity funsargs in
-    Util.array_fold_left2 (fun env rel_name rel_ar ->
-			     Environ.push_named (rel_name,None, Constrintern.interp_constr Evd.empty env rel_ar) env) env relnames rel_arities
+    Util.Array.fold_left2 (fun env rel_name rel_ar ->
+			     Environ.push_named (rel_name,None, 
+						 fst (with_full_print (Constrintern.interp_constr env Evd.empty) rel_ar)) env) env relnames rel_arities
   in
   (* and of the real constructors*)
   let constr i res =
@@ -1344,9 +1324,9 @@ let do_build_inductive
     (*i The next call to mk_rel_id is valid since we are constructing the graph
       Ensures by: obvious
       i*)
-    id_of_string ((string_of_id (mk_rel_id funnames.(i)))^"_"^(string_of_int !next_constructor_id))
+    Id.of_string ((Id.to_string (mk_rel_id funnames.(i)))^"_"^(string_of_int !next_constructor_id))
   in
-  let rel_constructors i rt : (identifier*glob_constr) list =
+  let rel_constructors i rt : (Id.t*glob_constr) list =
     next_constructor_id := (-1);
     List.map (fun constr -> (mk_constructor_id i),constr) (constr i rt)
   in
@@ -1360,19 +1340,19 @@ let do_build_inductive
     rel_constructors
   in
   let rel_arity i funargs =  (* Reduilding arities (with parameters) *)
-    let rel_first_args :(Names.name * Glob_term.glob_constr * bool ) list  =
-      (snd (list_chop nrel_params funargs))
+    let rel_first_args :(Name.t * Glob_term.glob_constr * bool ) list  =
+      (snd (List.chop nrel_params funargs))
     in
     List.fold_right
       (fun (n,t,is_defined) acc ->
 	 if is_defined
 	 then
-	   Topconstr.CLetIn(dummy_loc,(dummy_loc, n),Constrextern.extern_glob_constr Idset.empty t,
+	   Constrexpr.CLetIn(Loc.ghost,(Loc.ghost, n),with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t,
 			    acc)
 	 else
-	   Topconstr.CProdN
-	   (dummy_loc,
-	   [[(dummy_loc,n)],Topconstr.default_binder_kind,Constrextern.extern_glob_constr Idset.empty t],
+	   Constrexpr.CProdN
+	   (Loc.ghost,
+	   [[(Loc.ghost,n)],Constrexpr_ops.default_binder_kind,with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t],
 	    acc
 	   )
       )
@@ -1384,31 +1364,40 @@ let do_build_inductive
      Then save the graphs and reset Printing options to their primitive values
   *)
   let rel_arities = Array.mapi rel_arity funsargs in
+  let rel_params_ids =
+    List.fold_left
+      (fun  acc (na,_,_) ->
+       match na with
+	 Anonymous -> acc
+       | Name id -> id::acc
+      )
+      []
+      rels_params
+  in
   let rel_params =
     List.map
       (fun (n,t,is_defined) ->
 	 if is_defined
 	 then
-	   Topconstr.LocalRawDef((dummy_loc,n), Constrextern.extern_glob_constr Idset.empty t)
+	   Constrexpr.LocalRawDef((Loc.ghost,n), Constrextern.extern_glob_constr Id.Set.empty t)
 	 else
-	 Topconstr.LocalRawAssum
-	   ([(dummy_loc,n)], Topconstr.default_binder_kind, Constrextern.extern_glob_constr Idset.empty t)
+	 Constrexpr.LocalRawAssum
+	   ([(Loc.ghost,n)], Constrexpr_ops.default_binder_kind, Constrextern.extern_glob_constr Id.Set.empty t)
       )
       rels_params
   in
   let ext_rels_constructors =
     Array.map (List.map
       (fun (id,t) ->
-	 false,((dummy_loc,id),
-		Flags.with_option
-		  Flags.raw_print
-		  (Constrextern.extern_glob_type Idset.empty) ((* zeta_normalize *) t)
+	 false,((Loc.ghost,id),
+		with_full_print
+		  (Constrextern.extern_glob_type Id.Set.empty) ((* zeta_normalize *) (alpha_rt rel_params_ids t))
 	       )
       ))
       (rel_constructors)
   in
   let rel_ind i ext_rel_constructors =
-    ((dummy_loc,relnames.(i)),
+    ((Loc.ghost,relnames.(i)),
     rel_params,
     Some rel_arities.(i),
     ext_rel_constructors),[]
@@ -1437,7 +1426,7 @@ let do_build_inductive
 (*   in *)
   let _time2 = System.get_time () in
   try
-    with_full_print (Flags.silently (Command.do_mutual_inductive rel_inds)) true
+    with_full_print (Flags.silently (Command.do_mutual_inductive rel_inds false false)) Decl_kinds.Finite
   with
     | UserError(s,msg) as e ->
 	let _time3 = System.get_time () in
@@ -1448,7 +1437,7 @@ let do_build_inductive
 	in
 	let msg =
 	  str "while trying to define"++ spc () ++
-	    Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Decl_kinds.Finite,false,repacked_rel_inds))
+	    Ppvernac.pr_vernac (Vernacexpr.VernacInductive(false,Decl_kinds.Finite,repacked_rel_inds))
 	    ++ fnl () ++
 	    msg
 	in
@@ -1463,7 +1452,7 @@ let do_build_inductive
 	in
 	let msg =
 	  str "while trying to define"++ spc () ++
-	    Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Decl_kinds.Finite,false,repacked_rel_inds))
+	    Ppvernac.pr_vernac (Vernacexpr.VernacInductive(false,Decl_kinds.Finite,repacked_rel_inds))
 	    ++ fnl () ++
 	    Errors.print reraise
 	in
@@ -1472,9 +1461,9 @@ let do_build_inductive
 
 
 
-let build_inductive funnames funsargs returned_types rtl =
+let build_inductive mp_dp funnames funsargs returned_types rtl =
   try
-    do_build_inductive funnames funsargs returned_types rtl
+    do_build_inductive mp_dp funnames funsargs returned_types rtl
   with e when Errors.noncritical e -> raise (Building_graph e)
 
 
diff --git a/plugins/funind/glob_term_to_relation.mli b/plugins/funind/glob_term_to_relation.mli
index 5c91292b..b0a05ec3 100644
--- a/plugins/funind/glob_term_to_relation.mli
+++ b/plugins/funind/glob_term_to_relation.mli
@@ -1,5 +1,4 @@
-
-
+open Names
 
 (*
   [build_inductive parametrize funnames funargs returned_types bodies]
@@ -8,9 +7,10 @@
 *)
 
 val build_inductive :
-  Names.identifier list -> (* The list of function name *)
-  (Names.name*Glob_term.glob_constr*bool) list list -> (* The list of function args *)
-  Topconstr.constr_expr list -> (* The list of function returned type *)
+  (ModPath.t * DirPath.t) option ->
+  Id.t list -> (* The list of function name *)
+  (Name.t*Glob_term.glob_constr*bool) list list -> (* The list of function args *)
+  Constrexpr.constr_expr list -> (* The list of function returned type *)
   Glob_term.glob_constr list -> (* the list of body *)
   unit
 
diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml
index 6cc932b1..291f835e 100644
--- a/plugins/funind/glob_termops.ml
+++ b/plugins/funind/glob_termops.ml
@@ -1,24 +1,25 @@
 open Pp
 open Glob_term
+open Errors
 open Util
 open Names
-(* Ocaml 3.06 Map.S does not handle is_empty *)
-let idmap_is_empty m = m = Idmap.empty
+open Decl_kinds
+open Misctypes
 
 (*
    Some basic functions to rebuild glob_constr
-   In each of them the location is Util.dummy_loc
+   In each of them the location is Loc.ghost
 *)
-let mkGRef ref = GRef(dummy_loc,ref)
-let mkGVar id = GVar(dummy_loc,id)
-let mkGApp(rt,rtl) = GApp(dummy_loc,rt,rtl)
-let mkGLambda(n,t,b) = GLambda(dummy_loc,n,Explicit,t,b)
-let mkGProd(n,t,b) = GProd(dummy_loc,n,Explicit,t,b)
-let mkGLetIn(n,t,b) = GLetIn(dummy_loc,n,t,b)
-let mkGCases(rto,l,brl) = GCases(dummy_loc,Term.RegularStyle,rto,l,brl)
-let mkGSort s = GSort(dummy_loc,s)
-let mkGHole () = GHole(dummy_loc,Evd.BinderType Anonymous)
-let mkGCast(b,t) = GCast(dummy_loc,b,CastConv (Term.DEFAULTcast,t))
+let mkGRef ref = GRef(Loc.ghost,ref,None)
+let mkGVar id = GVar(Loc.ghost,id)
+let mkGApp(rt,rtl) = GApp(Loc.ghost,rt,rtl)
+let mkGLambda(n,t,b) = GLambda(Loc.ghost,n,Explicit,t,b)
+let mkGProd(n,t,b) = GProd(Loc.ghost,n,Explicit,t,b)
+let mkGLetIn(n,t,b) = GLetIn(Loc.ghost,n,t,b)
+let mkGCases(rto,l,brl) = GCases(Loc.ghost,Term.RegularStyle,rto,l,brl)
+let mkGSort s = GSort(Loc.ghost,s)
+let mkGHole () = GHole(Loc.ghost,Evar_kinds.BinderType Anonymous,Misctypes.IntroAnonymous,None)
+let mkGCast(b,t) = GCast(Loc.ghost,b,CastConv t)
 
 (*
   Some basic functions to decompose glob_constrs
@@ -107,7 +108,7 @@ let glob_make_or t1 t2 = mkGApp (mkGRef(Lazy.force Coqlib.coq_or_ref),[t1;t2])
    to [P1 \/ ( .... \/ Pn)]
 *)
 let rec glob_make_or_list = function
-  | [] -> raise (Invalid_argument "mk_or")
+  | [] -> invalid_arg "mk_or"
   | [e] -> e
   | e::l -> glob_make_or e (glob_make_or_list l)
 
@@ -115,7 +116,7 @@ let rec glob_make_or_list = function
 let remove_name_from_mapping mapping na =
   match na with
     | Anonymous -> mapping
-    | Name id -> Idmap.remove id mapping
+    | Name id -> Id.Map.remove id mapping
 
 let change_vars =
   let rec change_vars mapping rt =
@@ -124,7 +125,7 @@ let change_vars =
       | GVar(loc,id) ->
 	  let new_id =
 	    try
-	      Idmap.find id mapping
+	      Id.Map.find id mapping
 	    with Not_found -> id
 	  in
 	  GVar(loc,new_id)
@@ -179,13 +180,12 @@ let change_vars =
       | GRec _ -> error "Local (co)fixes are not supported"
       | GSort _ -> rt
       | GHole _ -> rt
-      | GCast(loc,b,CastConv (k,t)) ->
-	  GCast(loc,change_vars mapping b, CastConv (k,change_vars mapping t))
-      | GCast(loc,b,CastCoerce) ->
-	  GCast(loc,change_vars mapping b,CastCoerce)
+      | GCast(loc,b,c) ->
+	  GCast(loc,change_vars mapping b,
+		Miscops.map_cast_type (change_vars mapping) c)
   and change_vars_br mapping ((loc,idl,patl,res) as br) =
-    let new_mapping = List.fold_right Idmap.remove idl mapping in
-    if idmap_is_empty new_mapping
+    let new_mapping = List.fold_right Id.Map.remove idl mapping in
+    if Id.Map.is_empty new_mapping
     then br
     else (loc,idl,patl,change_vars new_mapping res)
   in
@@ -197,27 +197,27 @@ let rec alpha_pat excluded pat =
   match pat with
     | PatVar(loc,Anonymous) ->
 	let new_id = Indfun_common.fresh_id excluded "_x" in
-	PatVar(loc,Name new_id),(new_id::excluded),Idmap.empty
+	PatVar(loc,Name new_id),(new_id::excluded),Id.Map.empty
     | PatVar(loc,Name id) ->
-	if List.mem id excluded
+	if Id.List.mem id excluded
 	then
 	  let new_id = Namegen.next_ident_away id excluded in
 	  PatVar(loc,Name new_id),(new_id::excluded),
-	(Idmap.add id new_id Idmap.empty)
-	else pat,excluded,Idmap.empty
+	(Id.Map.add id new_id Id.Map.empty)
+	else pat,excluded,Id.Map.empty
     | PatCstr(loc,constr,patl,na) ->
 	let new_na,new_excluded,map =
 	  match na with
-	    | Name id when List.mem id excluded ->
+	    | Name id when Id.List.mem id excluded ->
 		let new_id = Namegen.next_ident_away id excluded in
-		Name new_id,new_id::excluded, Idmap.add id new_id Idmap.empty
-	    | _ -> na,excluded,Idmap.empty
+		Name new_id,new_id::excluded, Id.Map.add id new_id Id.Map.empty
+	    | _ -> na,excluded,Id.Map.empty
 	in
 	let new_patl,new_excluded,new_map =
 	  List.fold_left
 	    (fun (patl,excluded,map) pat ->
 	       let new_pat,new_excluded,new_map = alpha_pat excluded pat in
-	       (new_pat::patl,new_excluded,Idmap.fold Idmap.add new_map map)
+	       (new_pat::patl,new_excluded,Id.Map.fold Id.Map.add new_map map)
 	    )
 	    ([],new_excluded,map)
 	    patl
@@ -229,9 +229,9 @@ let alpha_patl excluded patl  =
     List.fold_left
       (fun (patl,excluded,map) pat ->
 	 let new_pat,new_excluded,new_map = alpha_pat excluded pat in
-	 new_pat::patl,new_excluded,(Idmap.fold Idmap.add new_map map)
+	 new_pat::patl,new_excluded,(Id.Map.fold Id.Map.add new_map map)
       )
-      ([],excluded,Idmap.empty)
+      ([],excluded,Id.Map.empty)
       patl
   in
   (List.rev patl,new_excluded,map)
@@ -263,7 +263,7 @@ let rec alpha_rt excluded rt =
     match rt with
       | GRef _ | GVar _ | GEvar _ | GPatVar _ -> rt
       | GLambda(loc,Anonymous,k,t,b) ->
-	  let new_id = Namegen.next_ident_away (id_of_string "_x") excluded in
+	  let new_id = Namegen.next_ident_away (Id.of_string "_x") excluded in
 	  let new_excluded = new_id :: excluded in
 	  let new_t = alpha_rt new_excluded t in
 	  let new_b = alpha_rt new_excluded b in
@@ -279,10 +279,10 @@ let rec alpha_rt excluded rt =
     | GLambda(loc,Name id,k,t,b) ->
 	let new_id = Namegen.next_ident_away id excluded in
 	let t,b =
-	  if new_id = id
+	  if Id.equal new_id id
 	  then t,b
 	  else
-	    let replace = change_vars (Idmap.add id new_id Idmap.empty) in
+	    let replace = change_vars (Id.Map.add id new_id Id.Map.empty) in
 	    (t,replace b)
 	in
 	let new_excluded = new_id::excluded in
@@ -293,10 +293,10 @@ let rec alpha_rt excluded rt =
 	let new_id = Namegen.next_ident_away id excluded in
 	let new_excluded = new_id::excluded in
 	let t,b =
-	  if new_id = id
+	  if Id.equal new_id id
 	  then t,b
 	  else
-	    let replace = change_vars (Idmap.add id new_id Idmap.empty) in
+	    let replace = change_vars (Id.Map.add id new_id Id.Map.empty) in
 	    (t,replace b)
 	in
 	let new_t = alpha_rt new_excluded t in
@@ -305,10 +305,10 @@ let rec alpha_rt excluded rt =
     | GLetIn(loc,Name id,t,b) ->
 	let new_id = Namegen.next_ident_away id excluded in
 	let t,b =
-	  if new_id = id
+	  if Id.equal new_id id
 	  then t,b
 	  else
-	    let replace = change_vars (Idmap.add id new_id Idmap.empty) in
+	    let replace = change_vars (Id.Map.add id new_id Id.Map.empty) in
 	    (t,replace b)
 	in
 	let new_excluded = new_id::excluded in
@@ -325,18 +325,18 @@ let rec alpha_rt excluded rt =
 		 | Anonymous -> (na::nal,excluded,mapping)
 		 | Name id ->
 		     let new_id = Namegen.next_ident_away id excluded in
-		     if new_id = id
+		     if Id.equal new_id id
 		     then
 		       na::nal,id::excluded,mapping
 		     else
-		       (Name new_id)::nal,id::excluded,(Idmap.add id new_id mapping)
+		       (Name new_id)::nal,id::excluded,(Id.Map.add id new_id mapping)
 	    )
-	    ([],excluded,Idmap.empty)
+	    ([],excluded,Id.Map.empty)
 	    nal
 	in
 	let new_nal = List.rev rev_new_nal in
 	let new_rto,new_t,new_b =
-	  if idmap_is_empty mapping
+	  if Id.Map.is_empty mapping
 	  then rto,t,b
 	  else let replace = change_vars mapping in
 	  (Option.map replace rto, t,replace b)
@@ -359,10 +359,9 @@ let rec alpha_rt excluded rt =
     | GRec _ -> error "Not handled GRec"
     | GSort _ -> rt
     | GHole _ -> rt
-    | GCast (loc,b,CastConv (k,t)) ->
-	GCast(loc,alpha_rt excluded b,CastConv(k,alpha_rt excluded t))
-    | GCast (loc,b,CastCoerce) ->
-	GCast(loc,alpha_rt excluded b,CastCoerce)
+    | GCast (loc,b,c) ->
+	GCast(loc,alpha_rt excluded b,
+	      Miscops.map_cast_type (alpha_rt excluded) c)
     | GApp(loc,f,args) ->
 	GApp(loc,
 	     alpha_rt excluded f,
@@ -385,14 +384,14 @@ and alpha_br excluded (loc,ids,patl,res) =
 let is_free_in id =
   let rec is_free_in = function
     | GRef _ ->  false
-    | GVar(_,id') -> id_ord id' id == 0
+    | GVar(_,id') -> Id.compare id' id == 0
     | GEvar _ -> false
     | GPatVar _ -> false
     | GApp(_,rt,rtl) -> List.exists is_free_in (rt::rtl)
     | GLambda(_,n,_,t,b) | GProd(_,n,_,t,b) | GLetIn(_,n,t,b) ->
 	let check_in_b =
 	  match n with
-	    | Name id' -> id_ord id' id <> 0
+	    | Name id' -> not (Id.equal id' id)
 	    | _ -> true
 	in
 	is_free_in t || (check_in_b && is_free_in b)
@@ -401,7 +400,7 @@ let is_free_in id =
 	  List.exists is_free_in_br brl
     | GLetTuple(_,nal,_,b,t) ->
 	let check_in_nal =
-	  not (List.exists (function Name id' -> id'= id | _ -> false) nal)
+	  not (List.exists (function Name id' -> Id.equal id' id | _ -> false) nal)
 	in
 	is_free_in t  || (check_in_nal && is_free_in b)
 
@@ -410,10 +409,10 @@ let is_free_in id =
     | GRec _ -> raise (UserError("",str "Not handled GRec"))
     | GSort _ -> false
     | GHole _ -> false
-    | GCast (_,b,CastConv (_,t)) -> is_free_in b || is_free_in t
+    | GCast (_,b,(CastConv t|CastVM t|CastNative t)) -> is_free_in b || is_free_in t
     | GCast (_,b,CastCoerce) -> is_free_in b
   and is_free_in_br (_,ids,_,rt) =
-    (not (List.mem id ids)) && is_free_in rt
+    (not (Id.List.mem id ids)) && is_free_in rt
   in
   is_free_in
 
@@ -425,7 +424,7 @@ let rec pattern_to_term  = function
 	mkGVar id
   | PatCstr(loc,constr,patternl,_) ->
       let cst_narg =
-	Inductiveops.mis_constructor_nargs_env
+	Inductiveops.constructor_nallargs_env
 	  (Global.env ())
 	  constr
       in
@@ -439,7 +438,7 @@ let rec pattern_to_term  = function
       let patl_as_term =
 	List.map pattern_to_term patternl
       in
-      mkGApp(mkGRef(Libnames.ConstructRef constr),
+      mkGApp(mkGRef(Globnames.ConstructRef constr),
 	     implicit_args@patl_as_term
 	    )
 
@@ -449,7 +448,7 @@ let replace_var_by_term x_id term =
   let rec replace_var_by_pattern rt =
     match rt with
       | GRef _ -> rt
-      | GVar(_,id) when id_ord id x_id == 0 -> term
+      | GVar(_,id) when Id.compare id x_id == 0 -> term
       | GVar _ -> rt
       | GEvar _ -> rt
       | GPatVar _ -> rt
@@ -458,7 +457,7 @@ let replace_var_by_term x_id term =
 	       replace_var_by_pattern rt',
 	       List.map replace_var_by_pattern rtl
 	      )
-      | GLambda(_,Name id,_,_,_) when id_ord id x_id == 0 -> rt
+      | GLambda(_,Name id,_,_,_) when Id.compare id x_id == 0 -> rt
       | GLambda(loc,name,k,t,b) ->
 	  GLambda(loc,
 		  name,
@@ -466,7 +465,7 @@ let replace_var_by_term x_id term =
 		  replace_var_by_pattern t,
 		  replace_var_by_pattern b
 		 )
-      | GProd(_,Name id,_,_,_) when id_ord id x_id == 0 -> rt
+      | GProd(_,Name id,_,_,_) when Id.compare id x_id == 0 -> rt
       | GProd(loc,name,k,t,b) ->
 	  GProd(loc,
 		  name,
@@ -474,7 +473,7 @@ let replace_var_by_term x_id term =
 		  replace_var_by_pattern t,
 		  replace_var_by_pattern b
 		 )
-      | GLetIn(_,Name id,_,_) when id_ord id x_id == 0 -> rt
+      | GLetIn(_,Name id,_,_) when Id.compare id x_id == 0 -> rt
       | GLetIn(loc,name,def,b) ->
 	  GLetIn(loc,
 		 name,
@@ -482,7 +481,7 @@ let replace_var_by_term x_id term =
 		 replace_var_by_pattern b
 		)
       | GLetTuple(_,nal,_,_,_)
-	  when List.exists (function Name id -> id = x_id | _ -> false) nal  ->
+	  when List.exists (function Name id -> Id.equal id x_id | _ -> false) nal  ->
 	  rt
       | GLetTuple(loc,nal,(na,rto),def,b) ->
 	  GLetTuple(loc,
@@ -506,12 +505,11 @@ let replace_var_by_term x_id term =
       | GRec _ -> raise (UserError("",str "Not handled GRec"))
       | GSort _ -> rt
       | GHole _ -> rt
-      | GCast(loc,b,CastConv(k,t)) ->
-	  GCast(loc,replace_var_by_pattern b,CastConv(k,replace_var_by_pattern t))
-      | GCast(loc,b,CastCoerce) ->
-	  GCast(loc,replace_var_by_pattern b,CastCoerce)
+      | GCast(loc,b,c) ->
+	  GCast(loc,replace_var_by_pattern b,
+		Miscops.map_cast_type replace_var_by_pattern c)
   and replace_var_by_pattern_br ((loc,idl,patl,res) as br) =
-    if List.exists (fun id -> id_ord id x_id == 0) idl
+    if List.exists (fun id -> Id.compare id x_id == 0) idl
     then br
     else (loc,idl,patl,replace_var_by_pattern res)
   in
@@ -529,13 +527,12 @@ let rec are_unifiable_aux  = function
       match eq with
 	 | PatVar _,_ | _,PatVar _ -> are_unifiable_aux eqs
 	 | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) ->
-	     if constructor2 <> constructor1
+	     if not (eq_constructor constructor2 constructor1)
 	     then raise NotUnifiable
 	     else
 	       let eqs' =
- 		 try  ((List.combine cpl1 cpl2)@eqs)
-		 with e when Errors.noncritical e ->
-                   anomaly "are_unifiable_aux"
+		 try (List.combine cpl1 cpl2) @ eqs
+		 with Invalid_argument _ -> anomaly (Pp.str "are_unifiable_aux")
 	       in
 	       are_unifiable_aux eqs'
 
@@ -552,13 +549,12 @@ let rec eq_cases_pattern_aux  = function
       match eq with
 	 | PatVar _,PatVar _ -> eq_cases_pattern_aux eqs
 	 | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) ->
-	     if constructor2 <> constructor1
+	     if not (eq_constructor constructor2 constructor1)
 	     then raise NotUnifiable
 	     else
 	       let eqs' =
- 		 try  ((List.combine cpl1 cpl2)@eqs)
-		 with e when Errors.noncritical e ->
-                   anomaly "eq_cases_pattern_aux"
+		 try (List.combine cpl1 cpl2) @ eqs
+		 with Invalid_argument _ -> anomaly (Pp.str "eq_cases_pattern_aux")
 	       in
 	       eq_cases_pattern_aux eqs'
 	 | _ -> raise NotUnifiable
@@ -574,13 +570,13 @@ let eq_cases_pattern pat1 pat2 =
 let ids_of_pat =
   let rec ids_of_pat ids = function
     | PatVar(_,Anonymous) -> ids
-    | PatVar(_,Name id) -> Idset.add id ids
+    | PatVar(_,Name id) -> Id.Set.add id ids
     | PatCstr(_,_,patl,_) -> List.fold_left ids_of_pat ids patl
   in
-  ids_of_pat Idset.empty
+  ids_of_pat Id.Set.empty
 
 let id_of_name = function
-  | Names.Anonymous -> id_of_string "x"
+  | Names.Anonymous -> Id.of_string "x"
   | Names.Name x -> x
 
 (* TODO: finish Rec caes *)
@@ -594,7 +590,7 @@ let ids_of_glob_constr c =
       | GLambda (loc,na,k,ty,c) -> idof na :: ids_of_glob_constr [] ty @ ids_of_glob_constr [] c @ acc
       | GProd (loc,na,k,ty,c) -> idof na :: ids_of_glob_constr [] ty @ ids_of_glob_constr [] c @ acc
       | GLetIn (loc,na,b,c) -> idof na :: ids_of_glob_constr [] b @ ids_of_glob_constr [] c @ acc
-      | GCast (loc,c,CastConv(k,t)) -> ids_of_glob_constr [] c @ ids_of_glob_constr [] t @ acc
+      | GCast (loc,c,(CastConv t|CastVM t|CastNative t)) -> ids_of_glob_constr [] c @ ids_of_glob_constr [] t @ acc
       | GCast (loc,c,CastCoerce) -> ids_of_glob_constr [] c @ acc
       | GIf (loc,c,(na,po),b1,b2) -> ids_of_glob_constr [] c @ ids_of_glob_constr [] b1 @ ids_of_glob_constr [] b2 @ acc
       | GLetTuple (_,nal,(na,po),b,c) ->
@@ -605,7 +601,7 @@ let ids_of_glob_constr c =
       | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> []
   in
   (* build the set *)
-  List.fold_left (fun acc x -> Idset.add x acc) Idset.empty (ids_of_glob_constr [] c)
+  List.fold_left (fun acc x -> Id.Set.add x acc) Id.Set.empty (ids_of_glob_constr [] c)
 
 
 
@@ -662,10 +658,9 @@ let zeta_normalize =
       | GRec _ -> raise (UserError("",str "Not handled GRec"))
       | GSort _ -> rt
       | GHole _ -> rt
-      | GCast(loc,b,CastConv(k,t)) ->
-	  GCast(loc,zeta_normalize_term b,CastConv(k,zeta_normalize_term t))
-      | GCast(loc,b,CastCoerce) ->
-	  GCast(loc,zeta_normalize_term b,CastCoerce)
+      | GCast(loc,b,c) ->
+	  GCast(loc,zeta_normalize_term b,
+                Miscops.map_cast_type zeta_normalize_term c)
   and zeta_normalize_br (loc,idl,patl,res) =
     (loc,idl,patl,zeta_normalize_term res)
   in
@@ -680,7 +675,7 @@ let expand_as =
     match pat with
       | PatVar _ -> map
       | PatCstr(_,_,patl,Name id) ->
-	  Idmap.add id (pattern_to_term pat) (List.fold_left add_as map patl)
+	  Id.Map.add id (pattern_to_term pat) (List.fold_left add_as map patl)
       | PatCstr(_,_,patl,_) -> List.fold_left add_as map patl
   in
   let rec expand_as map rt =
@@ -689,7 +684,7 @@ let expand_as =
       | GVar(_,id) ->
 	  begin
 	    try
-	      Idmap.find id map
+	      Id.Map.find id map
 	    with Not_found -> rt
 	  end
       | GApp(loc,f,args) -> GApp(loc,expand_as map f,List.map (expand_as map) args)
@@ -703,12 +698,13 @@ let expand_as =
 	  GIf(loc,expand_as map e,(na,Option.map (expand_as map) po),
 	      expand_as map br1, expand_as map br2)
       | GRec _ ->  error "Not handled GRec"
-      | GCast(loc,b,CastConv(kind,t)) -> GCast(loc,expand_as map b,CastConv(kind,expand_as map t))
-      | GCast(loc,b,CastCoerce) -> GCast(loc,expand_as map b,CastCoerce)
+      | GCast(loc,b,c) ->
+	  GCast(loc,expand_as map b,
+		Miscops.map_cast_type (expand_as map) c)
       | GCases(loc,sty,po,el,brl) ->
 	  GCases(loc, sty, Option.map (expand_as map) po, List.map (fun (rt,t) -> expand_as map rt,t) el,
 		List.map (expand_as_br map) brl)
   and expand_as_br map (loc,idl,cpl,rt) =
     (loc,idl,cpl, expand_as (List.fold_left add_as map cpl) rt)
   in
-  expand_as Idmap.empty
+  expand_as Id.Map.empty
diff --git a/plugins/funind/glob_termops.mli b/plugins/funind/glob_termops.mli
index bfd15357..0f10636f 100644
--- a/plugins/funind/glob_termops.mli
+++ b/plugins/funind/glob_termops.mli
@@ -1,11 +1,9 @@
+open Names
 open Glob_term
-
-(* Ocaml 3.06 Map.S does not handle is_empty *)
-val idmap_is_empty : 'a Names.Idmap.t -> bool
-
+open Misctypes
 
 (* [get_pattern_id pat] returns a list of all the variable appearing in [pat] *)
-val get_pattern_id : cases_pattern -> Names.identifier list
+val get_pattern_id : cases_pattern -> Id.t list
 
 (* [pattern_to_term pat] returns a glob_constr corresponding to [pat].
    [pat] must not contain occurences of anonymous pattern
@@ -14,14 +12,14 @@ val pattern_to_term : cases_pattern -> glob_constr
 
 (*
    Some basic functions to rebuild glob_constr
-   In each of them the location is Util.dummy_loc
+   In each of them the location is Util.Loc.ghost
 *)
-val mkGRef : Libnames.global_reference -> glob_constr
-val mkGVar : Names.identifier -> glob_constr
+val mkGRef : Globnames.global_reference -> glob_constr
+val mkGVar : Id.t -> glob_constr
 val mkGApp  : glob_constr*(glob_constr list) -> glob_constr
-val mkGLambda : Names.name * glob_constr * glob_constr -> glob_constr
-val mkGProd : Names.name * glob_constr * glob_constr -> glob_constr
-val mkGLetIn : Names.name * glob_constr * glob_constr -> glob_constr
+val mkGLambda : Name.t * glob_constr * glob_constr -> glob_constr
+val mkGProd : Name.t * glob_constr * glob_constr -> glob_constr
+val mkGLetIn : Name.t * glob_constr * glob_constr -> glob_constr
 val mkGCases : glob_constr option * tomatch_tuples * cases_clauses -> glob_constr
 val mkGSort : glob_sort -> glob_constr
 val mkGHole : unit -> glob_constr (* we only build Evd.BinderType Anonymous holes *)
@@ -30,15 +28,15 @@ val mkGCast : glob_constr* glob_constr -> glob_constr
   Some basic functions to decompose glob_constrs
   These are analogous to the ones constrs
 *)
-val glob_decompose_prod : glob_constr -> (Names.name*glob_constr) list * glob_constr
+val glob_decompose_prod : glob_constr -> (Name.t*glob_constr) list * glob_constr
 val glob_decompose_prod_or_letin :
-  glob_constr -> (Names.name*glob_constr option*glob_constr option) list * glob_constr
-val glob_decompose_prod_n : int -> glob_constr -> (Names.name*glob_constr) list * glob_constr
+  glob_constr -> (Name.t*glob_constr option*glob_constr option) list * glob_constr
+val glob_decompose_prod_n : int -> glob_constr -> (Name.t*glob_constr) list * glob_constr
 val glob_decompose_prod_or_letin_n : int -> glob_constr ->
-  (Names.name*glob_constr option*glob_constr option) list * glob_constr
-val glob_compose_prod : glob_constr -> (Names.name*glob_constr) list  ->  glob_constr
+  (Name.t*glob_constr option*glob_constr option) list * glob_constr
+val glob_compose_prod : glob_constr -> (Name.t*glob_constr) list  ->  glob_constr
 val glob_compose_prod_or_letin: glob_constr ->
-  (Names.name*glob_constr option*glob_constr option) list  ->  glob_constr
+  (Name.t*glob_constr option*glob_constr option) list  ->  glob_constr
 val glob_decompose_app : glob_constr -> glob_constr*(glob_constr list)
 
 
@@ -60,7 +58,7 @@ val  glob_make_or_list : glob_constr list -> glob_constr
 
 
 (* Replace the var mapped in the glob_constr/context *)
-val change_vars : Names.identifier Names.Idmap.t -> glob_constr -> glob_constr
+val change_vars : Id.t Id.Map.t -> glob_constr -> glob_constr
 
 
 
@@ -72,27 +70,27 @@ val change_vars : Names.identifier Names.Idmap.t -> glob_constr -> glob_constr
    [avoid] with the variables appearing in the result.
 *)
   val alpha_pat :
-    Names.Idmap.key list ->
+    Id.Map.key list ->
     Glob_term.cases_pattern ->
-    Glob_term.cases_pattern * Names.Idmap.key list *
-      Names.identifier Names.Idmap.t
+    Glob_term.cases_pattern * Id.Map.key list *
+      Id.t Id.Map.t
 
 (* [alpha_rt avoid rt] alpha convert [rt] s.t. the result repects barendregt
    conventions and  does not share bound variables with avoid
 *)
-val alpha_rt : Names.identifier list -> glob_constr -> glob_constr
+val alpha_rt : Id.t list -> glob_constr -> glob_constr
 
 (* same as alpha_rt but for case branches *)
-val alpha_br : Names.identifier list ->
-    Util.loc * Names.identifier list * Glob_term.cases_pattern list *
+val alpha_br : Id.t list ->
+    Loc.t * Id.t list * Glob_term.cases_pattern list *
     Glob_term.glob_constr ->
-    Util.loc * Names.identifier list * Glob_term.cases_pattern list *
+    Loc.t * Id.t list * Glob_term.cases_pattern list *
     Glob_term.glob_constr
 
 
 (* Reduction function *)
 val replace_var_by_term  :
-  Names.identifier ->
+  Id.t ->
   Glob_term.glob_constr -> Glob_term.glob_constr -> Glob_term.glob_constr
 
 
@@ -100,7 +98,7 @@ val replace_var_by_term  :
 (*
    [is_free_in id rt] checks if [id] is a free variable in [rt]
 *)
-val is_free_in : Names.identifier -> glob_constr -> bool
+val is_free_in : Id.t -> glob_constr -> bool
 
 
 val are_unifiable : cases_pattern -> cases_pattern -> bool
@@ -109,13 +107,13 @@ val eq_cases_pattern : cases_pattern -> cases_pattern -> bool
 
 
 (*
-   ids_of_pat : cases_pattern -> Idset.t
+   ids_of_pat : cases_pattern -> Id.Set.t
    returns the set of variables appearing in a pattern
 *)
-val   ids_of_pat : cases_pattern -> Names.Idset.t
+val   ids_of_pat : cases_pattern -> Id.Set.t
 
 (* TODO: finish this function (Fix not treated) *)
-val ids_of_glob_constr: glob_constr -> Names.Idset.t
+val ids_of_glob_constr: glob_constr -> Id.Set.t
 
 (*
    removing let_in construction in a glob_constr
diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml
index d2c065a0..6dbd61cf 100644
--- a/plugins/funind/indfun.ml
+++ b/plugins/funind/indfun.ml
@@ -1,11 +1,16 @@
+open Errors
 open Util
 open Names
 open Term
 open Pp
 open Indfun_common
 open Libnames
+open Globnames
 open Glob_term
 open Declarations
+open Declareops
+open Misctypes
+open Decl_kinds
 
 let is_rec_info scheme_info =
   let test_branche min acc (_,_,br) =
@@ -14,15 +19,13 @@ let is_rec_info scheme_info =
 	it_mkProd_or_LetIn mkProp (fst (decompose_prod_assum br)) in
       let free_rels_in_br = Termops.free_rels new_branche in
       let max = min + scheme_info.Tactics.npredicates in
-      Util.Intset.exists (fun i -> i >= min && i< max) free_rels_in_br
+      Int.Set.exists (fun i -> i >= min && i< max) free_rels_in_br
     )
   in
-  Util.list_fold_left_i test_branche 1 false (List.rev scheme_info.Tactics.branches)
+  List.fold_left_i test_branche 1 false (List.rev scheme_info.Tactics.branches)
 
 let choose_dest_or_ind scheme_info =
-    if is_rec_info scheme_info
-    then Tactics.new_induct false
-    else Tactics.new_destruct false
+  Tactics.induction_destruct (is_rec_info scheme_info) false
 
 let functional_induction with_clean c princl pat =
   Dumpglob.pause ();
@@ -33,7 +36,7 @@ let functional_induction with_clean c princl pat =
 	| None -> (* No principle is given let's find the good one *)
 	    begin
 	      match kind_of_term f with
-		| Const c' ->
+		| Const (c',u) ->
 		    let princ_option =
 		      let finfo = (* we first try to find out a graph on f *)
 			try find_Function_infos c'
@@ -54,7 +57,7 @@ let functional_induction with_clean c princl pat =
 			  (or f_rec, f_rect) i*)
 			let princ_name =
 			  Indrec.make_elimination_ident
-			    (id_of_label (con_label c'))
+			    (Label.to_id (con_label c'))
 			    (Tacticals.elimination_sort_of_goal g)
 			in
 			try
@@ -63,7 +66,7 @@ let functional_induction with_clean c princl pat =
 			  errorlabstrm "" (str "Cannot find induction principle for "
 					   ++Printer.pr_lconstr (mkConst c') )
 		    in
-		    (princ,Glob_term.NoBindings, Tacmach.pf_type_of g princ)
+		    (princ,NoBindings, Tacmach.pf_type_of g princ)
 		| _ -> raise (UserError("",str "functional induction must be used with a function" ))
 	    end
 	| Some ((princ,binding)) ->
@@ -75,50 +78,43 @@ let functional_induction with_clean c princl pat =
 	if princ_infos.Tactics.farg_in_concl
 	then [c] else []
       in
-      List.map (fun c -> Tacexpr.ElimOnConstr (Evd.empty,(c,NoBindings))) (args@c_list)
+      let encoded_pat_as_patlist =
+        List.make (List.length args + List.length c_list - 1) None @ [pat] in
+      List.map2 (fun c pat -> ((None,Tacexpr.ElimOnConstr (fun env sigma -> sigma,(c,NoBindings))),(None,pat),None))
+        (args@c_list) encoded_pat_as_patlist
     in
     let princ' = Some (princ,bindings) in
     let princ_vars =
       List.fold_right
-	(fun a acc ->
-	  try Idset.add (destVar a) acc
-	  with e when Errors.noncritical e -> acc
-	)
+	(fun a acc -> try Id.Set.add (destVar a) acc with DestKO -> acc)
 	args
-	Idset.empty
+	Id.Set.empty
     in
-    let old_idl = List.fold_right Idset.add (Tacmach.pf_ids_of_hyps g) Idset.empty in
-    let old_idl = Idset.diff old_idl princ_vars in
+    let old_idl = List.fold_right Id.Set.add (Tacmach.pf_ids_of_hyps g) Id.Set.empty in
+    let old_idl = Id.Set.diff old_idl princ_vars in
     let subst_and_reduce g =
       if with_clean
       then
 	let idl =
-	  map_succeed
-	    (fun id ->
-	       if Idset.mem id old_idl then failwith "subst_and_reduce";
-	       id
-	    )
+	  List.filter (fun id -> not (Id.Set.mem id old_idl))
 	    (Tacmach.pf_ids_of_hyps g)
 	in
 	let flag =
-	  Glob_term.Cbv
-	    {Glob_term.all_flags
-	     with Glob_term.rDelta = false;
+	  Genredexpr.Cbv
+	    {Redops.all_flags
+	     with Genredexpr.rDelta = false;
 	    }
 	in
 	Tacticals.tclTHEN
-	  (Tacticals.tclMAP (fun id -> Tacticals.tclTRY (Equality.subst_gen (do_rewrite_dependent ()) [id])) idl )
-	  (Hiddentac.h_reduce flag Tacticals.allHypsAndConcl)
+	  (Tacticals.tclMAP (fun id -> Tacticals.tclTRY (Proofview.V82.of_tactic (Equality.subst_gen (do_rewrite_dependent ()) [id]))) idl )
+	  (Tactics.reduce flag Locusops.allHypsAndConcl)
 	  g
       else Tacticals.tclIDTAC g
     in
     Tacticals.tclTHEN
-      (choose_dest_or_ind
+      (Proofview.V82.of_tactic (choose_dest_or_ind
 	 princ_infos
-	 args_as_induction_constr
-	 princ'
-	 (None,pat)
-         None)
+	 (args_as_induction_constr,princ')))
       subst_and_reduce
       g
   in
@@ -127,14 +123,14 @@ let functional_induction with_clean c princl pat =
 
 let rec abstract_glob_constr c = function
   | [] -> c
-  | Topconstr.LocalRawDef (x,b)::bl -> Topconstr.mkLetInC(x,b,abstract_glob_constr c bl)
-  | Topconstr.LocalRawAssum (idl,k,t)::bl ->
-      List.fold_right (fun x b -> Topconstr.mkLambdaC([x],k,t,b)) idl
+  | Constrexpr.LocalRawDef (x,b)::bl -> Constrexpr_ops.mkLetInC(x,b,abstract_glob_constr c bl)
+  | Constrexpr.LocalRawAssum (idl,k,t)::bl ->
+      List.fold_right (fun x b -> Constrexpr_ops.mkLambdaC([x],k,t,b)) idl
         (abstract_glob_constr c bl)
 
-let interp_casted_constr_with_implicits sigma env impls c  =
-  Constrintern.intern_gen false sigma env ~impls
-    ~allow_patvar:false  ~ltacvars:([],[]) c
+let interp_casted_constr_with_implicits env sigma impls c  =
+  Constrintern.intern_gen Pretyping.WithoutTypeConstraint env ~impls
+    ~allow_patvar:false c
 
 (*
    Construct a fixpoint as a Glob_term
@@ -149,26 +145,21 @@ let build_newrecursive
   let (rec_sign,rec_impls) =
     List.fold_left
       (fun (env,impls) ((_,recname),bl,arityc,_) ->
-        let arityc = Topconstr.prod_constr_expr arityc bl in
-        let arity = Constrintern.interp_type sigma env0 arityc in
-	let impl = Constrintern.compute_internalization_data env0 Constrintern.Recursive arity [] in
-        (Environ.push_named (recname,None,arity) env, Idmap.add recname impl impls))
+        let arityc = Constrexpr_ops.prod_constr_expr arityc bl in
+        let arity,ctx = Constrintern.interp_type env0 sigma arityc in
+	let evdref =  ref (Evd.from_env env0) in
+	let _, (_, impls') = Constrintern.interp_context_evars env evdref bl in
+	let impl = Constrintern.compute_internalization_data env0 Constrintern.Recursive arity impls' in
+        (Environ.push_named (recname,None,arity) env, Id.Map.add recname impl impls))
       (env0,Constrintern.empty_internalization_env) lnameargsardef in
   let recdef =
     (* Declare local notations *)
-    let fs = States.freeze() in
-    let def =
-      try
-	List.map
-	  (fun (_,bl,_,def)  ->
-             let def = abstract_glob_constr def bl in
-             interp_casted_constr_with_implicits
-	       sigma rec_sign rec_impls def
-	  )
-          lnameargsardef
-	with reraise ->
-	States.unfreeze fs; raise reraise in
-    States.unfreeze fs; def
+    let f (_,bl,_,def) =
+      let def = abstract_glob_constr def bl in
+      interp_casted_constr_with_implicits
+        rec_sign sigma rec_impls def
+    in
+    States.with_state_protection (List.map f) lnameargsardef
   in
   recdef,rec_impls
 
@@ -178,15 +169,15 @@ let build_newrecursive l =
        match body_opt with 
 	 | Some body -> 
 	     (fixna,bll,ar,body)
-	 | None -> user_err_loc (dummy_loc,"Function",str "Body of Function must be given")
+	 | None -> user_err_loc (Loc.ghost,"Function",str "Body of Function must be given")
     ) l
   in
   build_newrecursive l'
 
 (* Checks whether or not the mutual bloc is recursive *)
-let rec is_rec names =
-  let names = List.fold_right Idset.add names Idset.empty in
-  let check_id id names =  Idset.mem id names in
+let is_rec names =
+  let names = List.fold_right Id.Set.add names Id.Set.empty in
+  let check_id id names =  Id.Set.mem id names in
   let rec lookup names = function
     | GVar(_,id) -> check_id id names
     | GRef _ | GEvar _ | GPatVar _ | GSort _ |  GHole _ -> false
@@ -195,11 +186,11 @@ let rec is_rec names =
     | GIf(_,b,_,lhs,rhs) ->
 	(lookup names b) || (lookup names lhs) || (lookup names rhs)
     | GLetIn(_,na,t,b) | GLambda(_,na,_,t,b) | GProd(_,na,_,t,b)  ->
-	lookup names t || lookup (Nameops.name_fold Idset.remove na names) b
+	lookup names t || lookup (Nameops.name_fold Id.Set.remove na names) b
     | GLetTuple(_,nal,_,t,b) -> lookup names t ||
 	lookup
 	  (List.fold_left
-	     (fun acc na -> Nameops.name_fold Idset.remove na acc)
+	     (fun acc na -> Nameops.name_fold Id.Set.remove na acc)
 	     names
 	     nal
 	  )
@@ -209,7 +200,7 @@ let rec is_rec names =
 	List.exists (fun (e,_) -> lookup names e) el ||
 	  List.exists (lookup_br names) brl
   and lookup_br names (_,idl,_,rt) =
-    let new_names = List.fold_right Idset.remove idl names in
+    let new_names = List.fold_right Id.Set.remove idl names in
     lookup new_names rt
   in
   lookup names
@@ -217,8 +208,8 @@ let rec is_rec names =
 let rec local_binders_length = function
   (* Assume that no `{ ... } contexts occur *)
   | [] -> 0
-  | Topconstr.LocalRawDef _::bl -> 1 + local_binders_length bl
-  | Topconstr.LocalRawAssum (idl,_,_)::bl -> List.length idl + local_binders_length bl
+  | Constrexpr.LocalRawDef _::bl -> 1 + local_binders_length bl
+  | Constrexpr.LocalRawAssum (idl,_,_)::bl -> List.length idl + local_binders_length bl
 
 let prepare_body ((name,_,args,types,_),_) rt =
   let n = local_binders_length args in
@@ -226,12 +217,14 @@ let prepare_body ((name,_,args,types,_),_) rt =
   let fun_args,rt' = chop_rlambda_n n rt in
   (fun_args,rt')
 
+let process_vernac_interp_error e =
+  fst (Cerrors.process_vernac_interp_error (e, Exninfo.null))
 
 let derive_inversion fix_names =
   try
     (* we first transform the fix_names identifier into their corresponding constant *)
     let fix_names_as_constant =
-      List.map (fun id -> destConst (Constrintern.global_reference id)) fix_names
+      List.map (fun id -> fst (destConst (Constrintern.global_reference id))) fix_names
     in
     (*
        Then we check that the graphs have been defined
@@ -248,38 +241,45 @@ let derive_inversion fix_names =
 	  Ensures by : register_built
 	  i*)
 	(List.map
-	   (fun id -> destInd (Constrintern.global_reference (mk_rel_id id)))
+	   (fun id -> fst (destInd (Constrintern.global_reference (mk_rel_id id))))
 	   fix_names
 	)
     with e when Errors.noncritical e ->
-      let e' = Cerrors.process_vernac_interp_error e in
+      let e' = process_vernac_interp_error e in
       msg_warning
 	(str "Cannot build inversion information" ++
 	   if do_observe () then (fnl() ++ Errors.print e') else mt ())
   with e when Errors.noncritical e -> ()
 
 let warning_error names e =
-  let e = Cerrors.process_vernac_interp_error e in
+  let e = process_vernac_interp_error e in
   let e_explain e =
     match e with
-      | ToShow e -> spc () ++ Errors.print e
-      | _ -> if do_observe () then (spc () ++ Errors.print e) else mt ()
+      | ToShow e -> 
+	let e = process_vernac_interp_error e in
+	spc () ++ Errors.print e
+      | _ -> 
+	if do_observe () 
+	then 
+	  let e = process_vernac_interp_error e in 
+	  (spc () ++ Errors.print e) 
+	else mt ()
   in
   match e with
     | Building_graph e ->
-	Pp.msg_warning
-	  (str "Cannot define graph(s) for " ++
-	     h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++
-	     e_explain e)
+      Pp.msg_warning
+	(str "Cannot define graph(s) for " ++
+	   h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++
+	   e_explain e)
     | Defining_principle e ->
-	Pp.msg_warning
-	  (str "Cannot define principle(s) for "++
-	     h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++
-	     e_explain e)
+      Pp.msg_warning
+	(str "Cannot define principle(s) for "++
+	   h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++
+	   e_explain e)
     | _ -> raise e
 
 let error_error names e =
-  let e = Cerrors.process_vernac_interp_error e in
+  let e = process_vernac_interp_error e in
   let e_explain e =
     match e with
       | ToShow e -> spc () ++ Errors.print e
@@ -293,7 +293,7 @@ let error_error names e =
 	     e_explain e)
     | _ -> raise e
 
-let generate_principle  on_error
+let generate_principle  mp_dp on_error
     is_general do_built (fix_rec_l:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) recdefs  interactive_proof
     (continue_proof : int -> Names.constant array -> Term.constr array -> int ->
       Tacmach.tactic) : unit =
@@ -303,14 +303,14 @@ let generate_principle  on_error
   let funs_types =  List.map (function ((_,_,_,types,_),_) -> types) fix_rec_l in
   try
     (* We then register the Inductive graphs of the functions  *)
-    Glob_term_to_relation.build_inductive names funs_args funs_types recdefs;
+    Glob_term_to_relation.build_inductive mp_dp names funs_args funs_types recdefs;
     if do_built
     then
       begin
 	(*i The next call to mk_rel_id is valid since we have just construct the graph
 	   Ensures by : do_built
 	i*)
-	let f_R_mut = Ident (dummy_loc,mk_rel_id (List.nth names 0)) in
+	let f_R_mut = Ident (Loc.ghost,mk_rel_id (List.nth names 0)) in
 	let ind_kn =
 	  fst (locate_with_msg
 		 (pr_reference f_R_mut++str ": Not an inductive type!")
@@ -326,11 +326,10 @@ let generate_principle  on_error
 	in
 	let funs_kn = Array.of_list (List.map fname_kn fix_rec_l) in
 	let _ =
-	  list_map_i
+	  List.map_i
 	    (fun i x ->
-	       let princ = destConst (Indrec.lookup_eliminator (ind_kn,i) (InProp)) in
-	       let princ_type = Typeops.type_of_constant (Global.env()) princ
-	       in
+	       let princ = Indrec.lookup_eliminator (ind_kn,i) (InProp) in
+	       let princ_type = Global.type_of_global_unsafe princ in
 	       Functional_principles_types.generate_functional_principle
 		 interactive_proof
 		 princ_type
@@ -352,15 +351,11 @@ let generate_principle  on_error
 let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) =
   match fixpoint_exprl with
     | [((_,fname),_,bl,ret_type,body),_] when not is_rec ->
-      let body = match body with | Some body -> body | None -> user_err_loc (dummy_loc,"Function",str "Body of Function must be given") in 
-	let ce,imps =
-	  Command.interp_definition bl None body (Some ret_type)
-	in
-	Command.declare_definition
-	  fname (Decl_kinds.Global,Decl_kinds.Definition)
-	  ce imps (fun _ _ -> ())
+      let body = match body with | Some body -> body | None -> user_err_loc (Loc.ghost,"Function",str "Body of Function must be given") in 
+	Command.do_definition fname (Decl_kinds.Global,(*FIXME*)false,Decl_kinds.Definition)
+	  bl None body (Some ret_type) (Lemmas.mk_hook (fun _ _ -> ()))
     | _ ->
-	Command.do_fixpoint fixpoint_exprl
+	Command.do_fixpoint Global false(*FIXME*) fixpoint_exprl
 
 let generate_correction_proof_wf f_ref tcc_lemma_ref
     is_mes functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation
@@ -373,39 +368,39 @@ let generate_correction_proof_wf f_ref tcc_lemma_ref
 let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas args ret_type body
     pre_hook
     =
-  let type_of_f = Topconstr.prod_constr_expr ret_type args in
+  let type_of_f = Constrexpr_ops.prod_constr_expr ret_type args in
   let rec_arg_num =
     let names =
       List.map
 	snd
-	(Topconstr.names_of_local_assums args)
+	(Constrexpr_ops.names_of_local_assums args)
     in
     match wf_arg with
       | None ->
-	if List.length names = 1 then 1
+	if Int.equal (List.length names) 1 then 1
 	else error "Recursive argument must be specified"
       | Some wf_arg ->
-	  list_index (Name wf_arg) names
+	  List.index Name.equal (Name wf_arg) names
   in
   let unbounded_eq =
     let f_app_args =
-      Topconstr.CAppExpl
-	(dummy_loc,
-	 (None,(Ident (dummy_loc,fname))) ,
+      Constrexpr.CAppExpl
+	(Loc.ghost,
+	 (None,(Ident (Loc.ghost,fname)),None) ,
 	 (List.map
 	    (function
 	       | _,Anonymous -> assert false
-	       | _,Name e -> (Topconstr.mkIdentC e)
+	       | _,Name e -> (Constrexpr_ops.mkIdentC e)
 	    )
-	    (Topconstr.names_of_local_assums args)
+	    (Constrexpr_ops.names_of_local_assums args)
 	 )
 	)
     in
-    Topconstr.CApp (dummy_loc,(None,Topconstr.mkRefC (Qualid (dummy_loc,(qualid_of_string "Logic.eq")))),
+    Constrexpr.CApp (Loc.ghost,(None,Constrexpr_ops.mkRefC (Qualid (Loc.ghost,(qualid_of_string "Logic.eq")))),
 		    [(f_app_args,None);(body,None)])
   in
-  let eq = Topconstr.prod_constr_expr unbounded_eq args in
-  let hook f_ref tcc_lemma_ref functional_ref eq_ref rec_arg_num rec_arg_type
+  let eq = Constrexpr_ops.prod_constr_expr unbounded_eq args in
+  let hook (f_ref,_) tcc_lemma_ref (functional_ref,_) (eq_ref,_) rec_arg_num rec_arg_type
       nb_args relation =
     try
       pre_hook
@@ -433,7 +428,7 @@ let register_mes fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas
       | None ->
 	  begin
 	    match args with
-	      | [Topconstr.LocalRawAssum ([(_,Name x)],k,t)] -> t,x
+	      | [Constrexpr.LocalRawAssum ([(_,Name x)],k,t)] -> t,x
 	      | _ -> error "Recursive argument must be specified"
 	  end
       | Some wf_args ->
@@ -441,15 +436,15 @@ let register_mes fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas
 	    match
 	      List.find
 		(function
-		   | Topconstr.LocalRawAssum(l,k,t) ->
+		   | Constrexpr.LocalRawAssum(l,k,t) ->
 		       List.exists
-			 (function (_,Name id) -> id =  wf_args | _ -> false)
+			 (function (_,Name id) -> Id.equal id wf_args | _ -> false)
 			 l
 		   | _ -> false
 		)
 		args
 	    with
-	      | Topconstr.LocalRawAssum(_,k,t)  ->	    t,wf_args
+	      | Constrexpr.LocalRawAssum(_,k,t)  ->	    t,wf_args
 	      | _ -> assert false
 	  with Not_found -> assert false
   in
@@ -457,31 +452,31 @@ let register_mes fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas
     match wf_rel_expr_opt with 
       | None ->
 	  let ltof =
-	    let make_dir l = make_dirpath (List.map id_of_string (List.rev l)) in
-	    Libnames.Qualid (dummy_loc,Libnames.qualid_of_path
-			       (Libnames.make_path (make_dir ["Arith";"Wf_nat"]) (id_of_string "ltof")))
+	    let make_dir l = DirPath.make (List.rev_map Id.of_string l) in
+	    Libnames.Qualid (Loc.ghost,Libnames.qualid_of_path
+			       (Libnames.make_path (make_dir ["Arith";"Wf_nat"]) (Id.of_string "ltof")))
 	  in
 	  let fun_from_mes =
 	    let applied_mes =
-	      Topconstr.mkAppC(wf_mes_expr,[Topconstr.mkIdentC wf_arg])    in
-	    Topconstr.mkLambdaC ([(dummy_loc,Name wf_arg)],Topconstr.default_binder_kind,wf_arg_type,applied_mes)
+	      Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC wf_arg])    in
+	    Constrexpr_ops.mkLambdaC ([(Loc.ghost,Name wf_arg)],Constrexpr_ops.default_binder_kind,wf_arg_type,applied_mes)
 	  in
 	  let wf_rel_from_mes =
-	    Topconstr.mkAppC(Topconstr.mkRefC  ltof,[wf_arg_type;fun_from_mes])
+	    Constrexpr_ops.mkAppC(Constrexpr_ops.mkRefC  ltof,[wf_arg_type;fun_from_mes])
 	  in
 	  wf_rel_from_mes,true
       | Some wf_rel_expr -> 
 	  let wf_rel_with_mes = 
-	    let a = Names.id_of_string "___a" in 
-	    let b = Names.id_of_string "___b" in 
-	    Topconstr.mkLambdaC(
-	      [dummy_loc,Name a;dummy_loc,Name b],
-	      Topconstr.Default Lib.Explicit,
+	    let a = Names.Id.of_string "___a" in 
+	    let b = Names.Id.of_string "___b" in 
+	    Constrexpr_ops.mkLambdaC(
+	      [Loc.ghost,Name a;Loc.ghost,Name b],
+	      Constrexpr.Default Explicit,
 	      wf_arg_type,
-	      Topconstr.mkAppC(wf_rel_expr,
+	      Constrexpr_ops.mkAppC(wf_rel_expr,
 			       [
-				Topconstr.mkAppC(wf_mes_expr,[Topconstr.mkIdentC a]);
-				Topconstr.mkAppC(wf_mes_expr,[Topconstr.mkIdentC b])
+				Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC a]);
+				Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC b])
 			       ])
 			      )
 	  in
@@ -493,124 +488,62 @@ let register_mes fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas
 let map_option f = function 
   | None -> None 
   | Some v -> Some (f v)
-    
-let decompose_lambda_n_assum_constr_expr = 
-  let rec decompose_lambda_n_assum_constr_expr acc n e = 
-  if n = 0 then (List.rev acc,e)
-  else
-    match e with 
-      | Topconstr.CLambdaN(_, [],e') -> decompose_lambda_n_assum_constr_expr acc n e'
-      | Topconstr.CLambdaN(lambda_loc,(nal,bk,nal_type)::bl,e') ->
-	let nal_length = List.length nal in 
-	if nal_length <= n 
-	then
-	  decompose_lambda_n_assum_constr_expr 
-	    (Topconstr.LocalRawAssum(nal,bk,nal_type)::acc) 
-	    (n - nal_length) 
-	    (Topconstr.CLambdaN(lambda_loc,bl,e')) 
-  	else
-	  let nal_keep,nal_expr = list_chop n nal in 
-	  (List.rev (Topconstr.LocalRawAssum(nal_keep,bk,nal_type)::acc),
-	   Topconstr.CLambdaN(lambda_loc,(nal_expr,bk,nal_type)::bl,e')
-	  )
-      | Topconstr.CLetIn(_, na,nav,e') -> 
-	decompose_lambda_n_assum_constr_expr 
-	  (Topconstr.LocalRawDef(na,nav)::acc) (pred n) e'
-      | _ -> error "Not enough product or assumption"
-  in
-  decompose_lambda_n_assum_constr_expr []
-
-let decompose_prod_n_assum_constr_expr = 
-  let rec decompose_prod_n_assum_constr_expr acc n e = 
-    (* Pp.msgnl (str "n := " ++ int n ++ fnl ()++ *)
-    (* 		str "e := " ++ Ppconstr.pr_lconstr_expr e); *)
-  if n = 0 then 
-    (* let _ = Pp.msgnl (str "return_type := " ++ Ppconstr.pr_lconstr_expr e) in  *)
-      (List.rev acc,e)
-  else
-    match e with 
-      | Topconstr.CProdN(_, [],e') -> decompose_prod_n_assum_constr_expr acc n e'
-      | Topconstr.CProdN(lambda_loc,(nal,bk,nal_type)::bl,e') ->
-	let nal_length = List.length nal in 
-	if nal_length <= n 
-	then
-	  (* let _ = Pp.msgnl (str "first case") in  *)
-	  decompose_prod_n_assum_constr_expr 
-	    (Topconstr.LocalRawAssum(nal,bk,nal_type)::acc) 
-	    (n - nal_length) 
-	    (if bl = [] then e' else (Topconstr.CLambdaN(lambda_loc,bl,e')))
-  	else
-	  (* let _ = Pp.msgnl (str "second case") in  *)
-	  let nal_keep,nal_expr = list_chop n nal in 
-	  (List.rev (Topconstr.LocalRawAssum(nal_keep,bk,nal_type)::acc),
-	   Topconstr.CLambdaN(lambda_loc,(nal_expr,bk,nal_type)::bl,e')
-	  )
-      | Topconstr.CArrow(_,premisse,concl) -> 
-	(* let _ = Pp.msgnl (str "arrow case") in  *)
-	decompose_prod_n_assum_constr_expr 
-	  (Topconstr.LocalRawAssum([dummy_loc,Names.Anonymous],
-				   Topconstr.Default Lib.Explicit,premisse)
-	  ::acc)
-	  (pred n)
-	  concl
-      | Topconstr.CLetIn(_, na,nav,e') -> 
-	decompose_prod_n_assum_constr_expr 
-	  (Topconstr.LocalRawDef(na,nav)::acc) (pred n) e'
-      | _ -> error "Not enough product or assumption"
-  in
-  decompose_prod_n_assum_constr_expr []
 
+open Constrexpr
 open Topconstr
-    
-let id_of_name = function 
-  | Name id -> id 
-  | _ -> assert false
 
- let rec rebuild_bl (aux,assoc) bl typ = 
+let make_assoc assoc l1 l2 =
+  let fold assoc a b = match a, b with
+  | (_, Name na), (_, Name id) -> Id.Map.add na id assoc
+  | _, _ -> assoc
+  in
+  List.fold_left2 fold assoc l1 l2
+
+let rec rebuild_bl (aux,assoc) bl typ = 
 	match bl,typ with 
 	  | [], _ -> (List.rev aux,replace_vars_constr_expr assoc typ,assoc)
-	  | (Topconstr.LocalRawAssum(nal,bk,_))::bl',typ -> 
+	  | (Constrexpr.LocalRawAssum(nal,bk,_))::bl',typ ->
 	     rebuild_nal (aux,assoc) bk bl' nal (List.length nal) typ
-	  | (Topconstr.LocalRawDef(na,_))::bl',CLetIn(_,_,nat,typ') ->
-	    rebuild_bl ((Topconstr.LocalRawDef(na,replace_vars_constr_expr assoc nat)::aux),assoc)
+	  | (Constrexpr.LocalRawDef(na,_))::bl',Constrexpr.CLetIn(_,_,nat,typ') ->
+	    rebuild_bl ((Constrexpr.LocalRawDef(na,replace_vars_constr_expr assoc nat)::aux),assoc)
 	      bl' typ'
 	  | _ -> assert false
       and rebuild_nal (aux,assoc) bk bl' nal lnal typ = 
 	match nal,typ with 
 	  | [], _ -> rebuild_bl (aux,assoc) bl' typ
-	  | na::nal,CArrow(_,nat,typ') -> 
-	    rebuild_nal 
-	      ((LocalRawAssum([na],bk,replace_vars_constr_expr assoc nat))::aux,assoc) 
-	      bk bl' nal (pred lnal) typ'
 	  | _,CProdN(_,[],typ) -> rebuild_nal (aux,assoc) bk bl' nal lnal typ
 	  | _,CProdN(_,(nal',bk',nal't)::rest,typ') -> 
 	    let lnal' = List.length nal' in 
 	    if lnal' >= lnal 
 	    then 
-	      let old_nal',new_nal' = list_chop lnal nal' in 
-	      rebuild_bl ((LocalRawAssum(nal,bk,replace_vars_constr_expr assoc nal't)::aux),(List.rev_append (List.combine (List.map id_of_name (List.map snd old_nal'))  (List.map id_of_name (List.map snd nal))) assoc)) bl' 
-		(if new_nal' = [] && rest = []
-		 then  typ' 
-		 else if new_nal' = [] 
-		 then CProdN(dummy_loc,rest,typ')
-		 else CProdN(dummy_loc,((new_nal',bk',nal't)::rest),typ'))
+	      let old_nal',new_nal' = List.chop lnal nal' in
+	      let nassoc = make_assoc assoc old_nal' nal in
+	      let assum = LocalRawAssum(nal,bk,replace_vars_constr_expr assoc nal't) in
+	      rebuild_bl ((assum :: aux), nassoc) bl' 
+		(if List.is_empty new_nal' && List.is_empty rest
+		 then typ'
+		 else if List.is_empty new_nal'
+		 then CProdN(Loc.ghost,rest,typ')
+		 else CProdN(Loc.ghost,((new_nal',bk',nal't)::rest),typ'))
 	    else 
-	      let captured_nal,non_captured_nal = list_chop lnal' nal in 
-	      rebuild_nal ((LocalRawAssum(captured_nal,bk,replace_vars_constr_expr assoc nal't)::aux), (List.rev_append (List.combine (List.map id_of_name (List.map snd captured_nal)) ((List.map id_of_name (List.map snd nal)))) assoc))
-		bk bl' non_captured_nal (lnal - lnal') (CProdN(dummy_loc,rest,typ'))
+	      let captured_nal,non_captured_nal = List.chop lnal' nal in
+	      let nassoc = make_assoc assoc nal' captured_nal in
+	      let assum = LocalRawAssum(captured_nal,bk,replace_vars_constr_expr assoc nal't) in
+	      rebuild_nal ((assum :: aux), nassoc)
+		bk bl' non_captured_nal (lnal - lnal') (CProdN(Loc.ghost,rest,typ'))
 	  | _ -> assert false
 
 let rebuild_bl (aux,assoc) bl typ = rebuild_bl (aux,assoc) bl typ
 
 let recompute_binder_list (fixpoint_exprl : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = 
   let fixl,ntns = Command.extract_fixpoint_components false fixpoint_exprl in
-  let ((_,_,typel),_) = Command.interp_fixpoint fixl ntns in
+  let ((_,_,typel),_,_) = Command.interp_fixpoint fixl ntns in
   let constr_expr_typel = 
-    with_full_print (List.map (Constrextern.extern_constr false (Global.env ()))) typel in 
+    with_full_print (List.map (Constrextern.extern_constr false (Global.env ()) Evd.empty)) typel in
   let fixpoint_exprl_with_new_bl = 
     List.map2 (fun ((lna,(rec_arg_opt,rec_order),bl,ret_typ,opt_body),notation_list) fix_typ -> 
      
-      let new_bl',new_ret_type,_ = rebuild_bl ([],[]) bl fix_typ in 
+      let new_bl',new_ret_type,_ = rebuild_bl ([],Id.Map.empty) bl fix_typ in 
       (((lna,(rec_arg_opt,rec_order),new_bl',new_ret_type,opt_body),notation_list):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list))
     )
       fixpoint_exprl constr_expr_typel 
@@ -618,23 +551,24 @@ let recompute_binder_list (fixpoint_exprl : (Vernacexpr.fixpoint_expr * Vernacex
   fixpoint_exprl_with_new_bl
   
 
-let do_generate_principle on_error register_built interactive_proof
+let do_generate_principle mp_dp on_error register_built interactive_proof
     (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) :unit =
-  List.iter (fun (_,l) -> if l <> [] then error "Function does not support notations for now") fixpoint_exprl;
+  List.iter (fun (_,l) -> if not (List.is_empty l) then error "Function does not support notations for now") fixpoint_exprl;
   let _is_struct =
     match fixpoint_exprl with
-      | [((_,(wf_x,Topconstr.CWfRec wf_rel),_,_,_),_) as fixpoint_expr] ->
+      | [((_,(wf_x,Constrexpr.CWfRec wf_rel),_,_,_),_) as fixpoint_expr] ->
  	  let ((((_,name),_,args,types,body)),_)  as fixpoint_expr =
 	    match recompute_binder_list [fixpoint_expr] with 
 	      | [e] -> e
 	      | _ -> assert false
 	  in 
 	  let fixpoint_exprl = [fixpoint_expr] in 
-	  let body = match body with | Some body -> body | None -> user_err_loc (dummy_loc,"Function",str "Body of Function must be given") in 
+	  let body = match body with | Some body -> body | None -> user_err_loc (Loc.ghost,"Function",str "Body of Function must be given") in 
 	  let recdefs,rec_impls = build_newrecursive fixpoint_exprl in
 	  let using_lemmas = [] in 
 	  let pre_hook =
 	    generate_principle
+	      mp_dp
 	      on_error
 	      true
 	      register_built
@@ -645,7 +579,7 @@ let do_generate_principle on_error register_built interactive_proof
 	  if register_built
 	  then register_wf name rec_impls wf_rel (map_option snd wf_x) using_lemmas args types body pre_hook;
 	  false
-      |[((_,(wf_x,Topconstr.CMeasureRec(wf_mes,wf_rel_opt)),_,_,_),_) as fixpoint_expr] ->
+      |[((_,(wf_x,Constrexpr.CMeasureRec(wf_mes,wf_rel_opt)),_,_,_),_) as fixpoint_expr] ->
  	  let ((((_,name),_,args,types,body)),_)  as fixpoint_expr =
 	    match recompute_binder_list [fixpoint_expr] with 
 	      | [e] -> e
@@ -654,9 +588,10 @@ let do_generate_principle on_error register_built interactive_proof
 	  let fixpoint_exprl = [fixpoint_expr] in 
 	  let recdefs,rec_impls = build_newrecursive fixpoint_exprl in
 	  let using_lemmas = [] in
-	  let body = match body with | Some body -> body | None -> user_err_loc (dummy_loc,"Function",str "Body of Function must be given") in 
+	  let body = match body with | Some body -> body | None -> user_err_loc (Loc.ghost,"Function",str "Body of Function must be given") in 
 	  let pre_hook =
 	    generate_principle
+	      mp_dp
 	      on_error
 	      true
 	      register_built
@@ -670,7 +605,7 @@ let do_generate_principle on_error register_built interactive_proof
       | _ ->
 	  List.iter (function ((_na,(_,ord),_args,_body,_type),_not) ->
 		       match ord with 
-			 | Topconstr.CMeasureRec _ | Topconstr.CWfRec _ -> 
+			 | Constrexpr.CMeasureRec _ | Constrexpr.CWfRec _ ->
 			     error
 			       ("Cannot use mutual definition with well-founded recursion or measure")
 			 | _ -> ()
@@ -685,6 +620,7 @@ let do_generate_principle on_error register_built interactive_proof
 	let is_rec = List.exists (is_rec fix_names) recdefs in
 	if register_built then register_struct is_rec fixpoint_exprl;
 	generate_principle
+	  mp_dp
 	  on_error
 	  false
 	  register_built
@@ -697,18 +633,15 @@ let do_generate_principle on_error register_built interactive_proof
   in
   ()
 
-open Topconstr
 let rec add_args id new_args b =
   match b with
-  | CRef r ->
+  | CRef (r,_) ->
       begin      match r with
-	| Libnames.Ident(loc,fname) when fname = id ->
-	    CAppExpl(dummy_loc,(None,r),new_args)
+	| Libnames.Ident(loc,fname) when Id.equal fname id ->
+	    CAppExpl(Loc.ghost,(None,r,None),new_args)
 	| _ -> b
       end
-  | CFix  _  | CCoFix _ -> anomaly "add_args : todo"
-  | CArrow(loc,b1,b2) ->
-      CArrow(loc,add_args id new_args  b1, add_args id new_args b2)
+  | CFix  _  | CCoFix _ -> anomaly ~label:"add_args " (Pp.str "todo")
   | CProdN(loc,nal,b1) ->
       CProdN(loc,
 	     List.map (fun (nal,k,b2) -> (nal,k,add_args id new_args b2)) nal,
@@ -719,12 +652,12 @@ let rec add_args id new_args b =
 	       add_args id new_args  b1)
   | CLetIn(loc,na,b1,b2) ->
       CLetIn(loc,na,add_args id new_args b1,add_args id new_args b2)
-  | CAppExpl(loc,(pf,r),exprl) ->
+  | CAppExpl(loc,(pf,r,us),exprl) ->
       begin
 	match r with
-	| Libnames.Ident(loc,fname) when fname = id ->
-	    CAppExpl(loc,(pf,r),new_args@(List.map (add_args id new_args) exprl))
-	| _ -> CAppExpl(loc,(pf,r),List.map (add_args id new_args) exprl)
+	| Libnames.Ident(loc,fname) when Id.equal fname id ->
+	    CAppExpl(loc,(pf,r,us),new_args@(List.map (add_args id new_args) exprl))
+	| _ -> CAppExpl(loc,(pf,r,us),List.map (add_args id new_args) exprl)
       end
   | CApp(loc,(pf,b),bl) ->
       CApp(loc,(pf,add_args id new_args b),
@@ -733,7 +666,7 @@ let rec add_args id new_args b =
       CCases(loc,sty,Option.map (add_args id new_args) b_option,
 	     List.map (fun (b,(na,b_option)) ->
 			 add_args id new_args b,
-			 (na,Option.map (add_args id new_args) b_option)) cel,
+			 (na, b_option)) cel,
 	     List.map (fun (loc,cpl,e) -> (loc,cpl,add_args id new_args e)) cal
 	    )
   | CLetTuple(loc,nal,(na,b_option),b1,b2) ->
@@ -752,32 +685,29 @@ let rec add_args id new_args b =
   | CPatVar _ -> b
   | CEvar _ -> b
   | CSort _ -> b
-  | CCast(loc,b1,CastConv(ck,b2))  ->
-      CCast(loc,add_args id new_args b1,CastConv(ck,add_args id new_args b2))
-  | CCast(loc,b1,CastCoerce) ->
-      CCast(loc,add_args id new_args b1,CastCoerce)
+  | CCast(loc,b1,b2)  ->
+      CCast(loc,add_args id new_args b1,
+	    Miscops.map_cast_type (add_args id new_args) b2)
   | CRecord (loc, w, pars) ->
       CRecord (loc,
 	       (match w with Some w -> Some (add_args id new_args w) | _ -> None),
 	       List.map (fun (e,o) -> e, add_args id new_args o) pars)
-  | CNotation _ -> anomaly "add_args : CNotation"
-  | CGeneralization _ -> anomaly "add_args : CGeneralization"
+  | CNotation _ -> anomaly ~label:"add_args " (Pp.str "CNotation")
+  | CGeneralization _ -> anomaly ~label:"add_args " (Pp.str "CGeneralization")
   | CPrim _ -> b
-  | CDelimiters _ -> anomaly "add_args : CDelimiters"
-exception Stop of  Topconstr.constr_expr
+  | CDelimiters _ -> anomaly ~label:"add_args " (Pp.str "CDelimiters")
+exception Stop of  Constrexpr.constr_expr
 
 
 (* [chop_n_arrow n t] chops the [n] first arrows in [t]
-   Acts on Topconstr.constr_expr
+   Acts on Constrexpr.constr_expr
 *)
 let rec chop_n_arrow n t =
   if n <= 0
   then t (* If we have already removed all the arrows then return the type *)
   else (* If not we check the form of [t] *)
     match t with
-      | Topconstr.CArrow(_,_,t) ->  (* If we have an arrow, we discard it and recall [chop_n_arrow] *)
-	  chop_n_arrow (n-1) t
-      | Topconstr.CProdN(_,nal_ta',t') -> (* If we have a forall, to result are possible :
+      | Constrexpr.CProdN(_,nal_ta',t') -> (* If we have a forall, to result are possible :
 					     either we need to discard more than the number of arrows contained
 					     in this product declaration then we just recall [chop_n_arrow] on
 					     the remaining number of arrow to chop and [t'] we discard it and
@@ -796,8 +726,8 @@ let rec chop_n_arrow n t =
 		      aux (n - nal_l) nal_ta'
 		    else
 		      let new_t' =
-			Topconstr.CProdN(dummy_loc,
-					((snd (list_chop n nal)),k,t'')::nal_ta',t')
+			Constrexpr.CProdN(Loc.ghost,
+					((snd (List.chop n nal)),k,t'')::nal_ta',t')
 		      in
 		      raise (Stop new_t')
 		in
@@ -806,13 +736,13 @@ let rec chop_n_arrow n t =
 	      chop_n_arrow new_n t'
 	    with Stop t -> t
 	  end
-      | _ -> anomaly "Not enough products"
+      | _ -> anomaly (Pp.str "Not enough products")
 
 
-let rec get_args b t : Topconstr.local_binder list *
-    Topconstr.constr_expr * Topconstr.constr_expr =
+let rec get_args b t : Constrexpr.local_binder list *
+    Constrexpr.constr_expr * Constrexpr.constr_expr =
   match b with
-    | Topconstr.CLambdaN (loc, (nal_ta), b') ->
+    | Constrexpr.CLambdaN (loc, (nal_ta), b') ->
 	begin
 	  let n =
 	    (List.fold_left (fun n (nal,_,_) ->
@@ -820,7 +750,7 @@ let rec get_args b t : Topconstr.local_binder list *
 	  in
 	  let nal_tas,b'',t'' = get_args b' (chop_n_arrow n t) in
 	  (List.map (fun (nal,k,ta) ->
-		       (Topconstr.LocalRawAssum (nal,k,ta))) nal_ta)@nal_tas, b'',t''
+		       (Constrexpr.LocalRawAssum (nal,k,ta))) nal_ta)@nal_tas, b'',t''
 	end
     | _ -> [],b,t
 
@@ -836,17 +766,15 @@ let make_graph (f_ref:global_reference) =
       | _ -> raise (UserError ("", str "Not a function reference") )
   in
   Dumpglob.pause ();
-  (match body_of_constant c_body with
+  (match Global.body_of_constant_body c_body with
      | None -> error "Cannot build a graph over an axiom !"
-     | Some b ->
+     | Some body ->
 	 let env = Global.env () in
-	 let body = (force b) in
 	 let extern_body,extern_type =
-	   with_full_print
-	     (fun () ->
-		(Constrextern.extern_constr false env body,
-		 Constrextern.extern_type false env
-                   (Typeops.type_of_constant_type env c_body.const_type)
+	   with_full_print (fun () ->
+		(Constrextern.extern_constr false env Evd.empty body,
+		 Constrextern.extern_type false env Evd.empty
+                   ((*FIXNE*) Typeops.type_of_constant_type env c_body.const_type)
 		)
 	     )
 	     ()
@@ -854,7 +782,7 @@ let make_graph (f_ref:global_reference) =
 	 let (nal_tas,b,t)  = get_args extern_body extern_type in
 	 let expr_list =
 	   match b with
-	     | Topconstr.CFix(loc,l_id,fixexprl) ->
+	     | Constrexpr.CFix(loc,l_id,fixexprl) ->
 		 let l =
 		   List.map
 		     (fun (id,(n,recexp),bl,t,b) ->
@@ -863,34 +791,34 @@ let make_graph (f_ref:global_reference) =
 			  List.flatten
 			    (List.map
 			       (function
- 				  | Topconstr.LocalRawDef (na,_)-> []
-			      	  | Topconstr.LocalRawAssum (nal,_,_) ->
+				  | Constrexpr.LocalRawDef (na,_)-> []
+				  | Constrexpr.LocalRawAssum (nal,_,_) ->
 				      List.map
 					(fun (loc,n) ->
-					   CRef(Libnames.Ident(loc, Nameops.out_name n)))
+					   CRef(Libnames.Ident(loc, Nameops.out_name n),None))
 					nal
 			       )
 			       nal_tas
 			    )
 			in
 			let b' = add_args (snd id) new_args b in
-			(((id, ( Some (dummy_loc,rec_id),CStructRec),nal_tas@bl,t,Some b'),[]):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list))
+			(((id, ( Some (Loc.ghost,rec_id),CStructRec),nal_tas@bl,t,Some b'),[]):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list))
 		     )
 		     fixexprl
 		 in
 		 l
 	     | _ ->
-		 let id = id_of_label (con_label c) in
-		 [((dummy_loc,id),(None,Topconstr.CStructRec),nal_tas,t,Some b),[]]
+		let id = Label.to_id (con_label c) in
+		 [((Loc.ghost,id),(None,Constrexpr.CStructRec),nal_tas,t,Some b),[]]
 	 in
-	 do_generate_principle error_error false false expr_list;
-	 (* We register the infos *)
 	 let mp,dp,_ = repr_con c in
+	 do_generate_principle (Some (mp,dp)) error_error  false false expr_list;
+	 (* We register the infos *)
 	 List.iter
-	   (fun (((_,id),_,_,_,_),_) -> add_Function false (make_con mp dp (label_of_id id)))
+	   (fun (((_,id),_,_,_,_),_) -> add_Function false (make_con mp dp (Label.of_id id)))
 	   expr_list);
   Dumpglob.continue ()
 
-let do_generate_principle = do_generate_principle warning_error true
+let do_generate_principle = do_generate_principle None warning_error true
 
 
diff --git a/plugins/funind/indfun.mli b/plugins/funind/indfun.mli
index e65b5808..e7206914 100644
--- a/plugins/funind/indfun.mli
+++ b/plugins/funind/indfun.mli
@@ -1,11 +1,4 @@
-open Util
-open Names
-open Term
-open Pp
-open Indfun_common
-open Libnames
-open Glob_term
-open Declarations
+open Misctypes
 
 val do_generate_principle :  
   bool -> 
@@ -16,9 +9,9 @@ val do_generate_principle :
 val functional_induction :  
   bool ->
   Term.constr ->
-  (Term.constr * Term.constr Glob_term.bindings) option ->
-  Genarg.intro_pattern_expr Util.located option ->
+  (Term.constr * Term.constr bindings) option ->
+  Tacexpr.or_and_intro_pattern option ->
   Proof_type.goal Tacmach.sigma -> Proof_type.goal list Evd.sigma
 
 
-val make_graph :  Libnames.global_reference -> unit
+val make_graph :  Globnames.global_reference -> unit
diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml
index 827191b1..76f8c6d2 100644
--- a/plugins/funind/indfun_common.ml
+++ b/plugins/funind/indfun_common.ml
@@ -1,9 +1,9 @@
 open Names
 open Pp
-
 open Libnames
-
-let mk_prefix pre id = id_of_string (pre^(string_of_id id))
+open Globnames
+open Refiner
+let mk_prefix pre id = Id.of_string (pre^(Id.to_string id))
 let mk_rel_id = mk_prefix "R_"
 let mk_correct_id id = Nameops.add_suffix (mk_rel_id id) "_correct"
 let mk_complete_id id = Nameops.add_suffix (mk_rel_id id) "_complete"
@@ -12,10 +12,7 @@ let mk_equation_id id = Nameops.add_suffix id "_equation"
 let msgnl m =
   ()
 
-let invalid_argument s = raise (Invalid_argument s)
-
-
-let fresh_id avoid s = Namegen.next_ident_away_in_goal (id_of_string s) avoid
+let fresh_id avoid s = Namegen.next_ident_away_in_goal (Id.of_string s) avoid
 
 let fresh_name avoid s = Name (fresh_id avoid s)
 
@@ -29,7 +26,7 @@ let array_get_start a =
       (Array.length a - 1)
       (fun i -> a.(i))
   with Invalid_argument "index out of bounds" ->
-    invalid_argument "array_get_start"
+    invalid_arg "array_get_start"
 
 let id_of_name = function
     Name id -> id
@@ -51,10 +48,8 @@ let locate_constant ref =
 
 
 let locate_with_msg msg f x =
-  try
-    f x
-  with
-    | Not_found -> raise (Util.UserError("", msg))
+  try f x
+  with Not_found -> raise (Errors.UserError("", msg))
 
 
 let filter_map filter f =
@@ -78,7 +73,7 @@ let chop_rlambda_n  =
 	  | Glob_term.GLambda(_,name,k,t,b) -> chop_lambda_n ((name,t,false)::acc) (n-1) b
 	  | Glob_term.GLetIn(_,name,v,b) -> chop_lambda_n ((name,v,true)::acc) (n-1) b
 	  | _ ->
-	      raise (Util.UserError("chop_rlambda_n",
+	      raise (Errors.UserError("chop_rlambda_n",
 				    str "chop_rlambda_n: Not enough Lambdas"))
   in
   chop_lambda_n []
@@ -90,7 +85,7 @@ let chop_rprod_n  =
       else
 	match rt with
 	  | Glob_term.GProd(_,name,k,t,b) -> chop_prod_n ((name,t)::acc) (n-1) b
-	  | _ -> raise (Util.UserError("chop_rprod_n",str "chop_rprod_n: Not enough products"))
+	  | _ -> raise (Errors.UserError("chop_rprod_n",str "chop_rprod_n: Not enough products"))
   in
   chop_prod_n []
 
@@ -111,34 +106,27 @@ let list_add_set_eq eq_fun x l =
 
 let const_of_id id =
   let _,princ_ref =
-    qualid_of_reference (Libnames.Ident (Util.dummy_loc,id))
+    qualid_of_reference (Libnames.Ident (Loc.ghost,id))
   in
   try Nametab.locate_constant princ_ref
-  with Not_found -> Util.error ("cannot find "^ string_of_id id)
+  with Not_found -> Errors.error ("cannot find "^ Id.to_string id)
 
 let def_of_const t =
    match (Term.kind_of_term t) with
     Term.Const sp ->
-      (try (match Declarations.body_of_constant (Global.lookup_constant sp) with
-             | Some c -> Declarations.force c
+      (try (match Environ.constant_opt_value_in (Global.env()) sp with
+             | Some c -> c
 	     | _ -> assert false)
-       with e when Errors.noncritical e -> assert false)
+       with Not_found -> assert false)
     |_ -> assert false
 
 let coq_constant s =
   Coqlib.gen_constant_in_modules "RecursiveDefinition"
     Coqlib.init_modules s;;
 
-let constant sl s =
-  constr_of_global
-    (Nametab.locate (make_qualid(Names.make_dirpath
-			   (List.map id_of_string (List.rev sl)))
-	       (id_of_string s)));;
-
 let find_reference sl s =
-    (Nametab.locate (make_qualid(Names.make_dirpath
-			   (List.map id_of_string (List.rev sl)))
-	       (id_of_string s)));;
+  let dp = Names.DirPath.make (List.rev_map Id.of_string sl) in
+  Nametab.locate (make_qualid dp (Id.of_string s))
 
 let eq = lazy(coq_constant "eq")
 let refl_equal = lazy(coq_constant "eq_refl")
@@ -147,47 +135,40 @@ let refl_equal = lazy(coq_constant "eq_refl")
 (* Copy of the standart save mechanism but without the much too  *)
 (* slow reduction function                                       *)
 (*****************************************************************)
-open Declarations
 open Entries
 open Decl_kinds
 open Declare
-let definition_message id =
-  Flags.if_verbose message ((string_of_id id) ^ " is defined")
 
+let definition_message = Declare.definition_message
 
-let save with_clean id const (locality,kind) hook =
-  let {const_entry_body = pft;
-       const_entry_secctx = _;
-       const_entry_type = tpo;
-       const_entry_opaque = opacity } = const in
+let get_locality = function
+| Discharge -> true
+| Local -> true
+| Global -> false
+
+let save with_clean id const (locality,_,kind) hook =
+  let fix_exn = Future.fix_exn_of const.Entries.const_entry_body in
   let l,r = match locality with
-    | Local when Lib.sections_are_opened () ->
-        let k = logical_kind_of_goal_kind kind in
-	let c = SectionLocalDef (pft, tpo, opacity) in
+    | Discharge when Lib.sections_are_opened () ->
+        let k = Kindops.logical_kind_of_goal_kind kind in
+	let c = SectionLocalDef const in
 	let _ = declare_variable id (Lib.cwd(), c, k) in
 	(Local, VarRef id)
-    | Local ->
-        let k = logical_kind_of_goal_kind kind in
-        let kn = declare_constant id (DefinitionEntry const, k) in
-	(Global, ConstRef kn)
-    | Global ->
-        let k = logical_kind_of_goal_kind kind in
-        let kn = declare_constant id (DefinitionEntry const, k) in
-	(Global, ConstRef kn) in
+    | Discharge | Local | Global ->
+        let local = get_locality locality in
+        let k = Kindops.logical_kind_of_goal_kind kind in
+        let kn = declare_constant id ~local (DefinitionEntry const, k) in
+	(locality, ConstRef kn)
+  in
   if with_clean then  Pfedit.delete_current_proof ();
-  hook l r;
+  Ephemeron.iter_opt hook (fun f -> Lemmas.call_hook fix_exn f l r);
   definition_message id
 
 
 
 let cook_proof _ =
-  let (id,(entry,_,strength,hook)) = Pfedit.cook_proof (fun _ -> ()) in
-  (id,(entry,strength,hook))
-
-let new_save_named opacity =
-  let id,(const,persistence,hook) = cook_proof true  in
-  let const = { const with const_entry_opaque = opacity } in
-  save true id const persistence hook
+  let (id,(entry,_,strength)) = Pfedit.cook_proof () in
+  (id,(entry,strength))
 
 let get_proof_clean do_reduce =
   let result = cook_proof do_reduce in
@@ -197,7 +178,8 @@ let get_proof_clean do_reduce =
 let with_full_print f a =
   let old_implicit_args = Impargs.is_implicit_args ()
   and old_strict_implicit_args =  Impargs.is_strict_implicit_args ()
-  and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () in
+  and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () 
+  in
   let old_rawprint = !Flags.raw_print in
   Flags.raw_print := true;
   Impargs.make_implicit_args false;
@@ -248,8 +230,9 @@ type function_info =
 (* let function_table = ref ([] : function_db) *)
 
 
-let from_function = ref Cmap.empty
-let from_graph = ref Indmap.empty
+let from_function = Summary.ref Cmap_env.empty ~name:"functions_db_fn"
+let from_graph = Summary.ref Indmap.empty ~name:"functions_db_gr"
+
 (*
 let rec do_cache_info finfo = function
   | [] -> raise Not_found
@@ -272,15 +255,14 @@ let cache_Function (_,(finfos)) =
 *)
 
 let cache_Function (_,finfos) =
-  from_function := Cmap.add finfos.function_constant finfos !from_function;
+  from_function := Cmap_env.add finfos.function_constant finfos !from_function;
   from_graph := Indmap.add finfos.graph_ind finfos !from_graph
 
 
 let load_Function _  = cache_Function
-let open_Function _ = cache_Function
 let subst_Function (subst,finfos) =
-  let do_subst_con c = fst (Mod_subst.subst_con subst c)
-  and do_subst_ind (kn,i) = (Mod_subst.subst_ind subst kn,i)
+  let do_subst_con c = Mod_subst.subst_constant subst c
+  and do_subst_ind i = Mod_subst.subst_ind subst i
   in
   let function_constant' = do_subst_con finfos.function_constant in
   let graph_ind' = do_subst_ind finfos.graph_ind in
@@ -346,22 +328,29 @@ let discharge_Function (_,finfos) =
 	 }
 
 open Term
+
+let pr_ocst c =
+  Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) c (mt ())
+
 let pr_info f_info =
-  str "function_constant := " ++ Printer.pr_lconstr (mkConst f_info.function_constant)++ fnl () ++
-    str "function_constant_type := " ++
-    (try Printer.pr_lconstr (Global.type_of_global (ConstRef f_info.function_constant))
-     with e when Errors.noncritical e -> mt ()) ++ fnl () ++
-    str "equation_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.equation_lemma (mt ()) ) ++ fnl () ++
-    str "completeness_lemma :=" ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.completeness_lemma (mt ()) ) ++ fnl () ++
-    str "correctness_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.correctness_lemma (mt ()) ) ++ fnl () ++
-    str "rect_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.rect_lemma (mt ()) ) ++ fnl () ++
-    str "rec_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.rec_lemma (mt ()) ) ++ fnl () ++
-    str "prop_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.prop_lemma (mt ()) ) ++ fnl () ++
-    str "graph_ind := " ++ Printer.pr_lconstr (mkInd f_info.graph_ind) ++ fnl ()
+  str "function_constant := " ++
+  Printer.pr_lconstr (mkConst f_info.function_constant)++ fnl () ++
+  str "function_constant_type := " ++
+  (try
+     Printer.pr_lconstr
+       (Global.type_of_global_unsafe (ConstRef f_info.function_constant))
+   with e when Errors.noncritical e -> mt ()) ++ fnl () ++
+  str "equation_lemma := " ++ pr_ocst f_info.equation_lemma ++ fnl () ++
+  str "completeness_lemma :=" ++ pr_ocst f_info.completeness_lemma ++ fnl () ++
+  str "correctness_lemma := " ++ pr_ocst f_info.correctness_lemma ++ fnl () ++
+  str "rect_lemma := " ++ pr_ocst f_info.rect_lemma ++ fnl () ++
+  str "rec_lemma := " ++ pr_ocst f_info.rec_lemma ++ fnl () ++
+  str "prop_lemma := " ++ pr_ocst f_info.prop_lemma ++ fnl () ++
+  str "graph_ind := " ++ Printer.pr_lconstr (mkInd f_info.graph_ind) ++ fnl ()
 
 let pr_table tb =
-  let l = Cmap.fold (fun k v acc -> v::acc) tb [] in
-  Util.prlist_with_sep fnl pr_info l
+  let l = Cmap_env.fold (fun k v acc -> v::acc) tb [] in
+  Pp.prlist_with_sep fnl pr_info l
 
 let in_Function : function_info -> Libobject.obj =
   Libobject.declare_object
@@ -375,36 +364,16 @@ let in_Function : function_info -> Libobject.obj =
     }
 
 
-
-(* Synchronisation with reset *)
-let freeze () =
-  !from_function,!from_graph
-let unfreeze (functions,graphs) =
-(*   Pp.msgnl (str "unfreezing function_table : " ++ pr_table l); *)
-  from_function := functions;
-  from_graph := graphs
-
-let init () =
-(*   Pp.msgnl (str "reseting function_table");  *)
-  from_function := Cmap.empty;
-  from_graph := Indmap.empty
-
-let _ =
-  Summary.declare_summary "functions_db_sum"
-    { Summary.freeze_function = freeze;
-      Summary.unfreeze_function = unfreeze;
-      Summary.init_function = init }
-
 let find_or_none id =
   try Some
-    (match Nametab.locate (qualid_of_ident id) with ConstRef c -> c | _ -> Util.anomaly "Not a constant"
+    (match Nametab.locate (qualid_of_ident id) with ConstRef c -> c | _ -> Errors.anomaly (Pp.str "Not a constant")
     )
   with Not_found -> None
 
 
 
 let find_Function_infos f =
-  Cmap.find f !from_function
+  Cmap_env.find f !from_function
 
 
 let find_Function_of_graph ind =
@@ -416,7 +385,7 @@ let update_Function finfo =
 
 
 let add_Function is_general f =
-  let f_id = id_of_label (con_label f) in
+  let f_id = Label.to_id (con_label f) in
   let equation_lemma = find_or_none (mk_equation_id f_id)
   and correctness_lemma = find_or_none (mk_correct_id f_id)
   and completeness_lemma = find_or_none (mk_complete_id f_id)
@@ -425,7 +394,7 @@ let add_Function is_general f =
   and prop_lemma = find_or_none (Nameops.add_suffix f_id "_ind")
   and graph_ind =
     match Nametab.locate (qualid_of_ident (mk_rel_id f_id))
-    with | IndRef ind -> ind | _ -> Util.anomaly "Not an inductive"
+    with | IndRef ind -> ind | _ -> Errors.anomaly (Pp.str "Not an inductive")
   in
   let finfos =
     { function_constant = f;
@@ -475,8 +444,7 @@ let function_debug_sig =
 let _ = declare_bool_option function_debug_sig
 
 
-let do_observe () =
-  !function_debug = true
+let do_observe () = !function_debug 
 
 
 
@@ -499,25 +467,37 @@ exception Building_graph of exn
 exception Defining_principle of exn
 exception ToShow of exn
 
-let init_constant dir s =
-  try
-    Coqlib.gen_constant "Function" dir s
-  with e when Errors.noncritical e -> raise (ToShow e)
-
 let jmeq () =
   try
-    (Coqlib.check_required_library ["Coq";"Logic";"JMeq"];
-     init_constant ["Logic";"JMeq"] "JMeq")
-  with e when Errors.noncritical e -> raise (ToShow e)
-
-let jmeq_rec () =
-  try
-    Coqlib.check_required_library ["Coq";"Logic";"JMeq"];
-	  init_constant ["Logic";"JMeq"] "JMeq_rec"
+    Coqlib.check_required_library Coqlib.jmeq_module_name;
+    Coqlib.gen_constant "Function" ["Logic";"JMeq"] "JMeq"
   with e when Errors.noncritical e -> raise (ToShow e)
 
 let jmeq_refl () =
   try
-    Coqlib.check_required_library ["Coq";"Logic";"JMeq"];
-    init_constant ["Logic";"JMeq"] "JMeq_refl"
+    Coqlib.check_required_library Coqlib.jmeq_module_name;
+    Coqlib.gen_constant "Function" ["Logic";"JMeq"] "JMeq_refl"
   with e when Errors.noncritical e -> raise (ToShow e)
+
+let h_intros l =
+  tclMAP (fun x -> Proofview.V82.of_tactic (Tactics.Simple.intro x)) l
+
+let h_id = Id.of_string "h"
+let hrec_id = Id.of_string "hrec"
+let well_founded = function () -> (coq_constant "well_founded")
+let acc_rel = function () -> (coq_constant "Acc")
+let acc_inv_id = function () -> (coq_constant "Acc_inv")
+let well_founded_ltof = function () ->  (Coqlib.coq_constant "" ["Arith";"Wf_nat"] "well_founded_ltof")
+let ltof_ref = function  () -> (find_reference ["Coq";"Arith";"Wf_nat"] "ltof")
+
+let evaluable_of_global_reference r = (* Tacred.evaluable_of_global_reference (Global.env ()) *)
+  match r with
+      ConstRef sp -> EvalConstRef sp
+    | VarRef id -> EvalVarRef id
+    | _ -> assert false;;
+
+let list_rewrite (rev:bool) (eqs: (constr*bool) list) =
+  tclREPEAT
+    (List.fold_right
+       (fun (eq,b) i -> tclORELSE (Proofview.V82.of_tactic ((if b then Equality.rewriteLR else Equality.rewriteRL) eq)) i)
+       (if rev then (List.rev eqs) else eqs) (tclFAIL 0 (mt())));;
diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli
index e0076735..67ddf374 100644
--- a/plugins/funind/indfun_common.mli
+++ b/plugins/funind/indfun_common.mli
@@ -5,23 +5,21 @@ open Pp
    The mk_?_id function build different name w.r.t. a function
    Each of their use is justified in the code
 *)
-val mk_rel_id : identifier -> identifier
-val mk_correct_id : identifier -> identifier
-val mk_complete_id : identifier -> identifier
-val mk_equation_id : identifier -> identifier
+val mk_rel_id : Id.t -> Id.t
+val mk_correct_id : Id.t -> Id.t
+val mk_complete_id : Id.t -> Id.t
+val mk_equation_id : Id.t -> Id.t
 
 
 val msgnl : std_ppcmds -> unit
 
-val invalid_argument : string -> 'a
-
-val fresh_id : identifier list -> string -> identifier
-val fresh_name : identifier list -> string -> name
-val get_name : identifier list -> ?default:string -> name -> name
+val fresh_id : Id.t list -> string -> Id.t
+val fresh_name : Id.t list -> string -> Name.t
+val get_name : Id.t list -> ?default:string -> Name.t -> Name.t
 
 val array_get_start : 'a array -> 'a array
 
-val id_of_name : name -> identifier
+val id_of_name : Name.t -> Id.t
 
 val locate_ind : Libnames.reference -> inductive
 val locate_constant : Libnames.reference -> constant
@@ -36,38 +34,31 @@ val list_add_set_eq :
   ('a -> 'a -> bool) -> 'a -> 'a list -> 'a list
 
 val chop_rlambda_n : int -> Glob_term.glob_constr ->
-  (name*Glob_term.glob_constr*bool) list * Glob_term.glob_constr
+  (Name.t*Glob_term.glob_constr*bool) list * Glob_term.glob_constr
 
 val chop_rprod_n : int -> Glob_term.glob_constr ->
-  (name*Glob_term.glob_constr) list * Glob_term.glob_constr
+  (Name.t*Glob_term.glob_constr) list * Glob_term.glob_constr
 
 val def_of_const : Term.constr -> Term.constr
 val eq : Term.constr Lazy.t
 val refl_equal : Term.constr Lazy.t
-val const_of_id: identifier -> constant
+val const_of_id: Id.t -> constant
 val jmeq : unit -> Term.constr
 val jmeq_refl : unit -> Term.constr
 
-(* [save_named] is a copy of [Command.save_named] but uses
-   [nf_betaiotazeta] instead of [nf_betaiotaevar_preserving_vm_cast]
-*)
-
-val new_save_named : bool -> unit
-
-val save : bool -> identifier ->  Entries.definition_entry  -> Decl_kinds.goal_kind ->
-  Tacexpr.declaration_hook -> unit
+val save : bool -> Id.t -> Entries.definition_entry  -> Decl_kinds.goal_kind ->
+  unit Lemmas.declaration_hook Ephemeron.key -> unit
 
 (* [get_proof_clean do_reduce] : returns the proof name, definition, kind and hook and
    abort the proof
 *)
 val get_proof_clean : bool ->
-  Names.identifier *
-    (Entries.definition_entry * Decl_kinds.goal_kind *
-       Tacexpr.declaration_hook)
+  Names.Id.t *
+    (Entries.definition_entry * Decl_kinds.goal_kind)
 
 
 
-(* [with_full_print f a] applies [f] to [a] in full printing environment
+(* [with_full_print f a] applies [f] to [a] in full printing environment.
 
    This function preserves the print settings
 *)
@@ -112,3 +103,14 @@ exception Defining_principle of exn
 exception ToShow of exn
 
 val is_strict_tcc : unit -> bool
+
+val h_intros: Names.Id.t list -> Proof_type.tactic
+val h_id :  Names.Id.t
+val hrec_id :  Names.Id.t
+val acc_inv_id :  Term.constr Util.delayed
+val ltof_ref : Globnames.global_reference Util.delayed
+val well_founded_ltof : Term.constr Util.delayed
+val acc_rel : Term.constr Util.delayed
+val well_founded : Term.constr Util.delayed
+val evaluable_of_global_reference : Globnames.global_reference -> Names.evaluable_global_reference
+val list_rewrite : bool -> (Term.constr*bool) list -> Proof_type.tactic
diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml
index c770c7ce..0c7b0a0b 100644
--- a/plugins/funind/invfun.ml
+++ b/plugins/funind/invfun.ml
@@ -1,39 +1,40 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 open Tacexpr
 open Declarations
+open Errors
 open Util
 open Names
 open Term
+open Vars
 open Pp
-open Libnames
+open Globnames
 open Tacticals
 open Tactics
 open Indfun_common
 open Tacmach
-open Sign
-open Hiddentac
+open Misctypes
 
 (* Some pretty printing function for debugging purpose *)
 
 let pr_binding prc  =
   function
-    | loc, Glob_term.NamedHyp id, c -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ Pp.cut () ++ prc c)
-    | loc, Glob_term.AnonHyp n, c -> hov 1 (int n ++ str " := " ++ Pp.cut () ++ prc c)
+    | loc, NamedHyp id, c -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ Pp.cut () ++ prc c)
+    | loc, AnonHyp n, c -> hov 1 (int n ++ str " := " ++ Pp.cut () ++ prc c)
 
 let pr_bindings prc prlc = function
-  | Glob_term.ImplicitBindings l ->
+  | ImplicitBindings l ->
       brk (1,1) ++ str "with" ++ brk (1,1) ++
-      Util.prlist_with_sep spc prc l
-  | Glob_term.ExplicitBindings l ->
+      pr_sequence prc l
+  | ExplicitBindings l ->
       brk (1,1) ++ str "with" ++ brk (1,1) ++
-        Util.prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l
-  | Glob_term.NoBindings -> mt ()
+        pr_sequence (fun b -> str"(" ++ pr_binding prlc b ++ str")") l
+  | NoBindings -> mt ()
 
 
 let pr_with_bindings prc prlc (c,bl) =
@@ -45,17 +46,17 @@ let pr_constr_with_binding prc (c,bl) :  Pp.std_ppcmds =
   pr_with_bindings prc prc  (c,bl)
 
 (* The local debuging mechanism *)
-let msgnl = Pp.msgnl
+(* let msgnl = Pp.msgnl *)
 
 let observe strm =
   if do_observe ()
-  then Pp.msgnl strm
+  then Pp.msg_debug strm
   else ()
 
-let observennl strm =
+(*let observennl strm =
   if do_observe ()
   then begin Pp.msg strm;Pp.pp_flush () end
-  else ()
+  else ()*)
 
 
 let do_observe_tac s tac g =
@@ -64,22 +65,25 @@ let do_observe_tac s tac g =
     with e when Errors.noncritical e -> assert false
   in
   try
-    let v = tac g in msgnl (goal ++ fnl () ++ s ++(str " ")++(str "finished")); v
+    let v = tac g in
+    msgnl (goal ++ fnl () ++ s ++(str " ")++(str "finished")); v
   with reraise ->
-    let e' = Cerrors.process_vernac_interp_error reraise in
+    let reraise = Errors.push reraise in
+    let e = Cerrors.process_vernac_interp_error reraise in
     msgnl (str "observation "++ s++str " raised exception " ++
-	     Errors.print e' ++ str " on goal " ++ goal );
-    raise reraise;;
-
+	     Errors.iprint e ++ str " on goal " ++ goal );
+    iraise reraise;;
 
 
-let observe_tac_msg s tac g =
-   if do_observe ()
+let observe_tac_strm s tac g =
+  if do_observe ()
   then do_observe_tac s tac g
   else tac g
-    
-let observe_tac s tac g = 
-  observe_tac_msg (str s) tac g
+
+let observe_tac s tac g =
+  if do_observe ()
+  then do_observe_tac (str s) tac g
+  else tac g
 
 (* [nf_zeta] $\zeta$-normalization of a term *)
 let nf_zeta =
@@ -109,57 +113,47 @@ let id_to_constr id =
 
 let generate_type g_to_f f graph i =
   (*i we deduce the number of arguments of the function and its returned type from the graph i*)
-  let graph_arity = Inductive.type_of_inductive (Global.env()) (Global.lookup_inductive (destInd graph))  in
+  let gr,u = destInd graph in
+  let graph_arity = Inductive.type_of_inductive (Global.env()) 
+    (Global.lookup_inductive gr, u) in
   let ctxt,_ = decompose_prod_assum graph_arity in
   let fun_ctxt,res_type =
     match ctxt with
-      | [] | [_] -> anomaly "Not a valid context"
+      | [] | [_] -> anomaly (Pp.str "Not a valid context")
       | (_,_,res_type)::fun_ctxt -> fun_ctxt,res_type
   in
-  let nb_args = List.length fun_ctxt in
-  let args_from_decl i decl =
-    match decl with
-      | (_,Some _,_) -> incr i; failwith "args_from_decl"
-      | _ -> let j = !i in incr i;mkRel (nb_args - j  + 1)
+  let rec args_from_decl i accu = function
+  | [] -> accu
+  | (_, Some _, _) :: l ->
+    args_from_decl (succ i) accu l
+  | _ :: l ->
+    let t = mkRel i in
+    args_from_decl (succ i) (t :: accu) l
   in
   (*i We need to name the vars [res] and [fv] i*)
-  let res_id =
-    Namegen.next_ident_away_in_goal
-      (id_of_string "res")
-      (map_succeed (function (Name id,_,_) -> id | (Anonymous,_,_) -> failwith "") fun_ctxt)
-  in
-  let fv_id =
-    Namegen.next_ident_away_in_goal
-      (id_of_string "fv")
-      (res_id::(map_succeed (function (Name id,_,_) -> id | (Anonymous,_,_) -> failwith "Anonymous!") fun_ctxt))
-  in
+  let filter = function (Name id,_,_) -> Some id | (Anonymous,_,_) -> None in
+  let named_ctxt = List.map_filter filter fun_ctxt in
+  let res_id = Namegen.next_ident_away_in_goal (Id.of_string "_res") named_ctxt in
+  let fv_id = Namegen.next_ident_away_in_goal (Id.of_string "fv") (res_id :: named_ctxt) in
   (*i we can then type the argument to be applied to the function [f] i*)
-  let args_as_rels =
-    let i = ref 0 in
-    Array.of_list ((map_succeed (args_from_decl i) (List.rev fun_ctxt)))
-  in
-  let args_as_rels = Array.map Termops.pop args_as_rels in
+  let args_as_rels = Array.of_list (args_from_decl 1 [] fun_ctxt) in
   (*i
     the hypothesis [res = fv] can then be computed
     We will need to lift it by one in order to use it as a conclusion
     i*)
+  let make_eq () =
+(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq ())
+  in
   let res_eq_f_of_args =
-    mkApp(Coqlib.build_coq_eq (),[|lift 2 res_type;mkRel 1;mkRel 2|])
+    mkApp(make_eq (),[|lift 2 res_type;mkRel 1;mkRel 2|])
   in
   (*i
     The hypothesis [graph\ x_1\ldots x_n\ res] can then be computed
     We will need to lift it by one in order to use it as a conclusion
     i*)
-  let graph_applied =
-    let args_and_res_as_rels =
-      let i = ref 0 in
-      Array.of_list ((map_succeed (args_from_decl i) (List.rev ((Name res_id,None,res_type)::fun_ctxt))) )
-    in
-    let args_and_res_as_rels =
-      Array.mapi (fun i c -> if i <> Array.length args_and_res_as_rels - 1 then lift 1 c else c) args_and_res_as_rels
-    in
-    mkApp(graph,args_and_res_as_rels)
-  in
+  let args_and_res_as_rels = Array.of_list (args_from_decl 3 [] fun_ctxt) in
+  let args_and_res_as_rels = Array.append args_and_res_as_rels [|mkRel 1|] in
+  let graph_applied = mkApp(graph, args_and_res_as_rels) in
   (*i The [pre_context]  is the defined to be the context corresponding to
     \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res,  \]
     i*)
@@ -178,7 +172,7 @@ let generate_type g_to_f f graph i =
    WARNING: while convertible, [type_of body] and [type] can be non equal
 *)
 let find_induction_principle f =
-  let f_as_constant =  match kind_of_term f with
+  let f_as_constant,u =  match kind_of_term f with
     | Const c' -> c'
     | _ -> error "Must be used with a function"
   in
@@ -195,7 +189,7 @@ let find_induction_principle f =
 (*     let fname =  *)
 (*       match kind_of_term f with  *)
 (* 	| Const c' ->  *)
-(* 	    id_of_label (con_label c')  *)
+(* 	    Label.to_id (con_label c')  *)
 (* 	| _ -> error "Must be used with a function"  *)
 (*     in *)
 
@@ -217,6 +211,11 @@ let rec generate_fresh_id x avoid i =
     let id = Namegen.next_ident_away_in_goal x avoid in
     id::(generate_fresh_id x (id::avoid) (pred i))
 
+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 ())
+
 
 (* [prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos i ]
    is the tactic used to prove correctness lemma.
@@ -248,11 +247,266 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
        that is~:
        \[fun (x_1:t_1)\ldots(x_n:t_n)=> fun  fv => fun res => res = fv \rightarrow graph\ x_1\ldots x_n\ res\]
     *)
+    (* we the get the definition of the graphs block *)
+    let graph_ind,u = destInd graphs_constr.(i) in
+    let kn = fst graph_ind in
+    let mib,_ = Global.lookup_inductive graph_ind in
+    (* and the principle to use in this lemma in $\zeta$ normal form *)
+    let f_principle,princ_type = schemes.(i) in
+    let princ_type =  nf_zeta princ_type in
+    let princ_infos = Tactics.compute_elim_sig princ_type in
+    (* The number of args of the function is then easilly computable *)
+    let nb_fun_args = nb_prod (pf_concl g)  - 2  in
+    let args_names = generate_fresh_id (Id.of_string "x") [] nb_fun_args in
+    let ids = args_names@(pf_ids_of_hyps g) in
+    (* Since we cannot ensure that the funcitonnal principle is defined in the
+       environement and due to the bug #1174, we will need to pose the principle
+       using a name
+    *)
+    let principle_id = Namegen.next_ident_away_in_goal (Id.of_string "princ") ids in
+    let ids = principle_id :: ids in
+    (* We get the branches of the principle *)
+    let branches = List.rev princ_infos.branches in
+    (* and built the intro pattern for each of them *)
+    let intro_pats =
+      List.map
+	(fun (_,_,br_type) ->
+	   List.map
+	     (fun id -> Loc.ghost, IntroNaming (IntroIdentifier id))
+	     (generate_fresh_id (Id.of_string "y") ids (List.length (fst (decompose_prod_assum br_type))))
+	)
+	branches
+    in
+    (* before building the full intro pattern for the principle *)
+    let eq_ind = make_eq () in
+    let eq_construct = mkConstructUi (destInd eq_ind, 1) in
+    (* The next to referencies will be used to find out which constructor to apply in each branch *)
+    let ind_number = ref 0
+    and min_constr_number = ref 0 in
+    (* The tactic to prove the ith branch of the principle *)
+    let prove_branche i g =
+      (* We get the identifiers of this branch *)
+      (*
+	let this_branche_ids =
+	List.fold_right
+	(fun (_,pat) acc ->
+	     match pat with
+	       | Genarg.IntroIdentifier id -> Id.Set.add id acc
+	| _ -> anomaly (Pp.str "Not an identifier")
+	)
+	(List.nth intro_pats (pred i))
+	Id.Set.empty
+      in
+	let pre_args g =
+	List.fold_right
+	  (fun (id,b,t) pre_args ->
+	    if Id.Set.mem id this_branche_ids
+	    then
+	      match b with
+		| None -> id::pre_args
+		| Some b -> pre_args
+	    else pre_args
+	  )
+	  (pf_hyps g)
+	  ([])
+      in
+      let pre_args g = List.rev (pre_args g) in 
+      let pre_tac g =
+	List.fold_right
+	  (fun (id,b,t) pre_tac ->
+	     if Id.Set.mem id this_branche_ids
+	     then
+	       match b with
+		 | None -> pre_tac
+		 | Some b ->
+		   tclTHEN (h_reduce (Glob_term.Unfold([Glob_term.AllOccurrences,EvalVarRef id])) allHyps) pre_tac
+	     else pre_tac
+	  )
+	  (pf_hyps g)
+	  tclIDTAC
+      in
+*)     
+      let pre_args =
+      	List.fold_right
+      	  (fun (_,pat) acc ->
+      	     match pat with
+	       | IntroNaming (IntroIdentifier id) -> id::acc
+      	       | _ -> anomaly (Pp.str "Not an identifier")
+      	  )
+      	  (List.nth intro_pats (pred i))
+      	  []
+      in
+      (* and get the real args of the branch by unfolding the defined constant *)
+      (*
+	 We can then recompute the arguments of the constructor.
+	 For each [hid] introduced by this branch, if [hid] has type
+	 $forall res, res=fv -> graph.(j)\ x_1\ x_n res$ the corresponding arguments of the constructor are
+	 [ fv (hid fv (refl_equal fv)) ].
+	 If [hid] has another type the corresponding argument of the constructor is [hid]
+      *)
+      let constructor_args g =
+	List.fold_right
+	  (fun hid acc ->
+	     let type_of_hid = pf_type_of g (mkVar hid) in
+	     match kind_of_term type_of_hid with
+	       | Prod(_,_,t') ->
+		   begin
+		     match kind_of_term t' with
+		       | Prod(_,t'',t''') ->
+			   begin
+			     match kind_of_term t'',kind_of_term t''' with
+			       | App(eq,args), App(graph',_)
+				   when
+				     (eq_constr eq eq_ind) &&
+				       Array.exists  (eq_constr graph') graphs_constr ->
+				   (args.(2)::(mkApp(mkVar hid,[|args.(2);(mkApp(eq_construct,[|args.(0);args.(2)|]))|]))
+				    ::acc)
+			       | _ -> mkVar hid ::  acc
+			   end
+		       | _ -> mkVar hid :: acc
+		   end
+	       | _ -> mkVar hid :: acc
+	  ) pre_args []
+      in
+      (* in fact we must also add the parameters to the constructor args *)
+      let constructor_args g =
+	let params_id = fst (List.chop princ_infos.nparams args_names) in
+	(List.map mkVar params_id)@((constructor_args g))
+      in
+      (* We then get the constructor corresponding to this branch and
+	 modifies the references has needed i.e.
+	 if the constructor is the last one of the current inductive then
+	 add one the number of the inductive to take and add the number of constructor of the previous
+	 graph to the minimal constructor number
+      *)
+      let constructor =
+	let constructor_num = i - !min_constr_number in
+	let length = Array.length (mib.Declarations.mind_packets.(!ind_number).Declarations.mind_consnames) in
+	if constructor_num <= length
+	then
+	  begin
+	    (kn,!ind_number),constructor_num
+	  end
+	else
+	  begin
+	    incr ind_number;
+	    min_constr_number := !min_constr_number + length ;
+	    (kn,!ind_number),1
+	  end
+      in
+      (* we can then build the final proof term *)
+      let app_constructor g = applist((mkConstruct(constructor)),constructor_args g) in
+      (* an apply the tactic *)
+      let res,hres =
+	match generate_fresh_id (Id.of_string "z") (ids(* @this_branche_ids *)) 2 with
+	  | [res;hres] -> res,hres
+	  | _ -> assert false
+      in
+      (* observe (str "constructor := " ++ Printer.pr_lconstr_env (pf_env g) app_constructor); *)
+      (
+	tclTHENSEQ
+	  [
+	    observe_tac("h_intro_patterns ")  (let l = (List.nth intro_pats (pred i)) in 
+					       match l with 
+						 | [] -> tclIDTAC 
+						 | _ -> Proofview.V82.of_tactic (intro_patterns l));
+	    (* unfolding of all the defined variables introduced by this branch *)
+	    (* observe_tac "unfolding" pre_tac; *)
+	    (* $zeta$ normalizing of the conclusion *)
+	    reduce
+	      (Genredexpr.Cbv
+		 { Redops.all_flags with
+		     Genredexpr.rDelta = false ;
+		     Genredexpr.rConst = []
+		 }
+	      )
+	      Locusops.onConcl;
+	    observe_tac ("toto ") tclIDTAC;
+    
+	    (* introducing the the result of the graph and the equality hypothesis *)
+	    observe_tac "introducing" (tclMAP (fun x -> Proofview.V82.of_tactic (Simple.intro x)) [res;hres]);
+	    (* replacing [res] with its value *)
+	    observe_tac "rewriting res value" (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar hres)));
+	    (* Conclusion *)
+	    observe_tac "exact" (fun g -> Proofview.V82.of_tactic (exact_check (app_constructor g)) g)  
+	  ]
+      )
+	g
+    in
+    (* end of branche proof *)
+    let lemmas =
+      Array.map
+	(fun (_,(ctxt,concl)) ->
+	   match ctxt with
+	     | [] | [_] | [_;_] -> anomaly (Pp.str "bad context")
+	     | hres::res::(x,_,t)::ctxt ->
+		 Termops.it_mkLambda_or_LetIn
+		   (Termops.it_mkProd_or_LetIn concl [hres;res])
+		   ((x,None,t)::ctxt)
+	)
+	lemmas_types_infos
+    in
+    let param_names = fst (List.chop princ_infos.nparams args_names) in
+    let params = List.map mkVar param_names in
+    let lemmas = Array.to_list (Array.map (fun c -> applist(c,params)) lemmas) in
+    (* The bindings of the principle
+       that is the params of the principle and the different lemma types
+    *)
+    let bindings =
+      let params_bindings,avoid =
+	List.fold_left2
+	  (fun (bindings,avoid) (x,_,_) p ->
+	     let id = Namegen.next_ident_away (Nameops.out_name x) avoid in
+	     (*(Loc.ghost,Glob_term.NamedHyp id,p)*)p::bindings,id::avoid
+	  )
+	  ([],pf_ids_of_hyps g)
+	  princ_infos.params
+	  (List.rev params)
+      in
+      let lemmas_bindings =
+	List.rev (fst  (List.fold_left2
+	  (fun (bindings,avoid) (x,_,_) p ->
+	     let id = Namegen.next_ident_away (Nameops.out_name x) avoid in
+	     (*(Loc.ghost,Glob_term.NamedHyp id,(nf_zeta p))*) (nf_zeta p)::bindings,id::avoid)
+	  ([],avoid)
+	  princ_infos.predicates
+	  (lemmas)))
+      in
+      (* Glob_term.ExplicitBindings *) (params_bindings@lemmas_bindings)
+    in
+    tclTHENSEQ
+      [ 
+	observe_tac "principle" (Proofview.V82.of_tactic (assert_by
+	  (Name principle_id)
+	  princ_type
+	  (exact_check f_principle)));
+	observe_tac "intro args_names" (tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) args_names);
+	(* observe_tac "titi" (pose_proof (Name (Id.of_string "__")) (Reductionops.nf_beta Evd.empty  ((mkApp (mkVar principle_id,Array.of_list bindings))))); *)
+	observe_tac "idtac" tclIDTAC;
+	tclTHEN_i
+	  (observe_tac "functional_induction" (
+	    (fun gl -> 
+	      let term = mkApp (mkVar principle_id,Array.of_list bindings) in
+	      let gl', _ty = pf_eapply Typing.e_type_of gl term in
+		Proofview.V82.of_tactic (apply term) gl')
+	   ))
+	  (fun i g -> observe_tac ("proving branche "^string_of_int i) (prove_branche i) g )
+      ]
+      g
+
+
+(*
+let prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos i : tactic =
+  fun g ->
+    (* first of all we recreate the lemmas types to be used as predicates of the induction principle
+       that is~:
+       \[fun (x_1:t_1)\ldots(x_n:t_n)=> fun  fv => fun res => res = fv \rightarrow graph\ x_1\ldots x_n\ res\]
+    *)
     let lemmas =
       Array.map
 	(fun (_,(ctxt,concl)) ->
 	   match ctxt with
-	     | [] | [_] | [_;_] -> anomaly "bad context"
+	     | [] | [_] | [_;_] -> anomaly (Pp.str "bad context")
 	     | hres::res::(x,_,t)::ctxt ->
 		 Termops.it_mkLambda_or_LetIn
 		   (Termops.it_mkProd_or_LetIn concl [hres;res])
@@ -270,13 +524,13 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
     let princ_infos = Tactics.compute_elim_sig princ_type in
     (* The number of args of the function is then easilly computable *)
     let nb_fun_args = nb_prod (pf_concl g)  - 2  in
-    let args_names = generate_fresh_id (id_of_string "x") [] nb_fun_args in
+    let args_names = generate_fresh_id (Id.of_string "x") [] nb_fun_args in
     let ids = args_names@(pf_ids_of_hyps g) in
     (* Since we cannot ensure that the funcitonnal principle is defined in the
        environement and due to the bug #1174, we will need to pose the principle
        using a name
     *)
-    let principle_id = Namegen.next_ident_away_in_goal (id_of_string "princ") ids in
+    let principle_id = Namegen.next_ident_away_in_goal (Id.of_string "princ") ids in
     let ids = principle_id :: ids in
     (* We get the branches of the principle *)
     let branches = List.rev princ_infos.branches in
@@ -285,44 +539,43 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
       List.map
 	(fun (_,_,br_type) ->
 	   List.map
-	     (fun id -> dummy_loc, Genarg.IntroIdentifier id)
-	     (generate_fresh_id (id_of_string "y") ids (List.length (fst (decompose_prod_assum br_type))))
+	     (fun id -> Loc.ghost, Genarg.IntroIdentifier id)
+	     (generate_fresh_id (Id.of_string "y") ids (List.length (fst (decompose_prod_assum br_type))))
 	)
 	branches
     in
     (* before building the full intro pattern for the principle *)
+    let pat = Some (Loc.ghost,Genarg.IntroOrAndPattern intro_pats) in
     let eq_ind = Coqlib.build_coq_eq () in
     let eq_construct = mkConstruct((destInd eq_ind),1) in
     (* The next to referencies will be used to find out which constructor to apply in each branch *)
     let ind_number = ref 0
     and min_constr_number = ref 0 in
     (* The tactic to prove the ith branch of the principle *)
-    let this_branche_ids empty add  i =
-      List.fold_right
-	(fun (_,pat) acc ->
-	  match pat with
-	  | Genarg.IntroIdentifier id -> add id acc
-	  | _ -> anomaly "Not an identifier"
-	)
-	(List.nth intro_pats (pred i))
-	empty
-    in
     let prove_branche i g =
       (* We get the identifiers of this branch *)
+      let this_branche_ids =
+	List.fold_right
+	  (fun (_,pat) acc ->
+	     match pat with
+	       | Genarg.IntroIdentifier id -> Id.Set.add id acc
+	       | _ -> anomaly (Pp.str "Not an identifier")
+	  )
+	  (List.nth intro_pats (pred i))
+	  Id.Set.empty
+      in
       (* and get the real args of the branch by unfolding the defined constant *)
       let pre_args,pre_tac =
 	List.fold_right
 	  (fun (id,b,t) (pre_args,pre_tac) ->
-	     if Idset.mem id (this_branche_ids Idset.empty Idset.add i)
+	     if Id.Set.mem id this_branche_ids
 	     then
 	       match b with
-		 | None -> 
-		   (id::pre_args,pre_tac)
+		 | None -> (id::pre_args,pre_tac)
 		 | Some b ->
 		     (pre_args,
-		      tclTHEN (h_reduce (Glob_term.Unfold([Glob_term.all_occurrences_expr,EvalVarRef id])) allHyps) pre_tac
+		      tclTHEN (h_reduce (Glob_term.Unfold([Glob_term.AllOccurrences,EvalVarRef id])) allHyps) pre_tac
 		     )
-
 	     else (pre_args,pre_tac)
 	  )
 	  (pf_hyps g)
@@ -333,7 +586,6 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
 	 For each [hid] introduced by this branch, if [hid] has type
 	 $forall res, res=fv -> graph.(j)\ x_1\ x_n res$ the corresponding arguments of the constructor are
 	 [ fv (hid fv (refl_equal fv)) ].
-
 	 If [hid] has another type the corresponding argument of the constructor is [hid]
       *)
       let constructor_args =
@@ -350,9 +602,9 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
 			       | App(eq,args), App(graph',_)
 				   when
 				     (eq_constr eq eq_ind) &&
-				       array_exists  (eq_constr graph') graphs_constr ->
-				 ((mkApp(mkVar hid,[|args.(2);(mkApp(eq_construct,[|args.(0);args.(2)|]))|]))
-				  ::args.(2)::acc)
+				       Array.exists  (eq_constr graph') graphs_constr ->
+				   ((mkApp(mkVar hid,[|args.(2);(mkApp(eq_construct,[|args.(0);args.(2)|]))|]))
+				    ::args.(2)::acc)
 			       | _ -> mkVar hid ::  acc
 			   end
 		       | _ -> mkVar hid :: acc
@@ -362,7 +614,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
       in
       (* in fact we must also add the parameters to the constructor args *)
       let constructor_args =
-	let params_id = fst (list_chop princ_infos.nparams args_names) in
+	let params_id = fst (List.chop princ_infos.nparams args_names) in
 	(List.map mkVar params_id)@(List.rev constructor_args)
       in
       (* We then get the constructor corresponding to this branch and
@@ -390,11 +642,11 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
       let app_constructor = applist((mkConstruct(constructor)),constructor_args) in
       (* an apply the tactic *)
       let res,hres =
-	match generate_fresh_id (id_of_string "z") (ids(* @this_branche_ids *)) 2 with
+	match generate_fresh_id (Id.of_string "z") (ids(* @this_branche_ids *)) 2 with
 	  | [res;hres] -> res,hres
 	  | _ -> assert false
       in
-      observe_tac_msg (str "constructor := " ++ Printer.pr_lconstr_env (pf_env g) app_constructor)
+      observe (str "constructor := " ++ Printer.pr_lconstr_env (pf_env g) app_constructor);
       (
 	tclTHENSEQ
 	  [
@@ -414,13 +666,13 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
 	    (* replacing [res] with its value *)
 	    observe_tac "rewriting res value" (Equality.rewriteLR (mkVar hres));
 	    (* Conclusion *)
-	    observe_tac "exact" (h_exact app_constructor)
+	    observe_tac "exact" (exact_check app_constructor)
 	  ]
       )
 	g
     in
     (* end of branche proof *)
-    let param_names = fst (list_chop princ_infos.nparams args_names) in
+    let param_names = fst (List.chop princ_infos.nparams args_names) in
     let params = List.map mkVar param_names in
     let lemmas = Array.to_list (Array.map (fun c -> applist(c,params)) lemmas) in
     (* The bindings of the principle
@@ -431,7 +683,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
 	List.fold_left2
 	  (fun (bindings,avoid) (x,_,_) p ->
 	     let id = Namegen.next_ident_away (Nameops.out_name x) avoid in
-	     (dummy_loc,Glob_term.NamedHyp id,p)::bindings,id::avoid
+	     (Loc.ghost,Glob_term.NamedHyp id,p)::bindings,id::avoid
 	  )
 	  ([],pf_ids_of_hyps g)
 	  princ_infos.params
@@ -441,7 +693,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
 	List.rev (fst  (List.fold_left2
 	  (fun (bindings,avoid) (x,_,_) p ->
 	     let id = Namegen.next_ident_away (Nameops.out_name x) avoid in
-	     (dummy_loc,Glob_term.NamedHyp id,(nf_zeta p))::bindings,id::avoid)
+	     (Loc.ghost,Glob_term.NamedHyp id,(nf_zeta p))::bindings,id::avoid)
 	  ([],avoid)
 	  princ_infos.predicates
 	  (lemmas)))
@@ -453,18 +705,21 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
 	observe_tac "principle" (assert_by
 	  (Name principle_id)
 	  princ_type
-	  (h_exact f_principle));
+	  (exact_check f_principle));
 	tclTHEN_i
 	  (observe_tac "functional_induction" (
 	     fun g ->
 	       observe
 		 (pr_constr_with_binding (Printer.pr_lconstr_env (pf_env g))  (mkVar principle_id,bindings));
-	       h_apply false false [dummy_loc,(mkVar principle_id,bindings)] g
+	       functional_induction  false (applist(funs_constr.(i),List.map mkVar args_names))
+		 (Some (mkVar principle_id,bindings))
+		 pat g
 	   ))
-	  (fun i g -> observe_tac ("proving branche "^string_of_int i) 
-	    (tclTHEN (tclMAP h_intro (this_branche_ids [] (fun a b -> a::b) i)) (prove_branche i)) g )
+	  (fun i g -> observe_tac ("proving branche "^string_of_int i) (prove_branche i) g )
       ]
       g
+*)
+
 
 (* [generalize_dependent_of x hyp g]
    generalize every hypothesis which depends of [x] but [hyp]
@@ -472,8 +727,8 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
 let generalize_dependent_of x hyp g =
   tclMAP
     (function
-       | (id,None,t) when not (id = hyp) &&
-	   (Termops.occur_var (pf_env g) x t) -> tclTHEN (h_generalize [mkVar id]) (thin [id])
+       | (id,None,t) when not (Id.equal id hyp) &&
+	   (Termops.occur_var (pf_env g) x t) -> tclTHEN (Tactics.Simple.generalize [mkVar id]) (thin [id])
        | _ -> tclIDTAC
     )
     (pf_hyps g)
@@ -490,7 +745,7 @@ let  rec intros_with_rewrite g =
   observe_tac "intros_with_rewrite" intros_with_rewrite_aux g
 and intros_with_rewrite_aux : tactic =
   fun g ->
-    let eq_ind = Coqlib.build_coq_eq () in
+    let eq_ind = make_eq () in
     match kind_of_term (pf_concl g) with
 	  | Prod(_,t,t') ->
 	      begin
@@ -498,66 +753,79 @@ and intros_with_rewrite_aux : tactic =
 		  | App(eq,args) when (eq_constr eq eq_ind)  ->
  		      if Reductionops.is_conv (pf_env g) (project g) args.(1) args.(2)
 		      then
-			let id = pf_get_new_id (id_of_string "y") g  in
-			tclTHENSEQ [ h_intro id; thin [id]; intros_with_rewrite ] g
-
+			let id = pf_get_new_id (Id.of_string "y") g  in
+			tclTHENSEQ [ Proofview.V82.of_tactic (Simple.intro id); thin [id]; intros_with_rewrite ] g
+		      else if isVar args.(1) && (Environ.evaluable_named (destVar args.(1)) (pf_env g)) 
+		      then tclTHENSEQ[
+			unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(1)))];
+			tclMAP (fun id -> tclTRY(unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(1)))] ((destVar args.(1)),Locus.InHyp) ))
+			  (pf_ids_of_hyps g);
+			intros_with_rewrite
+		      ] g
+		      else if isVar args.(2) && (Environ.evaluable_named (destVar args.(2)) (pf_env g)) 
+		      then tclTHENSEQ[
+			unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(2)))];
+			tclMAP (fun id -> tclTRY(unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(2)))] ((destVar args.(2)),Locus.InHyp) ))
+			  (pf_ids_of_hyps g);
+			intros_with_rewrite
+		      ] g
 		      else if isVar args.(1)
 		      then
-			let id = pf_get_new_id (id_of_string "y") g  in
-			tclTHENSEQ [ h_intro id;
+			let id = pf_get_new_id (Id.of_string "y") g  in
+			tclTHENSEQ [ Proofview.V82.of_tactic (Simple.intro id);
 				     generalize_dependent_of (destVar args.(1)) id;
-				     tclTRY (Equality.rewriteLR (mkVar id));
+				     tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id)));
 				     intros_with_rewrite
 				   ]
 			  g
 		      else if isVar args.(2) 
 		      then 
-			let id = pf_get_new_id (id_of_string "y") g  in
-			tclTHENSEQ [ h_intro id;
+			let id = pf_get_new_id (Id.of_string "y") g  in
+			tclTHENSEQ [ Proofview.V82.of_tactic (Simple.intro id);
 				     generalize_dependent_of (destVar args.(2)) id;
-				     tclTRY (Equality.rewriteRL (mkVar id));
+				     tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar id)));
 				     intros_with_rewrite
 				   ]
 			  g
 		      else
 			begin
-			  let id = pf_get_new_id (id_of_string "y") g  in
+			  let id = pf_get_new_id (Id.of_string "y") g  in
 			  tclTHENSEQ[
-			    h_intro id;
-			    tclTRY (Equality.rewriteLR (mkVar id));
+			    Proofview.V82.of_tactic (Simple.intro id);
+			    tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id)));
 			    intros_with_rewrite
 			  ] g
 			end
 		  | Ind _ when eq_constr t (Coqlib.build_coq_False ()) ->
-		      Tauto.tauto g
+		      Proofview.V82.of_tactic Tauto.tauto g
 		  | Case(_,_,v,_) ->
 		      tclTHENSEQ[
-			h_case false (v,Glob_term.NoBindings);
+			Proofview.V82.of_tactic (simplest_case v);
 			intros_with_rewrite
 		      ] g
 		  | LetIn _ ->
 		      tclTHENSEQ[
-			h_reduce
-			  (Glob_term.Cbv
-			     {Glob_term.all_flags
-			      with Glob_term.rDelta = false;
+			reduce
+			  (Genredexpr.Cbv
+			     {Redops.all_flags
+			      with Genredexpr.rDelta = false;
 			     })
-			  onConcl
+			  Locusops.onConcl
 			;
 			intros_with_rewrite
 		      ] g
 		  | _ ->
-		      let id = pf_get_new_id (id_of_string "y") g  in
-		      tclTHENSEQ [ h_intro id;intros_with_rewrite] g
+		      let id = pf_get_new_id (Id.of_string "y") g  in
+		      tclTHENSEQ [ Proofview.V82.of_tactic (Simple.intro id);intros_with_rewrite] g
 	      end
 	  | LetIn _ ->
 	      tclTHENSEQ[
-		h_reduce
-		  (Glob_term.Cbv
-		     {Glob_term.all_flags
-		      with Glob_term.rDelta = false;
+		reduce
+		  (Genredexpr.Cbv
+		     {Redops.all_flags
+		      with Genredexpr.rDelta = false;
 		     })
-		  onConcl
+		  Locusops.onConcl
 		;
 		intros_with_rewrite
 	      ] g
@@ -569,14 +837,14 @@ let rec reflexivity_with_destruct_cases g =
       match kind_of_term (snd (destApp (pf_concl g))).(2) with
 	| Case(_,_,v,_) ->
 	    tclTHENSEQ[
-	      h_case false (v,Glob_term.NoBindings);
-	      intros;
+	      Proofview.V82.of_tactic (simplest_case v);
+	      Proofview.V82.of_tactic intros;
 	      observe_tac "reflexivity_with_destruct_cases" reflexivity_with_destruct_cases
 	    ]
-	| _ -> reflexivity
-    with e when Errors.noncritical e -> reflexivity
+        | _ -> Proofview.V82.of_tactic reflexivity
+    with e when Errors.noncritical e -> Proofview.V82.of_tactic reflexivity
   in
-  let eq_ind =     Coqlib.build_coq_eq () in
+  let eq_ind = make_eq () in
   let discr_inject =
     Tacticals.onAllHypsAndConcl (
        fun sc g ->
@@ -586,15 +854,15 @@ let rec reflexivity_with_destruct_cases g =
 	       match kind_of_term  (pf_type_of g (mkVar id)) with
 		 | App(eq,[|_;t1;t2|]) when eq_constr eq eq_ind ->
 		     if Equality.discriminable (pf_env g) (project g) t1 t2
-		     then Equality.discrHyp id g
+		     then Proofview.V82.of_tactic (Equality.discrHyp id) g
 		     else if Equality.injectable (pf_env g) (project g) t1 t2
-		     then tclTHENSEQ [Equality.injHyp id;thin [id];intros_with_rewrite]  g
+		     then tclTHENSEQ [Proofview.V82.of_tactic (Equality.injHyp None id);thin [id];intros_with_rewrite]  g
 		     else tclIDTAC g
 		 | _ -> tclIDTAC g
     )
   in
   (tclFIRST
-    [ observe_tac "reflexivity_with_destruct_cases : reflexivity" reflexivity;
+    [ observe_tac "reflexivity_with_destruct_cases : reflexivity" (Proofview.V82.of_tactic reflexivity);
       observe_tac "reflexivity_with_destruct_cases : destruct_case" ((destruct_case ()));
       (*  We reach this point ONLY if
 	  the same value is matched (at least) two times
@@ -654,23 +922,24 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic =
        and compute a fresh name for each of them
     *)
     let nb_fun_args = nb_prod (pf_concl g)  - 2  in
-    let args_names = generate_fresh_id (id_of_string "x") [] nb_fun_args in
+    let args_names = generate_fresh_id (Id.of_string "x") [] nb_fun_args in
     let ids = args_names@(pf_ids_of_hyps g) in
     (* and fresh names for res H and the principle (cf bug bug #1174) *)
     let res,hres,graph_principle_id =
-      match generate_fresh_id (id_of_string "z") ids 3 with
+      match generate_fresh_id (Id.of_string "z") ids 3 with
 	| [res;hres;graph_principle_id] -> res,hres,graph_principle_id
 	| _ -> assert false
     in
     let ids = res::hres::graph_principle_id::ids in
-    (* we also compute fresh names for each hyptohesis of each branche of the principle *)
+    (* we also compute fresh names for each hyptohesis of each branch
+       of the principle *)
     let branches = List.rev princ_infos.branches in
     let intro_pats =
       List.map
 	(fun (_,_,br_type) ->
 	   List.map
 	     (fun id -> id)
-	     (generate_fresh_id (id_of_string "y") ids (nb_prod br_type))
+	     (generate_fresh_id (Id.of_string "y") ids (nb_prod br_type))
 	)
 	branches
     in
@@ -680,28 +949,34 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic =
     *)
     let rewrite_tac j ids : tactic =
       let graph_def = graphs.(j) in
-      let infos =  try find_Function_infos (destConst funcs.(j)) with Not_found ->  error "No graph found" in
-      if infos.is_general ||  Rtree.is_infinite graph_def.mind_recargs
+      let infos =
+        try find_Function_infos (fst (destConst funcs.(j)))
+        with Not_found ->  error "No graph found"
+      in
+      if infos.is_general
+        || Rtree.is_infinite Declareops.eq_recarg graph_def.mind_recargs
       then
 	let eq_lemma =
 	  try Option.get (infos).equation_lemma
-	  with Option.IsNone -> anomaly "Cannot find equation lemma"
+	  with Option.IsNone -> anomaly (Pp.str "Cannot find equation lemma")
 	in
 	tclTHENSEQ[
-	  tclMAP h_intro ids;
-	  Equality.rewriteLR (mkConst eq_lemma);
-	  (* Don't forget to $\zeta$ normlize the term since the principles have been $\zeta$-normalized *)
-	  h_reduce
-	    (Glob_term.Cbv
-	       {Glob_term.all_flags
-		with Glob_term.rDelta = false;
+	  tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) ids;
+	  Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_lemma));
+	  (* Don't forget to $\zeta$ normlize the term since the principles
+             have been $\zeta$-normalized *)
+	  reduce
+	    (Genredexpr.Cbv
+	       {Redops.all_flags
+		with Genredexpr.rDelta = false;
 	       })
-	    onConcl
+	    Locusops.onConcl
 	  ;
-	  h_generalize (List.map mkVar ids);
+	  Simple.generalize (List.map mkVar ids);
 	  thin ids
 	]
-      else unfold_in_concl [(Termops.all_occurrences, Names.EvalConstRef (destConst f))]
+      else
+        unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst (destConst f)))]
     in
     (* The proof of each branche itself *)
     let ind_number = ref 0 in
@@ -725,21 +1000,21 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic =
 	(* we expand the definition of the function *)
         observe_tac "rewrite_tac" (rewrite_tac this_ind_number this_branche_ids);
 	(* introduce hypothesis with some rewrite *)
-        observe_tac "intros_with_rewrite" intros_with_rewrite;
+        observe_tac "intros_with_rewrite (all)" intros_with_rewrite;
 	(* The proof is (almost) complete *)
         observe_tac "reflexivity" (reflexivity_with_destruct_cases)
       ]
 	g
     in
-    let params_names = fst (list_chop princ_infos.nparams args_names) in
+    let params_names = fst (List.chop princ_infos.nparams args_names) in
     let params = List.map mkVar params_names in
     tclTHENSEQ
-      [ tclMAP h_intro (args_names@[res;hres]);
+      [ tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) (args_names@[res;hres]);
 	observe_tac "h_generalize"
-	(h_generalize [mkApp(applist(graph_principle,params),Array.map (fun c -> applist(c,params)) lemmas)]);
-	h_intro graph_principle_id;
+	(Simple.generalize [mkApp(applist(graph_principle,params),Array.map (fun c -> applist(c,params)) lemmas)]);
+	Proofview.V82.of_tactic (Simple.intro graph_principle_id);
 	observe_tac "" (tclTHEN_i
-	  (observe_tac "elim" ((elim false (mkVar hres,Glob_term.NoBindings) (Some (mkVar graph_principle_id,Glob_term.NoBindings)))))
+	  (observe_tac "elim" (Proofview.V82.of_tactic (elim false None (mkVar hres,NoBindings) (Some (mkVar graph_principle_id,NoBindings)))))
 	  (fun i g -> observe_tac "prove_branche" (prove_branche i) g ))
       ]
       g
@@ -747,7 +1022,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic =
 
 
 
-let do_save () = Lemmas.save_named false
+let do_save () = Lemmas.save_proof (Vernacexpr.Proved(false,None))
 
 
 (* [derive_correctness make_scheme functional_induction funs graphs] create correctness and completeness
@@ -758,15 +1033,14 @@ let do_save () = Lemmas.save_named false
 *)
 
 let derive_correctness make_scheme functional_induction (funs: constant list) (graphs:inductive list) =
-  let previous_state = States.freeze () in
   let funs = Array.of_list funs and graphs = Array.of_list graphs in
   let funs_constr = Array.map mkConst funs  in
-  try
+  States.with_state_protection_on_exception (fun () ->
     let graphs_constr = Array.map mkInd graphs in
     let lemmas_types_infos =
-      Util.array_map2_i
+      Util.Array.map2_i
 	(fun i f_constr graph ->
-	   let const_of_f = destConst f_constr in
+	   let const_of_f,u = destConst f_constr in
 	   let (type_of_lemma_ctxt,type_of_lemma_concl) as type_info =
 	     generate_type false const_of_f graph i
 	   in
@@ -783,15 +1057,15 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g
 	 if the block contains only one function we can safely reuse [f_rect]
       *)
       try
-	if Array.length funs_constr <> 1 then raise Not_found;
+	if not (Int.equal (Array.length funs_constr) 1) then raise Not_found;
 	[| find_induction_principle funs_constr.(0) |]
       with Not_found ->
 	  Array.of_list
 	    (List.map
 	       (fun entry ->
-		  (entry.Entries.const_entry_body, Option.get entry.Entries.const_entry_type )
+		  (fst (fst(Future.force entry.Entries.const_entry_body)), Option.get entry.Entries.const_entry_type )
 	       )
-	       (make_scheme (array_map_to_list (fun const -> const,Glob_term.GType None) funs))
+	       (make_scheme (Array.map_to_list (fun const -> const,GType []) funs))
 	    )
     in
     let proving_tac =
@@ -799,28 +1073,29 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g
     in
     Array.iteri
       (fun i f_as_constant ->
-	 let f_id = id_of_label (con_label f_as_constant) in
+	 let f_id = Label.to_id (con_label f_as_constant) in
 	 (*i The next call to mk_correct_id is valid since we are constructing the lemma
 	     Ensures by: obvious
 	 i*)
 	 let lem_id = mk_correct_id f_id in
 	 Lemmas.start_proof lem_id
-	   (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem))
-	   (fst lemmas_types_infos.(i))
-	   (fun _ _ -> ());
-	 Pfedit.by
-	   (observe_tac ("prove correctness ("^(string_of_id f_id)^")")
-	      (proving_tac i));
+	   (Decl_kinds.Global,false(*FIXME*),(Decl_kinds.Proof Decl_kinds.Theorem))
+                 (*FIXME*) Evd.empty
+	 (fst lemmas_types_infos.(i))
+           (Lemmas.mk_hook (fun _ _ -> ()));
+	 ignore (Pfedit.by
+	   (Proofview.V82.tactic (observe_tac ("prove correctness ("^(Id.to_string f_id)^")")
+	      (proving_tac i))));
 	 do_save ();
 	 let finfo = find_Function_infos f_as_constant in
-	 let lem_cst = destConst (Constrintern.global_reference lem_id) in
+	 let lem_cst = fst (destConst (Constrintern.global_reference lem_id)) in
 	 update_Function {finfo with correctness_lemma = Some lem_cst}
       )
       funs;
     let lemmas_types_infos =
-      Util.array_map2_i
+      Util.Array.map2_i
 	(fun i f_constr graph ->
-	   let const_of_f = destConst f_constr in
+	   let const_of_f = fst (destConst f_constr) in
 	   let (type_of_lemma_ctxt,type_of_lemma_concl) as type_info =
 	     generate_type true  const_of_f graph i
 	   in
@@ -832,51 +1107,46 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g
 	funs_constr
 	graphs_constr
     in
-    let kn,_ as graph_ind  = destInd graphs_constr.(0) in
+    let kn,_ as graph_ind  = fst (destInd graphs_constr.(0)) in
     let  mib,mip = Global.lookup_inductive graph_ind in
-    let schemes =
-      Array.of_list
+    let sigma, scheme = 
 	(Indrec.build_mutual_induction_scheme (Global.env ()) Evd.empty
 	   (Array.to_list
 	      (Array.mapi
-		 (fun i _ -> (kn,i),true,InType)
+		 (fun i _ -> ((kn,i),Univ.Instance.empty)(*FIXME*),true,InType)
 		 mib.Declarations.mind_packets
 	      )
 	   )
 	)
     in
+    let schemes =
+      Array.of_list scheme
+    in
     let proving_tac =
       prove_fun_complete funs_constr mib.Declarations.mind_packets schemes lemmas_types_infos
     in
     Array.iteri
       (fun i f_as_constant ->
-	 let f_id = id_of_label (con_label f_as_constant) in
+	 let f_id = Label.to_id (con_label f_as_constant) in
 	 (*i The next call to mk_complete_id is valid since we are constructing the lemma
 	     Ensures by: obvious
 	   i*)
 	 let lem_id = mk_complete_id f_id in
 	 Lemmas.start_proof lem_id
-	   (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem))
-	   (fst lemmas_types_infos.(i))
-	   (fun _ _ -> ());
-	 Pfedit.by
-	   (observe_tac ("prove completeness ("^(string_of_id f_id)^")")
-	      (proving_tac i));
+	   (Decl_kinds.Global,false(*FIXME*),(Decl_kinds.Proof Decl_kinds.Theorem))
+                            (*FIXME*) Evd.empty
+	 (fst lemmas_types_infos.(i))
+           (Lemmas.mk_hook (fun _ _ -> ()));
+	 ignore (Pfedit.by
+	   (Proofview.V82.tactic (observe_tac ("prove completeness ("^(Id.to_string f_id)^")")
+	      (proving_tac i))));
 	 do_save ();
 	 let finfo = find_Function_infos f_as_constant in
-	 let lem_cst = destConst (Constrintern.global_reference lem_id) in
+	 let lem_cst,u = destConst (Constrintern.global_reference lem_id) in
 	 update_Function {finfo with completeness_lemma = Some lem_cst}
       )
-      funs;
-  with reraise ->
-    (* In case of problem, we reset all the lemmas *)
-    Pfedit.delete_all_proofs ();
-    States.unfreeze previous_state;
-    raise reraise
-
-
-
-
+      funs)
+  ()
 
 (***********************************************)
 
@@ -890,13 +1160,13 @@ let revert_graph kn post_tac hid g =
     let typ = pf_type_of g (mkVar hid) in
     match kind_of_term typ with
       | App(i,args) when isInd i ->
-	  let ((kn',num) as ind') = destInd i in
-	  if kn = kn'
+	  let ((kn',num) as ind'),u = destInd i in
+	  if MutInd.equal kn kn'
 	  then (* We have generated a graph hypothesis so that we must change it if we can *)
 	    let info =
 	      try find_Function_of_graph ind'
 	      with Not_found -> (* The graphs are mutually recursive but we cannot find one of them !*)
-		anomaly "Cannot retrieve infos about a mutual block"
+		anomaly (Pp.str "Cannot retrieve infos about a mutual block")
 	    in
 	    (* if we can find a completeness lemma for this function
 	       then we can come back to the functional form. If not, we do nothing
@@ -904,12 +1174,12 @@ let revert_graph kn post_tac hid g =
 	    match info.completeness_lemma with
 	      | None -> tclIDTAC g
 	      | Some f_complete ->
-		  let f_args,res = array_chop (Array.length args - 1) args in
+		  let f_args,res = Array.chop (Array.length args - 1) args in
 		  tclTHENSEQ
 		    [
-		      h_generalize [applist(mkConst f_complete,(Array.to_list f_args)@[res.(0);mkVar hid])];
+		      Simple.generalize [applist(mkConst f_complete,(Array.to_list f_args)@[res.(0);mkVar hid])];
 		      thin [hid];
-		      h_intro hid;
+		      Proofview.V82.of_tactic (Simple.intro hid);
 		      post_tac hid
 		    ]
 		    g
@@ -937,26 +1207,26 @@ let revert_graph kn post_tac hid g =
 
 let functional_inversion kn hid fconst f_correct : tactic =
   fun g ->
-    let old_ids = List.fold_right Idset.add  (pf_ids_of_hyps g) Idset.empty in
+    let old_ids = List.fold_right Id.Set.add  (pf_ids_of_hyps g) Id.Set.empty in
     let type_of_h = pf_type_of g (mkVar hid) in
     match kind_of_term type_of_h with
-      | App(eq,args) when eq_constr eq (Coqlib.build_coq_eq ())  ->
+      | App(eq,args) when eq_constr eq (make_eq ())  ->
 	  let pre_tac,f_args,res =
 	    match kind_of_term args.(1),kind_of_term args.(2) with
 	      | App(f,f_args),_ when eq_constr f fconst ->
-		  ((fun hid -> h_symmetry (onHyp hid)),f_args,args.(2))
+		  ((fun hid -> Proofview.V82.of_tactic (intros_symmetry (Locusops.onHyp hid))),f_args,args.(2))
 	      |_,App(f,f_args) when eq_constr f fconst ->
 		 ((fun hid -> tclIDTAC),f_args,args.(1))
 	      | _ -> (fun hid -> tclFAIL 1 (mt ())),[||],args.(2)
 	  in
 	  tclTHENSEQ[
 	    pre_tac hid;
-	    h_generalize [applist(f_correct,(Array.to_list f_args)@[res;mkVar hid])];
+	    Simple.generalize [applist(f_correct,(Array.to_list f_args)@[res;mkVar hid])];
 	    thin [hid];
-	    h_intro hid;
-	    Inv.inv FullInversion None (Glob_term.NamedHyp hid);
+	    Proofview.V82.of_tactic (Simple.intro hid);
+	    Proofview.V82.of_tactic (Inv.inv FullInversion None (NamedHyp hid));
 	    (fun g ->
-	       let new_ids = List.filter (fun id -> not (Idset.mem id old_ids)) (pf_ids_of_hyps g) in
+	       let new_ids = List.filter (fun id -> not (Id.Set.mem id old_ids)) (pf_ids_of_hyps g) in
 	       tclMAP (revert_graph kn pre_tac)  (hid::new_ids)  g
 	    );
 	  ] g
@@ -968,14 +1238,16 @@ let invfun qhyp f  =
   let f =
     match f with
       | ConstRef f -> f
-      | _ -> raise (Util.UserError("",str "Not a function"))
+      | _ -> raise (Errors.UserError("",str "Not a function"))
   in
   try
     let finfos = find_Function_infos f in
     let f_correct = mkConst(Option.get finfos.correctness_lemma)
     and kn = fst finfos.graph_ind
     in
-    Tactics.try_intros_until (fun hid -> functional_inversion kn hid (mkConst f)  f_correct) qhyp
+    Proofview.V82.of_tactic (
+      Tactics.try_intros_until (fun hid -> Proofview.V82.tactic (functional_inversion kn hid (mkConst f)  f_correct)) qhyp
+    )
   with
     | Not_found ->  error "No graph found"
     | Option.IsNone  -> error "Cannot use equivalence with graph!"
@@ -985,16 +1257,17 @@ let invfun qhyp f g =
   match f with
     | Some f -> invfun qhyp f g
     | None ->
+        Proofview.V82.of_tactic begin
 	Tactics.try_intros_until
-	  (fun hid g ->
+	  (fun hid -> Proofview.V82.tactic begin fun g ->
 	     let hyp_typ = pf_type_of g (mkVar hid)  in
 	     match kind_of_term hyp_typ with
-	       | App(eq,args) when eq_constr eq (Coqlib.build_coq_eq ()) ->
+	       | App(eq,args) when eq_constr eq (make_eq ()) ->
 		   begin
 		     let f1,_ = decompose_app args.(1) in
 		     try
 		       if not (isConst f1) then failwith "";
-		       let finfos = find_Function_infos (destConst f1) in
+		       let finfos = find_Function_infos (fst (destConst f1)) in
 		       let f_correct = mkConst(Option.get finfos.correctness_lemma)
 		       and kn = fst finfos.graph_ind
 		       in
@@ -1003,14 +1276,14 @@ let invfun qhyp f g =
 		       try
 			 let f2,_ = decompose_app args.(2) in
 			 if not (isConst f2) then failwith "";
-			 let finfos = find_Function_infos (destConst f2) in
+			 let finfos = find_Function_infos (fst (destConst f2)) in
 			 let f_correct = mkConst(Option.get finfos.correctness_lemma)
 			 and kn = fst finfos.graph_ind
 			 in
 			 functional_inversion kn hid  f2 f_correct g
 		       with
 			 | Failure "" ->
-			     errorlabstrm "" (str "Hypothesis" ++ Ppconstr.pr_id hid ++ str " must contain at leat one Function")
+			     errorlabstrm "" (str "Hypothesis " ++ Ppconstr.pr_id hid ++ str " must contain at least one Function")
 			 | Option.IsNone  ->
 			     if do_observe ()
 			     then
@@ -1023,6 +1296,7 @@ let invfun qhyp f g =
 			     else errorlabstrm "" (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid)
 		   end
 	       | _ -> errorlabstrm "" (Ppconstr.pr_id hid ++ str " must be an equality ")
-	  )
+	  end)
 	  qhyp
+          end
 	  g
diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml
index e1f10be2..ea699580 100644
--- a/plugins/funind/merge.ml
+++ b/plugins/funind/merge.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,20 +8,23 @@
 
 (* Merging of induction principles. *)
 
-open Libnames
+open Globnames
 open Tactics
 open Indfun_common
+open Errors
 open Util
-open Topconstr
+open Constrexpr
 open Vernacexpr
 open Pp
 open Names
 open Term
+open Vars
+open Context
 open Termops
 open Declarations
-open Environ
 open Glob_term
 open Glob_termops
+open Decl_kinds
 
 (** {1 Utilities}  *)
 
@@ -48,33 +51,33 @@ let rec substitterm prof t by_t in_u =
 
 let lift_ldecl n ldecl = List.map (fun (x,y) -> x,lift n y) ldecl
 
-let understand = Pretyping.Default.understand Evd.empty (Global.env())
+let understand = Pretyping.understand (Global.env()) Evd.empty
 
 (** Operations on names and identifiers *)
 let id_of_name = function
-    Anonymous -> id_of_string "H"
+    Anonymous -> Id.of_string "H"
   | Name id   -> id;;
-let name_of_string str = Name (id_of_string str)
-let string_of_name nme = string_of_id (id_of_name nme)
+let name_of_string str = Name (Id.of_string str)
+let string_of_name nme = Id.to_string (id_of_name nme)
 
 (** [isVarf f x] returns [true] if term [x] is of the form [(Var f)]. *)
 let isVarf f x =
     match x with
-      | GVar (_,x) -> Pervasives.compare x f = 0
+      | GVar (_,x) -> Id.equal x f
       | _ -> false
 
 (** [ident_global_exist id] returns true if identifier [id] is linked
     in global environment. *)
 let ident_global_exist id =
   try
-    let ans = CRef (Libnames.Ident (dummy_loc,id)) in
-    let _ = ignore (Constrintern.intern_constr Evd.empty (Global.env()) ans) in
+    let ans = CRef (Libnames.Ident (Loc.ghost,id), None) in
+    let _ = ignore (Constrintern.intern_constr (Global.env()) ans) in
     true
   with e when Errors.noncritical e -> false
 
 (** [next_ident_fresh id] returns a fresh identifier (ie not linked in
     global env) with base [id]. *)
-let next_ident_fresh (id:identifier) =
+let next_ident_fresh (id:Id.t) =
     let res = ref id in
     while ident_global_exist !res do res := Nameops.lift_subscript !res done;
     !res
@@ -128,19 +131,15 @@ let prNamedRLDecl s lc =
     prstr "\n";
   end
 
-let showind (id:identifier) =
+let showind (id:Id.t) =
   let cstrid = Constrintern.global_reference id in
   let ind1,cstrlist = Inductiveops.find_inductive (Global.env()) Evd.empty cstrid in
-  let mib1,ib1 = Inductive.lookup_mind_specif (Global.env()) ind1 in
+  let mib1,ib1 = Inductive.lookup_mind_specif (Global.env()) (fst ind1) in
   List.iter (fun (nm, optcstr, tp) ->
     print_string (string_of_name nm^":");
     prconstr tp; print_string "\n")
     ib1.mind_arity_ctxt;
-  (match ib1.mind_arity with
-    | Monomorphic x ->
-        Printf.printf "arity :"; prconstr x.mind_user_arity
-    | Polymorphic x ->
-        Printf.printf "arity : universe?");
+    Printf.printf "arity :"; prconstr (Inductiveops.type_of_inductive (Global.env ()) ind1);
   Array.iteri
     (fun i x -> Printf.printf"type constr %d :" i ; prconstr x)
     ib1.mind_user_lc
@@ -152,23 +151,15 @@ exception Found of int
 (* Array scanning *)
 
 let array_prfx (arr: 'a array) (pred: int -> 'a -> bool): int =
-  try
-    for i=0 to Array.length arr - 1 do if pred i (arr.(i)) then raise (Found i) done;
-    Array.length arr (* all elt are positive *)
-  with Found i -> i
-
-let array_fold_lefti (f: int -> 'a -> 'b -> 'a) (acc:'a) (arr:'b array): 'a =
-  let i = ref 0 in
-  Array.fold_left
-    (fun acc x ->
-      let res = f !i acc x in i := !i + 1; res)
-    acc arr
+match Array.findi pred arr with
+| None -> Array.length arr (* all elt are positive *)
+| Some i -> i
 
-(* Like list_chop but except that [i] is the size of the suffix of [l]. *)
+(* Like List.chop but except that [i] is the size of the suffix of [l]. *)
 let list_chop_end i l =
   let size_prefix = List.length l -i in
   if size_prefix < 0 then failwith "list_chop_end"
-  else list_chop size_prefix l
+  else List.chop size_prefix l
 
 let list_fold_lefti (f: int -> 'a -> 'b -> 'a) (acc:'a) (arr:'b list): 'a =
   let i = ref 0 in
@@ -234,7 +225,7 @@ let linkmonad f lnkvar =
 let linklift lnkvar i = linkmonad (fun x -> x+i) lnkvar
 
 (* This map is used to deal with debruijn linked indices. *)
-module Link = Map.Make (struct type t = int let compare = Pervasives.compare end)
+module Link = Map.Make (Int)
 
 let pr_links l =
   Printf.printf "links:\n";
@@ -254,7 +245,7 @@ type 'a merged_arg =
 
 type merge_infos =
     {
-      ident:identifier; (** new inductive name *)
+      ident:Id.t; (** new inductive name *)
       mib1: mutual_inductive_body;
       oib1: one_inductive_body;
       mib2: mutual_inductive_body;
@@ -357,17 +348,17 @@ let filter_shift_stable_right (lnk:int merged_arg array) (l:'a list): 'a list =
 
 (** {1 Utilities for merging} *)
 
-let ind1name = id_of_string "__ind1"
-let ind2name = id_of_string "__ind2"
+let ind1name = Id.of_string "__ind1"
+let ind2name = Id.of_string "__ind2"
 
 (** Performs verifications on two graphs before merging: they must not
     be co-inductive, and for the moment they must not be mutual
     either. *)
 let verify_inds mib1 mib2 =
-  if not mib1.mind_finite then error "First argument is coinductive";
-  if not mib2.mind_finite then error "Second argument is coinductive";
-  if mib1.mind_ntypes <> 1 then error "First argument is mutual";
-  if mib2.mind_ntypes <> 1 then error "Second argument is mutual";
+  if mib1.mind_finite == Decl_kinds.CoFinite then error "First argument is coinductive";
+  if mib2.mind_finite == Decl_kinds.CoFinite then error "Second argument is coinductive";
+  if not (Int.equal mib1.mind_ntypes 1) then error "First argument is mutual";
+  if not (Int.equal mib2.mind_ntypes 1) then error "Second argument is mutual";
   ()
 
 (*
@@ -381,11 +372,11 @@ let build_raw_params prms_decl avoid =
   let _ = prNamedRConstr "RAWDUMMY" dummy_glob_constr in
   let res,_ = glob_decompose_prod dummy_glob_constr in
   let comblist = List.combine prms_decl res in
-  comblist, res , (avoid @ (Idset.elements (ids_of_glob_constr dummy_glob_constr)))
+  comblist, res , (avoid @ (Id.Set.elements (ids_of_glob_constr dummy_glob_constr)))
 *)
 
 let ids_of_rawlist avoid rawl =
-    List.fold_left Idset.union avoid (List.map ids_of_glob_constr rawl)
+    List.fold_left Id.Set.union avoid (List.map ids_of_glob_constr rawl)
 
 
 
@@ -463,7 +454,7 @@ let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array
       ([],[],[],[]) arity_ctxt in
 (*  let arity_ctxt2 =
     build_raw_params oib2.mind_arity_ctxt
-      (Idset.elements (ids_of_glob_constr oib1.mind_arity_ctxt)) in*)
+      (Id.Set.elements (ids_of_glob_constr oib1.mind_arity_ctxt)) in*)
   let recprms1,otherprms1,args1,funresprms1 = bldprms (List.rev oib1.mind_arity_ctxt) mlnk1 in
   let _ = prstr "\n\n\n" in
   let recprms2,otherprms2,args2,funresprms2 = bldprms (List.rev oib2.mind_arity_ctxt) mlnk2 in
@@ -514,16 +505,16 @@ let rec merge_app c1 c2 id1 id2 shift filter_shift_stable =
     | GApp(_,f1, arr1), GApp(_,f2,arr2) when isVarf id1 f1 && isVarf id2 f2 ->
         let _ = prstr "\nICI1!\n";Pp.flush_all() in
         let args = filter_shift_stable lnk (arr1 @ arr2) in
-        GApp (dummy_loc,GVar (dummy_loc,shift.ident) , args)
+        GApp (Loc.ghost,GVar (Loc.ghost,shift.ident) , args)
     | GApp(_,f1, arr1), GApp(_,f2,arr2)  -> raise NoMerge
     | GLetIn(_,nme,bdy,trm) , _ ->
         let _ = prstr "\nICI2!\n";Pp.flush_all() in
         let newtrm = merge_app trm c2 id1 id2 shift filter_shift_stable in
-        GLetIn(dummy_loc,nme,bdy,newtrm)
+        GLetIn(Loc.ghost,nme,bdy,newtrm)
     | _, GLetIn(_,nme,bdy,trm) ->
         let _ = prstr "\nICI3!\n";Pp.flush_all() in
         let newtrm = merge_app c1 trm id1 id2 shift filter_shift_stable in
-        GLetIn(dummy_loc,nme,bdy,newtrm)
+        GLetIn(Loc.ghost,nme,bdy,newtrm)
     | _ -> let _ = prstr "\nICI4!\n";Pp.flush_all() in
            raise NoMerge
 
@@ -532,16 +523,16 @@ let rec merge_app_unsafe c1 c2 shift filter_shift_stable =
   match c1 , c2 with
     | GApp(_,f1, arr1), GApp(_,f2,arr2) ->
         let args = filter_shift_stable lnk (arr1 @ arr2) in
-        GApp (dummy_loc,GVar(dummy_loc,shift.ident) , args)
+        GApp (Loc.ghost,GVar(Loc.ghost,shift.ident) , args)
           (* FIXME: what if the function appears in the body of the let? *)
     | GLetIn(_,nme,bdy,trm) , _ ->
         let _ = prstr "\nICI2 '!\n";Pp.flush_all() in
         let newtrm = merge_app_unsafe trm c2 shift filter_shift_stable in
-        GLetIn(dummy_loc,nme,bdy,newtrm)
+        GLetIn(Loc.ghost,nme,bdy,newtrm)
     | _, GLetIn(_,nme,bdy,trm) ->
         let _ = prstr "\nICI3 '!\n";Pp.flush_all() in
         let newtrm = merge_app_unsafe c1 trm shift filter_shift_stable in
-        GLetIn(dummy_loc,nme,bdy,newtrm)
+        GLetIn(Loc.ghost,nme,bdy,newtrm)
     | _ -> let _ = prstr "\nICI4 '!\n";Pp.flush_all() in raise NoMerge
 
 
@@ -550,8 +541,8 @@ let rec merge_app_unsafe c1 c2 shift filter_shift_stable =
    calls of branch 1 with all rec calls of branch 2. *)
 (* TODO: reecrire cette heuristique (jusqu'a merge_types) *)
 let rec merge_rec_hyps shift accrec
-    (ltyp:(Names.name * glob_constr option * glob_constr option) list)
-    filter_shift_stable : (Names.name * glob_constr option * glob_constr option) list =
+    (ltyp:(Name.t * glob_constr option * glob_constr option) list)
+    filter_shift_stable : (Name.t * glob_constr option * glob_constr option) list =
   let mergeonehyp t reldecl =
     match reldecl with
       | (nme,x,Some (GApp(_,i,args) as ind))
@@ -567,11 +558,11 @@ let rec merge_rec_hyps shift accrec
     | e::lt -> e :: merge_rec_hyps shift accrec lt filter_shift_stable
 
 
-let rec build_suppl_reccall (accrec:(name * glob_constr) list) concl2 shift =
+let build_suppl_reccall (accrec:(Name.t * glob_constr) list) concl2 shift =
   List.map (fun (nm,tp) -> (nm,merge_app_unsafe tp concl2 shift)) accrec
 
 
-let find_app (nme:identifier) ltyp =
+let find_app (nme:Id.t) ltyp =
   try
     ignore
       (List.map
@@ -591,9 +582,9 @@ let prnt_prod_or_letin nm letbdy typ =
 
 
 let rec merge_types shift accrec1
-    (ltyp1:(name * glob_constr option * glob_constr option) list)
-    (concl1:glob_constr) (ltyp2:(name * glob_constr option * glob_constr option) list) concl2
-    : (name * glob_constr option * glob_constr option) list * glob_constr =
+    (ltyp1:(Name.t * glob_constr option * glob_constr option) list)
+    (concl1:glob_constr) (ltyp2:(Name.t * glob_constr option * glob_constr option) list) concl2
+    : (Name.t * glob_constr option * glob_constr option) list * glob_constr =
   let _ = prstr "MERGE_TYPES\n" in
   let _ = prstr "ltyp 1 : " in
   let _ = List.iter (fun (nm,lbdy,tp) -> prnt_prod_or_letin nm lbdy tp) ltyp1 in
@@ -603,7 +594,7 @@ let rec merge_types shift accrec1
   let res =
     match ltyp1 with
       | [] ->
-          let isrec1 = (accrec1<>[]) in
+          let isrec1 = not (List.is_empty accrec1) in
           let isrec2 = find_app ind2name ltyp2 in
           let rechyps =
             if isrec1 && isrec2
@@ -657,22 +648,22 @@ let rec merge_types shift accrec1
     linked args [allargs2] to target args of [allargs1] as specified
     in [shift]. [allargs1] and [allargs2] are in reverse order.  Also
     returns the list of unlinked vars of [allargs2]. *)
-let build_link_map_aux (allargs1:identifier array) (allargs2:identifier array)
+let build_link_map_aux (allargs1:Id.t array) (allargs2:Id.t array)
     (lnk:int merged_arg array) =
-  array_fold_lefti
+  Array.fold_left_i
     (fun i acc e ->
-      if i = Array.length lnk - 1 then acc (* functional arg, not in allargs *)
+      if Int.equal i (Array.length lnk - 1) then acc (* functional arg, not in allargs *)
       else
         match e with
-          | Prm_linked j | Arg_linked j -> Idmap.add allargs2.(i) allargs1.(j) acc
+          | Prm_linked j | Arg_linked j -> Id.Map.add allargs2.(i) allargs1.(j) acc
           | _ -> acc)
-    Idmap.empty lnk
+    Id.Map.empty lnk
 
 let build_link_map allargs1 allargs2 lnk =
   let allargs1 =
-    Array.of_list (List.rev (List.map (fun (x,_,_) -> id_of_name x) allargs1)) in
+    Array.of_list (List.rev_map (fun (x,_,_) -> id_of_name x) allargs1) in
   let allargs2 =
-    Array.of_list (List.rev (List.map (fun (x,_,_) -> id_of_name x) allargs2)) in
+    Array.of_list (List.rev_map (fun (x,_,_) -> id_of_name x) allargs2) in
   build_link_map_aux allargs1 allargs2 lnk
 
 
@@ -749,18 +740,18 @@ let fresh_cstror_suffix , cstror_suffix_init =
 (** [merge_constructor_id id1 id2 shift] returns the identifier of the
     new constructor from the id of the two merged constructor and
     the merging info. *)
-let merge_constructor_id id1 id2 shift:identifier =
-  let id = string_of_id shift.ident ^ "_" ^ fresh_cstror_suffix () in
-  next_ident_fresh (id_of_string id)
+let merge_constructor_id id1 id2 shift:Id.t =
+  let id = Id.to_string shift.ident ^ "_" ^ fresh_cstror_suffix () in
+  next_ident_fresh (Id.of_string id)
 
 
 
 (** [merge_constructors lnk shift avoid] merges the two list of
     constructor [(name*type)]. These are translated to glob_constr
     first, each of them having distinct var names. *)
-let rec merge_constructors (shift:merge_infos) (avoid:Idset.t)
-    (typcstr1:(identifier * glob_constr) list)
-    (typcstr2:(identifier * glob_constr) list) : (identifier * glob_constr) list =
+let merge_constructors (shift:merge_infos) (avoid:Id.Set.t)
+    (typcstr1:(Id.t * glob_constr) list)
+    (typcstr2:(Id.t * glob_constr) list) : (Id.t * glob_constr) list =
   List.flatten
     (List.map
         (fun (id1,rawtyp1) ->
@@ -776,20 +767,20 @@ let rec merge_constructors (shift:merge_infos) (avoid:Idset.t)
 (** [merge_inductive_body lnk shift avoid oib1 oib2] merges two
     inductive bodies [oib1] and [oib2], linking with [lnk], params
     info in [shift], avoiding identifiers in [avoid]. *)
-let rec merge_inductive_body (shift:merge_infos) avoid (oib1:one_inductive_body)
+let merge_inductive_body (shift:merge_infos) avoid (oib1:one_inductive_body)
     (oib2:one_inductive_body) =
   (* building glob_constr type of constructors *)
   let mkrawcor nme avoid typ =
     (* first replace rel 1 by a varname *)
     let substindtyp = substitterm 0 (mkRel 1) (mkVar nme) typ in
-    Detyping.detype false (Idset.elements avoid) [] substindtyp in
+    Detyping.detype false (Id.Set.elements avoid) (Global.env()) Evd.empty substindtyp in
   let lcstr1: glob_constr list =
     Array.to_list (Array.map (mkrawcor ind1name avoid) oib1.mind_user_lc) in
   (* add  to avoid all indentifiers of lcstr1 *)
-  let avoid2 = Idset.union avoid (ids_of_rawlist avoid lcstr1) in
+  let avoid2 = Id.Set.union avoid (ids_of_rawlist avoid lcstr1) in
   let lcstr2 =
     Array.to_list (Array.map (mkrawcor ind2name avoid2) oib2.mind_user_lc) in
-  let avoid3 = Idset.union avoid (ids_of_rawlist avoid lcstr2) in
+  let avoid3 = Id.Set.union avoid (ids_of_rawlist avoid lcstr2) in
 
   let params1 =
     try fst (glob_decompose_prod_n shift.nrecprms1 (List.hd lcstr1))
@@ -810,14 +801,14 @@ let rec merge_inductive_body (shift:merge_infos) avoid (oib1:one_inductive_body)
     [lnk]. [shift] information on parameters of the new inductive.
     For the moment, inductives are supposed to be non mutual.
 *)
-let rec merge_mutual_inductive_body
+let merge_mutual_inductive_body
     (mib1:mutual_inductive_body) (mib2:mutual_inductive_body) (shift:merge_infos) =
   (* Mutual not treated, we take first ind body of each. *)
-  merge_inductive_body shift Idset.empty mib1.mind_packets.(0) mib2.mind_packets.(0)
+  merge_inductive_body shift Id.Set.empty mib1.mind_packets.(0) mib2.mind_packets.(0)
 
 
 let glob_constr_to_constr_expr x = (* build a constr_expr from a glob_constr *)
-  Flags.with_option Flags.raw_print (Constrextern.extern_glob_type Idset.empty) x
+  Flags.with_option Flags.raw_print (Constrextern.extern_glob_type Id.Set.empty) x
 
 let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) =
   let params = prms2 @ prms1 in
@@ -828,15 +819,15 @@ let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) =
         let _ = prNamedRConstr (string_of_name nme) tp in
         let _ = prstr "  ;  " in
         let typ = glob_constr_to_constr_expr tp in
-        LocalRawAssum ([(dummy_loc,nme)], Topconstr.default_binder_kind, typ) :: acc)
+        LocalRawAssum ([(Loc.ghost,nme)], Constrexpr_ops.default_binder_kind, typ) :: acc)
       [] params in
-  let concl = Constrextern.extern_constr false (Global.env()) concl in
+  let concl = Constrextern.extern_constr false (Global.env()) Evd.empty concl in
   let arity,_ =
     List.fold_left
       (fun (acc,env) (nm,_,c) ->
-        let typ = Constrextern.extern_constr false env c in
+        let typ = Constrextern.extern_constr false env Evd.empty c in
         let newenv = Environ.push_rel (nm,None,c) env in
-        CProdN (dummy_loc, [[(dummy_loc,nm)],Topconstr.default_binder_kind,typ] , acc) , newenv)
+        CProdN (Loc.ghost, [[(Loc.ghost,nm)],Constrexpr_ops.default_binder_kind,typ] , acc) , newenv)
       (concl,Global.env())
       (shift.funresprms2 @ shift.funresprms1
         @ shift.args2 @ shift.args1 @ shift.otherprms2 @ shift.otherprms1) in
@@ -849,33 +840,22 @@ let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) =
     [rawlist], named ident.
     FIXME: params et cstr_expr (arity) *)
 let glob_constr_list_to_inductive_expr prms1 prms2 mib1 mib2 shift
-    (rawlist:(identifier * glob_constr) list) =
-  let lident = dummy_loc, shift.ident in
+    (rawlist:(Id.t * glob_constr) list) =
+  let lident = Loc.ghost, shift.ident in
   let bindlist , cstr_expr = (* params , arities *)
     merge_rec_params_and_arity prms1 prms2 shift mkSet in
   let lcstor_expr : (bool * (lident * constr_expr)) list  =
     List.map (* zeta_normalize t ? *)
-      (fun (id,t) -> false, ((dummy_loc,id),glob_constr_to_constr_expr t))
+      (fun (id,t) -> false, ((Loc.ghost,id),glob_constr_to_constr_expr t))
       rawlist in
   lident , bindlist , Some cstr_expr , lcstor_expr
 
 
-
-let mkProd_reldecl (rdecl:rel_declaration) (t2:glob_constr) =
-  match rdecl with
-    | (nme,None,t) ->
-        let traw = Detyping.detype false [] [] t in
-        GProd (dummy_loc,nme,Explicit,traw,t2)
-    | (_,Some _,_) -> assert false
-
-
-
-
 let mkProd_reldecl (rdecl:rel_declaration) (t2:glob_constr) =
   match rdecl with
     | (nme,None,t) ->
-        let traw = Detyping.detype false [] [] t in
-        GProd (dummy_loc,nme,Explicit,traw,t2)
+        let traw = Detyping.detype false [] (Global.env()) Evd.empty t in
+        GProd (Loc.ghost,nme,Explicit,traw,t2)
     | (_,Some _,_) -> assert false
 
 
@@ -893,7 +873,7 @@ let merge_inductive (ind1: inductive) (ind2: inductive)
   let prms1,prms2, rawlist = merge_mutual_inductive_body mib1 mib2 shift_prm in
   let _ = prstr "\nrawlist : " in
   let _ =
-    List.iter (fun (nm,tp) -> prNamedRConstr (string_of_id nm) tp;prstr "\n") rawlist in
+    List.iter (fun (nm,tp) -> prNamedRConstr (Id.to_string nm) tp;prstr "\n") rawlist in
   let _ = prstr "\nend rawlist\n" in
 (* FIX: retransformer en constr ici
    let shift_prm =
@@ -904,15 +884,16 @@ let merge_inductive (ind1: inductive) (ind2: inductive)
   let indexpr = glob_constr_list_to_inductive_expr prms1 prms2 mib1 mib2 shift_prm rawlist in
   (* Declare inductive *)
   let indl,_,_ = Command.extract_mutual_inductive_declaration_components [(indexpr,[])] in
-  let mie,impls = Command.interp_mutual_inductive indl [] true (* means: not coinductive *) in
+  let mie,impls = Command.interp_mutual_inductive indl [] 
+          false (*FIXMEnon-poly *) false (* means not private *) Decl_kinds.Finite (* means: not coinductive *) in
   (* Declare the mutual inductive block with its associated schemes *)
-  ignore (Command.declare_mutual_inductive_with_eliminations Declare.UserVerbose mie impls)
+  ignore (Command.declare_mutual_inductive_with_eliminations mie impls)
 
 
 (* Find infos on identifier id. *)
-let find_Function_infos_safe (id:identifier): Indfun_common.function_info =
+let find_Function_infos_safe (id:Id.t): Indfun_common.function_info =
   let kn_of_id x =
-    let f_ref = Libnames.Ident (dummy_loc,x) in
+    let f_ref = Libnames.Ident (Loc.ghost,x) in
     locate_with_msg (str "Don't know what to do with " ++ Libnames.pr_reference f_ref)
       locate_constant f_ref in
     try find_Function_infos (kn_of_id id)
@@ -927,8 +908,8 @@ let find_Function_infos_safe (id:identifier): Indfun_common.function_info =
 
     Warning: For the moment, repetitions of an id in [args1] or
     [args2] are not supported. *)
-let merge (id1:identifier) (id2:identifier) (args1:identifier array)
-    (args2:identifier array) id : unit =
+let merge (id1:Id.t) (id2:Id.t) (args1:Id.t array)
+    (args2:Id.t array) id : unit =
   let finfo1 = find_Function_infos_safe id1 in
   let finfo2 = find_Function_infos_safe id2 in
   (* FIXME? args1 are supposed unlinked. mergescheme (G x x) ?? *)
@@ -938,7 +919,7 @@ let merge (id1:identifier) (id2:identifier) (args1:identifier array)
                  as above: vars may be linked inside args2?? *)
     Array.mapi
       (fun i c ->
-        match array_find_i (fun i x -> x=c) args1 with
+        match Array.findi (fun i x -> Id.equal x c) args1 with
           | Some j -> Linked j
           | None -> Unlinked)
       args2 in
@@ -955,7 +936,7 @@ let remove_last_arg c =
   let xnolast = List.rev (List.tl (List.rev x)) in
   compose_prod xnolast y
 
-let rec remove_n_fst_list n l = if n=0 then l else remove_n_fst_list (n-1) (List.tl l)
+let rec remove_n_fst_list n l = if Int.equal n 0 then l else remove_n_fst_list (n-1) (List.tl l)
 let remove_n_last_list n l = List.rev (remove_n_fst_list n (List.rev l))
 
 let remove_last_n_arg n c =
@@ -977,7 +958,7 @@ let funify_branches relinfo nfuns branch =
       | _ -> assert false in
   let is_dom c =
     match kind_of_term c with
-      | Ind((u,_)) | Construct((u,_),_) -> u = mut_induct
+      | Ind(((u,_),_)) | Construct(((u,_),_),_) -> MutInd.equal u mut_induct
       | _ -> false in
   let _dom_i c =
     assert (is_dom c);
diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml
index a33ae1d6..5558556e 100644
--- a/plugins/funind/recdef.ml
+++ b/plugins/funind/recdef.ml
@@ -1,59 +1,111 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i camlp4deps: "parsing/grammar.cma" i*)
-
 open Term
+open Vars
 open Namegen
 open Environ
-open Declarations
 open Entries
 open Pp
 open Names
 open Libnames
+open Globnames
 open Nameops
+open Errors
 open Util
-open Closure
-open RedFlags
 open Tacticals
-open Typing
 open Tacmach
 open Tactics
 open Nametab
-open Decls
 open Declare
 open Decl_kinds
 open Tacred
 open Proof_type
-open Vernacinterp
 open Pfedit
-open Topconstr
 open Glob_term
 open Pretyping
-open Pretyping.Default
-open Safe_typing
 open Constrintern
-open Hiddentac
+open Misctypes
+open Genredexpr
 
 open Equality
 open Auto
 open Eauto
 
-open Genarg
+open Indfun_common
 
 
-let compute_renamed_type gls c =
-  rename_bound_vars_as_displayed (*no avoid*) [] (*no rels*) []
-    (pf_type_of gls c)
 
-let qed () = Lemmas.save_named true
-let defined () = Lemmas.save_named false
+(* Ugly things which should not be here *)
+
+let coq_constant m s =
+  Coqlib.coq_constant "RecursiveDefinition" m s
+
+let arith_Nat = ["Arith";"PeanoNat";"Nat"]
+let arith_Lt = ["Arith";"Lt"]
+
+let coq_init_constant s =
+  Coqlib.gen_constant_in_modules "RecursiveDefinition" Coqlib.init_modules s
+
+let find_reference sl s =
+  let dp = Names.DirPath.make (List.rev_map Id.of_string sl) in
+  locate (make_qualid dp (Id.of_string s))
+
+let declare_fun f_id kind ?(ctx=Univ.UContext.empty) value =
+  let ce = definition_entry ~univs:ctx value (*FIXME *) in
+    ConstRef(declare_constant f_id (DefinitionEntry ce, kind));;
+
+let defined () = Lemmas.save_proof (Vernacexpr.Proved (false,None))
+
+let def_of_const t =
+   match (kind_of_term t) with
+    Const sp ->
+      (try (match constant_opt_value_in (Global.env ()) sp with
+             | Some c -> c
+	     | _ -> raise Not_found)
+       with Not_found ->
+	 anomaly (str "Cannot find definition of constant " ++
+		    (Id.print (Label.to_id (con_label (fst sp)))))
+      )
+     |_ -> assert false
+
+let type_of_const t =
+   match (kind_of_term t) with
+    Const sp -> Typeops.type_of_constant (Global.env()) sp
+    |_ -> assert false
+
+let constr_of_global x = 
+  fst (Universes.unsafe_constr_of_global x)
+
+let constant sl s = constr_of_global (find_reference sl s)
+
+let const_of_ref = function
+    ConstRef kn -> kn
+  | _ -> anomaly (Pp.str "ConstRef expected")
+
+
+let nf_zeta env =
+  Reductionops.clos_norm_flags  (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA])
+    env
+    Evd.empty
+
+
+let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta  *)
+  let clos_norm_flags flgs env sigma t =
+    Closure.norm_val (Closure.create_clos_infos flgs env) (Closure.inject (Reductionops.nf_evar sigma t)) in
+  clos_norm_flags Closure.betaiotazeta  Environ.empty_env Evd.empty
+
 
+
+
+
+
+(* Generic values *)
 let pf_get_new_ids idl g =
   let ids = pf_ids_of_hyps g in
   List.fold_right
@@ -61,14 +113,98 @@ let pf_get_new_ids idl g =
     idl
     []
 
-let pf_get_new_id id g =
-  List.hd (pf_get_new_ids [id] g)
+let compute_renamed_type gls c =
+  rename_bound_vars_as_displayed (*no avoid*) [] (*no rels*) []
+    (pf_type_of gls c)
+let h'_id = Id.of_string "h'"
+let teq_id = Id.of_string "teq"
+let ano_id = Id.of_string "anonymous"
+let x_id = Id.of_string "x"
+let k_id = Id.of_string "k"
+let v_id = Id.of_string "v"
+let def_id = Id.of_string "def"
+let p_id = Id.of_string "p"
+let rec_res_id = Id.of_string "rec_res";;
+let lt = function () -> (coq_init_constant "lt")
+let le = function () -> (coq_init_constant "le")
+let ex = function () -> (coq_init_constant "ex")
+let nat = function () -> (coq_init_constant "nat")
+let iter_ref () =  
+  try find_reference ["Recdef"] "iter" 
+  with Not_found -> error "module Recdef not loaded"
+let iter = function () -> (constr_of_global (delayed_force iter_ref))
+let eq = function () -> (coq_init_constant "eq")
+let le_lt_SS = function () -> (constant ["Recdef"] "le_lt_SS")
+let le_lt_n_Sm = function () -> (coq_constant arith_Lt "le_lt_n_Sm")
+let le_trans = function () -> (coq_constant arith_Nat "le_trans")
+let le_lt_trans = function () -> (coq_constant arith_Nat "le_lt_trans")
+let lt_S_n = function () -> (coq_constant arith_Lt "lt_S_n")
+let le_n = function () -> (coq_init_constant "le_n")
+let coq_sig_ref = function () -> (find_reference ["Coq";"Init";"Specif"] "sig")
+let coq_O = function () -> (coq_init_constant "O")
+let coq_S = function () -> (coq_init_constant "S")
+let lt_n_O = function () -> (coq_constant arith_Nat "nlt_0_r")
+let max_ref = function () -> (find_reference ["Recdef"] "max")
+let max_constr = function () -> (constr_of_global (delayed_force max_ref))
+let coq_conj = function () -> find_reference Coqlib.logic_module_name "conj"
+
+let f_S t = mkApp(delayed_force coq_S, [|t|]);;
 
-let h_intros l =
-  tclMAP h_intro l
+let rec n_x_id ids n =
+  if Int.equal n 0 then []
+  else let x = next_ident_away_in_goal x_id ids in
+          x::n_x_id (x::ids) (n-1);;
 
-let debug_queue = Stack.create ()
 
+let simpl_iter clause =
+  reduce
+    (Lazy
+       {rBeta=true;rIota=true;rZeta= true; rDelta=false;
+        rConst = [ EvalConstRef (const_of_ref (delayed_force iter_ref))]})
+    clause
+
+(* Others ugly things ... *)
+let (value_f:constr list -> global_reference -> constr) =
+  fun al fterm ->
+    let d0 = Loc.ghost in
+    let rev_x_id_l =
+      (
+	List.fold_left
+	  (fun x_id_l _ ->
+	     let x_id = next_ident_away_in_goal x_id x_id_l in
+	     x_id::x_id_l
+	  )
+	  []
+	  al
+      )
+    in
+    let context = List.map
+      (fun (x, c) -> Name x, None, c) (List.combine rev_x_id_l (List.rev al))
+    in
+    let env = Environ.push_rel_context context (Global.env ()) in
+    let glob_body =
+      GCases
+	(d0,RegularStyle,None,
+	 [GApp(d0, GRef(d0,fterm,None), List.rev_map (fun x_id -> GVar(d0, x_id)) rev_x_id_l),
+	  (Anonymous,None)],
+	 [d0, [v_id], [PatCstr(d0,(destIndRef
+				     (delayed_force coq_sig_ref),1),
+			       [PatVar(d0, Name v_id);
+				PatVar(d0, Anonymous)],
+			       Anonymous)],
+	  GVar(d0,v_id)])
+    in
+    let body = fst (understand env Evd.empty glob_body)(*FIXME*) in
+    it_mkLambda_or_LetIn body context
+
+let (declare_f : Id.t -> logical_kind -> constr list -> global_reference -> global_reference) =
+  fun f_id kind input_type fterm_ref ->
+    declare_fun f_id kind (value_f input_type fterm_ref);;
+
+
+
+(* Debuging mechanism *)
+let debug_queue = Stack.create ()
 
 let rec print_debug_queue b e = 
   if  not (Stack.is_empty debug_queue) 
@@ -76,267 +212,445 @@ let rec print_debug_queue b e =
     begin
       let lmsg,goal = Stack.pop debug_queue in 
       if b then 
-	msgnl (lmsg ++ (str " raised exception " ++ Errors.print e) ++ str " on goal " ++ goal)
+	Pp.msg_debug (lmsg ++ (str " raised exception " ++ Errors.print e) ++ str " on goal " ++ goal)
       else
 	begin
-	  msgnl (str " from " ++ lmsg ++ str " on goal " ++ goal);
+	  Pp.msg_debug (str " from " ++ lmsg ++ str " on goal " ++ goal);
 	end;
       print_debug_queue false e;
     end
 
-  
+let observe strm =
+  if do_observe ()
+  then Pp.msg_debug strm
+  else ()
+
 
 let do_observe_tac s tac g = 
   let goal = Printer.pr_goal g in
-  let lmsg = (str "recdef : ") ++ (str s) in 
+  let lmsg = (str "recdef : ") ++ s in 
+  observe (s++fnl());
   Stack.push (lmsg,goal) debug_queue;
   try 
     let v = tac g in 
     ignore(Stack.pop debug_queue);
     v
   with reraise ->
+    let reraise = Errors.push reraise in
     if not (Stack.is_empty debug_queue)
-    then
-      print_debug_queue true reraise;
-    raise reraise
+    then print_debug_queue true (fst (Cerrors.process_vernac_interp_error reraise));
+    iraise reraise
 
 let observe_tac s tac g =
-  if Tacinterp.get_debug () <> Tactic_debug.DebugOff
+  if do_observe ()
   then do_observe_tac s tac g
   else tac g
 
-let hyp_ids = List.map id_of_string
-    ["x";"v";"k";"def";"p";"h";"n";"h'"; "anonymous"; "teq"; "rec_res";
-     "hspec";"heq"; "hrec"; "hex"; "teq"; "pmax";"hle"];;
-
-let rec nthtl = function
-    l, 0 -> l  | _::tl, n -> nthtl (tl, n-1) | [], _ -> [];;
-
-let hyp_id n l = List.nth l n;;
-
-let (x_id:identifier) = hyp_id 0 hyp_ids;;
-let (v_id:identifier) = hyp_id 1 hyp_ids;;
-let (k_id:identifier) = hyp_id 2 hyp_ids;;
-let (def_id:identifier) = hyp_id 3 hyp_ids;;
-let (p_id:identifier) = hyp_id 4 hyp_ids;;
-let (h_id:identifier) = hyp_id 5 hyp_ids;;
-let (n_id:identifier) = hyp_id 6 hyp_ids;;
-let (h'_id:identifier) = hyp_id 7 hyp_ids;;
-let (ano_id:identifier) = hyp_id 8 hyp_ids;;
-let (rec_res_id:identifier) = hyp_id 10 hyp_ids;;
-let (hspec_id:identifier) = hyp_id 11 hyp_ids;;
-let (heq_id:identifier) = hyp_id 12 hyp_ids;;
-let (hrec_id:identifier) = hyp_id 13 hyp_ids;;
-let (hex_id:identifier) = hyp_id 14 hyp_ids;;
-let (teq_id:identifier) = hyp_id 15 hyp_ids;;
-let (pmax_id:identifier) = hyp_id 16 hyp_ids;;
-let (hle_id:identifier) = hyp_id 17 hyp_ids;;
-
-let message s = if Flags.is_verbose () then msgnl(str s);;
+(* Conclusion tactics *)
 
-let def_of_const t =
-   match (kind_of_term t) with
-    Const sp ->
-      (try (match body_of_constant (Global.lookup_constant sp) with
-             | Some c -> Declarations.force c
-	     | _ -> assert false)
-       with e when Errors.noncritical e ->
-	 anomaly ("Cannot find definition of constant "^
-		    (string_of_id (id_of_label (con_label sp))))
-      )
-     |_ -> assert false
+(* The boolean value is_mes expresses that the termination is expressed
+  using a measure function instead of a well-founded relation. *)
+let tclUSER tac is_mes l g =
+  let clear_tac =
+    match l with
+      | None -> clear []
+      | Some l -> tclMAP (fun id -> tclTRY (clear [id])) (List.rev l)
+  in
+  tclTHENLIST
+    [
+      clear_tac;
+      if is_mes
+      then tclTHENLIST
+        [
+	  unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference
+            (delayed_force Indfun_common.ltof_ref))];
+         tac
+	 ]
+      else tac
+    ]
+    g
 
-let type_of_const t =
-   match (kind_of_term t) with
-    Const sp -> Typeops.type_of_constant (Global.env()) sp
-    |_ -> assert false
+let tclUSER_if_not_mes concl_tac is_mes names_to_suppress =
+  if is_mes
+  then tclCOMPLETE (fun gl -> Proofview.V82.of_tactic (Simple.apply (delayed_force well_founded_ltof)) gl)
+  else (* tclTHEN (Simple.apply (delayed_force acc_intro_generator_function) ) *) (tclUSER concl_tac is_mes names_to_suppress)
+
+
+
+  
 
-let arg_type t =
-  match kind_of_term (def_of_const t) with
-      Lambda(a,b,c) -> b
-    | _ -> assert false;;
-
-let evaluable_of_global_reference r =
-  match r with
-      ConstRef sp -> EvalConstRef sp
-    | VarRef id -> EvalVarRef id
-    | _ -> assert false;;
-
-
-let rank_for_arg_list h =
-  let predicate a b =
-      try List.for_all2 eq_constr a b with
-        Invalid_argument _ -> false in
-  let rec rank_aux i = function
-  | [] -> None
-  | x::tl -> if predicate h x then Some i else rank_aux (i+1) tl in
-  rank_aux 0;;
-
-let rec check_not_nested f t = 
-  match kind_of_term t with 
-    | App(g, _) when eq_constr f g -> 
-	errorlabstrm "recdef" (str "Nested recursive function are not allowed with Function")
-    | Var(_) when eq_constr t f -> errorlabstrm "recdef" (str "Nested recursive function are not allowed with Function")
-    | _ -> iter_constr (check_not_nested f) t 
-
-
-
-
-let rec (find_call_occs : int -> int -> constr -> constr ->
-  (constr list -> constr) * constr list list) =
- fun nb_arg nb_lam f expr ->
-  match (kind_of_term expr) with
-    App (g, args) when eq_constr g f ->
-      if Array.length args <> nb_arg then errorlabstrm "recdef" (str "Partial application of function " ++ Printer.pr_lconstr expr ++ str " in its body is not allowed while using Function");
-      Array.iter (check_not_nested f) args;
-      (fun l -> List.hd l), [Array.to_list args]
-  | App (g, args) ->
-     let (largs: constr list) = Array.to_list args in
-     let rec find_aux = function
-	 []    -> (fun x -> []), []
-       | a::upper_tl ->
-         (match find_aux upper_tl with
-          (cf, ((arg1::args) as args_for_upper_tl)) ->
-           (match find_call_occs nb_arg nb_lam f a with
-             cf2, (_ :: _ as other_args) ->
-               let rec avoid_duplicates args =
-                  match args with
-                  | [] -> (fun _ -> []), []
-                  | h::tl ->
-                      let recomb_tl, args_for_tl =
-                          avoid_duplicates tl in
-                    match rank_for_arg_list h args_for_upper_tl with
-                    | None ->
-                        (fun l -> List.hd l::recomb_tl(List.tl l)),
-                        h::args_for_tl
-                    | Some i ->
-                        (fun l -> List.nth l (i+List.length args_for_tl)::
-                            recomb_tl l),
-                        args_for_tl
-               in
-               let recombine, other_args' =
-                   avoid_duplicates other_args in
-	       let len1 = List.length other_args' in
-                   (fun l -> cf2 (recombine l)::cf(nthtl(l,len1))),
-                     other_args'@args_for_upper_tl
-           | _, [] -> (fun x -> a::cf x), args_for_upper_tl)
-	 | _, [] ->
-	   (match find_call_occs nb_arg nb_lam f a with
-	     cf, (arg1::args) -> (fun l -> cf l::upper_tl), (arg1::args)
-	   | _, [] -> (fun x -> a::upper_tl), [])) in
-     begin
-       match (find_aux largs) with
-	   cf, [] -> (fun l -> mkApp(g, args)), []
-	 | cf, args ->
-	     (fun l -> mkApp (g, Array.of_list (cf l))), args
-     end
-  | Rel(v) -> if v > nb_lam then error "find_call_occs : Rel" else ((fun l -> expr),[])
-  | Var(_) when eq_constr expr f -> errorlabstrm "recdef" (str "Partial application of function " ++ Printer.pr_lconstr expr ++ str " in its body is not allowed while using Function")
-  | Var(id) -> (fun l -> expr), []
-  | Meta(_) -> error "Found a metavariable. Can not treat such a term" 
-  | Evar(_) -> error "Found an evar. Can not treat such a term"
-  | Sort(_)  -> (fun l -> expr), []
-  | Cast(b,_,_) -> find_call_occs nb_arg nb_lam f b
-  | Prod(na,t,b) -> 
-    error "Found a product. Can not treat such a term"
-  | Lambda(na,t,b) ->
+(* Travelling term.
+   Both definitions of [f_terminate] and [f_equation] use the same generic 
+   travelling mechanism.
+*)
+
+(* [check_not_nested forbidden e] checks that [e] does not contains any variable 
+   of [forbidden]
+*)
+let check_not_nested forbidden e =
+  let rec check_not_nested e =  
+    match kind_of_term e with 
+      | Rel _ -> ()
+      | Var x ->
+        if Id.List.mem x forbidden
+        then error ("check_not_nested : failure "^Id.to_string x)
+      | Meta _ | Evar _ | Sort _ -> ()
+      | Cast(e,_,t) -> check_not_nested e;check_not_nested t
+      | Prod(_,t,b) -> check_not_nested t;check_not_nested b
+      | Lambda(_,t,b) -> check_not_nested t;check_not_nested b
+      | LetIn(_,v,t,b) -> check_not_nested t;check_not_nested b;check_not_nested v
+      | App(f,l) -> check_not_nested f;Array.iter check_not_nested l
+      | Proj (p,c) -> check_not_nested c
+      | Const _ -> ()
+      | Ind _ -> ()
+      | Construct _ -> ()
+      | Case(_,t,e,a) -> 
+	check_not_nested t;check_not_nested e;Array.iter check_not_nested a
+      | Fix _ -> error "check_not_nested : Fix"
+      | CoFix _ -> error "check_not_nested : Fix"
+  in
+  try 
+    check_not_nested e 
+  with UserError(_,p) -> 
+    errorlabstrm "_" (str "on expr : " ++ Printer.pr_lconstr e ++ str " " ++ p)
+
+(* ['a info] contains the local information for travelling *)
+type 'a infos = 
+    { nb_arg : int; (* function number of arguments *)
+      concl_tac : tactic; (* final tactic to finish proofs *)
+      rec_arg_id : Id.t; (*name of the declared recursive argument *)
+      is_mes : bool; (* type of recursion *)
+      ih : Id.t; (* induction hypothesis name *)
+      f_id : Id.t;  (* function name *)
+      f_constr : constr;  (* function term *)
+      f_terminate : constr; (* termination proof term *)
+      func : global_reference; (* functionnal reference *)
+      info : 'a;
+      is_main_branch : bool; (* on the main branch or on a matched expression *)
+      is_final : bool; (* final first order term or not *)
+      values_and_bounds : (Id.t*Id.t) list; 
+      eqs : Id.t list; 
+      forbidden_ids : Id.t list;
+      acc_inv : constr lazy_t;
+      acc_id : Id.t;
+      args_assoc : ((constr list)*constr) list;
+    }
+
+
+type ('a,'b) journey_info_tac = 
+    'a -> (* the arguments of the constructor *)
+    'b infos -> (* infos of the caller *)
+    ('b infos -> tactic) -> (* the continuation tactic of the caller *)
+    'b infos -> (* argument of the tactic *)
+    tactic
+       
+(* journey_info : specifies the actions to do on the different term constructors during the travelling of the term
+*)
+type journey_info = 
+    { letiN : ((Name.t*constr*types*constr),constr) journey_info_tac;
+      lambdA : ((Name.t*types*constr),constr) journey_info_tac;
+      casE : ((constr infos -> tactic) -> constr infos -> tactic) -> 
+	((case_info * constr * constr * constr array),constr) journey_info_tac;
+      otherS : (unit,constr) journey_info_tac;
+      apP : (constr*(constr list),constr) journey_info_tac;
+      app_reC : (constr*(constr list),constr) journey_info_tac;
+      message : string
+    }
+
+	       
+
+let rec add_vars forbidden e = 
+  match kind_of_term e with 
+    | Var x -> x::forbidden 
+    | _ -> fold_constr add_vars forbidden e 
+
+
+let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic = 
+  fun g -> 
+    let rev_context,b = decompose_lam_n nb_lam e in 
+    let ids = List.fold_left (fun acc (na,_) -> 	
+      let pre_id = 
+	match na with 
+	  | Name x -> x 
+	  | Anonymous -> ano_id 
+      in
+      pre_id::acc
+    ) [] rev_context in 
+    let rev_ids = pf_get_new_ids (List.rev ids) g in 
+    let new_b = substl (List.map mkVar rev_ids) b in 
+    tclTHENLIST 
+      [
+	h_intros (List.rev rev_ids);
+	Proofview.V82.of_tactic (intro_using teq_id);
+	onLastHypId (fun heq -> 
+	  tclTHENLIST[
+	    thin to_intros;
+	    h_intros to_intros;
+	    (fun g' -> 
+	      let ty_teq = pf_type_of g' (mkVar heq) in
+	      let teq_lhs,teq_rhs =
+		let _,args = try destApp ty_teq with DestKO -> assert false in
+		args.(1),args.(2)
+	      in
+	      let new_b' = Termops.replace_term teq_lhs teq_rhs new_b in 
+	      let new_infos = {
+		infos with 
+		  info = new_b';
+		  eqs = heq::infos.eqs;
+		  forbidden_ids = 
+		  if forbid_new_ids 
+		  then add_vars infos.forbidden_ids new_b'
+		  else infos.forbidden_ids
+	      } in 
+	      finalize_tac new_infos g' 
+	    )
+	  ]
+	)
+      ] g
+
+let rec travel_aux jinfo continuation_tac (expr_info:constr infos) =
+  match kind_of_term expr_info.info with 
+    | CoFix _ | Fix _ -> error "Function cannot treat local fixpoint or cofixpoint"
+    | Proj _ -> error "Function cannot treat projections"
+    | LetIn(na,b,t,e) -> 
       begin
-	match find_call_occs nb_arg (succ nb_lam) f b with
-	  | _, [] ->  (* Lambda are authorized as long as they do not contain
-			 recursives calls *)
-	      (fun l -> expr),[]
-	  | _ ->  error "Found a lambda which body contains a recursive call. Such terms are not allowed"
+	let new_continuation_tac = 
+	  jinfo.letiN (na,b,t,e) expr_info continuation_tac
+	in
+	travel jinfo new_continuation_tac 
+	  {expr_info with info = b; is_final=false}
       end
-  | LetIn(na,v,t,b) ->
+    | Rel _ -> anomaly (Pp.str "Free var in goal conclusion !")
+    | Prod _ -> 
       begin
-	match find_call_occs nb_arg nb_lam f v, find_call_occs nb_arg (succ nb_lam) f b with
-	  | (_,[]),(_,[]) ->
-	      ((fun l -> expr), [])
-	  | (_,[]),(cf,(_::_ as l)) ->
-	      ((fun  l -> mkLetIn(na,v,t,cf l)),l)
-	  | (cf,(_::_ as l)),(_,[]) ->
-	      ((fun l -> mkLetIn(na,cf l,t,b)), l)
-	  | _ -> error "Found a letin with recursive calls in both variable value and body. Such terms are not allowed."
+	try
+	  check_not_nested (expr_info.f_id::expr_info.forbidden_ids) expr_info.info;
+	  jinfo.otherS () expr_info continuation_tac expr_info
+	with e when Errors.noncritical e ->
+	  errorlabstrm "Recdef.travel" (str "the term " ++ Printer.pr_lconstr expr_info.info ++ str " can not contain a recursive call to " ++ pr_id expr_info.f_id)
       end
-  | Const(_) -> (fun l -> expr), []
-  | Ind(_) -> (fun l -> expr), []
-  | Construct (_, _) -> (fun l -> expr), []
-  | Case(i,t,a,r) ->
-      (match find_call_occs nb_arg nb_lam f a with
-	cf, (arg1::args) -> (fun l -> mkCase(i, t, (cf l), r)),(arg1::args)
-      | _ -> (fun l -> expr),[])
-  | Fix(_) -> error "Found a local fixpoint. Can not treat such a term"
-  | CoFix(_) -> error "Found a local cofixpoint : CoFix";;
-
-let coq_constant s =
-  Coqlib.gen_constant_in_modules "RecursiveDefinition"
-    (Coqlib.init_modules @ Coqlib.arith_modules) s;;
-
-let coq_base_constant s =
-  Coqlib.gen_constant_in_modules "RecursiveDefinition"
-    (Coqlib.init_modules @ [["Coq";"Arith";"Le"];["Coq";"Arith";"Lt"]]) s;;
-
-let constant sl s =
-  constr_of_global
-    (locate (make_qualid(Names.make_dirpath
-			   (List.map id_of_string (List.rev sl)))
-	       (id_of_string s)));;
+    | Lambda(n,t,b) -> 
+      begin
+	try
+	  check_not_nested (expr_info.f_id::expr_info.forbidden_ids) expr_info.info;
+	  jinfo.otherS () expr_info continuation_tac expr_info
+	with e when Errors.noncritical e ->
+	  errorlabstrm "Recdef.travel" (str "the term " ++ Printer.pr_lconstr expr_info.info ++ str " can not contain a recursive call to " ++ pr_id expr_info.f_id)
+      end
+    | Case(ci,t,a,l) -> 
+      begin
+	let continuation_tac_a = 
+	  jinfo.casE 
+	    (travel jinfo) (ci,t,a,l) 
+	    expr_info continuation_tac in 
+	travel 
+	  jinfo continuation_tac_a 
+	  {expr_info with info = a; is_main_branch = false; 
+	    is_final = false}
+      end
+    | App _ -> 
+      let f,args = decompose_app expr_info.info in 
+      if eq_constr f (expr_info.f_constr) 
+      then jinfo.app_reC (f,args) expr_info continuation_tac expr_info 
+      else
+      begin
+	match kind_of_term f with 
+	  | App _ -> assert false (* f is coming from a decompose_app *)
+	  | Const _ | Construct _ | Rel _ | Evar _ | Meta _  | Ind _ 
+	  | Sort _ | Prod _ | Var _ -> 
+	    let new_infos = {expr_info with info=(f,args)} in 
+	    let new_continuation_tac = 
+	      jinfo.apP (f,args) expr_info continuation_tac in 
+	    travel_args jinfo
+	      expr_info.is_main_branch new_continuation_tac new_infos
+	  | Case _ ->  errorlabstrm "Recdef.travel" (str "the term " ++ Printer.pr_lconstr expr_info.info ++ str " can not contain an applied match (See Limitation in Section 2.3 of refman)")
+	  | _ -> anomaly (Pp.str "travel_aux : unexpected "++ Printer.pr_lconstr expr_info.info)
+      end
+    | Cast(t,_,_) -> travel jinfo continuation_tac {expr_info with info=t}
+    | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ ->
+      let new_continuation_tac = 
+	jinfo.otherS () expr_info continuation_tac in
+      new_continuation_tac expr_info
+and travel_args jinfo is_final continuation_tac infos = 
+  let (f_args',args) = infos.info in 
+  match args with 
+    | [] -> 
+      continuation_tac {infos with info = f_args'; is_final = is_final}
+    | arg::args' -> 
+      let new_continuation_tac new_infos = 
+	let new_arg = new_infos.info in 
+	travel_args jinfo is_final
+	  continuation_tac
+	  {new_infos with info = (mkApp(f_args',[|new_arg|]),args')}
+      in
+      travel jinfo new_continuation_tac 
+	{infos with info=arg;is_final=false} 
+and travel jinfo continuation_tac expr_info = 
+  observe_tac 
+    (str jinfo.message ++ Printer.pr_lconstr expr_info.info) 
+    (travel_aux jinfo continuation_tac expr_info)
 
-let find_reference sl s =
-    (locate (make_qualid(Names.make_dirpath
-			   (List.map id_of_string (List.rev sl)))
-	       (id_of_string s)));;
+(* Termination proof *) 
 
-let le_lt_SS = function () -> (constant ["Recdef"] "le_lt_SS")
-let le_lt_n_Sm = function () -> (coq_base_constant "le_lt_n_Sm")
-
-let le_trans = function () -> (coq_base_constant "le_trans")
-let le_lt_trans = function () -> (coq_base_constant "le_lt_trans")
-let lt_S_n = function () -> (coq_base_constant "lt_S_n")
-let le_n = function () -> (coq_base_constant "le_n")
-let refl_equal = function () -> (coq_base_constant "eq_refl")
-let eq = function () -> (coq_base_constant "eq")
-let ex = function () -> (coq_base_constant "ex")
-let coq_sig_ref = function () -> (find_reference ["Coq";"Init";"Specif"] "sig")
-let coq_sig = function () -> (coq_base_constant "sig")
-let coq_O = function () -> (coq_base_constant "O")
-let coq_S = function () -> (coq_base_constant "S")
-
-let gt_antirefl = function () -> (coq_constant "gt_irrefl")
-let lt_n_O = function () -> (coq_base_constant "lt_n_O")
-let lt_n_Sn = function () -> (coq_base_constant "lt_n_Sn")
-
-let f_equal = function () -> (coq_constant "f_equal")
-let well_founded_induction = function () -> (coq_constant "well_founded_induction")
-let well_founded = function () -> (coq_constant "well_founded")
-let acc_rel = function () -> (coq_constant "Acc")
-let acc_inv_id = function () -> (coq_constant "Acc_inv")
-let well_founded_ltof = function () ->  (Coqlib.coq_constant "" ["Arith";"Wf_nat"] "well_founded_ltof")
-let iter_ref = function () -> (try find_reference ["Recdef"] "iter" with Not_found -> error "module Recdef not loaded")
-let max_ref = function () -> (find_reference ["Recdef"] "max")
-let iter = function () -> (constr_of_global (delayed_force iter_ref))
-let max_constr = function () -> (constr_of_global (delayed_force max_ref))
+let rec prove_lt hyple g = 
+  begin
+    try
+      let (varx,varz) = match decompose_app (pf_concl g) with
+        | _, x::z::_ when isVar x && isVar z -> x, z
+        | _ -> assert false
+      in
+      let h =
+	List.find (fun id ->
+          match decompose_app (pf_type_of g (mkVar id)) with
+            | _, t::_ -> eq_constr t varx
+            | _ -> false
+	) hyple
+      in
+      let y =
+	List.hd (List.tl (snd (decompose_app (pf_type_of g (mkVar h))))) in
+      tclTHENLIST[
+	Proofview.V82.of_tactic (apply (mkApp(le_lt_trans (),[|varx;y;varz;mkVar h|])));
+	observe_tac (str "prove_lt") (prove_lt hyple)
+      ]
+    with Not_found -> 
+      (
+	(
+	  tclTHENLIST[
+	    Proofview.V82.of_tactic (apply (delayed_force lt_S_n));
+	    (observe_tac (str "assumption: " ++ Printer.pr_goal g) (Proofview.V82.of_tactic assumption))
+	  ])
+      )
+  end
+    g
+
+let rec destruct_bounds_aux infos (bound,hyple,rechyps) lbounds g = 
+  match lbounds with 
+    | [] -> 
+      let ids = pf_ids_of_hyps g in 
+      let s_max = mkApp(delayed_force coq_S, [|bound|]) in 
+      let k = next_ident_away_in_goal k_id ids in
+      let ids = k::ids in
+      let h' = next_ident_away_in_goal (h'_id) ids in
+      let ids = h'::ids in
+      let def = next_ident_away_in_goal def_id ids in
+      tclTHENLIST[
+	Proofview.V82.of_tactic (split (ImplicitBindings [s_max]));
+	Proofview.V82.of_tactic (intro_then
+	  (fun id -> 
+            Proofview.V82.tactic begin
+	    observe_tac (str "destruct_bounds_aux") 
+	      (tclTHENS (Proofview.V82.of_tactic (simplest_case (mkVar id)))
+		 [
+		   tclTHENLIST[Proofview.V82.of_tactic (intro_using h_id);
+			       Proofview.V82.of_tactic (simplest_elim(mkApp(delayed_force lt_n_O,[|s_max|])));
+			       Proofview.V82.of_tactic default_full_auto];
+		   tclTHENLIST[
+		     observe_tac (str "clearing k ") (clear [id]);
+		     h_intros [k;h';def];
+		     observe_tac (str "simple_iter") (simpl_iter Locusops.onConcl);
+		     observe_tac (str "unfold functional")
+		       (unfold_in_concl[(Locus.OnlyOccurrences [1],
+					 evaluable_of_global_reference infos.func)]);
+		     observe_tac (str "test" ) (
+		       tclTHENLIST[
+			 list_rewrite true
+			   (List.fold_right 
+			      (fun e acc -> (mkVar e,true)::acc)
+			      infos.eqs
+			      (List.map (fun e -> (e,true)) rechyps)
+			   );
+		      (* list_rewrite true *)
+		      (*   (List.map (fun e -> (mkVar e,true)) infos.eqs) *)
+		      (*   ; *)
+			 
+			 (observe_tac (str "finishing") 
+			    (tclORELSE
+			       (Proofview.V82.of_tactic intros_reflexivity)
+			       (observe_tac (str "calling prove_lt") (prove_lt hyple))))])
+		   ]
+	      ]
+	      )end))
+	  ] g
+      | (_,v_bound)::l -> 
+      tclTHENLIST[
+	Proofview.V82.of_tactic (simplest_elim (mkVar v_bound));
+	clear [v_bound];
+	tclDO 2 (Proofview.V82.of_tactic intro);
+	onNthHypId 1 
+	  (fun p_hyp -> 
+	    (onNthHypId 2 
+	       (fun p ->  
+		 tclTHENLIST[
+		   Proofview.V82.of_tactic (simplest_elim 
+		     (mkApp(delayed_force max_constr, [| bound; mkVar p|])));
+		   tclDO 3 (Proofview.V82.of_tactic intro);
+		   onNLastHypsId 3 (fun lids -> 
+		     match lids with
+		       [hle2;hle1;pmax] -> 
+			 destruct_bounds_aux infos 
+			   ((mkVar pmax),
+			    hle1::hle2::hyple,(mkVar p_hyp)::rechyps) 
+			   l 
+		       | _ -> assert false) ;
+		 ]
+	       )
+	    )
+	  )
+      ] g
+
+let destruct_bounds infos = 
+  destruct_bounds_aux infos (delayed_force coq_O,[],[]) infos.values_and_bounds
+
+let terminate_app f_and_args expr_info continuation_tac infos = 
+    if expr_info.is_final && expr_info.is_main_branch 
+    then 
+      tclTHENLIST[
+	continuation_tac infos;
+	observe_tac (str "first split") 
+	  (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info])));
+	observe_tac (str "destruct_bounds (1)") (destruct_bounds infos)
+      ]
+    else continuation_tac infos
+
+let terminate_others _ expr_info continuation_tac infos = 
+  if expr_info.is_final && expr_info.is_main_branch 
+  then 
+    tclTHENLIST[
+	    continuation_tac infos;
+      observe_tac (str "first split") 
+	(Proofview.V82.of_tactic (split (ImplicitBindings [infos.info])));
+      observe_tac (str "destruct_bounds") (destruct_bounds infos)
+    ]
+  else continuation_tac infos
+
+let terminate_letin (na,b,t,e) expr_info continuation_tac info = 
+  let new_e = subst1 info.info e in 
+  let new_forbidden = 
+    let forbid = 
+      try 
+	check_not_nested (expr_info.f_id::expr_info.forbidden_ids) b;
+	true
+      with e when Errors.noncritical e -> false
+    in
+    if forbid 
+    then 
+      match na with
+	| Anonymous -> info.forbidden_ids
+	| Name id -> id::info.forbidden_ids
+    else info.forbidden_ids 
+  in
+  continuation_tac {info with info = new_e; forbidden_ids = new_forbidden} 
+
+let pf_type c tac gl = 
+  let evars, ty = Typing.e_type_of (pf_env gl) (project gl) c in
+    tclTHEN (Refiner.tclEVARS evars) (tac ty) gl
 
-let ltof_ref = function  () -> (find_reference ["Coq";"Arith";"Wf_nat"] "ltof")
-let coq_conj = function () -> find_reference ["Coq";"Init";"Logic"] "conj"
-
-(* These are specific to experiments in nat with lt as well_founded_relation, *)
-(*    but this should be made more general. *)
-let nat = function () -> (coq_base_constant "nat")
-let lt = function () -> (coq_base_constant "lt")
-
-(* This is simply an implementation of the case_eq tactic.  this code
-  should be replaced with the tactic defined in Ltac in Init/Tactics.v *)
-let  mkCaseEq a  : tactic =
-     (fun g ->
-       let type_of_a = pf_type_of g a in
-       tclTHENLIST
-         [h_generalize [mkApp(delayed_force refl_equal, [| type_of_a; a|])];
-          (fun g2 ->
-	    change_in_concl None
-	     (pattern_occs [((false,[1]), a)] (pf_env g2) Evd.empty (pf_concl g2))
-		  g2);
-	  simplest_case a] g);;
+let pf_typel l tac =
+  let rec aux tys l =
+    match l with
+    | [] -> tac (List.rev tys)
+    | hd :: tl -> pf_type hd (fun ty -> aux (ty::tys) tl)
+  in aux [] l
 
 (* This is like the previous one except that it also rewrite on all
   hypotheses except the ones given in the first argument.  All the
@@ -344,390 +658,355 @@ let  mkCaseEq a  : tactic =
   introduced back later; the result is the pair of the tactic and the
   list of hypotheses that have been generalized and cleared. *)
 let mkDestructEq :
-  identifier list -> constr -> goal sigma -> tactic * identifier list =
+  Id.t list -> constr -> goal sigma -> tactic * Id.t list =
   fun not_on_hyp expr g ->
   let hyps = pf_hyps g in
   let to_revert =
-    Util.map_succeed
-      (fun (id,_,t) ->
-        if List.mem id not_on_hyp || not (Termops.occur_term expr t)
-        then failwith "is_expr_context";
-        id) hyps in
+    Util.List.map_filter
+      (fun (id, _, t) ->
+        if Id.List.mem id not_on_hyp || not (Termops.occur_term expr t)
+        then None else Some id) hyps in
   let to_revert_constr = List.rev_map mkVar to_revert in
   let type_of_expr = pf_type_of g expr in
-  let new_hyps = mkApp(delayed_force refl_equal, [|type_of_expr; expr|])::
+  let new_hyps = mkApp(Lazy.force refl_equal, [|type_of_expr; expr|])::
            to_revert_constr in
+    pf_typel new_hyps (fun _ ->
     tclTHENLIST
-     [h_generalize new_hyps;
+     [Simple.generalize new_hyps;
       (fun g2 ->
-	change_in_concl None
-	  (pattern_occs [((false,[1]), expr)] (pf_env g2) Evd.empty (pf_concl g2)) g2);
-      simplest_case expr], to_revert
-
-let rec  mk_intros_and_continue thin_intros (extra_eqn:bool)
-    cont_function (eqs:constr list) nb_lam (expr:constr) g =
-  observe_tac "mk_intros_and_continue" (
-  let finalize () =  	if extra_eqn then
-	  let teq = pf_get_new_id teq_id g in
-	    tclTHENLIST
-	      [ h_intro teq;
-		thin thin_intros;
-		h_intros thin_intros;
-
-		tclMAP
-		  (fun eq -> tclTRY (Equality.general_rewrite_in true Termops.all_occurrences true (* deps proofs also: *) true teq eq false))
-		  (List.rev eqs);
-		(fun g1 ->
-		   let ty_teq = pf_type_of g1 (mkVar teq) in
-		   let teq_lhs,teq_rhs =
-		     let _,args =
-                       try destApp ty_teq
-                       with e when Errors.noncritical e ->
-                         Pp.msgnl (Printer.pr_goal g1 ++ fnl () ++ pr_id teq ++ str ":" ++ Printer.pr_lconstr ty_teq); assert false
-                     in
-		     args.(1),args.(2)
-		   in
-	           cont_function (mkVar teq::eqs) (Termops.replace_term teq_lhs teq_rhs expr) g1
-		)
-	      ]
-	      
-	else
-	  tclTHENSEQ[
-	    thin thin_intros;
-	    h_intros thin_intros;
-	    cont_function eqs expr
-	  ] 
-  in
-  if nb_lam = 0
-  then finalize ()
-  else
-    match kind_of_term expr with
-      | Lambda (n, _, b) ->
-     	  let n1 =
-	    match n with
-      		Name x -> x
-              | Anonymous -> ano_id
-	  in
-     	  let new_n = pf_get_new_id n1 g in
-	  tclTHEN (h_intro new_n)
-	    (mk_intros_and_continue thin_intros extra_eqn cont_function eqs
-	       (pred nb_lam) (subst1 (mkVar new_n) b)) 
-      | _ ->
-	  assert false) g
-(* 	  finalize () *)
-let const_of_ref = function
-    ConstRef kn -> kn
-  | _ -> anomaly "ConstRef expected"
+	Proofview.V82.of_tactic (change_in_concl None
+	  (fun sigma ->
+	    pattern_occs [Locus.AllOccurrencesBut [1], expr] (pf_env g2) sigma (pf_concl g2))) g2);
+      Proofview.V82.of_tactic (simplest_case expr)]), to_revert
 
-let simpl_iter clause =
-  reduce
-    (Lazy
-       {rBeta=true;rIota=true;rZeta= true; rDelta=false;
-        rConst = [ EvalConstRef (const_of_ref (delayed_force iter_ref))]})
-(*     (Simpl (Some ([],mkConst (const_of_ref (delayed_force iter_ref))))) *)
-    clause
 
-(* The boolean value is_mes expresses that the termination is expressed
-  using a measure function instead of a well-founded relation. *)
-let tclUSER tac is_mes l g =
-  let clear_tac =
-    match l with
-      | None -> h_clear true []
-      | Some l -> tclMAP (fun id -> tclTRY (h_clear false [id])) (List.rev l)
+let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g =
+  let b =
+    try
+      check_not_nested (expr_info.f_id::expr_info.forbidden_ids) a;
+      false
+    with e when Errors.noncritical e ->
+      true
   in
-  tclTHENSEQ
-    [
-      clear_tac;
-      if is_mes
-      then tclTHEN
-             (unfold_in_concl [(Termops.all_occurrences, evaluable_of_global_reference
-                                      (delayed_force ltof_ref))])
-             tac
-      else tac
-    ]
+  let a' = infos.info in
+  let new_info =
+    {infos with
+      info = mkCase(ci,t,a',l);
+      is_main_branch = expr_info.is_main_branch;
+      is_final = expr_info.is_final} in
+  let destruct_tac,rev_to_thin_intro = 
+    mkDestructEq [expr_info.rec_arg_id] a' g in 
+  let to_thin_intro = List.rev rev_to_thin_intro in 
+  observe_tac (str "treating case " ++ int (Array.length l) ++ spc () ++ Printer.pr_lconstr a') 
+    (try
+      (tclTHENS
+	 destruct_tac
+	 (List.map_i (fun i e -> observe_tac (str "do treat case") (treat_case b to_thin_intro (next_step continuation_tac) ci.ci_cstr_ndecls.(i) e new_info)) 0 (Array.to_list l)
+	 ))
+    with 
+      | UserError("Refiner.thensn_tac3",_) 
+      | UserError("Refiner.tclFAIL_s",_) ->
+	(observe_tac (str "is computable " ++ Printer.pr_lconstr new_info.info) (next_step continuation_tac {new_info with info = nf_betaiotazeta new_info.info} )
+	))
     g
+    
+let terminate_app_rec (f,args) expr_info continuation_tac _ = 
+  List.iter (check_not_nested (expr_info.f_id::expr_info.forbidden_ids))
+    args;
+  begin
+    try 
+      let v = List.assoc_f (List.equal Constr.equal) args expr_info.args_assoc in
+      let new_infos = {expr_info with info = v} in 
+      tclTHENLIST[
+	continuation_tac new_infos;
+	if expr_info.is_final && expr_info.is_main_branch 
+	then
+	  tclTHENLIST[ 
+	    observe_tac (str "first split")
+	      (Proofview.V82.of_tactic (split (ImplicitBindings [new_infos.info])));
+	    observe_tac (str "destruct_bounds (3)")
+	      (destruct_bounds new_infos)
+	  ]
+	else
+	  tclIDTAC			       
+      ]    
+    with Not_found -> 
+      observe_tac (str "terminate_app_rec not found") (tclTHENS
+	(Proofview.V82.of_tactic (simplest_elim (mkApp(mkVar expr_info.ih,Array.of_list args))))
+	[		
+	  tclTHENLIST[
+	    Proofview.V82.of_tactic (intro_using rec_res_id);
+	    Proofview.V82.of_tactic intro;
+	    onNthHypId 1 
+	      (fun v_bound -> 
+		(onNthHypId 2 
+		   (fun v ->  
+		     let new_infos = { expr_info with 
+		       info = (mkVar v); 
+		       values_and_bounds = 
+			 (v,v_bound)::expr_info.values_and_bounds; 
+		       args_assoc=(args,mkVar v)::expr_info.args_assoc
+		     } in
+		     tclTHENLIST[
+		       continuation_tac new_infos;
+		       if expr_info.is_final && expr_info.is_main_branch 
+		       then
+			 tclTHENLIST[ 
+			   observe_tac (str "first split") 
+			     (Proofview.V82.of_tactic (split (ImplicitBindings [new_infos.info])));
+			   observe_tac (str "destruct_bounds (2)") 
+			     (destruct_bounds new_infos)
+			 ]
+		       else
+			 tclIDTAC			       
+		     ]    
+		   )
+		)
+	      )
+	  ];
+	  observe_tac (str "proving decreasing") (
+	    tclTHENS (* proof of args < formal args *)
+	      (Proofview.V82.of_tactic (apply (Lazy.force expr_info.acc_inv)))
+	      [ 
+		observe_tac (str "assumption") (Proofview.V82.of_tactic assumption);
+		tclTHENLIST
+		  [
+		    tclTRY(list_rewrite true 
+			     (List.map 
+				(fun e -> mkVar e,true) 
+				expr_info.eqs
+			     )
+		    );
+		    tclUSER expr_info.concl_tac true 
+		      (Some (
+		      expr_info.ih::expr_info.acc_id::
+			(fun (x,y) -> y) 
+			(List.split expr_info.values_and_bounds)
+		       )
+		      );
+		  ]
+	      ])
+	])
+  end
 
+let terminate_info = 
+  { message = "prove_terminate with term ";
+    letiN = terminate_letin;
+    lambdA = (fun _ _ _ _ -> assert false);
+    casE = terminate_case;
+    otherS = terminate_others;
+    apP = terminate_app;
+    app_reC = terminate_app_rec;
+  }
 
-let list_rewrite (rev:bool) (eqs: constr list) =
-  tclREPEAT
-    (List.fold_right
-       (fun eq i -> tclORELSE (rewriteLR eq) i)
-       (if rev then (List.rev eqs) else eqs) (tclFAIL 0 (mt())));;
-
-let base_leaf_terminate (func:global_reference) eqs expr =
-(*  let _ = msgnl (str "entering base_leaf") in *)
-  (fun g ->
-     let k',h =
-       match pf_get_new_ids [k_id;h_id] g with
-	   [k';h] -> k',h
-	 | _ -> assert false
-     in
-     tclTHENLIST
-     [observe_tac "first split" (split (ImplicitBindings [expr]));
-      observe_tac "second split"
-        (split (ImplicitBindings [delayed_force coq_O]));
-      observe_tac "intro k" (h_intro k');
-      observe_tac "case on k"
-        (tclTHENS (simplest_case (mkVar k'))
-        [(tclTHEN (h_intro h)
-          (tclTHEN (simplest_elim (mkApp (delayed_force gt_antirefl,
-					 [| delayed_force coq_O |])))
-            default_auto)); tclIDTAC ]);
-      intros;
-      simpl_iter onConcl;
-      unfold_constr func;
-      list_rewrite true eqs;
-      default_auto] g);;
-
-(* La fonction est donnee en premier argument a la
-   fonctionnelle suivie d'autres Lambdas et de Case ...
-   Pour recuperer la fonction f a partir de la
-   fonctionnelle *)
-
-let get_f foncl =
-  match (kind_of_term (def_of_const foncl)) with
-      Lambda (Name f, _, _) -> f
-    |_ -> error "la fonctionnelle est mal definie";;
-
-
-let rec compute_le_proofs = function
-    [] -> assumption
-  | a::tl ->
-      tclORELSE assumption
-	(tclTHENS
-	   (fun g ->
-	      let le_trans = delayed_force le_trans in
-	      let t_le_trans = compute_renamed_type g le_trans in
-	      let m_id =
-		let _,_,t = destProd t_le_trans in
-		let na,_,_ = destProd t in
-		Nameops.out_name na
-	      in
-	      apply_with_bindings
-		(le_trans,
-		 ExplicitBindings[dummy_loc,NamedHyp m_id,a])
-		g)
-	   [compute_le_proofs tl;
-            tclORELSE (apply (delayed_force le_n)) assumption])
-
-let make_lt_proof pmax le_proof =
-  tclTHENS
-    (fun g ->
-       let le_lt_trans = delayed_force le_lt_trans in
-       let t_le_lt_trans = compute_renamed_type g le_lt_trans in
-       let m_id =
-	 let _,_,t = destProd t_le_lt_trans in
-	 let na,_,_ = destProd t in
-	 Nameops.out_name na
-       in
-       apply_with_bindings
-	 (le_lt_trans,
-	  ExplicitBindings[dummy_loc,NamedHyp m_id, pmax]) g)
-    [observe_tac "compute_le_proofs" (compute_le_proofs le_proof);
-     tclTHENLIST[observe_tac "lt_S_n" (apply (delayed_force lt_S_n)); default_full_auto]];;
-
-let rec list_cond_rewrite k def pmax cond_eqs le_proofs =
-  match cond_eqs with
-    [] -> tclIDTAC
-  | eq::eqs ->
-      (fun g ->
-	 let t_eq = compute_renamed_type g (mkVar eq) in
-	 let k_id,def_id =
-	   let k_na,_,t = destProd t_eq in
-	   let _,_,t  = destProd t in
-	   let def_na,_,_ = destProd t in
-	   Nameops.out_name k_na,Nameops.out_name def_na
-	 in
-	 tclTHENS
-	   (general_rewrite_bindings false Termops.all_occurrences
-	      (* dep proofs also: *) true true
-	      (mkVar eq,
-	       ExplicitBindings[dummy_loc, NamedHyp k_id, mkVar k;
-				dummy_loc, NamedHyp def_id, mkVar def]) false)
-	   [list_cond_rewrite k def pmax eqs le_proofs;
-            observe_tac "make_lt_proof" (make_lt_proof pmax le_proofs)] g
-      )
+let prove_terminate = travel terminate_info
 
-let rec introduce_all_equalities func eqs values specs bound le_proofs
-    cond_eqs =
-  match specs with
-    [] ->
-      fun g ->
-	let ids = pf_ids_of_hyps g in
-	let s_max = mkApp(delayed_force coq_S, [|bound|]) in
-	let k = next_ident_away_in_goal k_id ids in
-        let ids = k::ids in
-	let h' = next_ident_away_in_goal (h'_id) ids in
-        let ids = h'::ids in
-	let def = next_ident_away_in_goal def_id ids in
-	tclTHENLIST
-	  [observe_tac "introduce_all_equalities_final split" (split (ImplicitBindings [s_max]));
-	   observe_tac "introduce_all_equalities_final intro k" (h_intro  k);
-	   tclTHENS
-	     (observe_tac "introduce_all_equalities_final case k" (simplest_case (mkVar k)))
-	     [
-	       tclTHENLIST[h_intro h';
-			   simplest_elim(mkApp(delayed_force lt_n_O,[|s_max|]));
-			   default_full_auto];
-	       tclIDTAC
-	     ];
-	   observe_tac "clearing k " (clear [k]);
-	   observe_tac "intros k h' def" (h_intros [k;h';def]);
-	   observe_tac "simple_iter" (simpl_iter onConcl);
-	   observe_tac "unfold functional"
-	     (unfold_in_concl[((true,[1]),evaluable_of_global_reference func)]);
-	   observe_tac "rewriting equations"
-	     (list_rewrite true eqs);
-           observe_tac ("cond rewrite "^(string_of_id k)) (list_cond_rewrite  k def bound cond_eqs le_proofs);
-	   observe_tac "refl equal" (apply (delayed_force refl_equal))] g
-  | spec1::specs ->
-      fun g ->
-	let ids = Termops.ids_of_named_context (pf_hyps g) in
-	let p = next_ident_away_in_goal p_id ids in
-        let ids = p::ids in
-	let pmax = next_ident_away_in_goal pmax_id ids in
-        let ids = pmax::ids in
-	let hle1 = next_ident_away_in_goal hle_id ids in
-        let ids = hle1::ids in
-	let hle2 = next_ident_away_in_goal  hle_id ids in
-	let ids = hle2::ids in
-	let heq = next_ident_away_in_goal heq_id ids in
-	tclTHENLIST
-	  [simplest_elim (mkVar spec1);
-	   list_rewrite true eqs;
-	   h_intros [p; heq];
-	   simplest_elim (mkApp(delayed_force max_constr, [| bound; mkVar p|]));
-	   h_intros [pmax; hle1; hle2];
-	   introduce_all_equalities func eqs values specs
-	     (mkVar pmax) ((mkVar pmax)::le_proofs)
-	     (heq::cond_eqs)] g;;
-
-let string_match s =
-  if String.length s < 3 then failwith "string_match";
-  try
-    for i = 0 to 3  do
-      if String.get s i <> String.get "Acc_" i then failwith "string_match"
-    done;
-  with Invalid_argument _ -> failwith "string_match"
-
-let retrieve_acc_var g =
-  (* Julien: I don't like this version .... *)
-  let hyps = pf_ids_of_hyps g  in
-  map_succeed
-    (fun id -> string_match (string_of_id id);id)
-    hyps
-
-let rec introduce_all_values concl_tac is_mes acc_inv func context_fn
-    eqs  hrec args values specs =
-    (match args with
-    [] ->
-      tclTHENLIST
-	[observe_tac "split" (split(ImplicitBindings
-		 [context_fn (List.map mkVar (List.rev values))]));
-	 observe_tac "introduce_all_equalities" (introduce_all_equalities func eqs
-	   (List.rev values) (List.rev specs) (delayed_force coq_O) [] [])]
-  | arg::args ->
-      (fun g ->
-	let ids = Termops.ids_of_named_context (pf_hyps g) in
-	let rec_res = next_ident_away_in_goal rec_res_id ids in
-        let ids = rec_res::ids in
-	let hspec = next_ident_away_in_goal hspec_id ids in
-	let tac =
-	  observe_tac "introduce_all_values" (
-	    introduce_all_values concl_tac is_mes acc_inv func context_fn eqs
-	      hrec args
-	      (rec_res::values)(hspec::specs)) in
-	(tclTHENS
-	   (observe_tac "elim h_rec"
-	      (simplest_elim (mkApp(mkVar hrec, Array.of_list arg)))
-	   )
-	   [tclTHENLIST [h_intros [rec_res; hspec];
-			 tac];
-	    (tclTHENS
-		 (observe_tac "acc_inv" (apply (Lazy.force acc_inv)))
-		 [(* tclTHEN (tclTRY(list_rewrite true eqs)) *)
-		    (observe_tac "h_assumption" h_assumption)
-		 ;
-		  tclTHENLIST
-		    [
-		      tclTRY(list_rewrite true eqs);
-		      observe_tac "user proof"
-			(fun g ->
-			   tclUSER
-			     concl_tac
-			     is_mes
-			     (Some (hrec::hspec::(retrieve_acc_var g)@specs))
-			     g
-			)
-		    ]
-		 ]
-	    )
-	   ]) g)
 
-    )
+(* Equation proof *)
 
+let equation_case next_step (ci,a,t,l) expr_info continuation_tac infos = 
+  terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos
 
-let rec_leaf_terminate nb_arg f_constr concl_tac is_mes acc_inv hrec (func:global_reference) eqs expr =
-  match find_call_occs nb_arg 0 f_constr expr with
-  | context_fn, args ->
-      observe_tac "introduce_all_values"
-	(introduce_all_values concl_tac is_mes acc_inv func context_fn eqs  hrec args  [] [])
+let rec prove_le g = 
+  let x,z = 
+    let _,args = decompose_app (pf_concl g) in 
+    (List.hd args,List.hd (List.tl args))
+  in 
+  tclFIRST[
+    Proofview.V82.of_tactic assumption;
+    Proofview.V82.of_tactic (apply (delayed_force le_n));
+    begin
+      try
+	let matching_fun = 
+	  pf_is_matching g
+	    (Pattern.PApp(Pattern.PRef (reference_of_constr (le ())),[|Pattern.PVar (destVar x);Pattern.PMeta None|])) in 
+	let (h,t) = List.find (fun (_,t) -> matching_fun t) (pf_hyps_types g)
+	in 
+	let y = 
+	  let _,args = decompose_app t in 
+	  List.hd (List.tl args)
+	in 
+	tclTHENLIST[
+	  Proofview.V82.of_tactic (apply(mkApp(le_trans (),[|x;y;z;mkVar h|])));
+	  observe_tac (str "prove_le (rec)") (prove_le)
+	] 
+      with Not_found -> tclFAIL 0 (mt())
+    end;
+  ]
+    g
 
-let proveterminate nb_arg rec_arg_id is_mes acc_inv (hrec:identifier)
-  (f_constr:constr) (func:global_reference) base_leaf rec_leaf =
-  let rec proveterminate (eqs:constr list) (expr:constr)  =
-    try
-      (*  let _ = msgnl (str "entering proveterminate") in *)
-      let v =
-        match (kind_of_term expr) with
-	  Case (ci, t, a, l) ->
-	  (match find_call_occs nb_arg 0 f_constr a with
-	    _,[] ->
-	    (fun g ->
-	      let destruct_tac, rev_to_thin_intro =
-                mkDestructEq rec_arg_id a g in
-		tclTHENS destruct_tac
-		  (list_map_i
-		    (fun i -> mk_intros_and_continue
-				(List.rev rev_to_thin_intro)
-				true
-				proveterminate
-				eqs
-				ci.ci_cstr_ndecls.(i))
-		    0 (Array.to_list l)) g)
-		  | _, _::_ ->
-		    (match find_call_occs  nb_arg 0 f_constr expr with
-	     	      _,[] -> observe_tac "base_leaf" (base_leaf func eqs expr)
-		    | _, _:: _ ->
-		      observe_tac "rec_leaf"
-		      (rec_leaf is_mes acc_inv hrec  func eqs expr)))
-	  | _ ->
-            (match find_call_occs  nb_arg 0 f_constr expr with
-	      _,[] ->
-	      (try observe_tac "base_leaf" (base_leaf func eqs expr)
-	       with reraise ->
-                 (msgerrnl (str "failure in base case");raise reraise ))
-	    | _, _::_ ->
-	      observe_tac "rec_leaf"
-	        (rec_leaf is_mes acc_inv hrec func eqs expr)) in
-      v
-    with reraise ->
+let rec make_rewrite_list expr_info max = function 
+  | [] -> tclIDTAC
+  | (_,p,hp)::l -> 
+    observe_tac (str "make_rewrite_list") (tclTHENS
+      (observe_tac (str "rewrite heq on " ++ pr_id p ) (
+	(fun g -> 
+	  let t_eq = compute_renamed_type g (mkVar hp) in
+	  let k,def =
+	    let k_na,_,t = destProd t_eq in
+	    let _,_,t  = destProd t in
+	    let def_na,_,_ = destProd t in
+	    Nameops.out_name k_na,Nameops.out_name def_na
+	  in
+	  Proofview.V82.of_tactic (general_rewrite_bindings false Locus.AllOccurrences
+	    true (* dep proofs also: *) true 
+	    (mkVar hp,
+	     ExplicitBindings[Loc.ghost,NamedHyp def,
+			      expr_info.f_constr;Loc.ghost,NamedHyp k,
+			      (f_S max)]) false) g) )
+      )
+      [make_rewrite_list expr_info max l;
+       tclTHENLIST[ (* x < S max proof *)
+	 Proofview.V82.of_tactic (apply (delayed_force le_lt_n_Sm));
+	 observe_tac (str "prove_le(2)") prove_le
+       ]
+      ] )
+
+let make_rewrite expr_info l hp max = 
+  tclTHENFIRST
+    (observe_tac (str "make_rewrite") (make_rewrite_list expr_info max l))
+    (observe_tac (str "make_rewrite") (tclTHENS
+       (fun g -> 
+	  let t_eq = compute_renamed_type g (mkVar hp) in
+	  let k,def =
+	    let k_na,_,t = destProd t_eq in
+	    let _,_,t  = destProd t in
+	    let def_na,_,_ = destProd t in
+	    Nameops.out_name k_na,Nameops.out_name def_na
+	  in
+	 observe_tac (str "general_rewrite_bindings")
+	   (Proofview.V82.of_tactic (general_rewrite_bindings false Locus.AllOccurrences
+	    true (* dep proofs also: *) true 
+	    (mkVar hp,
+	     ExplicitBindings[Loc.ghost,NamedHyp def,
+			      expr_info.f_constr;Loc.ghost,NamedHyp k,
+			      (f_S (f_S max))]) false)) g)
+       [observe_tac(str "make_rewrite finalize") (
+	 (* tclORELSE( h_reflexivity) *)
+	 (tclTHENLIST[
+	   simpl_iter Locusops.onConcl;
+	   observe_tac (str "unfold functional")
+	     (unfold_in_concl[(Locus.OnlyOccurrences [1],
+			       evaluable_of_global_reference expr_info.func)]);
+	   
+	   (list_rewrite true 
+	      (List.map (fun e -> mkVar e,true) expr_info.eqs));
+	   (observe_tac (str "h_reflexivity") (Proofview.V82.of_tactic intros_reflexivity))]))
+       ;
+	 tclTHENLIST[ (* x < S (S max) proof *)
+	 Proofview.V82.of_tactic (apply (delayed_force le_lt_SS));
+	 observe_tac (str "prove_le (3)") prove_le
+	 ]
+       ])  
+    )
+
+let rec compute_max rew_tac max l = 
+  match l with 
+    | [] -> rew_tac max
+    | (_,p,_)::l -> 
+      tclTHENLIST[
+	Proofview.V82.of_tactic (simplest_elim 
+	  (mkApp(delayed_force max_constr, [| max; mkVar p|])));
+	tclDO 3 (Proofview.V82.of_tactic intro);
+	onNLastHypsId 3 (fun lids -> 
+	  match lids with
+	    | [hle2;hle1;pmax] -> compute_max rew_tac (mkVar pmax) l 
+	    | _ -> assert false
+	)]
+
+let rec destruct_hex expr_info acc l = 
+  match l with 
+    | [] -> 
       begin
-        msgerrnl(str "failure in proveterminate");
-        raise reraise
+	match List.rev acc with 
+	  | [] -> tclIDTAC 
+	  | (_,p,hp)::tl  -> 
+	    observe_tac (str "compute max ") (compute_max (make_rewrite expr_info tl hp) (mkVar p) tl)
       end
-  in
-  proveterminate
+    | (v,hex)::l -> 
+      tclTHENLIST[
+	Proofview.V82.of_tactic (simplest_case (mkVar hex));
+	clear [hex];
+	tclDO 2 (Proofview.V82.of_tactic intro);
+	onNthHypId 1 (fun hp -> 
+	  onNthHypId 2 (fun p -> 
+	    observe_tac 
+	      (str "destruct_hex after " ++ pr_id hp ++ spc () ++ pr_id p)
+	      (destruct_hex expr_info ((v,p,hp)::acc) l)
+	  )
+	)
+      ]
+	
+let rec intros_values_eq expr_info acc = 
+  tclORELSE(
+    tclTHENLIST[
+      tclDO 2 (Proofview.V82.of_tactic intro);
+      onNthHypId 1 (fun hex -> 
+	(onNthHypId 2 (fun v -> intros_values_eq expr_info ((v,hex)::acc)))
+      )
+    ])
+    (tclCOMPLETE (
+      destruct_hex expr_info [] acc
+    ))
+
+let equation_others _ expr_info continuation_tac infos = 
+  if expr_info.is_final && expr_info.is_main_branch 
+  then 
+    tclTHEN 
+      (continuation_tac infos) 
+      (intros_values_eq expr_info [])
+  else continuation_tac infos
+
+let equation_app f_and_args expr_info continuation_tac infos = 
+    if expr_info.is_final && expr_info.is_main_branch 
+    then intros_values_eq expr_info []
+    else continuation_tac infos
+	    
+let equation_app_rec (f,args) expr_info continuation_tac info = 
+  begin
+    try
+      let v = List.assoc_f (List.equal Constr.equal) args expr_info.args_assoc in
+      let new_infos = {expr_info with info = v} in
+      observe_tac (str "app_rec found") (continuation_tac new_infos)
+    with Not_found ->
+      if expr_info.is_final && expr_info.is_main_branch 
+      then 
+	tclTHENLIST
+	  [ Proofview.V82.of_tactic (simplest_case (mkApp (expr_info.f_terminate,Array.of_list args)));
+	    continuation_tac {expr_info with args_assoc = (args,delayed_force coq_O)::expr_info.args_assoc};
+	    observe_tac (str "app_rec intros_values_eq") (intros_values_eq expr_info [])
+	  ]
+      else 
+	tclTHENLIST[
+  	  Proofview.V82.of_tactic (simplest_case (mkApp (expr_info.f_terminate,Array.of_list args)));
+	  observe_tac (str "app_rec not_found") (continuation_tac {expr_info with args_assoc = (args,delayed_force coq_O)::expr_info.args_assoc})
+	]
+  end
 
-let hyp_terminates nb_args func =
-  let a_arrow_b = arg_type (constr_of_global func) in
+let equation_info = 
+  {message = "prove_equation with term ";
+   letiN = (fun _ -> assert false);
+   lambdA = (fun _ _ _ _ -> assert false);
+   casE = equation_case;
+   otherS = equation_others;
+   apP = equation_app;
+   app_reC = equation_app_rec
+}
+    
+let prove_eq = travel equation_info
+
+(* wrappers *)
+(* [compute_terminate_type] computes the type of the Definition f_terminate from the type of f_F
+*)
+let compute_terminate_type nb_args func =
+  let _,a_arrow_b,_ = destLambda(def_of_const (constr_of_global func)) in
   let rev_args,b = decompose_prod_n nb_args a_arrow_b in
   let left =
     mkApp(delayed_force iter,
 	  Array.of_list
 	    (lift 5 a_arrow_b:: mkRel 3::
 	       constr_of_global func::mkRel 1::
-	       List.rev (list_map_i (fun i _ -> mkRel (6+i)) 0 rev_args)
+	       List.rev (List.map_i (fun i _ -> mkRel (6+i)) 0 rev_args)
 	    )
 	 )
   in
@@ -744,18 +1023,12 @@ let hyp_terminates nb_args func =
 		  delayed_force nat,
 		  (mkProd (Name k_id, delayed_force nat,
 			   mkArrow cond result))))|])in
-  let value = mkApp(delayed_force coq_sig,
+  let value = mkApp(constr_of_global (delayed_force coq_sig_ref),
 		    [|b;
 		      (mkLambda (Name v_id, b, nb_iter))|]) in
   compose_prod rev_args value
 
 
-
-let tclUSER_if_not_mes concl_tac is_mes names_to_suppress =
-  if is_mes
-  then tclCOMPLETE (h_simplest_apply (delayed_force well_founded_ltof))
-  else tclUSER concl_tac is_mes names_to_suppress
-
 let termination_proof_header is_mes input_type ids args_id relation
     rec_arg_num rec_arg_id tac wf_tac : tactic =
   begin
@@ -763,14 +1036,14 @@ let termination_proof_header is_mes input_type ids args_id relation
       let nargs = List.length args_id in
       let pre_rec_args =
 	List.rev_map
-	  mkVar (fst (list_chop (rec_arg_num - 1) args_id))
+	  mkVar (fst (List.chop (rec_arg_num - 1) args_id))
       in
       let relation = substl pre_rec_args relation in
       let input_type = substl pre_rec_args input_type in
-      let wf_thm = next_ident_away_in_goal (id_of_string ("wf_R")) ids in
+      let wf_thm = next_ident_away_in_goal (Id.of_string ("wf_R")) ids in
       let wf_rec_arg =
 	next_ident_away_in_goal
-	  (id_of_string ("Acc_"^(string_of_id rec_arg_id)))
+	  (Id.of_string ("Acc_"^(Id.to_string rec_arg_id)))
 	  (wf_thm::ids)
       in
       let hrec = next_ident_away_in_goal hrec_id
@@ -787,46 +1060,46 @@ let termination_proof_header is_mes input_type ids args_id relation
 	(h_intros args_id)
 	(tclTHENS
 	   (observe_tac
-	      "first assert"
-	      (assert_tac
+	      (str "first assert")
+	      (Proofview.V82.of_tactic (assert_before
 		 (Name wf_rec_arg)
 		 (mkApp (delayed_force acc_rel,
 			 [|input_type;relation;mkVar rec_arg_id|])
 		 )
-	      )
+	      ))
 	   )
 	   [
 	     (* accesibility proof *)
 	     tclTHENS
 	       (observe_tac
-		  "second assert"
-		  (assert_tac
+		  (str "second assert")
+		  (Proofview.V82.of_tactic (assert_before
 		     (Name wf_thm)
 		     (mkApp (delayed_force well_founded,[|input_type;relation|]))
-		  )
+		  ))
 	       )
 	       [
 		 (* interactive proof that the relation is well_founded *)
-		 observe_tac "wf_tac" (wf_tac is_mes (Some args_id));
+		 observe_tac (str "wf_tac") (wf_tac is_mes (Some args_id));
 		 (* this gives the accessibility argument *)
 		 observe_tac
-		   "apply wf_thm"
-		   (h_simplest_apply (mkApp(mkVar wf_thm,[|mkVar rec_arg_id|]))
+		   (str "apply wf_thm")
+		   (Proofview.V82.of_tactic (Simple.apply (mkApp(mkVar wf_thm,[|mkVar rec_arg_id|])))
 		   )
 	       ]
 	     ;
 	     (* rest of the proof *)
-	     tclTHENSEQ
-	       [observe_tac "generalize"
+	     tclTHENLIST
+	       [observe_tac (str "generalize")
 		  (onNLastHypsId (nargs+1)
 		     (tclMAP (fun id ->
-			tclTHEN (h_generalize [mkVar id]) (h_clear false [id]))
+			tclTHEN (Tactics.Simple.generalize [mkVar id]) (clear [id]))
 		     ))
 	       ;
-		observe_tac "h_fix" (h_fix (Some hrec) (nargs+1));
+		observe_tac (str "fix") (fix (Some hrec) (nargs+1));
 		h_intros args_id;
-		h_intro wf_rec_arg;
-		observe_tac "tac" (tac wf_rec_arg hrec acc_inv)
+		Proofview.V82.of_tactic (Simple.intro wf_rec_arg);
+		observe_tac (str "tac") (tac wf_rec_arg hrec wf_rec_arg acc_inv)
 	       ]
 	   ]
 	) g
@@ -838,10 +1111,8 @@ let rec instantiate_lambda t l =
   match l with
   | [] -> t
   | a::l ->
-      let (bound_name, _, body) = destLambda t in
+      let (_, _, body) = destLambda t in
       instantiate_lambda (subst1 a body) l
-;;
-
 
 let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_arg_num  : tactic =
   begin
@@ -852,7 +1123,7 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a
       let f_id =
 	match f_name with
 	  | Name f_id -> next_ident_away_in_goal f_id ids
-	  | Anonymous -> anomaly "Anonymous function"
+	  | Anonymous -> anomaly (Pp.str "Anonymous function")
       in
       let n_names_types,_ = decompose_lam_n nb_args body1 in
       let n_ids,ids =
@@ -862,7 +1133,7 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a
 	       | Name id ->
 		   let n_id = next_ident_away_in_goal id ids in
 		   n_id::n_ids,n_id::ids
-	       | _ -> anomaly "anonymous argument"
+	       | _ -> anomaly (Pp.str "anonymous argument")
 	  )
 	  ([],(f_id::ids))
 	  n_names_types
@@ -877,20 +1148,28 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a
 	relation
 	rec_arg_num
 	rec_arg_id
-	(fun rec_arg_id hrec acc_inv g ->
-           (proveterminate
-	      nb_args
-	      [rec_arg_id]
-	      is_mes
-	      acc_inv
-	      hrec
-	      (mkVar f_id)
-	      func
-	      base_leaf_terminate
-	      (rec_leaf_terminate nb_args (mkVar f_id) concl_tac)
-	      []
-	      expr
-	   )
+	(fun rec_arg_id hrec acc_id acc_inv g -> 	      
+	  (prove_terminate (fun infos -> tclIDTAC) 
+	     { is_main_branch = true; (* we are on the main branche (i.e. still on a match ... with .... end *)
+	       is_final = true;      (* and on leaf (more or less) *)
+	       f_terminate = delayed_force coq_O;
+	       nb_arg = nb_args;
+	       concl_tac = concl_tac;
+	       rec_arg_id = rec_arg_id;
+	       is_mes = is_mes;
+	       ih = hrec;
+	       f_id = f_id;
+	       f_constr = mkVar f_id;
+	       func = func;
+	       info = expr;
+	       acc_inv = acc_inv;
+	       acc_id = acc_id;
+	       values_and_bounds = [];
+	       eqs = [];
+	       forbidden_ids = [];
+	       args_assoc = []
+	     }
+	  ) 
 	     g
 	)
 	(tclUSER_if_not_mes concl_tac)
@@ -900,7 +1179,7 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a
 let get_current_subgoals_types () =
   let p = Proof_global.give_me_the_proof () in
   let { Evd.it=sgs ; sigma=sigma } = Proof.V82.subgoals p in
-  List.map (Goal.V82.abstract_type sigma) sgs
+    sigma, List.map (Goal.V82.abstract_type sigma) sgs
 
 let build_and_l l =
   let and_constr =  Coqlib.build_coq_and () in
@@ -913,7 +1192,8 @@ let build_and_l l =
       | App(_,_) -> 
 	let (f,_) = decompose_app t in 
 	eq_constr f (well_founded ())
-      | _ -> false
+      | _ -> 
+	false
   in
   let compare t1 t2 = 
     let b1,b2= is_well_founded t1,is_well_founded t2 in 
@@ -928,7 +1208,7 @@ let build_and_l l =
 	let c,tac,nb = f pl in
 	mk_and p1 c,
 	tclTHENS
-	  (apply (constr_of_global conj_constr))
+	  (Proofview.V82.of_tactic (apply (constr_of_global conj_constr)))
 	  [tclIDTAC;
 	   tac
 	  ],nb+1
@@ -936,12 +1216,12 @@ let build_and_l l =
 
 
 let is_rec_res id =
-  let rec_res_name = string_of_id rec_res_id   in
-  let id_name = string_of_id id in
+  let rec_res_name = Id.to_string rec_res_id   in
+  let id_name = Id.to_string id in
   try
-    String.sub id_name 0 (String.length rec_res_name) = rec_res_name
-  with e when Errors.noncritical e -> false
-
+    String.equal (String.sub id_name 0 (String.length rec_res_name)) rec_res_name
+  with Invalid_argument _ -> false
+ 
 let clear_goals =
   let rec clear_goal t =
     match kind_of_term t with
@@ -957,12 +1237,12 @@ let clear_goals =
 
 
 let build_new_goal_type () =
-  let sub_gls_types = get_current_subgoals_types () in
+  let sigma, sub_gls_types = get_current_subgoals_types () in
   (* Pp.msgnl (str "sub_gls_types1 := " ++ Util.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *)
   let sub_gls_types = clear_goals sub_gls_types in
-  (* Pp.msgnl (str "sub_gls_types2 := " ++ Util.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *)
+  (* Pp.msgnl (str "sub_gls_types2 := " ++ Pp.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *)
   let res = build_and_l sub_gls_types in
-  res
+    sigma, res
 
 let is_opaque_constant c =
   let cb = Global.lookup_constant c in
@@ -971,48 +1251,47 @@ let is_opaque_constant c =
     | Declarations.Undef _ -> true
     | Declarations.Def _ -> false
 
-let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal)   =
+let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal)   =
   (* Pp.msgnl (str "gls_type := " ++ Printer.pr_lconstr gls_type); *)
   let current_proof_name = get_current_proof_name () in
   let name = match goal_name with
     | Some s -> s
     | None   ->
-	try (add_suffix current_proof_name "_subproof")
+	try add_suffix current_proof_name "_subproof"
 	with e when Errors.noncritical e ->
-          anomaly "open_new_goal with an unamed theorem"
+          anomaly (Pp.str "open_new_goal with an unamed theorem")
   in
-  let sign = initialize_named_context_for_proof () in
   let na = next_global_ident_away name [] in
   if Termops.occur_existential gls_type then
-    Util.error "\"abstract\" cannot handle existentials";
+    Errors.error "\"abstract\" cannot handle existentials";
   let hook _ _ =
     let opacity =
-      let na_ref = Libnames.Ident (dummy_loc,na) in
-      let na_global = Nametab.global na_ref in
+      let na_ref = Libnames.Ident (Loc.ghost,na) in
+      let na_global = Smartlocate.global_with_alias na_ref in
       match na_global with
 	  ConstRef c -> is_opaque_constant c
-	| _ -> anomaly "equation_lemma: not a constant"
+	| _ -> anomaly ~label:"equation_lemma" (Pp.str "not a constant")
     in
-    let lemma = mkConst (Lib.make_con na) in
+    let lemma = mkConst (Names.Constant.make1 (Lib.make_kn na)) in
     ref_ := Some lemma ;
     let lid = ref [] in
     let h_num = ref (-1) in
-    Flags.silently Vernacentries.interp (Vernacexpr.VernacAbort None);
-    build_proof
+    Proof_global.discard_all ();
+    build_proof Evd.empty
       (  fun gls ->
 	   let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in
-	   tclTHENSEQ
+	   tclTHENLIST
 	     [
-	       h_generalize [lemma];
-	       h_intro hid;
+	       Simple.generalize [lemma];
+	       Proofview.V82.of_tactic (Simple.intro hid);
 	       (fun g ->
 		  let ids = pf_ids_of_hyps g in
 		  tclTHEN
-		    (Elim.h_decompose_and (mkVar hid))
+		    (Proofview.V82.of_tactic (Elim.h_decompose_and (mkVar hid)))
 		    (fun g ->
 		       let ids' = pf_ids_of_hyps g in
-		       lid := List.rev (list_subtract ids' ids);
-		       if !lid = [] then lid := [hid];
+		       lid := List.rev (List.subtract Id.equal ids' ids);
+		       if List.is_empty !lid then lid := [hid];
 		       tclIDTAC g
 		    )
 		    g
@@ -1021,40 +1300,39 @@ let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_
       (fun g ->
 	 match kind_of_term (pf_concl g) with
 	   | App(f,_) when eq_constr f (well_founded ()) ->
-	       Auto.h_auto None [] (Some [])  g
+	       Proofview.V82.of_tactic (Auto.h_auto None [] (Some []))  g
 	   | _ ->
 	       incr h_num;
-	       (observe_tac "finishing using"
+	       (observe_tac (str "finishing using")
 		  (
 		    tclCOMPLETE(
 		      tclFIRST[
 			tclTHEN
-			  (eapply_with_bindings (mkVar (List.nth !lid !h_num), NoBindings))
+			  (Proofview.V82.of_tactic (eapply_with_bindings (mkVar (List.nth !lid !h_num), NoBindings)))
 			  e_assumption;
 		      Eauto.eauto_with_bases
 			(true,5)
-			[Evd.empty,delayed_force refl_equal]
-			[Auto.Hint_db.empty empty_transparent_state false]
+			[Evd.empty,Lazy.force refl_equal]
+			[Hints.Hint_db.empty empty_transparent_state false]
 		      ]
 		    )
 		  )
 	       )
       		 g)
 ;
-    Lemmas.save_named opacity;
+    Lemmas.save_proof (Vernacexpr.Proved(opacity,None));
   in
-  start_proof
+  Lemmas.start_proof
     na
-    (Decl_kinds.Global, Decl_kinds.Proof Decl_kinds.Lemma)
-    sign
-    gls_type
-    hook ;
+    (Decl_kinds.Global, false (* FIXME *), Decl_kinds.Proof Decl_kinds.Lemma)
+    sigma gls_type
+    (Lemmas.mk_hook hook);
   if Indfun_common.is_strict_tcc  ()
   then
-    by (tclIDTAC)
+    ignore (by (Proofview.V82.tactic (tclIDTAC)))
   else 
     begin
-      by (
+      ignore (by (Proofview.V82.tactic begin
 	fun g ->
 	  tclTHEN
 	    (decompose_and_tac)
@@ -1062,23 +1340,21 @@ let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_
 	       (tclFIRST
 	 	  (List.map
 	 	     (fun c ->
-	 		tclTHENSEQ
+	 		Proofview.V82.of_tactic (Tacticals.New.tclTHENLIST
 	 		  [intros;
-	 		   h_simplest_apply (interp_constr Evd.empty (Global.env()) c);
-	 		   tclCOMPLETE Auto.default_auto
-	 		  ]
+	 		   Simple.apply (fst (interp_constr (Global.env()) Evd.empty c)) (*FIXME*);
+	 		   Tacticals.New.tclCOMPLETE Auto.default_auto
+	 		  ])
 	 	     )
 	 	     using_lemmas)
 	       ) tclIDTAC)
-	    g)
+	    g end))
     end;
   try
-    by tclIDTAC; (* raises UserError _ if the proof is complete *)
-    if Flags.is_verbose () then (pp (Printer.pr_open_subgoals()))
+    ignore (by (Proofview.V82.tactic tclIDTAC)); (* raises UserError _ if the proof is complete *)
   with UserError _ ->
     defined ()
 
-;;
 
 
 let com_terminate
@@ -1090,25 +1366,28 @@ let com_terminate
     relation
     rec_arg_num
     thm_name using_lemmas
-    nb_args
+    nb_args ctx
     hook =
-  let start_proof (tac_start:tactic) (tac_end:tactic) =
+  let start_proof ctx (tac_start:tactic) (tac_end:tactic) =
     let (evmap, env) = Lemmas.get_current_context() in
-    start_proof thm_name
-      (Global, Proof Lemma) (Environ.named_context_val env)
-      (hyp_terminates nb_args fonctional_ref) hook;
+    Lemmas.start_proof thm_name
+      (Global, false (* FIXME *), Proof Lemma) ~sign:(Environ.named_context_val env)
+      ctx (compute_terminate_type nb_args fonctional_ref) hook;
 
-    by (observe_tac "starting_tac" tac_start);
-    by (observe_tac "whole_start" (whole_start tac_end nb_args is_mes fonctional_ref
-				   input_type relation rec_arg_num ))
+    ignore (by (Proofview.V82.tactic (observe_tac (str "starting_tac") tac_start)));
+    ignore (by (Proofview.V82.tactic (observe_tac (str "whole_start") (whole_start tac_end nb_args is_mes fonctional_ref
+    				   input_type relation rec_arg_num ))))
   in
-  start_proof tclIDTAC tclIDTAC;
+  start_proof ctx tclIDTAC tclIDTAC;
   try
-    let new_goal_type = build_new_goal_type () in
-    open_new_goal start_proof using_lemmas tcc_lemma_ref
+    let sigma, new_goal_type = build_new_goal_type () in
+    let sigma =
+      Evd.from_env ~ctx:(Evd.evar_universe_context sigma) Environ.empty_env
+    in
+    open_new_goal start_proof sigma
+      using_lemmas tcc_lemma_ref
       (Some tcc_lemma_name)
       (new_goal_type);
-
   with Failure "empty list of subgoals!" ->
     (* a non recursive function declared with measure ! *)
     defined ()
@@ -1116,301 +1395,87 @@ let com_terminate
 
 
 
-let ind_of_ref = function
-  | IndRef (ind,i) -> (ind,i)
-  | _ -> anomaly "IndRef expected"
-
-let (value_f:constr list -> global_reference -> constr) =
-  fun al fterm ->
-    let d0 = dummy_loc in
-    let rev_x_id_l =
-      (
-	List.fold_left
-	  (fun x_id_l _ ->
-	     let x_id = next_ident_away_in_goal x_id x_id_l in
-	     x_id::x_id_l
-	  )
-	  []
-	  al
-      )
-    in
-    let context = List.map
-      (fun (x, c) -> Name x, None, c) (List.combine rev_x_id_l (List.rev al))
-    in
-    let env = Environ.push_rel_context context (Global.env ()) in
-    let glob_body =
-      GCases
-	(d0,RegularStyle,None,
-	 [GApp(d0, GRef(d0,fterm), List.rev_map (fun x_id -> GVar(d0, x_id)) rev_x_id_l),
-	  (Anonymous,None)],
-	 [d0, [v_id], [PatCstr(d0,(ind_of_ref
-				     (delayed_force coq_sig_ref),1),
-			       [PatVar(d0, Name v_id);
-				PatVar(d0, Anonymous)],
-			       Anonymous)],
-	  GVar(d0,v_id)])
-    in
-    let body = understand Evd.empty env glob_body in
-    it_mkLambda_or_LetIn body context
-
-let (declare_fun : identifier -> logical_kind -> constr -> global_reference) =
-  fun f_id kind value ->
-    let ce = {const_entry_body = value;
-              const_entry_secctx = None;
-	      const_entry_type = None;
-	      const_entry_opaque = false } in
-      ConstRef(declare_constant f_id (DefinitionEntry ce, kind));;
-
-let (declare_f : identifier -> logical_kind -> constr list -> global_reference -> global_reference) =
-  fun f_id kind input_type fterm_ref ->
-    declare_fun f_id kind (value_f input_type fterm_ref);;
-
-let rec n_x_id ids n =
-  if n = 0 then []
-  else let x = next_ident_away_in_goal x_id ids in
-          x::n_x_id (x::ids) (n-1);;
 
 let start_equation (f:global_reference) (term_f:global_reference)
-  (cont_tactic:identifier list -> tactic) g =
+  (cont_tactic:Id.t list -> tactic) g =
   let ids = pf_ids_of_hyps g in
   let terminate_constr = constr_of_global term_f in
-  let nargs = nb_prod (type_of_const terminate_constr) in
+  let nargs = nb_prod (fst (type_of_const terminate_constr)) (*FIXME*) in
   let x = n_x_id ids nargs in
   tclTHENLIST [
     h_intros x;
-    unfold_in_concl [(Termops.all_occurrences, evaluable_of_global_reference f)];
-    observe_tac "simplest_case"
-      (simplest_case (mkApp (terminate_constr,
-                             Array.of_list (List.map mkVar x))));
-    observe_tac "prove_eq" (cont_tactic x)] g;;
-
-let base_leaf_eq func eqs f_id g =
-  let ids = pf_ids_of_hyps g in
-  let k = next_ident_away_in_goal k_id ids in
-  let p = next_ident_away_in_goal p_id (k::ids) in
-  let v = next_ident_away_in_goal v_id (p::k::ids) in
-  let heq = next_ident_away_in_goal heq_id (v::p::k::ids) in
-  let heq1 = next_ident_away_in_goal heq_id (heq::v::p::k::ids) in
-  let hex = next_ident_away_in_goal hex_id (heq1::heq::v::p::k::ids) in
-    tclTHENLIST [
-      h_intros [v; hex];
-      simplest_elim (mkVar hex);
-      h_intros [p;heq1];
-      tclTRY
-	(rewriteRL
-	   (mkApp(mkVar heq1,
-		  [|mkApp (delayed_force coq_S, [|mkVar p|]);
-		    mkApp(delayed_force lt_n_Sn, [|mkVar p|]); f_id|])));
-      simpl_iter onConcl;
-      tclTRY (unfold_in_concl [((true,[1]), evaluable_of_global_reference func)]);
-      observe_tac "list_revrite" (list_rewrite true eqs);
-      apply (delayed_force refl_equal)] g;;
-
-let f_S t = mkApp(delayed_force coq_S, [|t|]);;
+    unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference f)];
+    observe_tac (str "simplest_case")
+      (Proofview.V82.of_tactic (simplest_case (mkApp (terminate_constr,
+                             Array.of_list (List.map mkVar x)))));
+    observe_tac (str "prove_eq") (cont_tactic x)] g;;
 
-
-let rec introduce_all_values_eq cont_tac functional termine
-    f p heq1 pmax bounds le_proofs eqs ids =
-  function
-      [] ->
-       let heq2 = next_ident_away_in_goal heq_id ids in
-	tclTHENLIST
-	  [pose_proof (Name heq2)
-             (mkApp(mkVar heq1, [|f_S(f_S(mkVar pmax))|]));
-           simpl_iter (onHyp heq2);
-           unfold_in_hyp [((true,[1]), evaluable_of_global_reference
-                             (global_of_constr functional))]
-             (heq2, Termops.InHyp);
-           tclTHENS
-	     (fun gls ->
-		let t_eq = compute_renamed_type gls (mkVar heq2) in
-		let def_id =
-		  let _,_,t  = destProd t_eq in let def_na,_,_ = destProd t in
-		  Nameops.out_name def_na
-		in
-		observe_tac "rewrite heq" (general_rewrite_bindings false Termops.all_occurrences
-		true (* dep proofs also: *) true (mkVar heq2,
-		 ExplicitBindings[dummy_loc,NamedHyp def_id,
-				  f]) false) gls)
-	     [tclTHENLIST
-		[observe_tac "list_rewrite" (list_rewrite true eqs);
-                 cont_tac pmax le_proofs];
-	      tclTHENLIST[apply (delayed_force le_lt_SS);
-			compute_le_proofs le_proofs]]]
-    | arg::args ->
-	let v' = next_ident_away_in_goal v_id ids in
-        let ids = v'::ids in
-	let hex' = next_ident_away_in_goal hex_id ids in
-        let ids = hex'::ids in
-	let p' = next_ident_away_in_goal p_id ids in
-        let ids = p'::ids in
-	let new_pmax = next_ident_away_in_goal pmax_id ids in
-        let ids = pmax::ids in
-	let hle1 = next_ident_away_in_goal hle_id ids in
-        let ids = hle1::ids in
-	let hle2 = next_ident_away_in_goal hle_id ids in
-        let ids = hle2::ids in
-	let heq = next_ident_away_in_goal heq_id ids in
-        let ids = heq::ids in
-	let heq2 = next_ident_away_in_goal heq_id ids in
-        let ids = heq2::ids in
-	tclTHENLIST
-	  [mkCaseEq(mkApp(termine, Array.of_list arg));
-	   h_intros [v'; hex'];
-	   simplest_elim(mkVar hex');
-	   h_intros [p'];
-	   simplest_elim(mkApp(delayed_force max_constr, [|mkVar pmax;
-							mkVar p'|]));
-	   h_intros [new_pmax;hle1;hle2];
-           introduce_all_values_eq
-              (fun pmax' le_proofs'->
-		tclTHENLIST
-		  [cont_tac pmax' le_proofs';
-		   h_intros [heq;heq2];
-		   observe_tac ("rewriteRL " ^ (string_of_id heq2))
-                     (tclTRY (rewriteLR (mkVar heq2)));
-		   tclTRY (tclTHENS
-		     ( fun g ->
-			 let t_eq = compute_renamed_type g (mkVar heq) in
-			 let k_id,def_id =
-			   let k_na,_,t = destProd t_eq in
-			   let _,_,t  = destProd t in
-			   let def_na,_,_ = destProd t in
-			   Nameops.out_name k_na,Nameops.out_name def_na
-			 in
-			 let c_b = (mkVar heq,
-			    ExplicitBindings
-			      [dummy_loc, NamedHyp k_id,
-			       f_S(mkVar pmax');
-			       dummy_loc, NamedHyp def_id, f])
-			 in
-			   observe_tac "general_rewrite_bindings" ( (general_rewrite_bindings false Termops.all_occurrences true (* dep proofs also: *) true
-							       c_b false))
-			     g
-		     )
-		     [tclIDTAC;
-		      tclTHENLIST
-			[apply (delayed_force le_lt_n_Sm);
-			 compute_le_proofs le_proofs']])])
-	     functional termine f p heq1 new_pmax
-	     (p'::bounds)((mkVar pmax)::le_proofs) eqs
-             (heq2::heq::hle2::hle1::new_pmax::p'::hex'::v'::ids) args]
-
-
-let rec_leaf_eq termine f ids functional eqs expr fn args =
-  let p = next_ident_away_in_goal p_id ids in
-  let ids = p::ids in
-  let v = next_ident_away_in_goal v_id ids in
-  let ids = v::ids in
-  let hex = next_ident_away_in_goal hex_id ids in
-  let ids = hex::ids in
-  let heq1 = next_ident_away_in_goal heq_id ids in
-  let ids = heq1::ids in
-  let hle1 = next_ident_away_in_goal hle_id ids in
-  let ids = hle1::ids in
-    tclTHENLIST
-      [observe_tac "intros v hex" (h_intros [v;hex]);
-       simplest_elim (mkVar hex);
-       h_intros [p;heq1];
-       h_generalize [mkApp(delayed_force le_n,[|mkVar p|])];
-       h_intros [hle1];
-       observe_tac "introduce_all_values_eq" (introduce_all_values_eq
-	 (fun _ _ -> tclIDTAC)
-	 functional termine f p heq1 p [] [] eqs ids args);
-       observe_tac "failing here" (apply (delayed_force refl_equal))]
-
-let rec prove_eq nb_arg  (termine:constr) (f:constr)(functional:global_reference)
-    (eqs:constr list) (expr:constr) =
-(*   tclTRY *)
-  observe_tac "prove_eq"  (match kind_of_term expr with
-     Case(ci,t,a,l) ->
-     (match find_call_occs nb_arg 0 f a with
-	_,[] ->
-	(fun g ->
-	  let destruct_tac,rev_to_thin_intro = mkDestructEq [] a g in
-	  tclTHENS
-            destruct_tac
-	    (list_map_i
-	       (fun i -> mk_intros_and_continue
-                          (List.rev rev_to_thin_intro) true
-			  (prove_eq nb_arg termine f functional)
-			  eqs ci.ci_cstr_ndecls.(i))
-	       0 (Array.to_list l)) g)
-	   | _,_::_ ->
-	      (match find_call_occs nb_arg 0 f expr with
-		_,[] -> observe_tac "base_leaf_eq(1)" (base_leaf_eq functional eqs f)
-	      | fn,args ->
-	        fun g ->
-		  let ids = Termops.ids_of_named_context (pf_hyps g) in
-	          observe_tac "rec_leaf_eq" (rec_leaf_eq termine f ids
-		    (constr_of_global functional)
-		    eqs expr fn args) g))
-       | _ ->
-	   (match find_call_occs nb_arg 0 f expr with
-		_,[] -> observe_tac "base_leaf_eq(2)" ( base_leaf_eq functional eqs f)
-	      | fn,args ->
-		  fun g ->
-		    let ids = Termops.ids_of_named_context (pf_hyps g) in
-		    observe_tac "rec_leaf_eq" (rec_leaf_eq
-		      termine f ids (constr_of_global functional)
-		      eqs expr fn args) g));;
-
-let (com_eqn : int -> identifier ->
+let (com_eqn : int -> Id.t ->
        global_reference -> global_reference -> global_reference
 	 -> constr -> unit) =
   fun nb_arg eq_name functional_ref f_ref terminate_ref equation_lemma_type ->
     let opacity =
       match terminate_ref with
 	| ConstRef c -> is_opaque_constant c
-	| _ -> anomaly "terminate_lemma: not a constant"
+	| _ -> anomaly ~label:"terminate_lemma" (Pp.str "not a constant")
     in
     let (evmap, env) = Lemmas.get_current_context() in
-    let f_constr = (constr_of_global f_ref) in
+    let evmap =
+      Evd.from_env ~ctx:(Evd.evar_universe_context evmap) Environ.empty_env
+    in
+    let f_constr = constr_of_global f_ref in
     let equation_lemma_type = subst1 f_constr equation_lemma_type in
-    (start_proof eq_name (Global, Proof Lemma)
-       (Environ.named_context_val env) equation_lemma_type (fun _ _ -> ());
-     by
-       (start_equation f_ref terminate_ref
+    (Lemmas.start_proof eq_name (Global, false, Proof Lemma)
+       ~sign:(Environ.named_context_val env)
+       evmap
+       equation_lemma_type
+       (Lemmas.mk_hook (fun _ _ -> ()));
+     ignore (by
+       (Proofview.V82.tactic (start_equation f_ref terminate_ref
 	  (fun  x ->
-	     prove_eq nb_arg
-	       (constr_of_global terminate_ref)
-	       f_constr
-	       functional_ref
-	       []
-	       (instantiate_lambda
-	       	  (def_of_const (constr_of_global functional_ref))
-	       	  (f_constr::List.map mkVar x)
-	       )
+	     prove_eq (fun _ -> tclIDTAC)
+	       {nb_arg=nb_arg;
+		f_terminate = constr_of_global terminate_ref; 
+	        f_constr = f_constr; 
+		concl_tac = tclIDTAC;
+		func=functional_ref;
+		info=(instantiate_lambda
+	       		(def_of_const (constr_of_global functional_ref))
+	       		(f_constr::List.map mkVar x)
+		);
+		is_main_branch = true;
+		is_final = true;
+		values_and_bounds = [];
+		eqs = [];
+		forbidden_ids = [];
+		acc_inv = lazy (assert false);
+		acc_id = Id.of_string "____";
+		args_assoc = [];
+		f_id = Id.of_string "______";
+		rec_arg_id = Id.of_string "______";
+		is_mes = false;
+		ih = Id.of_string "______";
+	       }
 	  )
-       );
-(*      (try Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowProof) with _ -> ()); *)
+       ))); 
+     (* (try Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowProof) with _ -> ()); *)
 (*      Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowScript); *)
-     Flags.silently (fun () -> Lemmas.save_named opacity) () ;
+     Flags.silently (fun () -> Lemmas.save_proof (Vernacexpr.Proved(opacity,None))) () ; 
 (*      Pp.msgnl (str "eqn finished"); *)
-
     );;
 
-let nf_zeta env =
-  Reductionops.clos_norm_flags  (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA])
-    env
-    Evd.empty
-
-let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta  *)
-  let clos_norm_flags flgs env sigma t =
-    Closure.norm_val (Closure.create_clos_infos flgs env) (Closure.inject (Reductionops.nf_evar sigma t)) in
-  clos_norm_flags Closure.betaiotazeta  Environ.empty_env Evd.empty
-
 
 let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num eq
     generate_induction_principle using_lemmas : unit =
-  let previous_label = Lib.current_command_label () in
-  let function_type = interp_constr Evd.empty (Global.env()) type_of_f in
-  let env = push_named (function_name,None,function_type) (Global.env()) in
+  let env = Global.env() in
+  let evd = ref (Evd.from_env env) in
+  let function_type = interp_type_evars env evd type_of_f in
+  let env = push_named (function_name,None,function_type) env in
   (* Pp.msgnl (str "function type := " ++ Printer.pr_lconstr function_type);  *)
-  let equation_lemma_type = 
-    nf_betaiotazeta
-      (interp_gen (OfType None) Evd.empty env ~impls:rec_impls eq) 
-  in
+  let ty = interp_type_evars env evd ~impls:rec_impls eq in
+  let evm, nf = Evarutil.nf_evars_and_universes !evd in
+  let equation_lemma_type = nf_betaiotazeta (nf ty) in
+  let function_type = nf function_type in
  (* Pp.msgnl (str "lemma type := " ++ Printer.pr_lconstr equation_lemma_type ++ fnl ()); *)
   let res_vars,eq' = decompose_prod equation_lemma_type in
   let env_eq' = Environ.push_rel_context (List.map (fun (x,y) -> (x,None,y)) res_vars) env in
@@ -1430,35 +1495,35 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num
   let equation_id = add_suffix function_name "_equation" in
   let functional_id =  add_suffix function_name "_F" in
   let term_id = add_suffix function_name "_terminate" in
-  let functional_ref = declare_fun functional_id (IsDefinition Decl_kinds.Definition) res in
+  let functional_ref = declare_fun functional_id (IsDefinition Decl_kinds.Definition) ~ctx:(Evd.universe_context evm) res in
   let env_with_pre_rec_args = push_rel_context(List.map (function (x,t) -> (x,None,t)) pre_rec_args) env in  
   let relation =
-    interp_constr
-      Evd.empty
+    fst (*FIXME*)(interp_constr
       env_with_pre_rec_args
-      r
+      Evd.empty
+      r)
   in
   let tcc_lemma_name = add_suffix function_name "_tcc" in
   let tcc_lemma_constr = ref None in
   (* let _ = Pp.msgnl (str "relation := " ++ Printer.pr_lconstr_env env_with_pre_rec_args relation) in *)
-  let hook _ _ =
+  let hook _ _ = 
     let term_ref = Nametab.locate (qualid_of_ident term_id) in
     let f_ref = declare_f function_name (IsProof Lemma) arg_types term_ref in
-    let _ = Table.extraction_inline true [Ident (dummy_loc,term_id)] in 
-(*     message "start second proof"; *)
-    let stop = ref false in
-    begin
-      try com_eqn (List.length res_vars) equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type)
+    let _ = Table.extraction_inline true [Ident (Loc.ghost,term_id)] in 
+    (*     message "start second proof"; *)
+    let stop = 
+      try com_eqn (List.length res_vars) equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type);
+	  false
       with e when Errors.noncritical e ->
 	begin
-	  if Tacinterp.get_debug () <> Tactic_debug.DebugOff
-	  then pperrnl (str "Cannot create equation Lemma " ++ Errors.print e)
-	  else anomaly "Cannot create equation Lemma"
+	  if do_observe ()
+	  then msg_debug (str "Cannot create equation Lemma " ++ Errors.print e)
+	  else anomaly (Pp.str "Cannot create equation Lemma")
 	  ;
-	  stop := true;
+	  true
 	end
-    end;
-    if not !stop
+    in
+    if not stop
     then
       let eq_ref = Nametab.locate (qualid_of_ident equation_id ) in
       let f_ref = destConst (constr_of_global f_ref)
@@ -1471,9 +1536,9 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num
 			 spc () ++ str"is defined" )++ fnl () ++
 		    h 1 (Ppconstr.pr_id equation_id ++
 			   spc () ++ str"is defined" )
-		 )
+      )
   in
-  try
+  States.with_state_protection_on_exception (fun () ->
     com_terminate
       tcc_lemma_name
       tcc_lemma_constr
@@ -1483,11 +1548,5 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num
       term_id
       using_lemmas
       (List.length res_vars)
-      hook
-  with reraise ->
-    begin
-      (try ignore (Backtrack.backto previous_label)
-       with e when Errors.noncritical e -> ());
-      (*       anomaly "Cannot create termination Lemma" *)
-      raise reraise
-    end
+      evm (Lemmas.mk_hook hook))
+    ()
diff --git a/plugins/funind/recdef.mli b/plugins/funind/recdef.mli
new file mode 100644
index 00000000..f60eedbe
--- /dev/null
+++ b/plugins/funind/recdef.mli
@@ -0,0 +1,20 @@
+
+
+(* val evaluable_of_global_reference : Libnames.global_reference -> Names.evaluable_global_reference *)
+val tclUSER_if_not_mes : 
+  Proof_type.tactic ->
+  bool -> 
+  Names.Id.t list option -> 
+  Proof_type.tactic
+val recursive_definition :  
+bool ->
+           Names.Id.t ->
+           Constrintern.internalization_env ->
+           Constrexpr.constr_expr ->
+           Constrexpr.constr_expr ->
+           int -> Constrexpr.constr_expr -> (Term.pconstant ->
+            Term.constr option ref ->
+            Term.pconstant ->
+            Term.pconstant -> int -> Term.types -> int -> Term.constr -> 'a) -> Constrexpr.constr_expr list -> unit
+
+
diff --git a/plugins/micromega/CheckerMaker.v b/plugins/micromega/CheckerMaker.v
deleted file mode 100644
index 04336747..00000000
--- a/plugins/micromega/CheckerMaker.v
+++ /dev/null
@@ -1,132 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-(*                                                                      *)
-(* Micromega: A reflexive tactic using the Positivstellensatz           *)
-(*                                                                      *)
-(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
-(*                                                                      *)
-(************************************************************************)
-
-(* FK: scheduled for deletion *)
-(*
-Require Import Setoid.
-Require Import Decidable.
-Require Import List.
-Require Import Refl.
-
-Set Implicit Arguments.
-
-Section CheckerMaker.
-
-(* 'Formula' is a syntactic representation of a certain kind of propositions. *)
-Variable Formula : Type.
-
-Variable Env : Type.
-
-Variable eval : Env -> Formula -> Prop.
-
-Variable Formula' : Type.
-
-Variable eval' : Env -> Formula' -> Prop.
-
-Variable normalise : Formula -> Formula'.
-
-Variable negate : Formula -> Formula'.
-
-Hypothesis normalise_sound :
-  forall (env : Env) (t : Formula), eval env t -> eval' env (normalise t).
-
-Hypothesis negate_correct :
-  forall (env : Env) (t : Formula), eval env t <-> ~ (eval' env (negate t)).
-
-Variable Witness : Type.
-
-Variable check_formulas' : list Formula' -> Witness -> bool.
-
-Hypothesis check_formulas'_sound :
-  forall (l : list Formula') (w : Witness),
-    check_formulas' l w = true ->
-      forall env : Env, make_impl (eval' env) l False.
-
-Definition normalise_list : list Formula -> list Formula' := map normalise.
-Definition negate_list : list Formula -> list Formula' := map negate.
-
-Definition check_formulas (l : list Formula) (w : Witness) : bool :=
-  check_formulas' (map normalise l) w.
-
-(* Contraposition of normalise_sound for lists *)
-Lemma normalise_sound_contr : forall (env : Env) (l : list Formula),
-  make_impl (eval' env) (map normalise l) False -> make_impl (eval env) l False.
-Proof.
-intros env l; induction l as [| t l IH]; simpl in *.
-trivial.
-intros H1 H2. apply IH. apply H1. now apply normalise_sound.
-Qed.
-
-Theorem check_formulas_sound :
-  forall (l : list Formula) (w : Witness),
-    check_formulas l w = true -> forall env : Env, make_impl (eval env) l False.
-Proof.
-unfold check_formulas; intros l w H env. destruct l as [| t l]; simpl in *.
-pose proof (check_formulas'_sound H env) as H1; now simpl in H1.
-intro H1. apply normalise_sound in H1.
-pose proof (check_formulas'_sound H env) as H2; simpl in H2.
-apply H2 in H1. now apply normalise_sound_contr.
-Qed.
-
-(* In check_conj_formulas', t2 is supposed to be a list of negations of
-formulas. If, for example, t1 = [A1, A2] and t2 = [~ B1, ~ B2], then
-check_conj_formulas' checks that each of [~ B1, A1, A2] and [~ B2, A1, A2] is
-inconsistent. This means that A1 /\ A2 -> B1 and A1 /\ A2 -> B1, i.e., that
-A1 /\ A2 -> B1 /\ B2. *)
-
-Fixpoint check_conj_formulas'
-  (t1 : list Formula') (wits : list Witness) (t2 : list Formula') {struct wits} : bool :=
-match t2 with
-| nil => true
-| t':: rt2 =>
-  match wits with
-  | nil => false
-  | w :: rwits =>
-    match check_formulas' (t':: t1) w with
-    | true => check_conj_formulas' t1 rwits rt2
-    | false => false
-    end
-  end
-end.
-
-(* checks whether the conjunction of t1 implies the conjunction of t2 *)
-
-Definition check_conj_formulas
-  (t1 : list Formula) (wits : list Witness) (t2 : list Formula) : bool :=
-    check_conj_formulas' (normalise_list t1) wits (negate_list t2).
-
-Theorem check_conj_formulas_sound :
-  forall (t1 : list Formula) (t2 : list Formula) (wits : list Witness),
-    check_conj_formulas t1 wits t2 = true ->
-      forall env : Env, make_impl (eval env) t1 (make_conj (eval env) t2).
-Proof.
-intro t1; induction t2 as [| a2 t2' IH].
-intros; apply make_impl_true.
-intros wits H env.
-unfold check_conj_formulas in H; simpl in H.
-destruct wits as [| w ws]; simpl in H. discriminate.
-case_eq (check_formulas' (negate a2 :: normalise_list t1) w);
-intro H1; rewrite H1 in H; [| discriminate].
-assert (H2 : make_impl (eval' env) (negate a2 :: normalise_list t1) False) by
-now apply check_formulas'_sound with (w := w). clear H1.
-pose proof (IH ws H env) as H1. simpl in H2.
-assert (H3 : eval' env (negate a2) -> make_impl (eval env) t1 False)
-by auto using normalise_sound_contr. clear H2.
-rewrite <- make_conj_impl in *.
-rewrite make_conj_cons. intro H2. split.
-apply <- negate_correct. intro; now elim H3. exact (H1 H2).
-Qed.
-
-End CheckerMaker.
-*)
\ No newline at end of file
diff --git a/plugins/micromega/Env.v b/plugins/micromega/Env.v
index 31c4a565..dd4d596f 100644
--- a/plugins/micromega/Env.v
+++ b/plugins/micromega/Env.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/plugins/micromega/EnvRing.v b/plugins/micromega/EnvRing.v
index 424f9f37..62a7333d 100644
--- a/plugins/micromega/EnvRing.v
+++ b/plugins/micromega/EnvRing.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/plugins/micromega/Lia.v b/plugins/micromega/Lia.v
new file mode 100644
index 00000000..72425585
--- /dev/null
+++ b/plugins/micromega/Lia.v
@@ -0,0 +1,44 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+(*                                                                      *)
+(* Micromega: A reflexive tactic using the Positivstellensatz           *)
+(*                                                                      *)
+(*  Frédéric Besson (Irisa/Inria)      2013                             *)
+(*                                                                      *)
+(************************************************************************)
+
+Require Import ZMicromega.
+Require Import ZArith.
+Require Import RingMicromega.
+Require Import VarMap.
+Require Tauto.
+Declare ML Module "micromega_plugin".
+
+Ltac preprocess :=
+  zify ; unfold Z.succ in * ; unfold Z.pred in *.
+
+Ltac lia :=
+  preprocess;
+  xlia ;
+  abstract (
+      intros __wit __varmap __ff ;
+      change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ;
+      apply (ZTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true)).
+
+Ltac nia :=
+  preprocess;
+  xnlia ;
+  abstract (
+      intros __wit __varmap __ff ;
+      change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ;
+      apply (ZTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true)).
+
+
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *)
diff --git a/plugins/micromega/MExtraction.v b/plugins/micromega/MExtraction.v
index 607eb2b6..22ddd549 100644
--- a/plugins/micromega/MExtraction.v
+++ b/plugins/micromega/MExtraction.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/plugins/micromega/OrderedRing.v b/plugins/micromega/OrderedRing.v
index 2469f644..34b8bbdd 100644
--- a/plugins/micromega/OrderedRing.v
+++ b/plugins/micromega/OrderedRing.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -85,9 +85,9 @@ Notation "x < y" := (rlt x y).
 
 
 Add Relation R req
-  reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _ )
-  symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _ )
-  transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _ )
+  reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _)
+  symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _)
+  transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _)
 as sor_setoid.
 
 
diff --git a/plugins/micromega/Psatz.v b/plugins/micromega/Psatz.v
index 42c65b5a..675321d9 100644
--- a/plugins/micromega/Psatz.v
+++ b/plugins/micromega/Psatz.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -16,35 +16,55 @@ Require Import ZMicromega.
 Require Import QMicromega.
 Require Import RMicromega.
 Require Import QArith.
-Require Export Ring_normalize.
 Require Import ZArith.
 Require Import Rdefinitions.
-Require Export RingMicromega.
+Require Import RingMicromega.
 Require Import VarMap.
 Require Tauto.
 Declare ML Module "micromega_plugin".
 
+Ltac preprocess := 
+    zify ; unfold Z.succ in * ; unfold Z.pred in *.
+
+Ltac lia :=
+  preprocess;
+  xlia ;
+  abstract (
+  intros __wit __varmap __ff ;
+    change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ;
+      apply (ZTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true)).
+
+Ltac nia :=
+  preprocess;
+  xnlia ;
+  abstract (
+  intros __wit __varmap __ff ;
+    change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ;
+      apply (ZTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true)).
+
+
 Ltac xpsatz dom d :=
   let tac := lazymatch dom with
   | Z =>
     (sos_Z || psatz_Z d) ;
+      abstract(
     intros __wit __varmap __ff ;
     change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ;
-    apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity
+    apply (ZTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true))
   | R =>
     (sos_R || psatz_R d) ;
     (* If csdp is not installed, the previous step might not produce any
     progress: the rest of the tactical will then fail. Hence the 'try'. *)
-    try (intros __wit __varmap __ff ;
+    try (abstract(intros __wit __varmap __ff ;
         change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ;
-        apply (RTautoChecker_sound __ff __wit); vm_compute ; reflexivity)
+        apply (RTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true)))
   | Q =>
     (sos_Q || psatz_Q d) ;
     (* If csdp is not installed, the previous step might not produce any
     progress: the rest of the tactical will then fail. Hence the 'try'. *)
-    try (intros __wit __varmap __ff ;
+    try  (abstract(intros __wit __varmap __ff ;
         change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ;
-        apply (QTautoChecker_sound __ff __wit); vm_compute ; reflexivity)
+        apply (QTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true)))
   | _ => fail "Unsupported domain"
   end in tac.
 
@@ -53,26 +73,22 @@ Tactic Notation "psatz" constr(dom) := xpsatz dom ltac:-1.
 
 Ltac psatzl dom :=
   let tac := lazymatch dom with
-  | Z =>
-    psatzl_Z ;
-    intros __wit __varmap __ff ;
-    change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ;
-    apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity
+  | Z => lia
   | Q =>
     psatzl_Q ;
     (* If csdp is not installed, the previous step might not produce any
     progress: the rest of the tactical will then fail. Hence the 'try'. *)
-    try (intros __wit __varmap __ff ;
+    try (abstract(intros __wit __varmap __ff ;
         change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ;
-        apply (QTautoChecker_sound __ff __wit); vm_compute ; reflexivity)
+        apply (QTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true)))
   | R =>
     unfold Rdiv in * ; 
     psatzl_R ;
     (* If csdp is not installed, the previous step might not produce any
     progress: the rest of the tactical will then fail. Hence the 'try'. *)
-    try (intros __wit __varmap __ff ;
+    try abstract((intros __wit __varmap __ff ;
         change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ;
-        apply (RTautoChecker_sound __ff __wit); vm_compute ; reflexivity)
+        apply (RTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true)))
   | _ => fail "Unsupported domain"
   end in tac.
 
@@ -80,19 +96,6 @@ Ltac psatzl dom :=
 Ltac lra := 
   first [ psatzl R | psatzl Q ].
 
-Ltac lia :=
-  zify ; unfold Z.succ in * ;
-  (*cbv delta - [Z.add Z.sub Z.opp Z.mul Z.pow Z.gt Z.ge Z.le Z.lt iff not] ;*) xlia ;
-  intros __wit __varmap __ff ;
-    change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ;
-      apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity.
-
-Ltac nia :=
-  zify ; unfold Z.succ in * ;
-  xnlia ;
-  intros __wit __varmap __ff ;
-    change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ;
-      apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity.
 
 
 (* Local Variables: *)
diff --git a/plugins/micromega/QMicromega.v b/plugins/micromega/QMicromega.v
index cbd7e334..6c157def 100644
--- a/plugins/micromega/QMicromega.v
+++ b/plugins/micromega/QMicromega.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -66,7 +66,7 @@ Require Import EnvRing.
 Fixpoint Qeval_expr (env: PolEnv Q) (e: PExpr Q) : Q :=
   match e with
     | PEc c =>  c
-    | PEX j =>  env j
+    | PEX _ j =>  env j
     | PEadd pe1 pe2 => (Qeval_expr env pe1) + (Qeval_expr env pe2)
     | PEsub pe1 pe2 => (Qeval_expr env pe1) - (Qeval_expr env pe2)
     | PEmul pe1 pe2 => (Qeval_expr env pe1) * (Qeval_expr env pe2)
@@ -78,7 +78,7 @@ Lemma Qeval_expr_simpl : forall env e,
   Qeval_expr env e =
   match e with
     | PEc c =>  c
-    | PEX j =>  env j
+    | PEX _ j =>  env j
     | PEadd pe1 pe2 => (Qeval_expr env pe1) + (Qeval_expr env pe2)
     | PEsub pe1 pe2 => (Qeval_expr env pe1) - (Qeval_expr env pe2)
     | PEmul pe1 pe2 => (Qeval_expr env pe1) * (Qeval_expr env pe2)
diff --git a/plugins/micromega/RMicromega.v b/plugins/micromega/RMicromega.v
index 65911a72..e9ab6962 100644
--- a/plugins/micromega/RMicromega.v
+++ b/plugins/micromega/RMicromega.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -243,7 +243,6 @@ Proof.
   unfold IQR ; intros.
   simpl.
   repeat rewrite mult_IZR.
-  simpl.  
   rewrite Pos2Nat.inj_mul.
   rewrite mult_INR.
   repeat INR_nat_of_P.
@@ -260,8 +259,8 @@ Proof.
   simpl.
   intros.
   unfold Qinv.
-  destruct x ; simpl in *.
-  destruct Qnum ; simpl.
+  destruct x.
+  destruct Qnum ; simpl in *.
   exfalso. auto with zarith.
   clear H.
   repeat INR_nat_of_P.
diff --git a/plugins/micromega/Refl.v b/plugins/micromega/Refl.v
index 6072e582..499a8c4c 100644
--- a/plugins/micromega/Refl.v
+++ b/plugins/micromega/Refl.v
@@ -1,7 +1,7 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/plugins/micromega/RingMicromega.v b/plugins/micromega/RingMicromega.v
index a2136506..a0545637 100644
--- a/plugins/micromega/RingMicromega.v
+++ b/plugins/micromega/RingMicromega.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -57,7 +57,7 @@ Variables ceqb cleb : C -> C -> bool.
 Variable phi : C -> R.
 
 (* Power coefficients *)
-Variable E : Set. (* the type of exponents *)
+Variable E : Type. (* the type of exponents *)
 Variable pow_phi : N -> E.
 Variable rpow : R -> E -> R.
 
@@ -78,9 +78,9 @@ Record SORaddon := mk_SOR_addon {
 Variable addon : SORaddon.
 
 Add Relation R req
-  reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _ )
-  symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _ )
-  transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _ )
+  reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _)
+  symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _)
+  transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _)
 as micomega_sor_setoid.
 
 Add Morphism rplus with signature req ==> req ==> req as rplus_morph.
@@ -141,8 +141,8 @@ Qed.
 
 Definition PolC := Pol C. (* polynomials in generalized Horner form, defined in Ring_polynom or EnvRing *)
 Definition PolEnv := Env R. (* For interpreting PolC *)
-Definition eval_pol (env : PolEnv) (p:PolC) : R :=
-   Pphi rplus rtimes phi env p.
+Definition eval_pol : PolEnv -> PolC -> R :=
+   Pphi rplus rtimes phi.
 
 Inductive Op1 : Set := (* relations with 0 *)
 | Equal (* == 0 *)
@@ -412,12 +412,12 @@ Proof.
   induction e.
   (* PsatzIn *)
   simpl ; intros.
-  destruct (nth_in_or_default n l (Pc cO, Equal)).
+  destruct (nth_in_or_default n l (Pc cO, Equal)) as [Hin|Heq].
   (* index is in bounds *)
-  apply H ; congruence.
+  apply H. congruence.
   (* index is out-of-bounds *)
   inversion H0.
-  rewrite e. simpl.
+  rewrite Heq. simpl.
   now apply  addon.(SORrm).(morph0).
   (* PsatzSquare *)
   simpl. intros. inversion H0.
@@ -679,7 +679,8 @@ match o with
 | OpGt => fun x y : R => y < x
 end.
 
-Definition  eval_pexpr (l : PolEnv) (pe : PExpr C) : R := PEeval rplus rtimes rminus ropp phi pow_phi rpow l pe.
+Definition  eval_pexpr : PolEnv -> PExpr C -> R :=
+ PEeval rplus rtimes rminus ropp phi pow_phi rpow.
 
 Record Formula (T:Type) : Type := {
   Flhs : PExpr T;
@@ -910,7 +911,7 @@ Proof.
   unfold pow_N. ring.
 Qed.
 
-Definition denorm (p : Pol C)  := xdenorm xH p.
+Definition denorm := xdenorm xH.
 
 Lemma denorm_correct : forall p env, eval_pol env p == eval_pexpr env (denorm p).
 Proof.
@@ -947,7 +948,7 @@ Variable phi_C_of_S :   forall c,  phiS c =  phi (C_of_S c).
 Fixpoint map_PExpr (e : PExpr S) : PExpr C :=
   match e with
     | PEc c => PEc (C_of_S c)
-    | PEX p => PEX _ p
+    | PEX _ p => PEX _ p
     | PEadd e1 e2 => PEadd (map_PExpr e1) (map_PExpr e2)
     | PEsub e1 e2 => PEsub (map_PExpr e1) (map_PExpr e2)
     | PEmul e1 e2 => PEmul (map_PExpr e1) (map_PExpr e2)
@@ -960,8 +961,8 @@ Definition map_Formula (f : Formula S)  : Formula C :=
     Build_Formula (map_PExpr l) o (map_PExpr r).
 
 
-Definition eval_sexpr (env : PolEnv) (e : PExpr S) : R :=
-  PEeval rplus rtimes rminus ropp phiS pow_phi rpow env e.
+Definition eval_sexpr : PolEnv -> PExpr S -> R :=
+  PEeval rplus rtimes rminus ropp phiS pow_phi rpow.
 
 Definition eval_sformula (env : PolEnv) (f : Formula S) : Prop :=
   let (lhs, op, rhs) := f in
diff --git a/plugins/micromega/Tauto.v b/plugins/micromega/Tauto.v
index a1d200ea..39d0c6b1 100644
--- a/plugins/micromega/Tauto.v
+++ b/plugins/micromega/Tauto.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -31,10 +31,10 @@ Set Implicit Arguments.
 
   Fixpoint eval_f (A:Type)  (ev:A -> Prop ) (f:BFormula A) {struct f}: Prop :=
     match f with
-      | TT => True
-      | FF => False
+      | TT _ => True
+      | FF _ => False
       | A a =>  ev a
-      | X p => p
+      | X _ p => p
       | Cj e1 e2 => (eval_f  ev e1) /\ (eval_f ev e2)
       | D e1 e2  => (eval_f  ev e1) \/ (eval_f  ev e2)
       | N e     => ~ (eval_f  ev e)
@@ -54,9 +54,9 @@ Set Implicit Arguments.
 
   Fixpoint map_bformula (T U : Type) (fct : T -> U) (f : BFormula T) : BFormula U :=
     match f with
-      | TT => TT _
-      | FF => FF _
-      | X p => X _ p
+      | TT _ => TT _
+      | FF _ => FF _
+      | X _ p => X _ p
       | A a => A (fct a)
       | Cj f1 f2 => Cj (map_bformula fct f1) (map_bformula fct f2)
       | D f1 f2 => D (map_bformula fct f1) (map_bformula fct f2)
@@ -172,9 +172,9 @@ Set Implicit Arguments.
 
     Fixpoint xcnf (pol : bool) (f : BFormula Term)  {struct f}: cnf :=
       match f with
-        | TT => if pol then tt else ff
-        | FF => if pol then ff else tt
-        | X p => if pol then ff else ff (* This is not complete - cannot negate any proposition *)
+        | TT _ => if pol then tt else ff
+        | FF _ => if pol then ff else tt
+        | X _ p => if pol then ff else ff (* This is not complete - cannot negate any proposition *)
         | A x => if pol then normalise x else negate x
         | N e  => xcnf (negb pol) e
         | Cj e1 e2 =>
diff --git a/plugins/micromega/VarMap.v b/plugins/micromega/VarMap.v
index 4391a01b..6e1fe222 100644
--- a/plugins/micromega/VarMap.v
+++ b/plugins/micromega/VarMap.v
@@ -1,7 +1,7 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/plugins/micromega/ZCoeff.v b/plugins/micromega/ZCoeff.v
index 7f748a0b..4c4b81a0 100644
--- a/plugins/micromega/ZCoeff.v
+++ b/plugins/micromega/ZCoeff.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -41,19 +41,19 @@ Notation "x < y" := (rlt x y).
 
 Lemma req_refl : forall x, req x x.
 Proof.
-  destruct sor.(SORsetoid).
+  destruct sor.(SORsetoid) as (Equivalence_Reflexive,_,_).
   apply Equivalence_Reflexive.
 Qed.
 
 Lemma req_sym : forall x y, req x y -> req y x.
 Proof.
-  destruct sor.(SORsetoid).
+  destruct sor.(SORsetoid) as (_,Equivalence_Symmetric,_).
   apply Equivalence_Symmetric.
 Qed.
 
 Lemma req_trans : forall x y z, req x y -> req y z -> req x z.
 Proof.
-  destruct sor.(SORsetoid).
+  destruct sor.(SORsetoid) as (_,_,Equivalence_Transitive).
   apply Equivalence_Transitive.
 Qed.
 
@@ -93,6 +93,7 @@ Ltac le_less := rewrite (Rle_lt_eq sor); left; try assumption.
 Ltac le_equal := rewrite (Rle_lt_eq sor); right; try reflexivity; try assumption.
 
 Definition gen_order_phi_Z : Z -> R := gen_phiZ 0 1 rplus rtimes ropp.
+Declare Equivalent Keys gen_order_phi_Z gen_phiZ.
 
 Notation phi_pos := (gen_phiPOS 1 rplus rtimes).
 Notation phi_pos1 := (gen_phiPOS1 1 rplus rtimes).
diff --git a/plugins/micromega/ZMicromega.v b/plugins/micromega/ZMicromega.v
index 4aecb39a..84a8d13c 100644
--- a/plugins/micromega/ZMicromega.v
+++ b/plugins/micromega/ZMicromega.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -62,7 +62,7 @@ Qed.
 Fixpoint Zeval_expr (env : PolEnv Z) (e: PExpr Z) : Z :=
   match e with
     | PEc c => c
-    | PEX x => env x
+    | PEX _ x => env x
     | PEadd e1 e2 => Zeval_expr env e1 + Zeval_expr env e2
     | PEmul e1 e2 => Zeval_expr env e1 * Zeval_expr env e2
     | PEpow e1 n  => Z.pow (Zeval_expr env e1) (Z.of_N n)
@@ -155,12 +155,16 @@ Proof.
 Qed.
 
 Definition psub  := psub Z0  Z.add Z.sub Z.opp Zeq_bool.
+Declare Equivalent Keys psub RingMicromega.psub.
 
 Definition padd  := padd Z0  Z.add Zeq_bool.
+Declare Equivalent Keys padd RingMicromega.padd.
 
 Definition norm  := norm 0 1 Z.add Z.mul Z.sub Z.opp Zeq_bool.
+Declare Equivalent Keys norm RingMicromega.norm.
 
 Definition eval_pol := eval_pol Z.add Z.mul (fun x => x).
+Declare Equivalent Keys eval_pol RingMicromega.eval_pol.
 
 Lemma eval_pol_sub : forall env lhs rhs, eval_pol env (psub  lhs rhs) = eval_pol env lhs - eval_pol env rhs.
 Proof.
@@ -202,11 +206,10 @@ Definition normalise (t:Formula Z) : cnf (NFormula Z) :=
 
 Lemma normalise_correct : forall env t, eval_cnf eval_nformula env (normalise t) <-> Zeval_formula env t.
 Proof.
-  Opaque padd.
-  unfold normalise, xnormalise  ; simpl; intros env t.
+  unfold normalise, xnormalise; cbn -[padd]; intros env t.
   rewrite Zeval_formula_compat.
   unfold eval_cnf, eval_clause.
-  destruct t as [lhs o rhs]; case_eq o; simpl;
+  destruct t as [lhs o rhs]; case_eq o; cbn -[padd];
     repeat rewrite eval_pol_sub;
       repeat rewrite eval_pol_add;
       repeat rewrite <- eval_pol_norm ; simpl in *;
@@ -216,7 +219,6 @@ Proof.
   generalize (eval_pexpr  Z.add Z.mul Z.sub Z.opp (fun x : Z => x)
     (fun x : N => x) (pow_N 1 Z.mul) env rhs) ; intros z1 z2 ; intros ; subst;
     intuition (auto with zarith).
-  Transparent padd.
 Qed.
 
 Definition xnegate (t:RingMicromega.Formula Z) : list (NFormula Z)  :=
@@ -317,7 +319,7 @@ Qed.
 
 Require Import QArith.
 
-Inductive ZArithProof : Type :=
+Inductive ZArithProof :=
 | DoneProof
 | RatProof : ZWitness -> ZArithProof -> ZArithProof
 | CutProof : ZWitness -> ZArithProof -> ZArithProof
diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml
index 32aeb993..b4f305dd 100644
--- a/plugins/micromega/certificate.ml
+++ b/plugins/micromega/certificate.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -76,7 +76,7 @@ let dev_form n_spec  p =
       let p = dev_form p in
       let n = C2Ml.n n in
       let rec pow n = 
-       if n = 0 
+       if Int.equal n 0 
        then Poly.constant (n_spec.number_to_num n_spec.unit)
        else Poly.product p (pow (n-1)) in
        pow n in
@@ -87,8 +87,8 @@ let monomial_to_polynomial mn =
  Monomial.fold 
   (fun v i acc -> 
      let v = Ml2C.positive v in
-     let mn = if i = 1 then Mc.PEX v else Mc.PEpow (Mc.PEX v ,Ml2C.n i) in
-       if acc = Mc.PEc (Mc.Zpos Mc.XH)
+     let mn = if Int.equal i 1 then Mc.PEX v else Mc.PEpow (Mc.PEX v ,Ml2C.n i) in
+       if Pervasives.(=) acc (Mc.PEc (Mc.Zpos Mc.XH)) (** FIXME *)
        then mn 
        else Mc.PEmul(mn,acc))
    mn 
@@ -105,10 +105,10 @@ let list_to_polynomial vars l =
   | c::l -> if c =/  (Int 0) then xtopoly p (i+1) l 
     else let c = Mc.PEc (Ml2C.bigint (numerator c)) in
     let mn = 
-     if c =  Mc.PEc (Mc.Zpos Mc.XH)
+     if Pervasives.(=) c (Mc.PEc (Mc.Zpos Mc.XH))
      then var i
      else Mc.PEmul (c,var i) in
-    let p' = if p = Mc.PEc Mc.Z0 then mn else
+    let p' = if Pervasives.(=) p (Mc.PEc Mc.Z0) then mn else
       Mc.PEadd (mn, p) in
      xtopoly p' (i+1) l in
   
@@ -116,7 +116,7 @@ let list_to_polynomial vars l =
 
 let rec fixpoint f x =
  let y' = f x in
-  if y' = x then y'
+  if Pervasives.(=) y' x then y'
   else fixpoint f y'
 
 let  rec_simpl_cone n_spec e = 
@@ -153,9 +153,9 @@ let factorise_linear_cone c =
  let factorise c1 c2 =
   match c1 , c2 with
    | Mc.PsatzMulC(x,y) , Mc.PsatzMulC(x',y') -> 
-      if x = x' then Some (Mc.PsatzMulC(x, Mc.PsatzAdd(y,y'))) else None
+      if Pervasives.(=) x x' then Some (Mc.PsatzMulC(x, Mc.PsatzAdd(y,y'))) else None
    | Mc.PsatzMulE(x,y) , Mc.PsatzMulE(x',y') -> 
-      if x = x' then Some (Mc.PsatzMulE(x, Mc.PsatzAdd(y,y'))) else None
+      if Pervasives.(=) x x' then Some (Mc.PsatzMulE(x, Mc.PsatzAdd(y,y'))) else None
    |  _     -> None in
   
  let rec rebuild_cone l pending  =
@@ -199,7 +199,7 @@ open Mfourier
 
 let constrain_monomial mn l  = 
  let coeffs = List.fold_left (fun acc p -> (Poly.get mn p)::acc) [] l in
-  if mn = Monomial.const
+  if Pervasives.(=) mn Monomial.const
   then  
    { coeffs = Vect.from_list ((Big_int unit_big_int):: (List.rev coeffs)) ; 
      op = Eq ; 
@@ -230,6 +230,7 @@ let string_of_op = function
  | Mc.NonEqual -> "<> 0"
 
 
+module MonSet = Set.Make(Monomial)
 
 (* If the certificate includes at least one strict inequality, 
    the obtained polynomial can also be 0 *)
@@ -238,8 +239,6 @@ let build_linear_system l =
  (* Gather the monomials:  HINT add up of the polynomials ==> This does not work anymore *)
  let l' = List.map fst l in
 
- let module MonSet = Set.Make(Monomial) in
-
  let monomials = 
   List.fold_left (fun acc p -> 
                     Poly.fold (fun m _ acc -> MonSet.add m acc) p acc) 
@@ -299,27 +298,28 @@ exception Found of Monomial.t
 
 exception Strict
 
+module MonMap = Map.Make(Monomial)
+
 let primal l = 
   let vr = ref 0 in
-  let module Mmn = Map.Make(Monomial) in
 
   let vect_of_poly map p =
     Poly.fold (fun mn vl (map,vect) -> 
-      if mn = Monomial.const 
+      if Pervasives.(=) mn Monomial.const 
       then (map,vect)
       else 
-	let (mn,m) = try (Mmn.find mn map,map) with Not_found -> let res = (!vr, Mmn.add mn !vr map) in incr vr ; res in
-	  (m,if sign_num vl = 0 then vect else (mn,vl)::vect)) p (map,[]) in
+	let (mn,m) = try (MonMap.find mn map,map) with Not_found -> let res = (!vr, MonMap.add mn !vr map) in incr vr ; res in
+	  (m,if Int.equal (sign_num vl) 0 then vect else (mn,vl)::vect)) p (map,[]) in
     
   let op_op = function Mc.NonStrict -> Ge |Mc.Equal -> Eq | _ -> raise Strict in
 
-  let cmp x y = Pervasives.compare (fst x) (fst y) in
+  let cmp x y = Int.compare (fst x) (fst y) in
 
    snd (List.fold_right (fun  (p,op) (map,l) ->
       let (mp,vect) = vect_of_poly map p in  
       let cstr = {coeffs = List.sort cmp vect; op = op_op op ; cst = minus_num (Poly.get Monomial.const p)} in
 
-	(mp,cstr::l)) l (Mmn.empty,[]))
+	(mp,cstr::l)) l (MonMap.empty,[]))
 
 let dual_raw_certificate (l:  (Poly.t * Mc.op1) list) = 
 (*  List.iter (fun (p,op) -> Printf.fprintf stdout "%a %s 0\n" Poly.pp p (string_of_op op) ) l ; *)
@@ -332,8 +332,8 @@ let dual_raw_certificate (l:  (Poly.t * Mc.op1) list) =
     | Inl cert ->  Some (rats_to_ints (Vect.to_list cert)) 
        (* should not use rats_to_ints *)
   with x when Errors.noncritical x ->
-   if debug 
-   then (Printf.printf "raw certificate %s" (Printexc.to_string x);   
+   if debug
+   then (Printf.printf "raw certificate %s" (Printexc.to_string x);
          flush stdout) ;
    None
 
@@ -367,7 +367,7 @@ let linear_prover n_spec l  =
   let build_system n_spec l = 
     let li = List.combine l (interval 0 (List.length l -1)) in
     let (l1,l') = List.partition 
-      (fun (x,_) -> if snd x = Mc.NonEqual then true else false) li in
+      (fun (x,_) -> if Pervasives.(=) (snd x) Mc.NonEqual then true else false) li in
       List.map 
 	(fun ((x,y),i) -> match y with
              Mc.NonEqual -> failwith "cannot happen"
@@ -378,7 +378,7 @@ let linear_prover n_spec l  =
 
 let linear_prover n_spec l  =
  try linear_prover n_spec l
- with x when x <> Sys.Break ->
+ with x when Errors.noncritical x ->
    (print_string (Printexc.to_string x); None)
 
 let linear_prover_with_cert spec l = 
@@ -394,7 +394,7 @@ let make_linear_system l =
  let monomials = List.fold_left (fun acc p -> Poly.addition p acc) 
   (Poly.constant (Int 0)) l' in
  let monomials = Poly.fold 
-  (fun mn _ l -> if mn = Monomial.const then l else mn::l) monomials [] in
+  (fun mn _ l -> if Pervasives.(=) mn Monomial.const then l else mn::l) monomials [] in
   (List.map (fun (c,op) -> 
    {coeffs = Vect.from_list (List.map (fun mn ->  (Poly.get mn c)) monomials) ; 
     op = op ; 
@@ -406,9 +406,7 @@ let pplus x y = Mc.PEadd(x,y)
 let pmult x y = Mc.PEmul(x,y)
 let pconst x = Mc.PEc x
 let popp x = Mc.PEopp x
- 
-let debug = false
- 
+
 (* keep track of enumerated vectors *)
 let rec mem p x  l = 
  match l with  [] -> false | e::l -> if p x e then true else mem p x l
@@ -417,7 +415,7 @@ let rec remove_assoc p x l =
  match l with [] -> [] | e::l -> if p x (fst e) then
   remove_assoc p x l else e::(remove_assoc p x l) 
 
-let eq x y = Vect.compare x y = 0
+let eq x y = Int.equal (Vect.compare x y) 0
 
 let  remove e  l  = List.fold_left (fun l x -> if eq x e then l else x::l) [] l
 
@@ -477,7 +475,7 @@ let rec scale_term t =
     let s1' = div_big_int s1 g in
     let s2' = div_big_int s2 g in
     let e = mult_big_int g (mult_big_int s1' s2') in
-     if (compare_big_int e unit_big_int) = 0
+     if Int.equal (compare_big_int e unit_big_int) 0
      then (unit_big_int, Add (y1,y2))
      else 	e, Add (Mul(Const (Big_int s2'), y1),
 		       Mul (Const (Big_int s1'), y2))
@@ -499,7 +497,7 @@ let get_index_of_ith_match f i l  =
    | [] -> failwith "bad index"
    | e::l -> if f e
      then 
-       (if j = i then res else get (j+1) (res+1) l )
+       (if Int.equal j i then res else get (j+1) (res+1) l )
      else get j (res+1) l in
   get 0 0 l
 
@@ -559,7 +557,7 @@ let  q_cert_of_pos  pos =
   | Axiom_lt i ->  Mc.PsatzIn (Ml2C.nat i)
   | Monoid l  -> product l
   | Rational_eq n | Rational_le n | Rational_lt n -> 
-     if compare_num n (Int 0) = 0 then Mc.PsatzZ else
+     if Int.equal (compare_num n (Int 0)) 0 then Mc.PsatzZ else
       Mc.PsatzC (Ml2C.q   n)
   | Square t -> Mc.PsatzSquare (term_to_q_pol  t)
   | Eqmul (t, y) -> Mc.PsatzMulC(term_to_q_pol t, _cert_of_pos y)
@@ -590,7 +588,7 @@ let  z_cert_of_pos  pos =
   | Axiom_lt i ->  Mc.PsatzIn (Ml2C.nat i)
   | Monoid l  -> product l
   | Rational_eq n | Rational_le n | Rational_lt n -> 
-     if compare_num n (Int 0) = 0 then Mc.PsatzZ else
+     if Int.equal (compare_num n (Int 0)) 0 then Mc.PsatzZ else
       Mc.PsatzC (Ml2C.bigint (big_int_of_num  n))
   | Square t -> Mc.PsatzSquare (term_to_z_pol  t)
   | Eqmul (t, y) -> 
@@ -631,7 +629,7 @@ struct
     let rec xid_of_hyp i l = 
       match l with
       | [] -> failwith "id_of_hyp"
-      | hyp'::l -> if hyp = hyp' then i else xid_of_hyp (i+1) l in
+      | hyp'::l -> if Pervasives.(=) hyp hyp' then i else xid_of_hyp (i+1) l in
       xid_of_hyp 0 l
 
 end
@@ -757,7 +755,7 @@ let check_sat (cstr,prf) =
 	  if eq_num gcd (Int 1)
 	  then Normalise(cstr,prf) 
 	  else
-	    if sign_num (mod_num cst gcd) = 0
+	    if Int.equal (sign_num (mod_num cst gcd)) 0
 	    then (* We can really normalise *)
 	      begin
 		assert (sign_num gcd >=1 ) ;
@@ -797,18 +795,18 @@ let pivot v (c1,p1) (c2,p2) =
     match Vect.get v v1 , Vect.get v v2 with
     | None , _ | _ , None -> None
     | Some a   , Some b   ->
-	if (sign_num a) * (sign_num b) = -1
+	if Int.equal ((sign_num a) * (sign_num b)) (-1)
 	then 
 	  let cv1 = abs_num b 
 	  and cv2 = abs_num a  in
 	    Some (xpivot cv1 cv2)
 	else 
-	  if op1 = Eq
+	  if op1 == Eq
           then 
 	    let cv1 = minus_num (b */ (Int (sign_num a)))
 	    and cv2 = abs_num a in
 	      Some (xpivot cv1 cv2)
-          else if op2 = Eq
+          else if op2 == Eq
 	  then
 	    let cv1 = abs_num b 
 	    and cv2 = minus_num (a */ (Int  (sign_num b))) in
@@ -817,7 +815,7 @@ let pivot v (c1,p1) (c2,p2) =
 	    
 exception FoundProof of  prf_rule
 
-let rec simpl_sys sys = 
+let simpl_sys sys = 
   List.fold_left (fun acc (c,p) -> 
 		    match check_sat (c,p) with
 		    | Tauto -> acc
@@ -831,7 +829,7 @@ let rec simpl_sys sys =
     Source: http://en.wikipedia.org/wiki/Extended_Euclidean_algorithm
 *)
 let rec ext_gcd a b = 
-  if sign_big_int b = 0 
+  if Int.equal (sign_big_int b) 0 
   then (unit_big_int,zero_big_int)
   else
     let (q,r) = quomod_big_int a b in
@@ -852,7 +850,7 @@ let pp_ext_gcd a b =
 exception Result of (int * (proof * cstr_compat))
 
 let split_equations psys = 
-  List.partition (fun (c,p) -> c.op = Eq)
+  List.partition (fun (c,p) -> c.op == Eq)
 
 
 let extract_coprime (c1,p1) (c2,p2) = 
@@ -860,9 +858,9 @@ let extract_coprime (c1,p1) (c2,p2) =
     match vect1 , vect2 with
     | _ , [] | [], _ -> None
     | (v1,n1)::vect1' , (v2, n2) :: vect2' -> 
-	if v1 = v2
+	if Pervasives.(=) v1 v2
 	then 
-	  if compare_big_int (gcd_big_int (numerator n1) (numerator n2)) unit_big_int  = 0
+	  if Int.equal (compare_big_int (gcd_big_int (numerator n1) (numerator n2)) unit_big_int) 0
 	  then Some (v1,n1,n2)
 	  else 
 	    exist2 vect1' vect2'
@@ -871,7 +869,7 @@ let extract_coprime (c1,p1) (c2,p2) =
 	  then exist2 vect1' vect2
 	  else exist2 vect1 vect2' in
     
-    if c1.op = Eq && c2.op = Eq 
+    if c1.op == Eq && c2.op == Eq 
     then exist2 c1.coeffs c2.coeffs
     else None
 
@@ -928,7 +926,7 @@ let reduce_coprime psys =
 (** If there is an equation [eq] of the form 1.x + e = c, do a pivot over x with equation [eq] *)
 let reduce_unary psys = 
   let is_unary_equation (cstr,prf) = 
-    if cstr.op = Eq 
+    if cstr.op == Eq 
     then 
       try 
 	Some (fst (List.find (fun (_,n) -> n =/ (Int 1) || n=/ (Int (-1))) cstr.coeffs))
@@ -944,12 +942,12 @@ let reduce_unary psys =
 let reduce_non_lin_unary psys = 
 
   let is_unary_equation (cstr,prf) = 
-    if cstr.op = Eq 
+    if cstr.op == Eq 
     then 
       try 
 	let x = fst (List.find (fun (x,n) ->  (n =/ (Int 1) || n=/ (Int (-1))) && Monomial.is_var (LinPoly.MonT.retrieve x) ) cstr.coeffs) in
 	let x' = LinPoly.MonT.retrieve x in
-	  if List.for_all (fun (y,_) -> y = x  || snd (Monomial.div (LinPoly.MonT.retrieve y) x') = 0) cstr.coeffs 
+	  if List.for_all (fun (y,_) -> Pervasives.(=) y x  || Int.equal (snd (Monomial.div (LinPoly.MonT.retrieve y) x')) 0) cstr.coeffs 
 	  then Some x
 	  else None
       with Not_found -> None
@@ -976,7 +974,7 @@ let reduce_var_change psys =
 	       Some ((x,v),(x',numerator v'))
 	   with Not_found -> rel_prime vect in
 
-  let rel_prime (cstr,prf) =  if cstr.op = Eq then rel_prime cstr.coeffs else None in
+  let rel_prime (cstr,prf) =  if cstr.op == Eq then rel_prime cstr.coeffs else None in
 
   let (oeq,sys) = extract rel_prime psys in
     
@@ -1007,7 +1005,7 @@ let reduce_var_change psys =
 
   let reduce_pivot psys = 
     let is_equation (cstr,prf) = 
-      if cstr.op = Eq
+      if cstr.op == Eq
       then
 	try 
 	  Some (fst (List.hd cstr.coeffs))
@@ -1067,7 +1065,7 @@ let reduce_var_change psys =
     (* For lia, there are no equations => these precautions are not needed *)
     (* For nlia, there are equations => do not enumerate over equations! *)
     let all_planes sys = 
-      let (eq,ineq) = List.partition (fun c -> c.op = Eq) sys in
+      let (eq,ineq) = List.partition (fun c -> c.op == Eq) sys in
 	match eq with
 	  | [] -> List.rev_map (fun c -> c.coeffs) ineq
 	  | _  -> 
@@ -1197,8 +1195,6 @@ let reduce_var_change psys =
 
     let is_linear =  List.for_all (fun ((p,_),_) -> Poly.is_linear p) sys in
 
-    let module MonMap = Map.Make(Monomial) in
-
     let collect_square = 
       List.fold_left (fun acc ((p,_),_) -> Poly.fold 
 			(fun m _ acc -> 
diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml
index 7e10464a..2812e36e 100644
--- a/plugins/micromega/coq_micromega.ml
+++ b/plugins/micromega/coq_micromega.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -16,6 +16,7 @@
 (*                                                                      *)
 (************************************************************************)
 
+open Pp
 open Mutils
 
 (**
@@ -44,7 +45,7 @@ type tag = Tag.t
 
 (**
   * An atom is of the form:
-  *   pExpr1 {<,>,=,<>,<=,>=} pExpr2
+  *   pExpr1 \{<,>,=,<>,<=,>=\} pExpr2
   * where pExpr1, pExpr2 are polynomial expressions (see Micromega). pExprs are
   * parametrized by 'cst, which is used as the type of constants.
   *)
@@ -65,7 +66,7 @@ type 'cst formula =
   | C of 'cst formula * 'cst formula
   | D of 'cst formula * 'cst formula
   | N of 'cst formula
-  | I of 'cst formula * Names.identifier option * 'cst formula
+  | I of 'cst formula * Names.Id.t option * 'cst formula
 
 (**
   * Formula pretty-printer.
@@ -82,7 +83,7 @@ let rec pp_formula o f =
     | I(f1,n,f2) -> Printf.fprintf o "I(%a%s,%a)"
 	pp_formula f1
 	  (match n with
-	    | Some id -> Names.string_of_id id
+	    | Some id -> Names.Id.to_string id
 	    | None -> "") pp_formula f2
     | N(f) -> Printf.fprintf o "N(%a)" pp_formula f
 
@@ -111,7 +112,7 @@ let rec ids_of_formula f =
 (**
   * A clause is a list of (tagged) nFormulas.
   * nFormulas are normalized formulas, i.e., of the form:
-  *   cPol {=,<>,>,>=} 0
+  *   cPol \{=,<>,>,>=\} 0
   * with cPol compact polynomials (see the Pol inductive type in EnvRing.v).
   *)
 
@@ -242,10 +243,10 @@ let rec add_term  t0 = function
   * MODULE: Ordered set of integers.
   *)
 
-module ISet = Set.Make(struct type t = int let compare : int -> int -> int = Pervasives.compare end)
+module ISet = Set.Make(Int)
 
 (**
-  * Given a set of integers s={i0,...,iN} and a list m, return the list of
+  * Given a set of integers s=\{i0,...,iN\} and a list m, return the list of
   * elements of m that are at position i0,...,iN.
   *)
 
@@ -535,10 +536,10 @@ struct
 
   let get_left_construct term =
    match Term.kind_of_term term with
-    | Term.Construct(_,i) -> (i,[| |])
+    | Term.Construct((_,i),_) -> (i,[| |])
     | Term.App(l,rst) ->
        (match Term.kind_of_term l with
-        | Term.Construct(_,i) -> (i,rst)
+        | Term.Construct((_,i),_) -> (i,rst)
         |   _     -> raise ParseError
        )
     | _ ->   raise ParseError
@@ -577,7 +578,7 @@ struct
 
   let pp_positive o x = Printf.fprintf o "%i" (CoqToCaml.positive x)
 
-  let rec dump_n x =
+  let dump_n x =
    match x with
     | Mc.N0 -> Lazy.force coq_N0
     | Mc.Npos p -> Term.mkApp(Lazy.force coq_Npos,[| dump_positive p|])
@@ -590,12 +591,12 @@ struct
 
   let pp_index o x = Printf.fprintf o "%i" (CoqToCaml.index x)
 
-  let rec pp_n o x =  output_string o  (string_of_int (CoqToCaml.n x))
+  let pp_n o x =  output_string o  (string_of_int (CoqToCaml.n x))
 
   let dump_pair t1 t2 dump_t1 dump_t2 (x,y) =
    Term.mkApp(Lazy.force coq_pair,[| t1 ; t2 ; dump_t1 x ; dump_t2 y|])
 
-  let rec parse_z term =
+  let parse_z term =
    let (i,c) = get_left_construct term in
     match i with
      | 1 -> Mc.Z0
@@ -622,7 +623,7 @@ struct
 
   let parse_q term =
      match Term.kind_of_term term with
-       | Term.App(c, args) -> if c = Lazy.force coq_Qmake then
+       | Term.App(c, args) -> if Constr.equal c (Lazy.force coq_Qmake) then
              {Mc.qnum = parse_z args.(0) ; Mc.qden = parse_positive args.(1) }
        else raise ParseError
    |  _ -> raise ParseError
@@ -780,7 +781,7 @@ struct
         Printf.fprintf o "0" in
     pp_cone o e
 
-  let rec dump_op = function
+  let dump_op = function
    | Mc.OpEq-> Lazy.force coq_OpEq
    | Mc.OpNEq-> Lazy.force coq_OpNEq
    | Mc.OpLe -> Lazy.force coq_OpLe
@@ -808,7 +809,7 @@ struct
 
   let assoc_const x l =
    try
-   snd (List.find (fun (x',y) -> x = Lazy.force x') l)
+   snd (List.find (fun (x',y) -> Constr.equal x (Lazy.force x')) l)
    with
      Not_found -> raise ParseError
 
@@ -830,25 +831,33 @@ struct
    coq_Qeq, Mc.OpEq
   ]
 
-  let parse_zop (op,args) =
+  let has_typ gl t1 typ = 
+   let ty = Retyping.get_type_of (Tacmach.pf_env gl) (Tacmach.project gl) t1 in
+   Constr.equal ty typ
+
+
+  let is_convertible gl t1 t2 = 
+   Reductionops.is_conv (Tacmach.pf_env gl) (Tacmach.project gl) t1 t2
+
+  let parse_zop gl (op,args) =
    match kind_of_term op with
-    | Const x -> (assoc_const op zop_table, args.(0) , args.(1))
-    |  Ind(n,0) ->
-        if op = Lazy.force coq_Eq &&   args.(0) = Lazy.force coq_Z
+    | Const (x,_) -> (assoc_const op zop_table, args.(0) , args.(1))
+    | Ind((n,0),_) ->
+        if Constr.equal op (Lazy.force coq_Eq) && is_convertible gl args.(0) (Lazy.force coq_Z)
         then (Mc.OpEq, args.(1), args.(2))
         else raise ParseError
     |   _ -> failwith "parse_zop"
 
-  let parse_rop (op,args) =
+  let parse_rop gl (op,args) =
     match kind_of_term op with
-     | Const x -> (assoc_const op rop_table, args.(0) , args.(1))
-     |  Ind(n,0) ->
-        if op = Lazy.force coq_Eq &&   args.(0) = Lazy.force coq_R
+     | Const (x,_) -> (assoc_const op rop_table, args.(0) , args.(1))
+     | Ind((n,0),_) ->
+        if Constr.equal op (Lazy.force coq_Eq) && is_convertible gl args.(0) (Lazy.force coq_R)
         then (Mc.OpEq, args.(1), args.(2))
         else raise ParseError
     |   _ -> failwith "parse_zop"
 
-  let parse_qop (op,args) =
+  let parse_qop gl (op,args) =
     (assoc_const op qop_table, args.(0) , args.(1))
 
   let is_constant t = (* This is an approx *)
@@ -864,7 +873,7 @@ struct
 
   let assoc_ops x l =
    try
-     snd (List.find (fun (x',y) -> x = Lazy.force x') l)
+     snd (List.find (fun (x',y) -> Constr.equal x (Lazy.force x')) l)
    with
      Not_found -> Ukn "Oups"
 
@@ -901,10 +910,7 @@ struct
 
   let parse_expr parse_constant parse_exp ops_spec env term =
     if debug
-    then (Pp.pp (Pp.str "parse_expr: ");
-          Pp.pp (Printer.prterm term);
-          Pp.pp (Pp.str "\n");
-          Pp.pp_flush ());
+    then Pp.msg_debug (Pp.str "parse_expr: " ++ Printer.prterm term);
 
 (*
     let constant_or_variable env term =
@@ -941,7 +947,7 @@ struct
                            let (expr,env) = parse_expr env args.(0) in
                            let power = (parse_exp expr args.(1)) in
                              (power  , env)
-			 with e when e <> Sys.Break ->
+			 with e when Errors.noncritical e ->
                            (* if the exponent is a variable *)
                            let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env)
                        end
@@ -994,9 +1000,9 @@ struct
   let rec rconstant term =
    match Term.kind_of_term term with
     | Const x ->
-        if term = Lazy.force coq_R0
+        if Constr.equal term (Lazy.force coq_R0)
         then Mc.C0
-        else if term = Lazy.force coq_R1
+        else if Constr.equal term (Lazy.force coq_R1)
         then Mc.C1
         else raise ParseError
     | App(op,args) -> 
@@ -1010,8 +1016,8 @@ struct
 	  with
 	      ParseError -> 
 		match op with
-		  | op when op = Lazy.force coq_Rinv -> Mc.CInv(rconstant args.(0))
-		  | op when op = Lazy.force coq_IQR  -> Mc.CQ (parse_q args.(0))
+		  | op when Constr.equal op (Lazy.force coq_Rinv) -> Mc.CInv(rconstant args.(0))
+		  | op when Constr.equal op (Lazy.force coq_IQR)  -> Mc.CQ (parse_q args.(0))
 (*		  | op when op = Lazy.force coq_IZR  -> Mc.CZ (parse_z args.(0))*)
 		  | _ ->  raise ParseError
 	end
@@ -1021,11 +1027,7 @@ struct
 
   let rconstant term = 
     if debug
-    then (Pp.pp_flush ();
-          Pp.pp (Pp.str "rconstant: ");
-          Pp.pp (Printer.prterm  term);
-          Pp.pp (Pp.str "\n");
-          Pp.pp_flush ());
+    then Pp.msg_debug (Pp.str "rconstant: " ++ Printer.prterm term ++ fnl ());
     let res = rconstant term in
       if debug then 
 	(Printf.printf "rconstant -> %a\n" pp_Rcst res ; flush stdout) ;
@@ -1063,26 +1065,22 @@ struct
         Mc.PEpow(expr,exp))
    rop_spec
 
-  let  parse_arith parse_op parse_expr env cstr =
+  let  parse_arith parse_op parse_expr env cstr gl =
    if debug
-   then (Pp.pp_flush ();
-         Pp.pp (Pp.str "parse_arith: ");
-         Pp.pp (Printer.prterm  cstr);
-         Pp.pp (Pp.str "\n");
-         Pp.pp_flush ());
+   then Pp.msg_debug (Pp.str "parse_arith: " ++ Printer.prterm  cstr ++ fnl ());
    match kind_of_term cstr with
     | App(op,args) ->
-       let (op,lhs,rhs) = parse_op (op,args) in
+       let (op,lhs,rhs) = parse_op gl (op,args) in
        let (e1,env) = parse_expr env lhs in
        let (e2,env) = parse_expr env rhs in
         ({Mc.flhs = e1; Mc.fop = op;Mc.frhs = e2},env)
     |  _ -> failwith "error : parse_arith(2)"
 
-  let parse_zarith = parse_arith  parse_zop parse_zexpr
+  let parse_zarith = parse_arith parse_zop parse_zexpr
 
-  let parse_qarith = parse_arith  parse_qop parse_qexpr
+  let parse_qarith = parse_arith parse_qop parse_qexpr
 
-  let parse_rarith = parse_arith  parse_rop parse_rexpr
+  let parse_rarith = parse_arith parse_rop parse_rexpr
 
   (* generic parsing of arithmetic expressions *)
 
@@ -1115,14 +1113,13 @@ struct
     * This is the big generic function for formula parsers.
     *)
   
-  let parse_formula parse_atom env tg term =
+  let parse_formula gl parse_atom env tg term =
 
     let parse_atom env tg t =
       try
-        let (at,env) = parse_atom env t in
+        let (at,env) = parse_atom env t gl in
         (A(at,tg,t), env,Tag.next tg)
-      with e when e <> Sys.Break -> (X(t),env,tg)
-    in
+      with e when Errors.noncritical e -> (X(t),env,tg) in
 
     let rec xparse_formula env tg term =
      match kind_of_term term with
@@ -1177,7 +1174,7 @@ struct
     | (e::l) ->
        let (name,expr,typ) = e in
         xset (Term.mkNamedLetIn
-               (Names.id_of_string name)
+               (Names.Id.of_string name)
                expr typ acc) l in
     xset concl l
 
@@ -1199,13 +1196,13 @@ let same_proof sg cl1 cl2 =
   match sg with
    | [] -> true
    | n::sg ->
-     (try List.nth cl1 n = List.nth cl2 n with e when e <> Sys.Break -> false)
+     (try Int.equal (List.nth cl1 n) (List.nth cl2 n) with Invalid_argument _ -> false)
       && (xsame_proof sg ) in
   xsame_proof sg
 
 let tags_of_clause tgs wit clause =
  let rec xtags tgs = function
-  | Mc.PsatzIn n -> Names.Idset.union tgs
+  | Mc.PsatzIn n -> Names.Id.Set.union tgs
      (snd (List.nth clause (CoqToCaml.nat n) ))
   | Mc.PsatzMulC(e,w) -> xtags tgs w
   | Mc.PsatzMulE (w1,w2) | Mc.PsatzAdd(w1,w2) -> xtags (xtags tgs w1) w2
@@ -1214,7 +1211,7 @@ let tags_of_clause tgs wit clause =
 
 (*let tags_of_cnf wits cnf =
  List.fold_left2 (fun acc w cl -> tags_of_clause acc w cl)
-  Names.Idset.empty wits cnf *)
+  Names.Id.Set.empty wits cnf *)
 
 let find_witness prover polys1 = try_any prover polys1
 
@@ -1263,7 +1260,7 @@ let btree_of_array typ a  =
 let btree_of_array typ a =
  try
   btree_of_array typ a
- with x when x <> Sys.Break ->
+ with x when Errors.noncritical x ->
   failwith (Printf.sprintf "btree of array : %s" (Printexc.to_string x))
 
 let dump_varmap typ env =
@@ -1324,24 +1321,24 @@ let rec pp_proof_term o = function
 	(pp_psatz pp_z) c1 (pp_psatz pp_z) c2
      (pp_list "[" "]" pp_proof_term) rst
 
-let rec parse_hyps parse_arith env tg hyps =
+let rec parse_hyps gl parse_arith env tg hyps =
  match hyps with
   | [] -> ([],env,tg)
   | (i,t)::l ->
-     let (lhyps,env,tg) = parse_hyps parse_arith env tg l in
+     let (lhyps,env,tg) = parse_hyps gl parse_arith env tg l in
       try
-       let (c,env,tg) = parse_formula parse_arith env  tg t in
+       let (c,env,tg) = parse_formula gl parse_arith env  tg t in
 	((i,c)::lhyps, env,tg)
-      with e when e <> Sys.Break -> 		(lhyps,env,tg)
+      with e when Errors.noncritical e -> (lhyps,env,tg)
        (*(if debug then Printf.printf "parse_arith : %s\n" x);*)
 
 
 (*exception ParseError*)
 
-let parse_goal parse_arith env hyps term =
+let parse_goal gl parse_arith env hyps term =
  (*  try*)
- let (f,env,tg) = parse_formula parse_arith env (Tag.from 0) term in
- let (lhyps,env,tg) = parse_hyps parse_arith env tg hyps in
+ let (f,env,tg) = parse_formula gl parse_arith env (Tag.from 0) term in
+ let (lhyps,env,tg) = parse_hyps gl parse_arith env tg hyps in
   (lhyps,f,env)
    (*  with Failure x -> raise ParseError*)
 
@@ -1385,22 +1382,31 @@ let rcst_domain_spec  = lazy {
   * witness.
   *)
 
-let micromega_order_change spec cert cert_typ env ff gl =
+
+
+let micromega_order_change spec cert cert_typ env ff : Tacmach.tactic = 
+ let ids = Util.List.map_i (fun i _ -> (Names.Id.of_string ("__z"^(string_of_int i)))) 0 env in 
  let formula_typ = (Term.mkApp (Lazy.force coq_Cstr,[|spec.coeff|])) in
- let ff = dump_formula formula_typ (dump_cstr spec.coeff spec.dump_coeff) ff in
+ let ff  = dump_formula formula_typ (dump_cstr spec.coeff spec.dump_coeff) ff in
  let vm = dump_varmap (spec.typ) env in
-  Tactics.change_in_concl None
+ (* todo : directly generate the proof term - or generalize befor conversion? *)
+ Tacticals.tclTHENSEQ [
+  (fun gl -> 
+   Proofview.V82.of_tactic (Tactics.change_concl
    (set
      [
       ("__ff", ff, Term.mkApp(Lazy.force coq_Formula, [|formula_typ |]));
       ("__varmap", vm, Term.mkApp
        (Coqlib.gen_constant_in_modules "VarMap"
-	 [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t", [|spec.typ|]));
+	 [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t", [|spec.typ|])); 
       ("__wit", cert, cert_typ)
      ]
-     (Tacmach.pf_concl gl)
-   )
-   gl
+     (Tacmach.pf_concl gl))) gl);
+  Tactics.generalize env ;
+  Tacticals.tclTHENSEQ (List.map (fun id -> Proofview.V82.of_tactic (Tactics.introduction id)) ids) ; 
+ ] 
+
+
 
 (**
   * The datastructures that aggregate prover attributes.
@@ -1476,7 +1482,7 @@ let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) =
           (pp_ml_list prover.pp_f) (List.map fst new_cl)   ;
           flush stdout
       end ; *)
-    let res = try prover.compact prf remap with x when x <> Sys.Break ->
+    let res = try prover.compact prf remap with x when Errors.noncritical x ->
       if debug then Printf.fprintf stdout "Proof compaction %s" (Printexc.to_string x) ;
       (* This should not happen -- this is the recovery plan... *)
       match prover.prover (List.map fst new_cl) with
@@ -1494,7 +1500,7 @@ let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) =
   let is_proof_compatible (old_cl:'cst clause) (prf,prover) (new_cl:'cst clause) =
     let hyps_idx = prover.hyps prf in
     let hyps = selecti hyps_idx old_cl in
-      is_sublist hyps new_cl in
+      is_sublist Pervasives.(=) hyps new_cl in
 
   let cnf_res = List.combine cnf_ff res in (* we get pairs clause * proof *)
 
@@ -1644,7 +1650,7 @@ let micromega_gen
   let concl = Tacmach.pf_concl gl in
   let hyps  = Tacmach.pf_hyps_types gl in
   try
-   let (hyps,concl,env) = parse_goal parse_arith Env.empty hyps concl in
+   let (hyps,concl,env) = parse_goal gl parse_arith Env.empty hyps concl in
    let env = Env.elements env in
    let spec = Lazy.force spec in
 
@@ -1658,8 +1664,6 @@ let micromega_gen
 		  (Term.mkApp(Lazy.force coq_list, [|spec.proof_typ|])) env ff'
 	      ]) gl
   with
-(*   | Failure x -> flush stdout ; Pp.pp_flush () ;
-      Tacticals.tclFAIL 0 (Pp.str x) gl *)
    | ParseError  -> Tacticals.tclFAIL 0 (Pp.str "Bad logical fragment") gl
    | CsdpNotFound -> flush stdout ; Pp.pp_flush () ;
       Tacticals.tclFAIL 0 (Pp.str 
@@ -1679,7 +1683,7 @@ let micromega_order_changer cert env ff gl =
  let formula_typ = (Term.mkApp (Lazy.force coq_Cstr,[| coeff|])) in
  let ff = dump_formula formula_typ (dump_cstr coeff dump_coeff) ff in
  let vm = dump_varmap (typ) env in
-  Tactics.change_in_concl None
+  Proofview.V82.of_tactic (Tactics.change_concl
    (set
      [
       ("__ff", ff, Term.mkApp(Lazy.force coq_Formula, [|formula_typ |]));
@@ -1689,7 +1693,7 @@ let micromega_order_changer cert env ff gl =
       ("__wit", cert, cert_typ)
      ]
      (Tacmach.pf_concl gl)
-   )
+   ))
    gl
 
 
@@ -1710,7 +1714,7 @@ let micromega_genr prover gl =
   let concl = Tacmach.pf_concl gl in
   let hyps  = Tacmach.pf_hyps_types gl in
   try
-   let (hyps,concl,env) = parse_goal parse_arith Env.empty hyps concl in
+   let (hyps,concl,env) = parse_goal gl parse_arith Env.empty hyps concl in
    let env = Env.elements env in
    let spec = Lazy.force spec in
 
@@ -1729,8 +1733,6 @@ let micromega_genr prover gl =
                 micromega_order_changer res' env (abstract_wrt_formula ff' ff)
               ]) gl
   with
-(*   | Failure x -> flush stdout ; Pp.pp_flush () ;
-      Tacticals.tclFAIL 0 (Pp.str x) gl *)
    | ParseError  -> Tacticals.tclFAIL 0 (Pp.str "Bad logical fragment") gl
    | CsdpNotFound -> flush stdout ; Pp.pp_flush () ;
       Tacticals.tclFAIL 0 (Pp.str 
@@ -1760,7 +1762,7 @@ open Persistent_cache
 
 module Cache = PHashtable(struct
   type t = (provername * micromega_polys)
-  let equal = (=)
+  let equal = Pervasives.(=)
   let hash  = Hashtbl.hash
 end)
 
@@ -1954,7 +1956,7 @@ let non_linear_prover_Z str o  = {
 
 module CacheZ = PHashtable(struct
   type t = (Mc.z Mc.pol * Mc.op1) list
-  let equal = (=)
+  let equal = Pervasives.(=)
   let hash  = Hashtbl.hash
 end)
 
diff --git a/plugins/micromega/csdpcert.ml b/plugins/micromega/csdpcert.ml
index b5c08300..b41f29c9 100644
--- a/plugins/micromega/csdpcert.ml
+++ b/plugins/micromega/csdpcert.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -12,13 +12,11 @@
 (*                                                                      *)
 (************************************************************************)
 
-open Big_int
 open Num
 open Sos
 open Sos_types
 open Sos_lib
 
-
 module Mc = Micromega
 module Ml2C = Mutils.CamlToCoq
 module C2Ml = Mutils.CoqToCaml
@@ -55,13 +53,12 @@ struct
 end
 open M
 
-open List
 open Mutils
 
 
 
 
-let rec canonical_sum_to_string = function s -> failwith "not implemented"
+let canonical_sum_to_string = function s -> failwith "not implemented"
 
 let print_canonical_sum m = Format.print_string (canonical_sum_to_string m)
 
@@ -122,7 +119,7 @@ let real_nonlinear_prover d l =
     match kd with
      | Axiom_lt i -> poly_mul p y
      | Axiom_eq i -> poly_mul (poly_pow p 2) y
-     |   _        -> failwith "monoids") m (poly_const (Int 1)) , map  snd m))
+     |   _        -> failwith "monoids") m (poly_const (Int 1)) , List.map snd m))
    (sets_of_list neq) in
 
   let (cert_ideal, cert_cone,monoid) = deepen_until d (fun d ->
@@ -130,10 +127,10 @@ let real_nonlinear_prover d l =
     real_positivnullstellensatz_general false d peq pge (poly_neg (fst m) ) in
 		      (ci,cc,snd m)) monoids) 0 in
 
-  let proofs_ideal = map2 (fun q i -> Eqmul(term_of_poly q,Axiom_eq i))
+  let proofs_ideal = List.map2 (fun q i -> Eqmul(term_of_poly q,Axiom_eq i))
    cert_ideal (List.map snd eq) in
 
-  let proofs_cone = map term_of_sos cert_cone in
+  let proofs_cone = List.map term_of_sos cert_cone in
 
   let proof_ne =
    let (neq , lt) = List.partition
@@ -150,7 +147,7 @@ let real_nonlinear_prover d l =
    S (Some proof)
  with
   | Sos_lib.TooDeep -> S None
-  | x when x <> Sys.Break -> F (Printexc.to_string x)
+  | any -> F (Printexc.to_string any)
 
 (* This is somewhat buggy, over Z, strict inequality vanish... *)
 let pure_sos  l =
@@ -159,8 +156,8 @@ let pure_sos  l =
  (* If there is no strict inequality,
     I should nonetheless be able to try something - over Z  > is equivalent to -1  >= *)
  try
-  let l = List.combine l (interval 0 (length l -1)) in
-  let (lt,i) =  try (List.find (fun (x,_) -> snd x =  Mc.Strict) l)
+  let l = List.combine l (interval 0 (List.length l -1)) in
+  let (lt,i) =  try (List.find (fun (x,_) -> Pervasives.(=) (snd x) Mc.Strict) l)
    with Not_found -> List.hd l in
   let plt = poly_neg (poly_of_term (expr_to_term (fst lt))) in
   let (n,polys) = sumofsquares plt in (* n * (ci * pi^2) *)
@@ -174,7 +171,7 @@ let pure_sos  l =
     S (Some proof)
  with
 (*   | Sos.CsdpNotFound -> F "Sos.CsdpNotFound" *)
-   | x when x <> Sys.Break -> (* May be that could be refined *) S None
+   | any -> (* May be that could be refined *) S None
 
 
 
diff --git a/plugins/micromega/g_micromega.ml4 b/plugins/micromega/g_micromega.ml4
index 4270d5bb..1ac44a42 100644
--- a/plugins/micromega/g_micromega.ml4
+++ b/plugins/micromega/g_micromega.ml4
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -14,65 +14,65 @@
 (*                                                                      *)
 (************************************************************************)
 
-(*i camlp4deps: "parsing/grammar.cma" i*)
+(*i camlp4deps: "grammar/grammar.cma" i*)
 
-open Quote
-open Ring
-open Mutils
-open Glob_term
-open Util
+open Errors
+open Misctypes
+
+DECLARE PLUGIN "micromega_plugin"
 
 let out_arg = function
-  | ArgVar _ -> anomaly "Unevaluated or_var variable"
+  | ArgVar _ -> anomaly (Pp.str "Unevaluated or_var variable")
   | ArgArg x -> x
 
 TACTIC EXTEND PsatzZ
-| [ "psatz_Z" int_or_var(i) ] -> [ Coq_micromega.psatz_Z (out_arg i) ]
-| [ "psatz_Z" ] -> [ Coq_micromega.psatz_Z (-1) ]
+| [ "psatz_Z" int_or_var(i) ] -> [ Proofview.V82.tactic (Coq_micromega.psatz_Z (out_arg i)) ]
+| [ "psatz_Z" ] -> [ Proofview.V82.tactic (Coq_micromega.psatz_Z (-1)) ]
 END
 
-TACTIC EXTEND ZOmicron
-[ "xlia"  ] -> [ Coq_micromega.xlia]
+TACTIC EXTEND Lia
+[ "xlia"  ] -> [  Proofview.V82.tactic (Coq_micromega.xlia) ]
 END
 
-TACTIC EXTEND Nlia
-[ "xnlia"  ] -> [ Coq_micromega.xnlia]
+TACTIC EXTEND Nia
+[ "xnlia"  ] -> [  Proofview.V82.tactic (Coq_micromega.xnlia) ]
 END
 
 
 
 TACTIC EXTEND Sos_Z
-| [ "sos_Z" ] -> [ Coq_micromega.sos_Z]
+| [ "sos_Z" ] -> [  Proofview.V82.tactic (Coq_micromega.sos_Z) ]
    END
 
 TACTIC EXTEND Sos_Q
-| [ "sos_Q" ] -> [ Coq_micromega.sos_Q]
+| [ "sos_Q" ] -> [  Proofview.V82.tactic (Coq_micromega.sos_Q) ]
    END
 
 TACTIC EXTEND Sos_R
-| [ "sos_R" ] -> [ Coq_micromega.sos_R]
+| [ "sos_R" ] -> [  Proofview.V82.tactic (Coq_micromega.sos_R) ]
 END
 
-
+(*
 TACTIC EXTEND Omicron
-[ "psatzl_Z"  ] -> [ Coq_micromega.psatzl_Z]
+[ "psatzl_Z"  ] -> [  Proofview.V82.tactic (Coq_micromega.psatzl_Z) ]
 END
+*)
 
-TACTIC EXTEND QOmicron
-[ "psatzl_Q"  ] -> [ Coq_micromega.psatzl_Q]
+TACTIC EXTEND LRA_Q
+[ "psatzl_Q"  ] -> [  Proofview.V82.tactic (Coq_micromega.psatzl_Q) ]
 END
 
-TACTIC EXTEND ROmicron
-[ "psatzl_R"  ] -> [ Coq_micromega.psatzl_R]
+TACTIC EXTEND LRA_R
+[ "psatzl_R"  ] -> [  Proofview.V82.tactic (Coq_micromega.psatzl_R) ]
 END
 
-TACTIC EXTEND RMicromega
-| [ "psatz_R" int_or_var(i) ] -> [ Coq_micromega.psatz_R (out_arg i) ]
-| [ "psatz_R" ] -> [ Coq_micromega.psatz_R (-1) ]
+TACTIC EXTEND PsatzR
+| [ "psatz_R" int_or_var(i) ] -> [  Proofview.V82.tactic (Coq_micromega.psatz_R (out_arg i)) ]
+| [ "psatz_R" ] -> [  Proofview.V82.tactic (Coq_micromega.psatz_R (-1)) ]
 END
 
-TACTIC EXTEND QMicromega
-| [ "psatz_Q" int_or_var(i) ] -> [ Coq_micromega.psatz_Q (out_arg i) ]
-| [ "psatz_Q" ] -> [ Coq_micromega.psatz_Q (-1) ]
+TACTIC EXTEND PsatzQ
+| [ "psatz_Q" int_or_var(i) ] -> [ Proofview.V82.tactic (Coq_micromega.psatz_Q (out_arg i)) ]
+| [ "psatz_Q" ] -> [ Proofview.V82.tactic (Coq_micromega.psatz_Q (-1)) ]
 END
 
diff --git a/plugins/micromega/mfourier.ml b/plugins/micromega/mfourier.ml
index 6effa4c4..88c1a783 100644
--- a/plugins/micromega/mfourier.ml
+++ b/plugins/micromega/mfourier.ml
@@ -3,13 +3,14 @@ module Utils = Mutils
 open Polynomial
 open Vect
 
-
 let map_option = Utils.map_option
 let from_option = Utils.from_option
 
 let debug = false
 type ('a,'b) lr = Inl of 'a | Inr of 'b
 
+let compare_float (p : float) q = Pervasives.compare p q
+
 (** Implementation of intervals *)
 module Itv =
 struct
@@ -18,10 +19,10 @@ struct
   type interval = num option * num option
       (** None models the absence of bound i.e. infinity *)
       (** As a result,
-	  - None , None   -> ]-oo,+oo[
-	  - None , Some v -> ]-oo,v]
-	  - Some v, None  -> [v,+oo[
-	  - Some v, Some v' -> [v,v']
+	  - None , None   -> \]-oo,+oo\[
+	  - None , Some v -> \]-oo,v\]
+	  - Some v, None  -> \[v,+oo\[
+	  - Some v, Some v' -> \[v,v'\]
       Intervals needs to be explicitely normalised.
       *)
 
@@ -89,7 +90,7 @@ type vector = Vect.t
     {coeffs = v ; bound = (l,r) } models the constraints l <= v <= r
 **)
 
-module ISet = Set.Make(struct type t = int let compare = Pervasives.compare end)
+module ISet = Set.Make(Int)
 
 
 module PSet = ISet
@@ -116,7 +117,7 @@ and cstr_info = {
 }
 
 
-(** A system of constraints has the form [{sys = s ; vars = v}].
+(** A system of constraints has the form [\{sys = s ; vars = v\}].
     [s] is a hashtable mapping a normalised vector to a [cstr_info] record where
     - [bound] is an interval
     - [prf_idx] is the set of hypothese indexes (i.e. constraints in the initial system) used to obtain the current constraint.
@@ -195,7 +196,7 @@ let pp_split_cstr o (vl,v,c,_) =
 let merge_cstr_info i1 i2 =
   let { pos = p1 ; neg = n1 ; bound = i1 ; prf = prf1 } = i1
   and { pos = p2 ; neg = n2 ; bound = i2 ; prf = prf2 } = i2 in
-    assert (p1 = p2 && n1 = n2) ;
+    assert (Int.equal p1 p2 && Int.equal n1 n2) ;
     match inter i1 i2 with
       | None -> None (* Could directly raise a system contradiction exception *)
       | Some bnd ->
@@ -207,7 +208,7 @@ let merge_cstr_info i1 i2 =
 *)
 
 let xadd_cstr vect cstr_info sys =
-  if debug && System.length sys mod 1000 = 0 then (print_string "*" ; flush stdout) ;
+  if debug && Int.equal (System.length sys mod 1000) 0 then (print_string "*" ; flush stdout) ;
   try
     let info = System.find sys vect in
       match merge_cstr_info cstr_info !info with
@@ -235,7 +236,7 @@ let normalise_cstr vect cinfo =
 	  | (_,n)::_ ->  Cstr(
 	      (if n <>/ Int 1 then List.map (fun (x,nx) -> (x,nx // n)) vect else vect),
 			     let divn x = x // n in
-			       if sign_num n = 1
+			       if Int.equal (sign_num n) 1
 			       then{cinfo with bound = (map_option divn l , map_option  divn r) }
 			       else {cinfo with pos = cinfo.neg ; neg = cinfo.pos ; bound = (map_option divn r , map_option divn l)})
 
@@ -252,7 +253,7 @@ let count v =
       | [] -> (n,p)
       | (_,vl)::v -> let sg = sign_num vl in
 		       assert (sg <> 0) ;
-	  if sg = 1 then count n (p+1) v else count (n+1) p v in
+	  if Int.equal sg 1 then count n (p+1) v else count (n+1) p v in
     count 0 0 v
 
 
@@ -304,7 +305,7 @@ let add (v1,c1)  (v2,c2)  =
   let rec xadd v1 v2  =
     match v1 , v2 with
       | (x1,n1)::v1' , (x2,n2)::v2' ->
-	  if x1 = x2
+	  if Int.equal x1 x2
 	  then
 	    let n' = (n1 // c1) +/ (n2 // c2) in
 	      if n' =/ Int 0 then xadd v1' v2'
@@ -352,7 +353,7 @@ let split x (vect: vector) info (l,m,r) =
               | Some bnd -> (vl,vect,{info with bound = Some bnd,None})::lst in
 
           let lb,rb = info.bound in
-            if sign_num vl = 1
+            if Int.equal (sign_num vl) 1
             then  (cons_bound l lb,m,cons_bound r rb)
             else (* sign_num vl = -1 *)
               (cons_bound l rb,m,cons_bound r lb)
@@ -437,7 +438,7 @@ let elim_var_using_eq vr vect cst  prf sys =
 (** [size sys] computes the number of entries in the system of constraints *)
 let size sys = System.fold (fun v iref s -> s + (!iref).neg + (!iref).pos) sys 0
 
-module IMap = Map.Make(struct type t = int let compare : int -> int -> int = Pervasives.compare end)
+module IMap = Map.Make(Int)
 
 let pp_map o map = IMap.fold (fun k elt () -> Printf.fprintf o "%i -> %s\n" k (string_of_num elt)) map ()
 
@@ -498,7 +499,7 @@ let pick_small_value bnd =
 	then ceiling_num i (* why not *) else i
 
 
-(** [solution s1 sys_l  = Some(sn,[(vn-1,sn-1);...; (v1,s1)]@sys_l)]
+(** [solution s1 sys_l  = Some(sn,\[(vn-1,sn-1);...; (v1,s1)\]\@sys_l)]
     then [sn] is a  system which contains only [black_v] -- if it existed in [s1]
     and [sn+1] is obtained by projecting [vn] out of [sn]
     @raise SystemContradiction if  system [s] has no solution
@@ -556,7 +557,7 @@ struct
             match  l1 with
             | [] -> xpart rl (([],info)::ltl) n (info.neg+info.pos+z) p
             | (vr,vl)::rl1 ->
-		if v = vr
+		if Int.equal v vr
 		then
 		  let cons_bound lst bd =
 		    match  bd with
@@ -564,7 +565,7 @@ struct
 		      | Some bnd -> info.neg+info.pos::lst in
 
 		  let lb,rb = info.bound in
-		    if sign_num vl = 1
+		    if Int.equal (sign_num vl) 1
 		    then  xpart rl ((rl1,info)::ltl) (cons_bound n lb) z (cons_bound p rb)
 		    else  xpart rl ((rl1,info)::ltl) (cons_bound n rb) z (cons_bound p lb)
 		else
@@ -590,7 +591,7 @@ struct
       (ISet.fold (fun v (eval,s) -> let ts,vl = abstract_partition v s  in
                                       ((v,vl)::eval, ts)) v ([],sl)) in
 
-      List.sort (fun x y -> Pervasives.compare (snd x) (snd y) ) evals
+      List.sort (fun x y -> compare_float (snd x) (snd y) ) evals
 
 
 end
@@ -615,7 +616,7 @@ struct
   let rec unroll_until v l =
     match l with
       | [] -> (false,[])
-      | (i,_)::rl -> if i = v
+      | (i,_)::rl -> if Int.equal i v
 	then (true,rl)
 	else if i < v then unroll_until v rl else (false,l)
 
@@ -632,7 +633,7 @@ struct
 
   let choose_primal_equation eqs sys_l =
 
-    (* Counts the number of equations refering to variable [v] --
+    (* Counts the number of equations referring to variable [v] --
        It looks like nb_cst is dead...
     *)
     let is_primal_equation_var v =
@@ -646,7 +647,7 @@ struct
 	| [] -> None
 	| (i,_)::vect ->
 	    let nb_eq = is_primal_equation_var i in
-	      if nb_eq = 2 
+	      if Int.equal nb_eq 2 
 	      then Some i else find_var vect in
 
     let rec find_eq_var eqs =
@@ -704,7 +705,7 @@ struct
 
 	      (*      pp_list (fun o ((v,eq,_,_),cst) -> Printf.fprintf o "((%i,%a),%i)\n" v pp_vect eq cst) stdout all_costs ; *)
 
-	      List.sort (fun x y -> Pervasives.compare (snd x) (snd y) ) all_costs
+	      List.sort (fun x y -> Int.compare (snd x) (snd y) ) all_costs
 	| Some (v,vect, const,prf,_) -> [(v,vect,const,prf),0]
 
 
@@ -727,9 +728,9 @@ struct
 	| Inl (s,_) ->
 	    try
 	      Some (bound_of_variable IMap.empty fresh s.sys)
-	    with
-	      x when x <> Sys.Break ->
-                Printf.printf "optimise Exception : %s" (Printexc.to_string x) ; None
+	    with x when Errors.noncritical x ->
+	      Printf.printf "optimise Exception : %s" (Printexc.to_string x);
+              None
 
 
   let find_point cstrs =
@@ -793,18 +794,18 @@ struct
       match Vect.get v v1 , Vect.get v v2 with
         | None , _ | _ , None -> None
         | Some a   , Some b   ->
-            if (sign_num a) * (sign_num b) = -1
+            if Int.equal ((sign_num a) * (sign_num b)) (-1)
             then 
 	      Some (add (p1,abs_num a) (p2,abs_num b) ,
                       {coeffs = add (v1,abs_num a) (v2,abs_num b) ;
                        op = add_op op1 op2 ;
                        cst = n1 // (abs_num a) +/ n2 // (abs_num b) })
-            else if op1 = Eq
+            else if op1 == Eq
             then Some (add (p1,minus_num (a // b)) (p2,Int 1),
                       {coeffs = add (v1,minus_num (a// b)) (v2 ,Int 1) ;
                        op     = add_op op1 op2;
                        cst    = n1 // (minus_num (a// b)) +/ n2 // (Int 1)})
-            else if op2 = Eq
+            else if op2 == Eq
 	    then
 	      Some (add (p2,minus_num (b // a)) (p1,Int 1),
                    {coeffs = add (v2,minus_num (b// a)) (v1 ,Int 1) ;
diff --git a/plugins/micromega/micromega.ml b/plugins/micromega/micromega.ml
index 564126d2..0537cdbe 100644
--- a/plugins/micromega/micromega.ml
+++ b/plugins/micromega/micromega.ml
@@ -1499,7 +1499,7 @@ module N =
   
   (** val eqb : n -> n -> bool **)
   
-  let rec eqb n0 m =
+  let eqb n0 m =
     match n0 with
     | N0 ->
       (match m with
@@ -1693,7 +1693,7 @@ module N =
   
   (** val ldiff : n -> n -> n **)
   
-  let rec ldiff n0 m =
+  let ldiff n0 m =
     match n0 with
     | N0 -> N0
     | Npos p ->
@@ -2205,7 +2205,7 @@ module Z =
   
   (** val eqb : z -> z -> bool **)
   
-  let rec eqb x y =
+  let eqb x y =
     match x with
     | Z0 ->
       (match y with
diff --git a/plugins/micromega/mutils.ml b/plugins/micromega/mutils.ml
index 7f0dce04..a07cbec6 100644
--- a/plugins/micromega/mutils.ml
+++ b/plugins/micromega/mutils.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -31,7 +31,7 @@ let finally f rst =
       rst () ; res
   with reraise ->
     (try rst ()
-    with any  -> raise reraise
+    with any -> raise reraise
     ); raise reraise
 
 let map_option f x =
@@ -72,15 +72,15 @@ let rec map3 f l1 l2 l3 =
   match l1 , l2 ,l3 with
     | [] , [] , [] -> []
     | e1::l1 , e2::l2 , e3::l3 -> (f e1 e2 e3)::(map3 f l1 l2 l3)
-    |      _   -> raise (Invalid_argument "map3")
+    |      _   -> invalid_arg "map3"
 
-let rec is_sublist l1 l2 =
+let rec is_sublist f l1 l2 =
   match l1 ,l2 with
     | [] ,_ -> true
     | e::l1', [] -> false
     | e::l1' , e'::l2' ->
-	if e = e' then is_sublist l1' l2'
-	else is_sublist l1 l2'
+	if f e e' then is_sublist f l1' l2'
+	else is_sublist f l1 l2'
 
 let list_try_find f =
   let rec try_find_f = function
@@ -89,7 +89,7 @@ let list_try_find f =
   in
   try_find_f
 
-let rec list_fold_right_elements f l =
+let list_fold_right_elements f l =
   let rec aux = function
     | [] -> invalid_arg "list_fold_right_elements"
     | [x] -> x
@@ -142,9 +142,9 @@ let rec rec_gcd_list c l  =
   | [] -> c
   | e::l -> rec_gcd_list (gcd_big_int  c (numerator e)) l
 
-let rec gcd_list l =
+let gcd_list l =
  let res = rec_gcd_list zero_big_int l in
-  if compare_big_int res zero_big_int = 0
+  if Int.equal (compare_big_int res zero_big_int) 0
   then unit_big_int else res
 
 let rats_to_ints l =
@@ -192,7 +192,7 @@ let  select_pos lpos l =
       match l with
        | []   -> failwith "select_pos"
        | e::l ->
-	  if i = j
+	  if Int.equal i j
 	  then e:: (xselect (i+1) rpos l)
 	  else xselect (i+1) lpos l in
   xselect 0 lpos l
@@ -269,19 +269,19 @@ struct
 
 
  let rec positive n =
-  if n=1 then XH
-  else if n land 1 = 1 then XI (positive (n lsr 1))
+  if Int.equal n 1 then XH
+  else if Int.equal (n land 1) 1 then XI (positive (n lsr 1))
   else  XO (positive (n lsr 1))
 
  let n nt =
   if nt < 0
   then assert false
-  else if nt = 0 then N0
+  else if Int.equal nt 0 then N0
   else Npos (positive nt)
 
  let rec index  n =
-  if n=1 then XH
-  else if n land 1 = 1 then XI (index (n lsr 1))
+  if Int.equal n 1 then XH
+  else if Int.equal (n land 1) 1 then XI (index (n lsr 1))
   else  XO (index (n lsr 1))
 
 
@@ -289,8 +289,8 @@ struct
   (*a.k.a path_of_int *)
   (* returns the list of digits of n in reverse order with initial 1 removed *)
   let rec digits_of_int n =
-   if n=1 then []
-   else (n mod 2 = 1)::(digits_of_int (n lsr 1))
+   if Int.equal n 1 then []
+   else (Int.equal (n mod 2) 1)::(digits_of_int (n lsr 1))
   in
    List.fold_right
     (fun b c -> (if b then XI c else XO c))
@@ -342,7 +342,7 @@ struct
    | [] -> 0 (* Equal *)
    | f::l ->
       let cmp = f () in
-       if cmp = 0 then compare_lexical l else cmp
+       if Int.equal cmp 0 then compare_lexical l else cmp
 
  let rec compare_list cmp l1 l2 =
   match l1 , l2 with
@@ -351,7 +351,7 @@ struct
    | _   , [] -> 1
    | e1::l1 , e2::l2 ->
       let c = cmp e1 e2 in
-       if c = 0 then compare_list cmp l1 l2 else c
+       if Int.equal c 0 then compare_list cmp l1 l2 else c
 
 (**
   * hash_list takes a hash function and a list, and computes an integer which
@@ -393,7 +393,7 @@ struct
   let from i = i
   let next i = i + 1
   let pp o i = output_string o (string_of_int i)
-  let compare : int -> int -> int = Pervasives.compare
+  let compare : int -> int -> int = Int.compare
 
 end
 
@@ -403,6 +403,12 @@ end
 
 module TagSet = Set.Make(Tag)
 
+(** As for Unix.close_process, our Unix.waipid will ignore all EINTR *)
+
+let rec waitpid_non_intr pid =
+  try snd (Unix.waitpid [] pid)
+  with Unix.Unix_error (Unix.EINTR, _, _) -> waitpid_non_intr pid
+
 (**
   * Forking routine, plumbing the appropriate pipes where needed.
   *)
@@ -422,25 +428,33 @@ let command exe_path args vl =
     flush outch ;
 
   (* Wait for its completion *)
-    let _pid,status = Unix.waitpid [] pid in
+    let status = waitpid_non_intr pid in
 
       finally
         (* Recover the result *)
 	(fun () ->
 	  match status with
 	    | Unix.WEXITED 0 ->
-		let inch  = Unix.in_channel_of_descr stdout_read in
-		  begin try Marshal.from_channel inch 
-                        with x when x <> Sys.Break ->
-                          failwith (Printf.sprintf "command \"%s\" exited %s" exe_path (Printexc.to_string x))
-                  end
-	    | Unix.WEXITED i   -> failwith (Printf.sprintf "command \"%s\" exited %i" exe_path i)
-	    | Unix.WSIGNALED i -> failwith (Printf.sprintf "command \"%s\" killed %i" exe_path i)
-	    | Unix.WSTOPPED i  -> failwith (Printf.sprintf "command \"%s\" stopped %i" exe_path i))
+		let inch = Unix.in_channel_of_descr stdout_read in
+		begin
+                  try Marshal.from_channel inch
+                  with any ->
+                    failwith
+                      (Printf.sprintf "command \"%s\" exited %s" exe_path
+                         (Printexc.to_string any))
+                end
+	    | Unix.WEXITED i   ->
+                failwith (Printf.sprintf "command \"%s\" exited %i" exe_path i)
+	    | Unix.WSIGNALED i ->
+                failwith (Printf.sprintf "command \"%s\" killed %i" exe_path i)
+	    | Unix.WSTOPPED i  ->
+                failwith (Printf.sprintf "command \"%s\" stopped %i" exe_path i))
         (* Cleanup  *)
 	(fun () ->
-	  List.iter (fun x -> try Unix.close x with e when e <> Sys.Break -> ())
-            [stdin_read; stdin_write; stdout_read; stdout_write; stderr_read; stderr_write])
+	  List.iter (fun x -> try Unix.close x with any -> ())
+            [stdin_read; stdin_write;
+             stdout_read; stdout_write;
+             stderr_read; stderr_write])
 
 (* Local Variables: *)
 (* coding: utf-8 *)
diff --git a/plugins/micromega/persistent_cache.ml b/plugins/micromega/persistent_cache.ml
index 2465617a..2dc0d003 100644
--- a/plugins/micromega/persistent_cache.ml
+++ b/plugins/micromega/persistent_cache.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,11 +8,10 @@
 (*                                                                      *)
 (*  A persistent hashtable                                              *)
 (*                                                                      *)
-(*  Frédéric Besson (Inria Rennes) 2009-2011                            *)
+(*  Frédéric Besson (Inria Rennes) 2009-2014                            *)
 (*                                                                      *)
 (************************************************************************)
 
-
 module type PHashtable =
   sig
     type 'a t
@@ -84,7 +83,7 @@ let finally f rst =
       rst () ; res
   with reraise ->
     (try rst ()
-    with any  -> raise reraise
+    with any -> raise reraise
     ); raise reraise
 
 
@@ -93,26 +92,52 @@ let read_key_elem inch =
     Some (Marshal.from_channel inch)
   with
     | End_of_file -> None
-    | e when e <> Sys.Break -> raise InvalidTableFormat
-
-(** In win32, it seems that we should unlock the exact zone
-    that has been locked, and not the whole file *)
+    | e when Errors.noncritical e -> raise InvalidTableFormat
+
+(** 
+    We used to only lock/unlock regions.
+    Is-it more robust/portable to lock/unlock a fixed region e.g. [0;1]?  
+    In case of locking failure, the cache is not used.
+**)
+
+type lock_kind = Read | Write
+
+let lock kd fd = 
+ let pos = lseek fd 0 SEEK_CUR in 
+ let success   = 
+  try 
+   ignore (lseek fd 0 SEEK_SET);
+   let lk =  match kd with 
+    | Read  -> F_RLOCK 
+    | Write -> F_LOCK in  
+   lockf fd lk 1; true
+  with Unix.Unix_error(_,_,_) -> false in
+ ignore (lseek fd pos SEEK_SET) ; 
+ success
+
+let unlock fd = 
+  let pos = lseek fd 0 SEEK_CUR in
+  try 
+   ignore (lseek fd 0 SEEK_SET) ; 
+   lockf fd F_ULOCK 1
+  with 
+   Unix.Unix_error(_,_,_) -> ()    
+    (* Here, this is really bad news -- 
+       there is a pending lock which could cause a deadlock.
+       Should it be an anomaly or produce a warning ?
+    *);
+  ignore (lseek fd pos SEEK_SET) 
 
-let locked_start = ref 0
 
-let lock fd =
-  locked_start := lseek fd 0 SEEK_CUR;
-  lockf fd F_LOCK 0
+(* We make the assumption that an acquired lock can always be released *)
 
-let rlock fd =
-  locked_start := lseek fd 0 SEEK_CUR;
-  lockf fd F_RLOCK 0
+let do_under_lock kd fd f = 
+ if lock kd fd
+ then
+  finally f (fun () -> unlock fd)
+ else f ()
+  
 
-let unlock fd =
-  let pos = lseek fd 0 SEEK_CUR in
-  ignore (lseek fd !locked_start SEEK_SET);
-  lockf fd F_ULOCK 0;
-  ignore (lseek fd pos SEEK_SET)
 
 let open_in f =
   let flags = [O_RDONLY ; O_CREAT] in
@@ -128,37 +153,30 @@ let open_in f =
 	  xload () in
     try
       (* Locking of the (whole) file while reading *)
-      rlock finch;
-      finally 
-	(fun () -> xload () ) 
-	(fun () -> 
-	   unlock finch ;
-	   close_in_noerr inch ; 
-	) ;
+      do_under_lock Read finch xload ; 
+      close_in_noerr inch ; 
       {
-	outch = out_channel_of_descr (openfile f [O_WRONLY;O_APPEND;O_CREAT] 0o666) ;
-	status = Open ;
-	htbl = htbl
+       outch = out_channel_of_descr (openfile f [O_WRONLY;O_APPEND;O_CREAT] 0o666) ;
+       status = Open ;
+       htbl = htbl
       }
     with InvalidTableFormat ->
-      (* Try to keep as many entries as possible *)
-      begin
-	let flags = [O_WRONLY; O_TRUNC;O_CREAT] in
-	let out =  (openfile f flags 0o666) in
-	let outch = out_channel_of_descr out in
-	  lock out;
-	  (try 
-	    Table.iter 
-	      (fun k e -> Marshal.to_channel outch (k,e) [Marshal.No_sharing]) htbl;
-	    flush outch ; 
-	  with e when e <> Sys.Break -> () )
-	    ;
-	    unlock out ; 
-	    { outch = outch ;
-	      status = Open ;
-	      htbl   = htbl
-	    }
-      end
+     (* The file is corrupted *)
+     begin
+      close_in_noerr inch ;
+      let flags = [O_WRONLY; O_TRUNC;O_CREAT] in
+      let out =  (openfile f flags 0o666) in
+      let outch = out_channel_of_descr out in
+      do_under_lock Write out 
+       (fun () -> 
+	Table.iter 
+	  (fun k e -> Marshal.to_channel outch (k,e) [Marshal.No_sharing]) htbl;
+        flush outch) ; 
+      { outch = outch ;
+        status = Open ;
+        htbl   = htbl
+      }
+     end
 
 
 let close t =
@@ -172,22 +190,22 @@ let close t =
 
 let add t k e =
   let {outch = outch ; status = status ; htbl = tbl} = t in
-    if status = Closed
+    if status == Closed
     then raise UnboundTable
     else
       let fd = descr_of_out_channel outch in
       begin
-	Table.add tbl k e ;
-	lock fd;
-	ignore (lseek fd 0 SEEK_END);
-	Marshal.to_channel outch (k,e) [Marshal.No_sharing] ;
-	flush outch ;
-	unlock fd
+       Table.add tbl k e ;
+       do_under_lock Write fd 
+        (fun _ -> 
+         Marshal.to_channel outch (k,e) [Marshal.No_sharing] ;
+         flush outch
+        )
       end
 
 let find t k =
   let {outch = outch ; status = status ; htbl = tbl} = t in
-    if status = Closed
+    if status == Closed
     then raise UnboundTable
     else
       let res = Table.find tbl k in
diff --git a/plugins/micromega/polynomial.ml b/plugins/micromega/polynomial.ml
index 9372cb66..b8b42a3f 100644
--- a/plugins/micromega/polynomial.ml
+++ b/plugins/micromega/polynomial.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -44,7 +44,7 @@ end
  =
 struct
  (* A monomial is represented by a multiset of variables  *)
- module Map = Map.Make(struct type t = var let compare = Pervasives.compare end)
+ module Map = Map.Make(Int)
  open Map
  
  type t = int Map.t
@@ -65,8 +65,8 @@ struct
    fun m1 m2 -> 
      let s1 = sum_degree m1 
      and s2 = sum_degree m2 in
-       if s1 = s2 then Map.compare Pervasives.compare m1 m2
-       else Pervasives.compare s1 s2
+       if Int.equal s1 s2 then Map.compare Int.compare m1 m2
+       else Int.compare s1 s2
 
  let is_const m = (m = Map.empty)
   
@@ -218,7 +218,7 @@ struct
 
  let fold = P.fold
 
- let is_null p = fold (fun mn vl b -> b & sign_num vl = 0) p  true
+ let is_null p = fold (fun mn vl b -> b && sign_num vl = 0) p  true
 
  let compare = compare compare_num
 
@@ -241,8 +241,7 @@ module Vect =
     type var = int
     type t = (var * num) list
 
-(** [equal v1 v2 = true] if the vectors are syntactically equal.
-    ([num] is not handled by  [Pervasives.equal] *)
+(** [equal v1 v2 = true] if the vectors are syntactically equal. *)
 
     let rec equal v1 v2 =
       match v1 , v2 with
@@ -250,7 +249,7 @@ module Vect =
 	| [] , _    -> false
 	| _::_ , [] -> false
 	| (i1,n1)::v1 , (i2,n2)::v2 ->
-	    (i1 = i2) && n1 =/ n2 && equal v1 v2
+	    (Int.equal i1 i2) && n1 =/ n2 && equal v1 v2
 
     let hash v =
       let rec hash i = function
@@ -294,7 +293,7 @@ module Vect =
       match t with
 	| [] -> cons i (f zero_num) []
 	| (k,v)::l ->
-	    match Pervasives.compare i k with
+	    match Int.compare i k with
 	  | 0 -> cons k (f v) l
 	  | -1 -> cons i (f zero_num) t
 	  |  1 -> (k,v) ::(update i f l)
@@ -304,7 +303,7 @@ module Vect =
       match t with
 	| [] -> cons i n []
 	| (k,v)::l ->
-	    match Pervasives.compare i k with
+	    match Int.compare i k with
 	      | 0 -> cons k n l
 	      | -1 -> cons i n t
 	      |  1 -> (k,v) :: (set i n l)
@@ -315,7 +314,7 @@ module Vect =
 	if Big_int.compare_big_int res Big_int.zero_big_int = 0
 	then Big_int.unit_big_int else res
 
-    let rec mul z t =
+    let mul z t =
       match z with
 	| Int 0 -> []
 	| Int 1 -> t
@@ -346,7 +345,7 @@ module Vect =
 
     let compare : t -> t -> int = Utils.Cmp.compare_list (fun x y -> Utils.Cmp.compare_lexical
       [
-	(fun () -> Pervasives.compare (fst x) (fst y));
+	(fun () -> Int.compare (fst x) (fst y));
 	(fun () -> compare_num (snd x) (snd y))])
 
     (** [tail v vect] returns
@@ -359,7 +358,7 @@ module Vect =
       match vect with
 	| [] -> None
 	| (v',vl)::vect' ->
-	    match Pervasives.compare v' v with
+	    match Int.compare v' v with
 	      | 0 -> Some (vl,vect) (* Ok, found *)
 	      | -1 -> tail v vect' (* Might be in the tail *)
 	      | _  -> None (* Hopeless *)
@@ -585,7 +584,7 @@ struct
   module MonT = 
   struct
     module MonoMap = Map.Make(Monomial)
-    module IntMap  = Map.Make(struct type t = int let compare = Pervasives.compare end)
+    module IntMap  = Map.Make(Int)
 	  
     (** A hash table might be preferable but requires a hash function. *)
     let (index_of_monomial : int MonoMap.t ref) = ref (MonoMap.empty)
@@ -615,7 +614,7 @@ struct
   end 
 
   let normalise (v,c) = 
-    (List.sort  (fun x y -> Pervasives.compare (fst x) (fst y)) v , c)
+    (List.sort  (fun x y -> Int.compare (fst x) (fst y)) v , c)
 
 
   let output_mon o (x,v) = 
diff --git a/plugins/micromega/sos.ml b/plugins/micromega/sos.ml
index 6ddc48e7..cc89e2b9 100644
--- a/plugins/micromega/sos.ml
+++ b/plugins/micromega/sos.ml
@@ -1,16 +1,15 @@
 (* ========================================================================= *)
 (* - This code originates from John Harrison's HOL LIGHT 2.30                *)
 (*   (see file LICENSE.sos for license, copyright and disclaimer)            *)
-(* - Laurent Théry (thery@sophia.inria.fr) has isolated the HOL              *)
+(* - Laurent Théry (thery@sophia.inria.fr) has isolated the HOL              *)
 (*   independent bits                                                        *)
-(* - Frédéric Besson (fbesson@irisa.fr) is using it to feed  micromega       *)
+(* - Frédéric Besson (fbesson@irisa.fr) is using it to feed  micromega       *)
 (* ========================================================================= *)
 
 (* ========================================================================= *)
 (* Nonlinear universal reals procedure using SOS decomposition.              *)
 (* ========================================================================= *)
 open Num;;
-open List;;
 open Sos_types;;
 open Sos_lib;;
 
@@ -40,7 +39,7 @@ let decimalize =
     let z = pow10(-e) */ y +/ Int 1 in
     let k = round_num(pow10 d */ z) in
     (if x </ Int 0 then "-0." else "0.") ^
-    implode(tl(explode(string_of_num k))) ^
+    implode(List.tl(explode(string_of_num k))) ^
     (if e = 0 then "" else "e"^string_of_int e);;
 
 (* ------------------------------------------------------------------------- *)
@@ -123,7 +122,7 @@ let vector_dot (v1:vector) (v2:vector) =
         (combine ( */ ) (fun x -> x =/ Int 0) (snd v1) (snd v2));;
 
 let vector_of_list l =
-  let n = length l in
+  let n = List.length l in
   (n,itlist2 (|->) (1--n) l undefined :vector);;
 
 (* ------------------------------------------------------------------------- *)
@@ -176,9 +175,9 @@ let diagonal (v:vector) =
   ((n,n),foldl (fun a i c -> ((i,i) |-> c) a) undefined (snd v) : matrix);;
 
 let matrix_of_list l =
-  let m = length l in
+  let m = List.length l in
   if m = 0 then matrix_0 (0,0) else
-  let n = length (hd l) in
+  let n = List.length (List.hd l) in
   (m,n),itern 1 l (fun v i -> itern 1 v (fun c j -> (i,j) |-> c)) undefined;;
 
 (* ------------------------------------------------------------------------- *)
@@ -201,11 +200,11 @@ let monomial_pow (m:monomial) k =
   else mapf (fun x -> k * x) m;;
 
 let monomial_divides (m1:monomial) (m2:monomial) =
-  foldl (fun a x k -> tryapplyd m2 x 0 >= k & a) true m1;;
+  foldl (fun a x k -> tryapplyd m2 x 0 >= k && a) true m1;;
 
 let monomial_div (m1:monomial) (m2:monomial) =
   let m = combine (+) (fun x -> x = 0) m1 (mapf (fun x -> -x) m2) in
-  if foldl (fun a x k -> k >= 0 & a) true m then m
+  if foldl (fun a x k -> k >= 0 && a) true m then m
   else failwith "monomial_div: non-divisible";;
 
 let monomial_degree x (m:monomial) = tryapplyd m x 0;;
@@ -227,7 +226,7 @@ let eval assig (p:poly) =
 
 let poly_0 = (undefined:poly);;
 
-let poly_isconst (p:poly) = foldl (fun a m c -> m = monomial_1 & a) true p;;
+let poly_isconst (p:poly) = foldl (fun a m c -> m = monomial_1 && a) true p;;
 
 let poly_var x = ((monomial_var x) |=> Int 1 :poly);;
 
@@ -283,13 +282,13 @@ let poly_variables (p:poly) =
 (* Order monomials for human presentation.                                   *)
 (* ------------------------------------------------------------------------- *)
 
-let humanorder_varpow (x1,k1) (x2,k2) = x1 < x2 or x1 = x2 & k1 > k2;;
+let humanorder_varpow (x1,k1) (x2,k2) = x1 < x2 or x1 = x2 && k1 > k2;;
 
 let humanorder_monomial =
   let rec ord l1 l2 = match (l1,l2) with
     _,[] -> true
   | [],_ -> false
-  | h1::t1,h2::t2 -> humanorder_varpow h1 h2 or h1 = h2 & ord t1 t2 in
+  | h1::t1,h2::t2 -> humanorder_varpow h1 h2 or h1 = h2 && ord t1 t2 in
   fun m1 m2 -> m1 = m2 or
                ord (sort humanorder_varpow (graph m1))
                    (sort humanorder_varpow (graph m2));;
@@ -302,14 +301,14 @@ let string_of_vector min_size max_size (v:vector) =
   let n_raw = dim v in
   if n_raw = 0 then "[]" else
   let n = max min_size (min n_raw max_size) in
-  let xs = map ((o) string_of_num (element v)) (1--n) in
+  let xs = List.map ((o) string_of_num (element v)) (1--n) in
   "[" ^ end_itlist (fun s t -> s ^ ", " ^ t) xs ^
   (if n_raw > max_size then ", ...]" else "]");;
 
 let string_of_matrix max_size (m:matrix) =
   let i_raw,j_raw = dimensions m in
   let i = min max_size i_raw and j = min max_size j_raw in
-  let rstr = map (fun k -> string_of_vector j j (row k m)) (1--i) in
+  let rstr = List.map (fun k -> string_of_vector j j (row k m)) (1--i) in
   "["^end_itlist(fun s t -> s^";\n "^t) rstr ^
   (if j > max_size then "\n ...]" else "]");;
 
@@ -408,7 +407,7 @@ let rec poly_of_term t = match t with
 
 let sdpa_of_vector (v:vector) =
   let n = dim v in
-  let strs = map (o (decimalize 20)  (element v)) (1--n) in
+  let strs = List.map (o (decimalize 20)  (element v)) (1--n) in
   end_itlist (fun x y -> x ^ " " ^ y) strs ^ "\n";;
 
 (* ------------------------------------------------------------------------- *)
@@ -445,15 +444,15 @@ let sdpa_of_matrix k (m:matrix) =
 (* ------------------------------------------------------------------------- *)
 
 let sdpa_of_problem comment obj mats =
-  let m = length mats - 1
-  and n,_ = dimensions (hd mats) in
+  let m = List.length mats - 1
+  and n,_ = dimensions (List.hd mats) in
   "\"" ^ comment ^ "\"\n" ^
   string_of_int m ^ "\n" ^
   "1\n" ^
   string_of_int n ^ "\n" ^
   sdpa_of_vector obj ^
   itlist2 (fun k m a -> sdpa_of_matrix (k - 1) m ^ a)
-          (1--length mats) mats "";;
+          (1--List.length mats) mats "";;
 
 (* ------------------------------------------------------------------------- *)
 (* More parser basics.                                                       *)
@@ -461,7 +460,7 @@ let sdpa_of_problem comment obj mats =
 
 let word s =
    end_itlist (fun p1 p2 -> (p1 ++ p2) >> (fun (s,t) -> s^t))
-              (map a (explode s));;
+              (List.map a (explode s));;
 let token s =
   many (some isspace) ++ word s ++ many (some isspace)
   >> (fun ((_,t),_) -> t);;
@@ -470,7 +469,7 @@ let decimal =
   let numeral = some isnum in
   let decimalint = atleast 1 numeral >> ((o) Num.num_of_string  implode) in
   let decimalfrac = atleast 1 numeral
-    >> (fun s -> Num.num_of_string(implode s) // pow10 (length s)) in
+    >> (fun s -> Num.num_of_string(implode s) // pow10 (List.length s)) in
   let decimalsig =
     decimalint ++ possibly (a "." ++ decimalfrac >> snd)
     >> (function (h,[x]) -> h +/ x | (h,_) -> h) in
@@ -626,13 +625,13 @@ let scale_then =
   fun solver obj mats ->
     let cd1 = itlist common_denominator mats (Int 1)
     and cd2 = common_denominator (snd obj)  (Int 1) in
-    let mats' = map (mapf (fun x -> cd1 */ x)) mats
+    let mats' = List.map (mapf (fun x -> cd1 */ x)) mats
     and obj' = vector_cmul cd2 obj in
     let max1 = itlist maximal_element mats' (Int 0)
     and max2 = maximal_element (snd obj') (Int 0) in
     let scal1 = pow2 (20-int_of_float(log(float_of_num max1) /. log 2.0))
     and scal2 = pow2 (20-int_of_float(log(float_of_num max2) /. log 2.0)) in
-    let mats'' = map (mapf (fun x -> x */ scal1)) mats'
+    let mats'' = List.map (mapf (fun x -> x */ scal1)) mats'
     and obj'' = vector_cmul scal2 obj' in
     solver obj'' mats'';;
 
@@ -651,7 +650,7 @@ let nice_vector n = mapa (nice_rational n);;
 
 let linear_program_basic a =
   let m,n = dimensions a in
-  let mats =  map (fun j -> diagonal (column j a)) (1--n)
+  let mats =  List.map (fun j -> diagonal (column j a)) (1--n)
   and obj = vector_const (Int 1) m in
   let rv,res = run_csdp false obj mats in
   if rv = 1 or rv = 2 then false
@@ -665,7 +664,7 @@ let linear_program_basic a =
 let linear_program a b =
   let m,n = dimensions a in
   if dim b <> m then failwith "linear_program: incompatible dimensions" else
-  let mats = diagonal b :: map (fun j -> diagonal (column j a)) (1--n)
+  let mats = diagonal b :: List.map (fun j -> diagonal (column j a)) (1--n)
   and obj = vector_const (Int 1) m in
   let rv,res = run_csdp false obj mats in
   if rv = 1 or rv = 2 then false
@@ -679,10 +678,10 @@ let linear_program a b =
 (* ------------------------------------------------------------------------- *)
 
 let in_convex_hull pts pt =
-  let pts1 = (1::pt) :: map (fun x -> 1::x) pts in
-  let pts2 = map (fun p -> map (fun x -> -x) p @ p) pts1 in
-  let n = length pts + 1
-  and v = 2 * (length pt + 1) in
+  let pts1 = (1::pt) :: List.map (fun x -> 1::x) pts in
+  let pts2 = List.map (fun p -> List.map (fun x -> -x) p @ p) pts1 in
+  let n = List.length pts + 1
+  and v = 2 * (List.length pt + 1) in
   let m = v + n - 1 in
   let mat =
     (m,n),
@@ -700,8 +699,8 @@ let minimal_convex_hull =
     | (m::ms) -> if in_convex_hull ms m then ms else ms@[m] in
   let augment m ms = funpow 3 augment1 (m::ms) in
   fun mons ->
-    let mons' = itlist augment (tl mons) [hd mons] in
-    funpow (length mons') augment1 mons';;
+    let mons' = itlist augment (List.tl mons) [List.hd mons] in
+    funpow (List.length mons') augment1 mons';;
 
 (* ------------------------------------------------------------------------- *)
 (* Stuff for "equations" (generic A->num functions).                         *)
@@ -743,7 +742,7 @@ let eliminate_equations =
                   let b = tryapplyd e v (Int 0) in
                   if b =/ Int 0 then e else
                   equation_add e (equation_cmul (minus_num b // a) eq) in
-                eliminate vs ((v |-> eq') (mapf elim dun)) (map elim oeqs)
+                eliminate vs ((v |-> eq') (mapf elim dun)) (List.map elim oeqs)
             with Failure _ -> eliminate vs dun eqs in
   fun one vars eqs ->
     let assig = eliminate vars undefined eqs in
@@ -774,7 +773,7 @@ let eliminate_all_equations one =
           let b = tryapplyd e v (Int 0) in
           if b =/ Int 0 then e else
           equation_add e (equation_cmul (minus_num b // a) eq) in
-        eliminate ((v |-> eq') (mapf elim dun)) (map elim oeqs) in
+        eliminate ((v |-> eq') (mapf elim dun)) (List.map elim oeqs) in
   fun eqs ->
     let assig = eliminate undefined eqs in
     let vs = foldl (fun a x f -> subtract (dom f) [one] @ a) [] assig in
@@ -805,14 +804,14 @@ let solve_equations one eqs =
 
 let newton_polytope pol =
   let vars = poly_variables pol in
-  let mons = map (fun m -> map (fun x -> monomial_degree x m) vars) (dom pol)
-  and ds = map (fun x -> (degree x pol + 1) / 2) vars in
+  let mons = List.map (fun m -> List.map (fun x -> monomial_degree x m) vars) (dom pol)
+  and ds = List.map (fun x -> (degree x pol + 1) / 2) vars in
   let all = itlist (fun n -> allpairs (fun h t -> h::t) (0--n)) ds [[]]
   and mons' = minimal_convex_hull mons in
   let all' =
-    filter (fun m -> in_convex_hull mons' (map (fun x -> 2 * x) m)) all in
-  map (fun m -> itlist2 (fun v i a -> if i = 0 then a else (v |-> i) a)
-                        vars m monomial_1) (rev all');;
+    List.filter (fun m -> in_convex_hull mons' (List.map (fun x -> 2 * x) m)) all in
+  List.map (fun m -> itlist2 (fun v i a -> if i = 0 then a else (v |-> i) a)
+                        vars m monomial_1) (List.rev all');;
 
 (* ------------------------------------------------------------------------- *)
 (* Diagonalize (Cholesky/LDU) the matrix corresponding to a quadratic form.  *)
@@ -851,10 +850,10 @@ let deration d =
     let a = foldl (fun a i c -> lcm_num a (denominator c)) (Int 1) (snd l) //
             foldl (fun a i c -> gcd_num a (numerator c)) (Int 0) (snd l) in
     (c // (a */ a)),mapa (fun x -> a */ x) l in
-  let d' = map adj d in
+  let d' = List.map adj d in
   let a = itlist ((o) lcm_num ( (o) denominator fst)) d' (Int 1) //
           itlist ((o) gcd_num ( (o) numerator fst)) d' (Int 0)  in
-  (Int 1 // a),map (fun (c,l) -> (a */ c,l)) d';;
+  (Int 1 // a),List.map (fun (c,l) -> (a */ c,l)) d';;
 
 (* ------------------------------------------------------------------------- *)
 (* Enumeration of monomials with given multidegree bound.                    *)
@@ -865,8 +864,8 @@ let rec enumerate_monomials d vars =
   else if d = 0 then [undefined]
   else if vars = [] then [monomial_1] else
   let alts =
-    map (fun k -> let oths = enumerate_monomials (d - k) (tl vars) in
-                  map (fun ks -> if k = 0 then ks else (hd vars |-> k) ks) oths)
+    List.map (fun k -> let oths = enumerate_monomials (d - k) (List.tl vars) in
+                  List.map (fun ks -> if k = 0 then ks else (List.hd vars |-> k) ks) oths)
         (0--d) in
   end_itlist (@) alts;;
 
@@ -883,7 +882,7 @@ let rec enumerate_products d pols =
   | (p,b)::ps -> let e = multidegree p in
                  if e = 0 then enumerate_products d ps else
                  enumerate_products d ps @
-                 map (fun (q,c) -> poly_mul p q,Product(b,c))
+                 List.map (fun (q,c) -> poly_mul p q,Product(b,c))
                      (enumerate_products (d - e) ps);;
 
 (* ------------------------------------------------------------------------- *)
@@ -936,15 +935,15 @@ let sdpa_of_blockdiagonal k m =
 (* ------------------------------------------------------------------------- *)
 
 let sdpa_of_blockproblem comment nblocks blocksizes obj mats =
-  let m = length mats - 1 in
+  let m = List.length mats - 1 in
   "\"" ^ comment ^ "\"\n" ^
   string_of_int m ^ "\n" ^
   string_of_int nblocks ^ "\n" ^
-  (end_itlist (fun s t -> s^" "^t) (map string_of_int blocksizes)) ^
+  (end_itlist (fun s t -> s^" "^t) (List.map string_of_int blocksizes)) ^
   "\n" ^
   sdpa_of_vector obj ^
   itlist2 (fun k m a -> sdpa_of_blockdiagonal (k - 1) m ^ a)
-          (1--length mats) mats "";;
+          (1--List.length mats) mats "";;
 
 (* ------------------------------------------------------------------------- *)
 (* Hence run CSDP on a problem in block diagonal form.                       *)
@@ -996,35 +995,35 @@ let bmatrix_sub m1 m2 = bmatrix_add m1 (bmatrix_neg m2);;
 (* ------------------------------------------------------------------------- *)
 
 let blocks blocksizes bm =
-  map (fun (bs,b0) ->
+  List.map (fun (bs,b0) ->
         let m = foldl
           (fun a (b,i,j) c -> if b = b0 then ((i,j) |-> c) a else a)
           undefined bm in
         (((bs,bs),m):matrix))
-      (zip blocksizes (1--length blocksizes));;
+      (zip blocksizes (1--List.length blocksizes));;
 
 (* ------------------------------------------------------------------------- *)
 (* Positiv- and Nullstellensatz. Flag "linf" forces a linear representation. *)
 (* ------------------------------------------------------------------------- *)
 
 let real_positivnullstellensatz_general linf d eqs leqs pol =
-  let vars = itlist ((o) union poly_variables) (pol::eqs @ map fst leqs) [] in
+  let vars = itlist ((o) union poly_variables) (pol::eqs @ List.map fst leqs) [] in
   let monoid =
     if linf then
       (poly_const num_1,Rational_lt num_1)::
-      (filter (fun (p,c) -> multidegree p <= d) leqs)
+      (List.filter (fun (p,c) -> multidegree p <= d) leqs)
     else enumerate_products d leqs in
-  let nblocks = length monoid in
+  let nblocks = List.length monoid in
   let mk_idmultiplier k p =
     let e = d - multidegree p in
     let mons = enumerate_monomials e vars in
-    let nons = zip mons (1--length mons) in
+    let nons = zip mons (1--List.length mons) in
     mons,
     itlist (fun (m,n) -> (m |-> ((-k,-n,n) |=> Int 1))) nons undefined in
   let mk_sqmultiplier k (p,c) =
     let e = (d - multidegree p) / 2 in
     let mons = enumerate_monomials e vars in
-    let nons = zip mons (1--length mons) in
+    let nons = zip mons (1--List.length mons) in
     mons,
     itlist (fun (m1,n1) ->
       itlist (fun (m2,n2) a ->
@@ -1035,9 +1034,9 @@ let real_positivnullstellensatz_general linf d eqs leqs pol =
           (m |-> equation_add ((k,n1,n2) |=> c) e) a)
          nons)
        nons undefined in
-  let sqmonlist,sqs = unzip(map2 mk_sqmultiplier (1--length monoid) monoid)
-  and idmonlist,ids =  unzip(map2 mk_idmultiplier (1--length eqs) eqs) in
-  let blocksizes = map length sqmonlist in
+  let sqmonlist,sqs = unzip(List.map2 mk_sqmultiplier (1--List.length monoid) monoid)
+  and idmonlist,ids =  unzip(List.map2 mk_idmultiplier (1--List.length eqs) eqs) in
+  let blocksizes = List.map List.length sqmonlist in
   let bigsum =
     itlist2 (fun p q a -> epoly_pmul p q a) eqs ids
             (itlist2 (fun (p,c) s a -> epoly_pmul p s a) monoid sqs
@@ -1053,10 +1052,10 @@ let real_positivnullstellensatz_general linf d eqs leqs pol =
                                 ((b,j,i) |-> c) (((b,i,j) |-> c) m))
           undefined allassig in
   let diagents = foldl
-    (fun a (b,i,j) e -> if b > 0 & i = j then equation_add e a else a)
+    (fun a (b,i,j) e -> if b > 0 && i = j then equation_add e a else a)
     undefined allassig in
-  let mats = map mk_matrix qvars
-  and obj = length pvs,
+  let mats = List.map mk_matrix qvars
+  and obj = List.length pvs,
             itern 1 pvs (fun v i -> (i |--> tryapplyd diagents v (Int 0)))
                         undefined in
   let raw_vec = if pvs = [] then vector_0 0
@@ -1071,11 +1070,11 @@ let real_positivnullstellensatz_general linf d eqs leqs pol =
      (fun i a -> bmatrix_add (bmatrix_cmul (element vec i) (el i mats)) a)
      (bmatrix_neg (el 0 mats)) in
     let allmats = blocks blocksizes blockmat in
-    vec,map diag allmats in
+    vec,List.map diag allmats in
   let vec,ratdias =
     if pvs = [] then find_rounding num_1
-    else tryfind find_rounding (map Num.num_of_int (1--31) @
-                                map pow2 (5--66)) in
+    else tryfind find_rounding (List.map Num.num_of_int (1--31) @
+                                List.map pow2 (5--66)) in
   let newassigs =
     itlist (fun k -> el (k - 1) pvs |-> element vec k)
            (1--dim vec) ((0,0,0) |=> Int(-1)) in
@@ -1088,11 +1087,11 @@ let real_positivnullstellensatz_general linf d eqs leqs pol =
   let mk_sos mons =
     let mk_sq (c,m) =
         c,itlist (fun k a -> (el (k - 1) mons |--> element m k) a)
-                 (1--length mons) undefined in
-    map mk_sq in
-  let sqs = map2 mk_sos sqmonlist ratdias
-  and cfs = map poly_of_epoly ids in
-  let msq = filter (fun (a,b) -> b <> []) (map2 (fun a b -> a,b) monoid sqs) in
+                 (1--List.length mons) undefined in
+    List.map mk_sq in
+  let sqs = List.map2 mk_sos sqmonlist ratdias
+  and cfs = List.map poly_of_epoly ids in
+  let msq = List.filter (fun (a,b) -> b <> []) (List.map2 (fun a b -> a,b) monoid sqs) in
   let eval_sq sqs = itlist
    (fun (c,q) -> poly_add (poly_cmul c (poly_mul q q))) sqs poly_0 in
   let sanity =
@@ -1100,7 +1099,7 @@ let real_positivnullstellensatz_general linf d eqs leqs pol =
            (itlist2 (fun p q -> poly_add (poly_mul p q)) cfs eqs
                     (poly_neg pol)) in
   if not(is_undefined sanity) then raise Sanity else
-  cfs,map (fun (a,b) -> snd a,b) msq;;
+  cfs,List.map (fun (a,b) -> snd a,b) msq;;
 
 (* ------------------------------------------------------------------------- *)
 (* Iterative deepening.                                                      *)
@@ -1138,7 +1137,7 @@ let monomial_order =
     else lexorder mon1 mon2;;
 
 let dest_poly p =
-  map (fun (m,c) -> c,dest_monomial m)
+  List.map (fun (m,c) -> c,dest_monomial m)
       (sort (fun (m1,_) (m2,_) -> monomial_order m1 m2) (graph p));;
 
 (* ------------------------------------------------------------------------- *)
@@ -1164,7 +1163,7 @@ let term_of_cmonomial =
 let term_of_poly =
   fun p ->
     if p = poly_0 then Zero else
-    let cms = map term_of_cmonomial
+    let cms = List.map term_of_cmonomial
      (sort (fun (m1,_) (m2,_) -> monomial_order m1 m2) (graph p)) in
     end_itlist (fun t1 t2 -> Add (t1,t2)) cms;;
 
@@ -1173,7 +1172,7 @@ let term_of_sqterm (c,p) =
 
 let term_of_sos (pr,sqs) =
   if sqs = [] then pr
-  else Product(pr,end_itlist (fun a b -> Sum(a,b)) (map term_of_sqterm sqs));;
+  else Product(pr,end_itlist (fun a b -> Sum(a,b)) (List.map term_of_sqterm sqs));;
 
 (* ------------------------------------------------------------------------- *)
 (* Interface to HOL.                                                         *)
@@ -1236,7 +1235,7 @@ let REAL_NONLINEAR_SUBST_PROVER =
     match tm with
       Var(_,Tyapp("real",[])) when not (mem tm fvs) -> Int 1,tm
     | Comb(Comb(Const("real_mul",_),c),(Var(_,_) as t))
-         when is_ratconst c & not (mem t fvs)
+         when is_ratconst c && not (mem t fvs)
           -> rat_of_term c,t
     | Comb(Comb(Const("real_add",_),s),t) ->
          (try substitutable_monomial (union (frees t) fvs) s
@@ -1292,10 +1291,10 @@ let REAL_SOSFIELD =
     with Failure _ -> REAL_SOS t
   and is_inv =
     let is_div = is_binop `(/):real->real->real` in
-    fun tm -> (is_div tm or (is_comb tm & rator tm = inv_tm)) &
+    fun tm -> (is_div tm or (is_comb tm && rator tm = inv_tm)) &&
               not(is_ratconst(rand tm)) in
   let BASIC_REAL_FIELD tm =
-    let is_freeinv t = is_inv t & free_in t tm in
+    let is_freeinv t = is_inv t && free_in t tm in
     let itms = setify(map rand (find_terms is_freeinv tm)) in
     let hyps = map (fun t -> SPEC t REAL_MUL_RINV) itms in
     let tm' = itlist (fun th t -> mk_imp(concl th,t)) hyps tm in
@@ -1371,14 +1370,14 @@ let SOS_RULE tm =
 
 let rec allpermutations l =
   if l = [] then [[]] else
-  itlist (fun h acc -> map (fun t -> h::t)
+  itlist (fun h acc -> List.map (fun t -> h::t)
                 (allpermutations (subtract l [h])) @ acc) l [];;
 
 let allvarorders l =
-  map (fun vlis x -> index x vlis) (allpermutations l);;
+  List.map (fun vlis x -> index x vlis) (allpermutations l);;
 
 let changevariables_monomial zoln (m:monomial) =
-  foldl (fun a x k -> (assoc x zoln |-> k) a) monomial_1 m;;
+  foldl (fun a x k -> (List.assoc x zoln |-> k) a) monomial_1 m;;
 
 let changevariables zoln pol =
   foldl (fun a m c -> (changevariables_monomial zoln m |-> c) a)
@@ -1390,7 +1389,7 @@ let changevariables zoln pol =
 
 let sdpa_of_vector (v:vector) =
   let n = dim v in
-  let strs = map (o (decimalize 20) (element v)) (1--n) in
+  let strs = List.map (o (decimalize 20) (element v)) (1--n) in
   end_itlist (fun x y -> x ^ " " ^ y) strs ^ "\n";;
 
 let sdpa_of_blockdiagonal k m =
@@ -1412,15 +1411,15 @@ let sdpa_of_matrix k (m:matrix) =
      " " ^ decimalize 20 c ^ "\n" ^ a) mss "";;
 
 let sdpa_of_problem comment obj mats =
-  let m = length mats - 1
-  and n,_ = dimensions (hd mats) in
+  let m = List.length mats - 1
+  and n,_ = dimensions (List.hd mats) in
   "\"" ^ comment ^ "\"\n" ^
   string_of_int m ^ "\n" ^
   "1\n" ^
   string_of_int n ^ "\n" ^
   sdpa_of_vector obj ^
   itlist2 (fun k m a -> sdpa_of_matrix (k - 1) m ^ a)
-          (1--length mats) mats "";;
+          (1--List.length mats) mats "";;
 
 let run_csdp dbg obj mats =
   let input_file = Filename.temp_file "sos" ".dat-s" in
@@ -1455,33 +1454,33 @@ let csdp obj mats =
 let sumofsquares_general_symmetry tool pol =
   let vars = poly_variables pol
   and lpps = newton_polytope pol in
-  let n = length lpps in
+  let n = List.length lpps in
   let sym_eqs =
-    let invariants = filter
+    let invariants = List.filter
      (fun vars' ->
         is_undefined(poly_sub pol (changevariables (zip vars vars') pol)))
      (allpermutations vars) in
-    let lpns = zip lpps (1--length lpps) in
+    let lpns = zip lpps (1--List.length lpps) in
     let lppcs =
-      filter (fun (m,(n1,n2)) -> n1 <= n2)
+      List.filter (fun (m,(n1,n2)) -> n1 <= n2)
              (allpairs
                (fun (m1,n1) (m2,n2) -> (m1,m2),(n1,n2)) lpns lpns) in
     let clppcs = end_itlist (@)
-       (map (fun ((m1,m2),(n1,n2)) ->
-                map (fun vars' ->
+       (List.map (fun ((m1,m2),(n1,n2)) ->
+                List.map (fun vars' ->
                         (changevariables_monomial (zip vars vars') m1,
                          changevariables_monomial (zip vars vars') m2),(n1,n2))
                     invariants)
             lppcs) in
-    let clppcs_dom = setify(map fst clppcs) in
-    let clppcs_cls = map (fun d -> filter (fun (e,_) -> e = d) clppcs)
+    let clppcs_dom = setify(List.map fst clppcs) in
+    let clppcs_cls = List.map (fun d -> List.filter (fun (e,_) -> e = d) clppcs)
                          clppcs_dom in
-    let eqvcls = map (o setify (map snd)) clppcs_cls in
+    let eqvcls = List.map (o setify (List.map snd)) clppcs_cls in
     let mk_eq cls acc =
       match cls with
         [] -> raise Sanity
       | [h] -> acc
-      | h::t -> map (fun k -> (k |-> Int(-1)) (h |=> Int 1)) t @ acc in
+      | h::t -> List.map (fun k -> (k |-> Int(-1)) (h |=> Int 1)) t @ acc in
     itlist mk_eq eqvcls [] in
   let eqs = foldl (fun a x y -> y::a) []
    (itern 1 lpps (fun m1 n1 ->
@@ -1497,15 +1496,15 @@ let sumofsquares_general_symmetry tool pol =
   let allassig = itlist (fun v -> (v |-> (v |=> Int 1))) pvs assig in
   let qvars = (0,0)::pvs in
   let diagents =
-    end_itlist equation_add (map (fun i -> apply allassig (i,i)) (1--n)) in
+    end_itlist equation_add (List.map (fun i -> apply allassig (i,i)) (1--n)) in
   let mk_matrix v =
    ((n,n),
     foldl (fun m (i,j) ass -> let c = tryapplyd ass v (Int 0) in
                               if c =/ Int 0 then m else
                               ((j,i) |-> c) (((i,j) |-> c) m))
           undefined allassig :matrix) in
-  let mats = map mk_matrix qvars
-  and obj = length pvs,
+  let mats = List.map mk_matrix qvars
+  and obj = List.length pvs,
             itern 1 pvs (fun v i -> (i |--> tryapplyd diagents v (Int 0)))
                 undefined in
   let raw_vec = if pvs = [] then vector_0 0 else tool obj mats in
@@ -1524,12 +1523,12 @@ let sumofsquares_general_symmetry tool pol =
        let mat = matrix_neg (el 0 mats) in
        deration(diag mat)
     else
-       tryfind find_rounding (map Num.num_of_int (1--31) @
-                              map pow2 (5--66)) in
+       tryfind find_rounding (List.map Num.num_of_int (1--31) @
+                              List.map pow2 (5--66)) in
   let poly_of_lin(d,v) =
     d,foldl(fun a i c -> (el (i - 1) lpps |-> c) a) undefined (snd v) in
-  let lins = map poly_of_lin dia in
-  let sqs = map (fun (d,l) -> poly_mul (poly_const d) (poly_pow l 2)) lins in
+  let lins = List.map poly_of_lin dia in
+  let sqs = List.map (fun (d,l) -> poly_mul (poly_const d) (poly_pow l 2)) lins in
   let sos = poly_cmul rat (end_itlist poly_add sqs) in
   if is_undefined(poly_sub sos pol) then rat,lins else raise Sanity;;
 
diff --git a/plugins/micromega/sos.mli b/plugins/micromega/sos.mli
index d7314ccb..fc0b2fd4 100644
--- a/plugins/micromega/sos.mli
+++ b/plugins/micromega/sos.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/plugins/micromega/sos_lib.ml b/plugins/micromega/sos_lib.ml
index baf90d4d..f54914f2 100644
--- a/plugins/micromega/sos_lib.ml
+++ b/plugins/micromega/sos_lib.ml
@@ -2,13 +2,12 @@
 (* - This code originates from John Harrison's HOL LIGHT 2.30                *)
 (*   (see file LICENSE.sos for license, copyright and disclaimer)            *)
 (*   This code is the HOL LIGHT library code used by sos.ml                  *)
-(* - Laurent Théry (thery@sophia.inria.fr) has isolated the HOL              *)
+(* - Laurent Théry (thery@sophia.inria.fr) has isolated the HOL              *)
 (*   independent bits                                                        *)
-(* - Frédéric Besson (fbesson@irisa.fr) is using it to feed  micromega       *)
+(* - Frédéric Besson (fbesson@irisa.fr) is using it to feed  micromega       *)
 (* ========================================================================= *)
-open Sos_types
+
 open Num
-open List
 
 let debugging = ref false;;
 
@@ -16,11 +15,13 @@ let debugging = ref false;;
 (* Comparisons that are reflexive on NaN and also short-circuiting.          *)
 (* ------------------------------------------------------------------------- *)
 
-let (=?) = fun x y -> Pervasives.compare x y = 0;;
-let (<?) = fun x y -> Pervasives.compare x y < 0;;
-let (<=?) = fun x y -> Pervasives.compare x y <= 0;;
-let (>?) = fun x y -> Pervasives.compare x y > 0;;
-let (>=?) = fun x y -> Pervasives.compare x y >= 0;;
+let cmp = Pervasives.compare (** FIXME *)
+
+let (=?) = fun x y -> cmp x y = 0;;
+let (<?) = fun x y -> cmp x y < 0;;
+let (<=?) = fun x y -> cmp x y <= 0;;
+let (>?) = fun x y -> cmp x y > 0;;
+let (>=?) = fun x y -> cmp x y >= 0;;
 
 (* ------------------------------------------------------------------------- *)
 (* Combinators.                                                              *)
@@ -53,7 +54,7 @@ let gcd_num n1 n2 =
   num_of_big_int(Big_int.gcd_big_int (big_int_of_num n1) (big_int_of_num n2));;
 
 let lcm_num x y =
-  if x =/ num_0 & y =/ num_0 then num_0
+  if x =/ num_0 && y =/ num_0 then num_0
   else abs_num((x */ y) // gcd_num x y);;
 
 
@@ -62,7 +63,7 @@ let lcm_num x y =
 (* ------------------------------------------------------------------------- *)
 
 let rec el n l =
-  if n = 0 then hd l else el (n - 1) (tl l);;
+  if n = 0 then List.hd l else el (n - 1) (List.tl l);;
 
 
 (* ------------------------------------------------------------------------- *)
@@ -141,7 +142,7 @@ let rec (--) = fun m n -> if m > n then [] else m::((m + 1) -- n);;
 let rec forall p l =
   match l with
     [] -> true
-  | h::t -> p(h) & forall p t;;
+  | h::t -> p(h) && forall p t;;
 
 let rec tryfind f l =
   match l with
@@ -162,14 +163,14 @@ let index x =
 let rec mem x lis =
   match lis with
     [] -> false
-  | (h::t) -> x =? h or mem x t;;
+  | (h::t) -> x =? h || mem x t;;
 
 let insert x l =
   if mem x l then l else x::l;;
 
 let union l1 l2 = itlist insert l1 l2;;
 
-let subtract l1 l2 = filter (fun x -> not (mem x l2)) l1;;
+let subtract l1 l2 = List.filter (fun x -> not (mem x l2)) l1;;
 
 (* ------------------------------------------------------------------------- *)
 (* Merging and bottom-up mergesort.                                          *)
@@ -224,7 +225,7 @@ let rec sort cmp lis =
   match lis with
     [] -> []
   | piv::rest ->
-      let r,l = partition (cmp piv) rest in
+      let r,l = List.partition (cmp piv) rest in
       (sort cmp l) @ (piv::(sort cmp r));;
 
 (* ------------------------------------------------------------------------- *)
@@ -416,7 +417,7 @@ let (|=>) = fun x y -> (x |-> y) undefined;;
 let rec choose t =
   match t with
     Empty -> failwith "choose: completely undefined function"
-  | Leaf(h,l) -> hd l
+  | Leaf(h,l) -> List.hd l
   | Branch(b,p,t1,t2) -> choose t1;;
 
 (* ------------------------------------------------------------------------- *)
@@ -547,7 +548,7 @@ let fix err prs input =
   try prs input
   with Noparse -> failwith (err ^ " expected");;
 
-let rec listof prs sep err =
+let listof prs sep err =
   prs ++ many (sep ++ fix err prs >> snd) >> (fun (h,t) -> h::t);;
 
 let possibly prs input =
@@ -583,7 +584,7 @@ let strings_of_file filename =
   let rec suck_lines acc =
     try let l = Pervasives.input_line fd in
         suck_lines (l::acc)
-    with End_of_file -> rev acc in
+    with End_of_file -> List.rev acc in
   let data = suck_lines [] in
   (Pervasives.close_in fd; data);;
 
diff --git a/plugins/micromega/sos_types.ml b/plugins/micromega/sos_types.ml
index 351a3133..e9543714 100644
--- a/plugins/micromega/sos_types.ml
+++ b/plugins/micromega/sos_types.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/plugins/micromega/vo.itarget b/plugins/micromega/vo.itarget
index 30201308..bf6a1a7d 100644
--- a/plugins/micromega/vo.itarget
+++ b/plugins/micromega/vo.itarget
@@ -1,4 +1,3 @@
-CheckerMaker.vo
 EnvRing.vo
 Env.vo
 OrderedRing.vo
@@ -11,3 +10,4 @@ Tauto.vo
 VarMap.vo
 ZCoeff.vo
 ZMicromega.vo
+Lia.vo
\ No newline at end of file
diff --git a/plugins/nsatz/Nsatz.v b/plugins/nsatz/Nsatz.v
index f8929d58..eaf95e94 100644
--- a/plugins/nsatz/Nsatz.v
+++ b/plugins/nsatz/Nsatz.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -98,7 +98,7 @@ Definition PhiR : list R -> PolZ -> R :=
     (InitialRing.gen_phiZ ring0 ring1 add mul opp)).
 
 Definition PEevalR : list R -> PEZ -> R :=
-   PEeval ring0 add mul sub opp
+   PEeval ring0 ring1 add mul sub opp
     (gen_phiZ ring0 ring1 add mul opp)
          N.to_nat pow.
 
@@ -241,7 +241,9 @@ Fixpoint interpret3 t fv {struct t}: R :=
   | (PEpow t1 t2) =>
        let v1  := interpret3 t1 fv in pow v1 (N.to_nat t2)
   | (PEc t1) => (IZR1 t1)
-  | (PEX n) => List.nth (pred (Pos.to_nat n)) fv 0
+  | PEO => 0
+  | PEI => 1
+  | (PEX _ n) => List.nth (pred (Pos.to_nat n)) fv 0
   end.
 
 
diff --git a/plugins/nsatz/ideal.ml b/plugins/nsatz/ideal.ml
index 4bfcc436..8ff82454 100644
--- a/plugins/nsatz/ideal.ml
+++ b/plugins/nsatz/ideal.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -16,7 +16,6 @@ a polynomial is a sorted list of (coefficient, monomial)
  *)
 
 open Utile
-open List
 
 exception NotInIdeal
 
@@ -134,7 +133,7 @@ let deg m = m.(0)
 
 let mult_mon m m' =
   let d = nvar m in
-  let m'' = Array.create (d+1) 0 in
+  let m'' = Array.make (d+1) 0 in
   for i=0 to d do
     m''.(i)<- (m.(i)+m'.(i));
   done;
@@ -168,7 +167,7 @@ let compare_mon m m' =
 
 let div_mon m m' =
   let d = nvar m in
-  let m'' = Array.create (d+1) 0 in
+  let m'' = Array.make (d+1) 0 in
   for i=0 to d do
     m''.(i)<- (m.(i)-m'.(i));
   done;
@@ -199,7 +198,7 @@ let set_deg m =
 (* lcm *)
 let ppcm_mon m m' =
   let d = nvar m in
-  let m'' = Array.create (d+1) 0 in
+  let m'' = Array.make (d+1) 0 in
   for i=1 to d do
     m''.(i)<- (max m.(i) m'.(i));
   done;
@@ -215,13 +214,13 @@ let ppcm_mon m m' =
 let repr p = p
 
 let equal =
-  Util.list_for_all2eq
+  Util.List.for_all2eq
     (fun (c1,m1) (c2,m2) -> P.equal c1 c2 && m1=m2)
 
 let hash p =
-  let c = map fst p in
-  let m = map snd p in
-  fold_left (fun h p -> h * 17 + P.hash p) (Hashtbl.hash m) c
+  let c = List.map fst p in
+  let m = List.map snd p in
+  List.fold_left (fun h p -> h * 17 + P.hash p) (Hashtbl.hash m) c
 
 module Hashpol = Hashtbl.Make(
   struct
@@ -236,9 +235,8 @@ module Hashpol = Hashtbl.Make(
 open Format
 
 let getvar lv i =
-  try (nth lv i)
-  with e when Errors.noncritical e ->
-    (fold_left (fun r x -> r^" "^x) "lv= " lv)
+  try (List.nth lv i)
+  with Failure _ -> (List.fold_left (fun r x -> r^" "^x) "lv= " lv)
     ^" i="^(string_of_int i)
 
 let string_of_pol zeroP hdP tlP coefterm monterm string_of_coef
@@ -363,8 +361,8 @@ let stringPcut p =
   (*Polynomesrec.nsP1:=20;*)
   nsP2:=10;
   let res =
-    if (length p)> !nsP2
-    then (stringP [hd p])^" + "^(string_of_int (length p))^" terms"
+    if (List.length p)> !nsP2
+    then (stringP [List.hd p])^" + "^(string_of_int (List.length p))^" terms"
     else  stringP p in
   (*Polynomesrec.nsP1:= max_int;*)
   nsP2:= max_int;
@@ -399,7 +397,7 @@ let zeroP = []
 
 (* returns a constant polynom ial with d variables *)
 let polconst d c =
-  let m = Array.create (d+1) 0 in
+  let m = Array.make (d+1) 0 in
   let m = set_deg m in 
   [(c,m)]
 
@@ -432,7 +430,7 @@ let coef_of_int x = P.of_num (Num.Int x)
 
 (* variable i *)
 let gen d i =
-  let m = Array.create (d+1) 0 in
+  let m = Array.make (d+1) 0 in
   m.(i) <- 1;
   let m = set_deg m in 
   [((coef_of_int 1),m)]
@@ -463,10 +461,10 @@ let puisP p n=
   match p with
     [] -> []
   |_ ->
-      let d = nvar (snd (hd p)) in
+      let d = nvar (snd (List.hd p)) in
       let rec puisP n =
 	match n with
-	  0 -> [coef1, Array.create (d+1) 0]
+	  0 -> [coef1, Array.make (d+1) 0]
 	| 1 -> p
 	|_ -> multP p (puisP (n-1))
       in puisP n
@@ -484,7 +482,7 @@ let contentPlist lp =
   match lp with
   |[] -> coef1
   |p::l1 ->
-      fold_left
+      List.fold_left
 	(fun r q ->
 	  if P.equal r coef1 || P.equal r coefm1
 	  then r
@@ -501,17 +499,17 @@ let polynom0 =  {pol = ref []; num = 0; sugar = 0}
    
 let ppol p = !(p.pol)
 
-let lm p = snd (hd (ppol p))
+let lm p = snd (List.hd (ppol p))
 
 let nallpol = ref 0
 
-let allpol = ref (Array.create 1000 polynom0)
+let allpol = ref (Array.make 1000 polynom0)
 
 let new_allpol p s =
   nallpol := !nallpol + 1;
   if !nallpol >= Array.length !allpol
   then
-    allpol := Array.append !allpol (Array.create !nallpol polynom0);
+    allpol := Array.append !allpol (Array.make !nallpol polynom0);
   let p = {pol = ref p; num = !nallpol; sugar = s} in
   !allpol.(!nallpol)<- p;
   p
@@ -521,7 +519,7 @@ let new_allpol p s =
 let rec selectdiv m l =
   match l with
     [] -> polynom0
-  |q::r -> let m'= snd (hd (ppol q)) in
+  |q::r -> let m'= snd (List.hd (ppol q)) in
     match (div_mon_test m m') with
       true -> q
     |false -> selectdiv m r
@@ -550,7 +548,7 @@ let div_coef a b = P.divP a b
 (* remainder r of the division of p by polynomials of l, returns (c,r) where c is the coefficient for pseudo-division : c p = sum_i q_i p_i + r *)
 
 let reduce2 p l =
-  let l = if nouveaux_pol_en_tete then rev l else l in
+  let l = if nouveaux_pol_en_tete then List.rev l else l in
   let rec reduce p =
     match p with
       [] -> (coef1,[])
@@ -601,8 +599,8 @@ let coefpoldep_set p q c =
 
 let initcoefpoldep d lp =
   poldep:=lp;
-  poldepcontent:= map (fun p -> contentP (ppol p)) lp;
-  iter
+  poldepcontent:= List.map (fun p -> contentP (ppol p)) lp;
+  List.iter
     (fun p -> coefpoldep_set p p (polconst d (coef_of_int 1)))
     lp
 
@@ -610,7 +608,7 @@ let initcoefpoldep d lp =
    divides without pseudodivisions *)
 
 let reduce2_trace p l lcp =
-  let l = if nouveaux_pol_en_tete then rev l else l in
+  let l = if nouveaux_pol_en_tete then List.rev l else l in
   (* rend (lq,r), ou r = p + sum(lq) *)
   let rec reduce p =
     match p with
@@ -646,10 +644,10 @@ let reduce2_trace p l lcp =
      info ((stringP x)^"\n"))
      lq;
      info "ok\n";*)
-  (map2
+  (List.map2
      (fun c0 q ->
        let c =
-	 fold_left
+	 List.fold_left
 	   (fun x (a,m,s) ->
 	     if equal (ppol s) (ppol q)
 	     then
@@ -672,7 +670,7 @@ let pol_courant = ref polynom0
 let sugar_flag = ref true
 
 let compute_sugar p =
-  fold_left (fun s (a,m) -> max s m.(0)) 0 p
+  List.fold_left (fun s (a,m) -> max s m.(0)) 0 p
 
 let mk_polynom p = 
   new_allpol p (compute_sugar p)
@@ -680,12 +678,12 @@ let mk_polynom p =
 let spol ps qs=
   let p = ppol ps in
   let q = ppol qs in
-  let m = snd (hd p) in
-  let m'= snd (hd q) in
-  let a = fst (hd p) in
-  let b = fst (hd q) in
-  let p'= tl p in
-  let q'= tl q in
+  let m = snd (List.hd p) in
+  let m'= snd (List.hd q) in
+  let a = fst (List.hd p) in
+  let b = fst (List.hd q) in
+  let p'= List.tl p in
+  let q'= List.tl q in
   let c = (pgcdpos a b) in
   let m''=(ppcm_mon m m') in
   let m1 = div_mon m'' m in
@@ -709,8 +707,8 @@ let spol ps qs=
   
 
 let etrangers p p'=
-  let m = snd (hd p) in
-  let m'= snd (hd p') in
+  let m = snd (List.hd p) in
+  let m'= snd (List.hd p') in
   let d = nvar m in
   let res=ref true in
   let i=ref 1 in
@@ -723,9 +721,9 @@ let etrangers p p'=
 (* teste if head monomial of p'' divides lcm of lhead monomials of p and p' *)
 
 let div_ppcm p p' p'' =
-  let m = snd (hd p) in
-  let m'= snd (hd p') in
-  let m''= snd (hd p'') in
+  let m = snd (List.hd p) in
+  let m'= snd (List.hd p') in
+  let m''= snd (List.hd p'') in
   let d = nvar m in
   let res=ref true in
   let i=ref 1 in
@@ -766,7 +764,7 @@ let slice i a q =
 
 (* sugar strategy *)
 
-let rec addS x l =    l @ [x] (* oblige de mettre en queue sinon le certificat deconne *)
+let addS x l =    l @ [x] (* oblige de mettre en queue sinon le certificat deconne *)
 			  
 let addSsugar x l =
   if !sugar_flag
@@ -823,10 +821,10 @@ let ordcpair ((i1,j1),m1) ((i2,j2),m2) =
   compare_mon m1 m2 
 
 let sortcpairs lcp = 
-  sort ordcpair lcp
+  List.sort ordcpair lcp
 
 let mergecpairs l1 l2 =
-  merge ordcpair l1 l2 
+  List.merge ordcpair l1 l2 
 
 let ord i j =
   if i<j then (i,j) else (j,i)
@@ -838,7 +836,7 @@ let cpair p q =
 	 ppcm_mon (lm p) (lm q))]
       
 let cpairs1 p lq =
-  sortcpairs (fold_left (fun r q -> r @ (cpair p q)) [] lq)
+  sortcpairs (List.fold_left (fun r q -> r @ (cpair p q)) [] lq)
     
 let cpairs lp =
   let rec aux l =
@@ -849,18 +847,18 @@ let cpairs lp =
     
     
 let critere2 ((i,j),m) lp lcp =
-  exists
+  List.exists
     (fun h ->
       h.num <> i && h.num <> j
         && (div_mon_test m (lm h))
 	&& (let c1 = ord i h.num in
-	not (exists (fun (c,_) -> c1 = c) lcp))
+	not (List.exists (fun (c,_) -> c1 = c) lcp))
 	&& (let c1 = ord j h.num in
-	not (exists (fun (c,_) -> c1 = c) lcp)))
+	not (List.exists (fun (c,_) -> c1 = c) lcp)))
     lp
 
 let critere3 ((i,j),m) lp lcp =
-  exists
+  List.exists
     (fun h ->
       h.num <> i && h.num <> j
         && (div_mon_test m (lm h))
@@ -881,8 +879,8 @@ let step = ref 0
 
 let infobuch p q =
   if !step = 0 
-  then (info ("[" ^ (string_of_int (length p))
-              ^ "," ^  (string_of_int (length q))
+  then (info ("[" ^ (string_of_int (List.length p))
+              ^ "," ^  (string_of_int (List.length q))
               ^ "]"))
 
 (* in lp new polynomials are at the end *)
@@ -900,13 +898,13 @@ let test_dans_ideal p lp lp0 =
   pol_courant:= mk_polynom r;
   if r=[]
   then (info "polynomial reduced to 0\n";
-	let lcp = map (fun q -> []) !poldep in
+	let lcp = List.map (fun q -> []) !poldep in
 	let c = !coef_courant in
 	let (lcq,r) = reduce2_trace (emultP c p) lp lcp in
 	info "r ok\n";
 	info ("r: "^(stringP r)^"\n");
         let res=ref  (emultP c p) in
-	iter2
+	List.iter2
 	  (fun cq q -> res:=plusP (!res) (multP cq (ppol q));
 	  )
 	  lcq !poldep;
@@ -916,22 +914,22 @@ let test_dans_ideal p lp lp0 =
 	  match lp with
 	  |[] -> []
 	  |p::lp ->
-	      (map
+	      (List.map
 		 (fun q -> coefpoldep_find p q)
 		 lp)::(aux lp)
 	in
 	let coefficient_multiplicateur = c in
-	let liste_polynomes_de_depart = rev lp0 in
+	let liste_polynomes_de_depart = List.rev lp0 in
 	let polynome_a_tester = p in
 	let liste_des_coefficients_intermediaires =
-	  (let lci = rev (aux (rev lp)) in
+	  (let lci = List.rev (aux (List.rev lp)) in
 	  let lci = ref lci (* (map rev lci) *) in
-	  iter (fun x -> lci := tl (!lci)) lp0;
+	  List.iter (fun x -> lci := List.tl (!lci)) lp0;
 	  !lci) in
 	let liste_des_coefficients =
-	  map
+	  List.map
 	    (fun cq -> emultP (coef_of_int (-1)) cq)
-	    (rev lcq) in
+	    (List.rev lcq) in
 	(liste_polynomes_de_depart,
 	 polynome_a_tester,
 	 {coef = coefficient_multiplicateur;
@@ -946,7 +944,7 @@ let test_dans_ideal p lp lp0 =
 let divide_rem_with_critical_pair = ref false
 
 let list_diff l x =
-  filter (fun y -> y <> x) l
+  List.filter (fun y -> y <> x) l
 
 let deg_hom p =
   match p with
@@ -984,12 +982,12 @@ let pbuchf pq p lp0=
 (*		info "pair reduced\n";*)
 		  a.pol := emultP ca (ppol a);
 		  let (lca,a0) = reduce2_trace (ppol a) lp
-		      (map (fun q -> emultP ca (coefpoldep_find a q))
+		      (List.map (fun q -> emultP ca (coefpoldep_find a q))
 			 !poldep) in
 (*		info "paire re-reduced";*)
 		  a.pol := a0;
 (*		  let a0 = new_allpol a0 sa in*)
-		  iter2 (fun c q ->
+		  List.iter2 (fun c q ->
 		    coefpoldep_remove a q;
 		    coefpoldep_set a q c) lca !poldep;
 		  let a0 = a in
@@ -1009,7 +1007,7 @@ let is_homogeneous p =
   match p with
   | [] -> true
   | (a,m)::p1 -> let d = m.(0) in
-    for_all (fun (b,m') -> m'.(0)=d) p1
+    List.for_all (fun (b,m') -> m'.(0)=d) p1
     
 (* returns
    c
@@ -1030,15 +1028,15 @@ let in_ideal d lp p =
   Hashtbl.clear hmon;
   Hashtbl.clear coefpoldep;
   nallpol := 0;
-  allpol := Array.create 1000 polynom0;
-  homogeneous := for_all is_homogeneous (p::lp);
+  allpol := Array.make 1000 polynom0;
+  homogeneous := List.for_all is_homogeneous (p::lp);
   if !homogeneous then info "homogeneous polynomials\n";
   info ("p: "^(stringPcut p)^"\n");
-  info ("lp:\n"^(fold_left (fun r p -> r^(stringPcut p)^"\n") "" lp));
+  info ("lp:\n"^(List.fold_left (fun r p -> r^(stringPcut p)^"\n") "" lp));
   (*info ("p: "^(stringP p)^"\n");
   info ("lp:\n"^(fold_left (fun r p -> r^(stringP p)^"\n") "" lp));*)
 
-  let lp = map mk_polynom lp in
+  let lp = List.map mk_polynom lp in
   let p = mk_polynom p in
   initcoefpoldep d lp;
   coef_courant:=coef1;
@@ -1049,7 +1047,7 @@ let in_ideal d lp p =
     with NotInIdeal -> pbuchf (lp, (cpairs lp)) p lp in
   info "computed\n";
 
-  (map ppol lp1, p1, cert)
+  (List.map ppol lp1, p1, cert)
     
 (* *)
 end
diff --git a/plugins/nsatz/nsatz.ml4 b/plugins/nsatz/nsatz.ml4
index a66bd44b..b4eb57ec 100644
--- a/plugins/nsatz/nsatz.ml4
+++ b/plugins/nsatz/nsatz.ml4
@@ -1,42 +1,24 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i camlp4deps: "parsing/grammar.cma" i*)
+(*i camlp4deps: "grammar/grammar.cma" i*)
 
-open Pp
+open Errors
 open Util
-open Names
 open Term
-open Closure
-open Environ
-open Libnames
 open Tactics
-open Glob_term
-open Tacticals
-open Tacexpr
-open Pcoq
-open Tactic
-open Constr
-open Proof_type
 open Coqlib
-open Tacmach
-open Mod_subst
-open Tacinterp
-open Libobject
-open Printer
-open Declare
-open Decl_kinds
-open Entries
 
 open Num
-open Unix
 open Utile
 
+DECLARE PLUGIN "nsatz_plugin"
+
 (***********************************************************************
  Operations on coefficients
 *)
@@ -74,7 +56,7 @@ module BigInt = struct
   let to_int x = int_of_big_int x
   let hash x =
     try (int_of_big_int x)
-    with _-> 1
+    with Failure _ -> 1
   let puis = power_big_int_positive_int
 
   (* a et b positifs, résultat positif *)
@@ -156,7 +138,7 @@ type term =
 
 let const n =
   if eq_num n num_0 then Zero else Const n
-let pow(p,i) = if i=1 then p else Pow(p,i)
+let pow(p,i) = if Int.equal i 1 then p else Pow(p,i)
 let add = function
     (Zero,q) -> q
   | (p,Zero) -> p
@@ -212,7 +194,7 @@ let rec mkt_pos n =
     mkt_app pxI [mkt_pos (quo_num n num_2)]
 
 let mkt_n n =
-  if n=num_0
+  if Num.eq_num n num_0
   then Lazy.force nN0
   else mkt_app nNpos [mkt_pos n]
 
@@ -232,7 +214,7 @@ let rec mkt_term t  =  match t with
 | Add (t1,t2) -> mkt_app  ttadd [Lazy.force tz; mkt_term t1; mkt_term t2]
 | Sub (t1,t2) -> mkt_app  ttsub [Lazy.force tz; mkt_term t1; mkt_term t2]
 | Mul (t1,t2) -> mkt_app  ttmul [Lazy.force tz; mkt_term t1; mkt_term t2]
-| Pow (t1,n) ->  if (n = 0) then
+| Pow (t1,n) ->  if Int.equal n 0 then
     mkt_app ttconst [Lazy.force tz; mkt_z num_1]
 else
     mkt_app ttpow [Lazy.force tz; mkt_term t1; mkt_n (num_of_int n)]
@@ -331,7 +313,7 @@ let term_pol_sparse np t=
     match t with
     | Zero -> zeroP
     | Const r ->
-	if r = num_0
+	if Num.eq_num r num_0
 	then zeroP
 	else polconst d (Poly.Pint (Coef.of_num r))
     | Var v ->
@@ -385,19 +367,19 @@ let pol_sparse_to_term n2 p =
 		if m.(k)>0
 		then i0:=k
 	      done;
-	      if !i0 = 0
+	      if Int.equal !i0 0
 	      then (r,d)
 	      else if !i0 > r
 	      then (!i0, m.(!i0))
-	      else if !i0 = r && m.(!i0)<d
+	      else if Int.equal !i0 r && m.(!i0)<d
 	      then (!i0, m.(!i0))
 	      else (r,d))
 	  (0,0)
 	  p in
-      if i0=0
+      if Int.equal i0 0
       then
 	let mp = ref (polrec_to_term a) in
-        if p1=[]
+        if List.is_empty p1
 	then !mp
 	else add(!mp,aux p1)
       else (
@@ -411,7 +393,7 @@ let pol_sparse_to_term n2 p =
 	     else p2:=(a,m)::(!p2))
 	  p;
 	let vm =
-	  if e0=1
+	  if Int.equal e0 1
 	  then Var (string_of_int (i0))
 	  else pow (Var (string_of_int (i0)),e0) in
 	add(mul(vm, aux (List.rev (!p1))), aux (List.rev (!p2))))
@@ -419,13 +401,13 @@ let pol_sparse_to_term n2 p =
   aux p
 
 
-let rec remove_list_tail l i =
+let remove_list_tail l i =
   let rec aux l i =
-    if l=[]
+    if List.is_empty l
     then []
     else if i<0
     then l
-    else if i=0
+    else if Int.equal i 0
     then List.tl l
     else
       match l with
@@ -447,7 +429,7 @@ let rec remove_list_tail l i =
 let remove_zeros zero lci =
   let n = List.length (List.hd lci) in
   let m=List.length lci in
-  let u = Array.create m false in
+  let u = Array.make m false in
   let rec utiles k =
     if k>=m
     then ()
@@ -543,7 +525,7 @@ let theoremedeszeros_termes lp =
 	  let (cert,lp0,p,_lct) = theoremedeszeros lpol p in
           info "cert ok\n";
 	  let lc = cert.last_comb::List.rev cert.gb_comb in
-	  match remove_zeros (fun x -> x=zeroP) lc with
+	  match remove_zeros (fun x -> equal x zeroP) lc with
 	  | [] -> assert false
 	  | (lq::lci) ->
 	      (* lci commence par les nouveaux polynomes *)
@@ -610,7 +592,7 @@ let nsatz_compute t =
   return_term lpol
 
 TACTIC EXTEND nsatz_compute
-| [ "nsatz_compute"  constr(lt) ] -> [ nsatz_compute lt ]
+| [ "nsatz_compute"  constr(lt) ] -> [ Proofview.V82.tactic (nsatz_compute lt) ]
 END
 
 
diff --git a/plugins/nsatz/polynom.ml b/plugins/nsatz/polynom.ml
index 026b66c7..a9651304 100644
--- a/plugins/nsatz/polynom.ml
+++ b/plugins/nsatz/polynom.ml
@@ -1,14 +1,14 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
 (* Recursive polynomials: R[x1]...[xn]. *)
-open Utile
 open Util
+open Utile
 
 (* 1. Coefficients: R *)
 
@@ -133,7 +133,7 @@ let x n = Prec (n,[|cf0;cf1|])
 let monome v n =
   match n with
       0->Pint coef1;
-    |_->let tmp = Array.create (n+1) (Pint coef0) in
+    |_->let tmp = Array.make (n+1) (Pint coef0) in
         tmp.(n)<-(Pint coef1);
         Prec (v, tmp)
 
@@ -159,28 +159,21 @@ let rec max_var_pol2 p =
       Pint _ -> 0
     |Prec(v,c)-> Array.fold_right (fun q m -> max (max_var_pol2 q) m) c v
 
-let rec max_var l = Array.fold_right (fun p m -> max (max_var_pol2 p) m) l 0
+let max_var l = Array.fold_right (fun p m -> max (max_var_pol2 p) m) l 0
 
 (* equality between polynomials *)
 
 let rec equal p q =
   match (p,q) with
       (Pint a,Pint b) -> C.equal a b
-    |(Prec(x,p1),Prec(y,q1)) ->
-       if x<>y then false
-       else if (Array.length p1)<>(Array.length q1) then false
-       else (try (Array.iteri (fun i a -> if not (equal a q1.(i))
-			       then failwith "raté")
-		    p1;
-		  true)
-	     with e when Errors.noncritical e -> false)
+    |(Prec(x,p1),Prec(y,q1)) -> (Int.equal x y) && Array.for_all2 equal p1 q1
     | (_,_) -> false
 
 (* normalize polynomial: remove head zeros, coefficients are normalized
    if constant, returns the coefficient
 *)
 
-let rec norm p = match p with
+let norm p = match p with
     Pint _ -> p
   |Prec (x,a)->
      let d = (Array.length a -1) in
@@ -189,17 +182,17 @@ let rec norm p = match p with
 	 n:=!n-1;
        done;
        if !n<0 then Pint coef0
-       else if !n=0 then a.(0)
-       else if !n=d then p
-       else (let b=Array.create (!n+1) (Pint coef0) in
+       else if Int.equal !n 0 then a.(0)
+       else if Int.equal !n d then p
+       else (let b=Array.make (!n+1) (Pint coef0) in
                for i=0 to !n do b.(i)<-a.(i);done;
                Prec(x,b))
 
 
 (* degree in v, v >= max var of p *)
-let rec deg v p =
+let deg v p =
   match p with
-      Prec(x,p1) when x=v -> Array.length p1 -1
+      Prec(x,p1) when Int.equal x v -> Array.length p1 -1
     |_ -> 0
 
 
@@ -219,8 +212,8 @@ let rec copyP p =
 (* coefficient of degree i in v, v >= max var of p *)
 let coef v i p =
   match p with
-      Prec (x,p1) when x=v  -> if i<(Array.length p1) then p1.(i) else Pint coef0
-    |_ -> if i=0 then p else Pint coef0
+      Prec (x,p1) when Int.equal x v  -> if i<(Array.length p1) then p1.(i) else Pint coef0
+    |_ -> if Int.equal i 0 then p else Pint coef0
 
 (* addition *)
 
@@ -243,7 +236,7 @@ let rec plusP p q =
                               Prec (x,p2))
           else
             (let n=max (deg x p) (deg x q) in
-             let r=Array.create (n+1) (Pint coef0) in
+             let r=Array.make (n+1) (Pint coef0) in
                for i=0 to n do
                  r.(i)<- plusP (coef x i p) (coef x i q);
                done;
@@ -275,15 +268,15 @@ let rec vars=function
 
 
 (* multiply p by v^n, v >= max_var p *)
-let rec multx n v p =
+let multx n v p =
   match p with
-      Prec (x,p1) when x=v -> let p2= Array.create ((Array.length p1)+n) (Pint coef0) in
+      Prec (x,p1) when Int.equal x v -> let p2= Array.make ((Array.length p1)+n) (Pint coef0) in
         for i=0 to (Array.length p1)-1 do
           p2.(i+n)<-p1.(i);
         done;
         Prec (x,p2)
     |_ -> if equal p (Pint coef0) then (Pint coef0)
-       else (let p2=Array.create (n+1) (Pint coef0) in
+       else (let p2=Array.make (n+1) (Pint coef0) in
                p2.(n)<-p;
                Prec (v,p2))
 
@@ -313,14 +306,14 @@ let rec multP p q =
 
 
 (* derive p with variable v, v >= max_var p *)
-let rec deriv v p =
+let deriv v p =
   match p with
       Pint a -> Pint coef0
-    | Prec(x,p1) when x=v ->
+    | Prec(x,p1) when Int.equal x v ->
        let d = Array.length p1 -1 in
-         if d=1 then p1.(1)
+         if Int.equal d 1 then p1.(1)
          else
-           (let p2 = Array.create d (Pint coef0) in
+           (let p2 = Array.make d (Pint coef0) in
               for i=0 to d-1 do
 		p2.(i)<- multP (Pint (coef_of_int (i+1))) p1.(i+1);
               done;
@@ -415,7 +408,7 @@ let rec string_of_Pcut p =
       and s=ref ""
       and sp=ref "" in
     let st0 = string_of_Pcut t.(0) in
-      if st0<>"0"
+      if not (String.equal st0 "0")
       then s:=st0;
     let fin = ref false in
     for i=(Array.length t)-1 downto 1 do
@@ -426,31 +419,31 @@ let rec string_of_Pcut p =
       else (
 	let si=string_of_Pcut  t.(i) in
 	sp:="";
-	if i=1
+	if Int.equal i 1
 	then (
-	  if si<>"0"
+	  if not (String.equal si "0")
 	  then (nsP:=(!nsP)-1;
-		if si="1"
+		if String.equal si "1"
 		then sp:=v
 		else
 		  (if (String.contains si '+')
 		  then sp:="("^si^")*"^v
 		  else sp:=si^"*"^v)))
 	else (
-	  if si<>"0"
+	  if not (String.equal si "0")
 	  then (nsP:=(!nsP)-1;
-		if si="1"
+		if String.equal si "1"
 		then sp:=v^"^"^(string_of_int i)
 		else (if (String.contains si '+')
 		then sp:="("^si^")*"^v^"^"^(string_of_int i)
 		else  sp:=si^"*"^v^"^"^(string_of_int i))));
-	if !sp<>"" && not (!fin)
+	if not (String.is_empty !sp) && not (!fin)
 	then (nsP:=(!nsP)-1;
-	      if !s=""
+	      if String.is_empty !s
 	      then s:=!sp
 	      else s:=(!s)^"+"^(!sp)));
     done;
-    if !s="" then (nsP:=(!nsP)-1;
+    if String.is_empty !s then (nsP:=(!nsP)-1;
 		   (s:="0"));
     !s
 
@@ -473,7 +466,7 @@ let print_lpoly lp = print_tpoly (Array.of_list lp)
 
 (* return (s,r) s.t. p = s*q+r *)
 let rec quo_rem_pol p q x =
-  if x=0
+  if Int.equal x 0
   then (match (p,q) with
           |(Pint a, Pint b) ->
 	     if C.equal (C.modulo a b) coef0
@@ -519,12 +512,11 @@ let divP p q=
 
 let div_pol_rat p q=
   let x = max (max_var_pol p) (max_var_pol q) in
-    try (let s = div_pol (multP p (puisP (Pint(coef_int_tete q))
-				     (1+(deg x p) - (deg x q))))
-		   q x in
-         (* degueulasse, mais c 'est pour enlever un warning *)
-         if s==s then true else true)
-    with e when Errors.noncritical e -> false
+  try
+    let r = puisP (Pint(coef_int_tete q)) (1+(deg x p)-(deg x q)) in
+    let _ = div_pol (multP p r) q x in
+    true
+  with Failure _ -> false
 
 (***********************************************************************
   5. Pseudo-division and gcd with subresultants.
@@ -538,7 +530,7 @@ let div_pol_rat p q=
 let pseudo_div p q x =
   match q with
       Pint _ -> (cf0, q,1, p)
-    | Prec (v,q1) when x<>v -> (cf0, q,1, p)
+    | Prec (v,q1) when not (Int.equal x v) -> (cf0, q,1, p)
     | Prec (v,q1) ->
 	(
 	  (*  pr "pseudo_division: c^d*p = s*q + r";*)
@@ -575,13 +567,13 @@ and pgcd_pol p q x =
 
 and content_pol p x =
   match p with
-      Prec(v,p1) when v=x ->
+      Prec(v,p1) when Int.equal v x ->
         Array.fold_left (fun a b -> pgcd_pol_rec a b (x-1)) cf0 p1
     | _ -> p
 
 and pgcd_coef_pol c p x =
   match p with
-      Prec(v,p1) when x=v ->
+      Prec(v,p1) when Int.equal x v ->
         Array.fold_left (fun a b -> pgcd_pol_rec a b (x-1)) c  p1
     |_ -> pgcd_pol_rec c p (x-1)
 
@@ -593,9 +585,9 @@ and pgcd_pol_rec p q x =
 	  then q
 	  else if equal q cf0
 	  then p
-	  else if (deg x q) = 0
+	  else if Int.equal (deg x q) 0
 	  then pgcd_coef_pol q p x
-	  else if (deg x p) = 0
+	  else if Int.equal (deg x p) 0
 	  then pgcd_coef_pol p q x
 	  else (
 	    let a = content_pol p x in
@@ -610,7 +602,7 @@ and pgcd_pol_rec p q x =
 	    res
 	   )
 
-(* Sub-résultants:
+(* Sub-résultants:
 
    ai*Ai = Qi*Ai+1 + bi*Ai+2
 
@@ -655,7 +647,7 @@ and gcd_sub_res_rec p q s c d x =
 
 and lazard_power c s d x =
   let res = ref c in
-    for i=1 to d-1 do
+    for _i = 1 to d - 1 do
       res:= div_pol ((!res)@@c) s x;
     done;
     !res
diff --git a/plugins/nsatz/polynom.mli b/plugins/nsatz/polynom.mli
index 0f1e0481..9d46cd99 100644
--- a/plugins/nsatz/polynom.mli
+++ b/plugins/nsatz/polynom.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/plugins/nsatz/utile.ml b/plugins/nsatz/utile.ml
index 17c8654b..8e2fc07c 100644
--- a/plugins/nsatz/utile.ml
+++ b/plugins/nsatz/utile.ml
@@ -26,20 +26,6 @@ let set_of_list_eq eq l =
    List.iter (fun x -> if not (list_mem_eq eq x (!res)) then res:=x::(!res)) l;
    List.rev !res
 
-
-(* Memoization
-   f is compatible with nf: f(nf(x)) = f(x)
-*)
-
-let memos s memoire nf f x =
-   try (let v = Hashtbl.find memoire (nf x) in pr s;v)
-   with e when Errors.noncritical e ->
-     (pr "#";
-      let v = f x in
-      Hashtbl.add memoire (nf x) v;
-      v)
-
-
 (**********************************************************************
   Eléments minimaux pour un ordre partiel de division.
   E est un ensemble, avec une multiplication
@@ -95,7 +81,7 @@ let facteurs_liste div constant lp =
    c est un élément quelconque de E.
 *)
 let factorise_tableau div zero c f l1 =
-    let res = Array.create (Array.length f) (c,[]) in
+    let res = Array.make (Array.length f) (c,[]) in
     Array.iteri (fun i p ->
       let r = ref p in
       let li = ref [] in
diff --git a/plugins/nsatz/utile.mli b/plugins/nsatz/utile.mli
index 83b2ac39..1f841575 100644
--- a/plugins/nsatz/utile.mli
+++ b/plugins/nsatz/utile.mli
@@ -10,10 +10,6 @@ val info : string -> unit
 val list_mem_eq : ('a -> 'b -> bool) -> 'a -> 'b list -> bool
 val set_of_list_eq : ('a -> 'a -> bool) -> 'a list -> 'a list
 
-(* Memoization *)
-val memos :
-  string -> ('a, 'b) Hashtbl.t -> ('c -> 'a) -> ('c -> 'b) -> 'c -> 'b
-
 
 val facteurs_liste : ('a -> 'a -> 'a) -> ('a -> bool) -> 'a list -> 'a list
 val factorise_tableau :
diff --git a/plugins/omega/Omega.v b/plugins/omega/Omega.v
index 0192528c..7400d462 100644
--- a/plugins/omega/Omega.v
+++ b/plugins/omega/Omega.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -54,4 +54,4 @@ Hint Extern 10 (~ (_ < _)%Z) => abstract omega: zarith.
 Hint Extern 10 (~ (_ >= _)%Z) => abstract omega: zarith.
 Hint Extern 10 (~ (_ > _)%Z) => abstract omega: zarith.
 
-Hint Extern 10 False => abstract omega: zarith.
\ No newline at end of file
+Hint Extern 10 False => abstract omega: zarith.
diff --git a/plugins/omega/OmegaPlugin.v b/plugins/omega/OmegaPlugin.v
index d23e3d13..9e5c1484 100644
--- a/plugins/omega/OmegaPlugin.v
+++ b/plugins/omega/OmegaPlugin.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/plugins/omega/PreOmega.v b/plugins/omega/PreOmega.v
index ae445f3a..ee0f841c 100644
--- a/plugins/omega/PreOmega.v
+++ b/plugins/omega/PreOmega.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -400,6 +400,5 @@ Ltac zify_N := repeat zify_N_rel; repeat zify_N_op; unfold Z_of_N' in *.
 
 (** The complete Z-ification tactic *)
 
-Ltac zify :=
- repeat progress (zify_nat; zify_positive; zify_N); zify_op.
+Ltac zify := repeat (zify_nat; zify_positive; zify_N); zify_op.
 
diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml
index 78d276da..37428c39 100644
--- a/plugins/omega/coq_omega.ml
+++ b/plugins/omega/coq_omega.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -9,38 +9,35 @@
 (*                                                                        *)
 (* Omega: a solver of quantifier-free problems in Presburger Arithmetic   *)
 (*                                                                        *)
-(* Pierre Crégut (CNET, Lannion, France)                                  *)
+(* Pierre Crégut (CNET, Lannion, France)                                  *)
 (*                                                                        *)
 (**************************************************************************)
 
+open Errors
 open Util
-open Pp
-open Reduction
-open Proof_type
 open Names
 open Nameops
 open Term
-open Declarations
-open Environ
-open Sign
-open Inductive
 open Tacticals
 open Tacmach
-open Evar_refiner
 open Tactics
-open Clenv
 open Logic
 open Libnames
+open Globnames
 open Nametab
 open Contradiction
+open Misctypes
 
 module OmegaSolver = Omega.MakeOmegaSolver (Bigint)
 open OmegaSolver
 
 (* Added by JCF, 09/03/98 *)
 
-let elim_id id gl = simplest_elim (pf_global gl id) gl
-let resolve_id id gl = apply (pf_global gl id) gl
+let elim_id id =
+  Proofview.Goal.nf_enter begin fun gl ->
+    simplest_elim (Tacmach.New.pf_global id gl)
+  end
+let resolve_id id gl = Proofview.V82.of_tactic (apply (pf_global gl id)) gl
 
 let timing timer_name f arg = f arg
 
@@ -51,20 +48,15 @@ let old_style_flag = ref false
 
 (* Should we reset all variable labels between two runs of omega ? *)
 
-let reset_flag = ref false
+let reset_flag = ref true
 
-(* Historical version of Coq do not perform such resets, and this
-   implies that omega is slightly non-deterministic: successive runs of
-   omega on the same problem may lead to distinct proof-terms.
-   At the very least, these terms will differ on the inner
+(* Coq < 8.5 was not performing such resets, hence omega was slightly
+   non-deterministic: successive runs of omega on the same problem may
+   lead to distinct proof-terms.
+   At the very least, these terms differed on the inner
    variable names, but they could even be non-convertible :
    the OmegaSolver relies on Hashtbl.iter, it can hence find a different
-   solution when variable indices differ.
-
-   Starting from Coq 8.4pl4, omega may be made stable via the option
-   [Set Stable Omega]. In the 8.4 branch, this option is unset by default
-   for compatibility. In Coq >= 8.5, this option is set by default.
-*)
+   solution when variable indices differ. *)
 
 let read f () = !f
 let write f x = f:=x
@@ -101,19 +93,12 @@ let _ =
 let _ =
   declare_bool_option
     { optsync  = true;
-      optdepr  = false;
+      optdepr  = true;
       optname  = "Omega automatic reset of generated names";
       optkey   = ["Stable";"Omega"];
       optread  = read reset_flag;
       optwrite = write reset_flag }
 
-let all_time        = timing "Omega     "
-let solver_time     = timing "Solver    "
-let exact_time      = timing "Rewrites  "
-let elim_time       = timing "Elim      "
-let simpl_time      = timing "Simpl     "
-let generalize_time = timing "Generalize"
-
 let intref, reset_all_references =
   let refs = ref [] in
   (fun n -> let r = ref n in refs := (r,n) :: !refs; r),
@@ -121,7 +106,7 @@ let intref, reset_all_references =
 
 let new_identifier =
   let cpt = intref 0 in
-  (fun () -> let s = "Omega" ^ string_of_int !cpt in incr cpt; id_of_string s)
+  (fun () -> let s = "Omega" ^ string_of_int !cpt in incr cpt; Id.of_string s)
 
 let new_identifier_state =
   let cpt = intref 0 in
@@ -129,7 +114,7 @@ let new_identifier_state =
 
 let new_identifier_var =
   let cpt = intref 0 in
-  (fun () -> let s = "Zvar" ^ string_of_int !cpt in incr cpt; id_of_string s)
+  (fun () -> let s = "Zvar" ^ string_of_int !cpt in incr cpt; Id.of_string s)
 
 let new_id =
   let cpt = intref 0 in fun () -> incr cpt; !cpt
@@ -145,7 +130,7 @@ let display_var i = Printf.sprintf "X%d" i
 let intern_id,unintern_id,reset_intern_tables =
   let cpt = ref 0 in
   let table = Hashtbl.create 7 and co_table = Hashtbl.create 7 in
-  (fun (name : identifier) ->
+  (fun (name : Id.t) ->
      try Hashtbl.find table name with Not_found ->
        let idx = !cpt in
        Hashtbl.add table name idx;
@@ -159,30 +144,33 @@ let intern_id,unintern_id,reset_intern_tables =
 
 let mk_then = tclTHENLIST
 
-let exists_tac c = constructor_tac false (Some 1) 1 (Glob_term.ImplicitBindings [c])
+let exists_tac c = constructor_tac false (Some 1) 1 (ImplicitBindings [c])
 
-let generalize_tac t = generalize_time (generalize t)
-let elim t = elim_time (simplest_elim t)
-let exact t = exact_time (Tactics.refine t)
-let unfold s = Tactics.unfold_in_concl [Termops.all_occurrences, Lazy.force s]
+let generalize_tac t = generalize t
+let elim t = simplest_elim t
+let exact t = Tactics.refine t
+let unfold s = Tactics.unfold_in_concl [Locus.AllOccurrences, Lazy.force s]
 
 let rev_assoc k =
   let rec loop = function
-    | [] -> raise Not_found | (v,k')::_ when k = k' -> v | _ :: l -> loop l
+    | [] -> raise Not_found
+    | (v,k')::_ when Int.equal k k' -> v
+    | _ :: l -> loop l
   in
   loop
 
 let tag_hypothesis,tag_of_hyp, hyp_of_tag, clear_tags =
-  let l = ref ([]:(identifier * int) list) in
+  let l = ref ([]:(Id.t * int) list) in
   (fun h id -> l := (h,id):: !l),
-  (fun h -> try List.assoc h !l with Not_found -> failwith "tag_hypothesis"),
+  (fun h -> try Id.List.assoc h !l with Not_found -> failwith "tag_hypothesis"),
   (fun h -> try rev_assoc h !l with Not_found -> failwith "tag_hypothesis"),
   (fun () -> l := [])
 
 let hide_constr,find_constr,clear_constr_tables,dump_tables =
-  let l = ref ([]:(constr * (identifier * identifier * bool)) list) in
+  let l = ref ([]:(constr * (Id.t * Id.t * bool)) list) in
   (fun h id eg b -> l := (h,(id,eg,b)):: !l),
-  (fun h -> try list_assoc_f eq_constr h !l with Not_found -> failwith "find_contr"),
+  (fun h ->
+    try List.assoc_f eq_constr_nounivs h !l with Not_found -> failwith "find_contr"),
   (fun () -> l := []),
   (fun () -> !l)
 
@@ -230,8 +218,6 @@ let coq_Zopp = lazy (zbase_constant "Z.opp")
 let coq_Zminus = lazy (zbase_constant "Z.sub")
 let coq_Zsucc = lazy (zbase_constant "Z.succ")
 let coq_Zpred = lazy (zbase_constant "Z.pred")
-let coq_Zgt = lazy (zbase_constant "Z.gt")
-let coq_Zle = lazy (zbase_constant "Z.le")
 let coq_Z_of_nat = lazy (zbase_constant "Z.of_nat")
 let coq_inj_plus = lazy (z_constant "Nat2Z.inj_add")
 let coq_inj_mult = lazy (z_constant "Nat2Z.inj_mul")
@@ -318,10 +304,10 @@ let coq_le = lazy (init_constant "le")
 let coq_lt = lazy (init_constant "lt")
 let coq_ge = lazy (init_constant "ge")
 let coq_gt = lazy (init_constant "gt")
-let coq_minus = lazy (init_constant "minus")
-let coq_plus = lazy (init_constant "plus")
-let coq_mult = lazy (init_constant "mult")
-let coq_pred = lazy (init_constant "pred")
+let coq_minus = lazy (init_constant "Nat.sub")
+let coq_plus = lazy (init_constant "Nat.add")
+let coq_mult = lazy (init_constant "Nat.mul")
+let coq_pred = lazy (init_constant "Nat.pred")
 let coq_nat = lazy (init_constant "nat")
 let coq_S = lazy (init_constant "S")
 let coq_O = lazy (init_constant "O")
@@ -363,11 +349,10 @@ let coq_iff = lazy (constant "iff")
 (* uses build_coq_and, build_coq_not, build_coq_or, build_coq_ex *)
 
 (* For unfold *)
-open Closure
 let evaluable_ref_of_constr s c = match kind_of_term (Lazy.force c) with
-  | Const kn when Tacred.is_evaluable (Global.env()) (EvalConstRef kn) ->
+  | Const (kn,u) when Tacred.is_evaluable (Global.env()) (EvalConstRef kn) ->
       EvalConstRef kn
-  | _ -> anomaly ("Coq_omega: "^s^" is not an evaluable constant")
+  | _ -> anomaly ~label:"Coq_omega" (Pp.str (s^" is not an evaluable constant"))
 
 let sp_Zsucc =     lazy (evaluable_ref_of_constr "Z.succ" coq_Zsucc)
 let sp_Zpred =     lazy (evaluable_ref_of_constr "Z.pred" coq_Zpred)
@@ -378,19 +363,20 @@ let sp_Zge = lazy (evaluable_ref_of_constr "Z.ge" coq_Zge)
 let sp_Zlt = lazy (evaluable_ref_of_constr "Z.lt" coq_Zlt)
 let sp_not = lazy (evaluable_ref_of_constr "not" (lazy (build_coq_not ())))
 
-let mk_var v = mkVar (id_of_string v)
+let mk_var v = mkVar (Id.of_string v)
 let mk_plus t1 t2 = mkApp (Lazy.force coq_Zplus, [| t1; t2 |])
 let mk_times t1 t2 = mkApp (Lazy.force coq_Zmult, [| t1; t2 |])
 let mk_minus t1 t2 = mkApp (Lazy.force coq_Zminus, [| t1;t2 |])
-let mk_eq t1 t2 = mkApp (build_coq_eq (), [| Lazy.force coq_Z; t1; t2 |])
+let mk_eq t1 t2 = mkApp (Universes.constr_of_global (build_coq_eq ()),
+			 [| Lazy.force coq_Z; t1; t2 |])
 let mk_le t1 t2 = mkApp (Lazy.force coq_Zle, [| t1; t2 |])
 let mk_gt t1 t2 = mkApp (Lazy.force coq_Zgt, [| t1; t2 |])
 let mk_inv t = mkApp (Lazy.force coq_Zopp, [| t |])
 let mk_and t1 t2 =  mkApp (build_coq_and (), [| t1; t2 |])
 let mk_or t1 t2 =  mkApp (build_coq_or (), [| t1; t2 |])
 let mk_not t = mkApp (build_coq_not (), [| t |])
-let mk_eq_rel t1 t2 = mkApp (build_coq_eq (),
-			      [| Lazy.force coq_comparison; t1; t2 |])
+let mk_eq_rel t1 t2 = mkApp (Universes.constr_of_global (build_coq_eq ()),
+			     [| Lazy.force coq_comparison; t1; t2 |])
 let mk_inj t = mkApp (Lazy.force coq_Z_of_nat, [| t |])
 
 let mk_integer n =
@@ -419,7 +405,7 @@ type omega_proposition =
   | Kn
 
 type result =
-  | Kvar of identifier
+  | Kvar of Id.t
   | Kapp of omega_constant * constr list
   | Kimp of constr * constr
   | Kufo
@@ -434,7 +420,7 @@ type result =
 let destructurate_prop t =
   let c, args = decompose_app t in
   match kind_of_term c, args with
-    | _, [_;_;_] when eq_constr c (build_coq_eq ()) -> Kapp (Eq,args)
+    | _, [_;_;_] when is_global (build_coq_eq ()) c -> Kapp (Eq,args)
     | _, [_;_] when eq_constr c (Lazy.force coq_neq) -> Kapp (Neq,args)
     | _, [_;_] when eq_constr c (Lazy.force coq_Zne) -> Kapp (Zne,args)
     | _, [_;_] when eq_constr c (Lazy.force coq_Zle) -> Kapp (Zle,args)
@@ -451,11 +437,11 @@ let destructurate_prop t =
     | _, [_;_] when eq_constr c (Lazy.force coq_lt) -> Kapp (Lt,args)
     | _, [_;_] when eq_constr c (Lazy.force coq_ge) -> Kapp (Ge,args)
     | _, [_;_] when eq_constr c (Lazy.force coq_gt) -> Kapp (Gt,args)
-    | Const sp, args ->
+    | Const (sp,_), args ->
 	Kapp (Other (string_of_path (path_of_global (ConstRef sp))),args)
-    | Construct csp , args ->
+    | Construct (csp,_) , args ->
 	Kapp (Other (string_of_path (path_of_global (ConstructRef csp))), args)
-    | Ind isp, args ->
+    | Ind (isp,_), args ->
 	Kapp (Other (string_of_path (path_of_global (IndRef isp))),args)
     | Var id,[] -> Kvar id
     | Prod (Anonymous,typ,body), [] -> Kimp(typ,body)
@@ -549,7 +535,6 @@ let context operation path (t : constr) =
       | ((P_TYPE :: p), LetIn (n,b,t,c)) ->
 	  (mkLetIn (n,b,loop i p t,c))
       | (p, _) ->
-	  ppnl (Printer.pr_lconstr t);
 	  failwith ("abstract_path " ^ string_of_int(List.length p))
   in
   loop 1 path t
@@ -570,7 +555,6 @@ let occurence path (t : constr) =
     | ((P_TYPE :: p), Lambda (n,term,c)) -> loop p term
     | ((P_TYPE :: p), LetIn (n,b,term,c)) -> loop p term
     | (p, _) ->
-	ppnl (Printer.pr_lconstr t);
 	failwith ("occurence " ^ string_of_int(List.length p))
   in
   loop path t
@@ -578,19 +562,19 @@ let occurence path (t : constr) =
 let abstract_path typ path t =
   let term_occur = ref (mkRel 0) in
   let abstract = context (fun i t -> term_occur:= t; mkRel i) path t in
-  mkLambda (Name (id_of_string "x"), typ, abstract), !term_occur
+  mkLambda (Name (Id.of_string "x"), typ, abstract), !term_occur
 
 let focused_simpl path gl =
   let newc = context (fun i t -> pf_nf gl t) (List.rev path) (pf_concl gl) in
-  convert_concl_no_check newc DEFAULTcast gl
+  Proofview.V82.of_tactic (convert_concl_no_check newc DEFAULTcast) gl
 
-let focused_simpl path = simpl_time (focused_simpl path)
+let focused_simpl path = focused_simpl path
 
 type oformula =
   | Oplus of oformula * oformula
   | Oinv of  oformula
   | Otimes of oformula * oformula
-  | Oatom of identifier
+  | Oatom of Id.t
   | Oz of bigint
   | Oufo of constr
 
@@ -602,7 +586,7 @@ let rec oprint = function
   | Otimes (t1,t2) ->
       print_string "("; oprint t1; print_string "*";
       oprint t2; print_string ")"
-  | Oatom s -> print_string (string_of_id s)
+  | Oatom s -> print_string (Id.to_string s)
   | Oz i -> print_string (string_of_bigint i)
   | Oufo f -> print_string "?"
 
@@ -629,11 +613,11 @@ let compile name kind =
 	let id = new_id () in
 	tag_hypothesis name id;
 	{kind = kind; body = List.rev accu; constant = n; id = id}
-    | _ -> anomaly "compile_equation"
+    | _ -> anomaly (Pp.str "compile_equation")
   in
   loop []
 
-let rec decompile af =
+let decompile af =
   let rec loop = function
     | ({v=v; c=n}::r) -> Oplus(Otimes(Oatom (unintern_id v),Oz n),loop r)
     | [] -> Oz af.constant
@@ -648,10 +632,10 @@ let clever_rewrite_base_poly typ p result theorem gl =
   let t =
     applist
       (mkLambda
-	 (Name (id_of_string "P"),
+	 (Name (Id.of_string "P"),
 	  mkArrow typ mkProp,
           mkLambda
-	    (Name (id_of_string "H"),
+	    (Name (Id.of_string "H"),
 	     applist (mkRel 1,[result]),
 	     mkApp (Lazy.force coq_eq_ind_r,
 		       [| typ; result; mkRel 2; mkRel 1; occ; theorem |]))),
@@ -724,10 +708,10 @@ let rec shuffle p (t1,t2) =
 	  Oplus(t2,t1)
 	else [],Oplus(t1,t2)
 
-let rec shuffle_mult p_init k1 e1 k2 e2 =
+let shuffle_mult p_init k1 e1 k2 e2 =
   let rec loop p = function
     | (({c=c1;v=v1}::l1) as l1'),(({c=c2;v=v2}::l2) as l2') ->
-	if v1 = v2 then
+	if Int.equal v1 v2 then
           let tac =
             clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1; P_APP 1];
                               [P_APP 1; P_APP 1; P_APP 1; P_APP 2];
@@ -781,10 +765,10 @@ let rec shuffle_mult p_init k1 e1 k2 e2 =
   in
   loop p_init (e1,e2)
 
-let rec shuffle_mult_right p_init e1 k2 e2 =
+let shuffle_mult_right p_init e1 k2 e2 =
   let rec loop p = function
     | (({c=c1;v=v1}::l1) as l1'),(({c=c2;v=v2}::l2) as l2') ->
-	if v1 = v2 then
+	if Int.equal v1 v2 then
           let tac =
             clever_rewrite p
               [[P_APP 1; P_APP 1; P_APP 1];
@@ -866,7 +850,7 @@ let rec scalar p n = function
   | Oz i -> [focused_simpl p],Oz(n*i)
   | Oufo c -> [], Oufo (mkApp (Lazy.force coq_Zmult, [| mk_integer n; c |]))
 
-let rec scalar_norm p_init =
+let scalar_norm p_init =
   let rec loop p = function
     | [] -> [focused_simpl p_init]
     | (_::l) ->
@@ -877,7 +861,7 @@ let rec scalar_norm p_init =
   in
   loop p_init
 
-let rec norm_add p_init =
+let norm_add p_init =
   let rec loop p = function
     | [] -> [focused_simpl p_init]
     | _:: l ->
@@ -887,7 +871,7 @@ let rec norm_add p_init =
   in
   loop p_init
 
-let rec scalar_norm_add p_init =
+let scalar_norm_add p_init =
   let rec loop p = function
     | [] -> [focused_simpl p_init]
     | _ :: l ->
@@ -1015,7 +999,7 @@ let reduce_factor p = function
 
 let rec condense p = function
   | Oplus(f1,(Oplus(f2,r) as t)) ->
-      if weight f1 = weight f2 then begin
+      if Int.equal (weight f1) (weight f2) then begin
 	let shrink_tac,t = shrink_pair (P_APP 1 :: p) f1 f2 in
 	let assoc_tac =
           clever_rewrite p
@@ -1031,7 +1015,7 @@ let rec condense p = function
   | Oplus(f1,Oz n) ->
       let tac,f1' = reduce_factor (P_APP 1 :: p) f1 in tac,Oplus(f1',Oz n)
   | Oplus(f1,f2) ->
-      if weight f1 = weight f2 then begin
+      if Int.equal (weight f1) (weight f2) then begin
 	let tac_shrink,t = shrink_pair p f1 f2 in
 	let tac,t' = condense p t in
 	tac_shrink :: tac,t'
@@ -1059,17 +1043,17 @@ let rec clear_zero p = function
   | t -> [],t
 
 let replay_history tactic_normalisation =
-  let aux  = id_of_string "auxiliary" in
-  let aux1 = id_of_string "auxiliary_1" in
-  let aux2 = id_of_string "auxiliary_2" in
+  let aux  = Id.of_string "auxiliary" in
+  let aux1 = Id.of_string "auxiliary_1" in
+  let aux2 = Id.of_string "auxiliary_2" in
   let izero = mk_integer zero in
-  let rec loop t =
+  let rec loop t : unit Proofview.tactic =
     match t with
       | HYP e :: l ->
 	  begin
 	    try
-	      tclTHEN
-		(List.assoc (hyp_of_tag e.id) tactic_normalisation)
+	      Tacticals.New.tclTHEN
+		(Id.List.assoc (hyp_of_tag e.id) tactic_normalisation)
 		(loop l)
 	    with Not_found -> loop l end
       | NEGATE_CONTRADICT (e2,e1,b) :: l ->
@@ -1080,16 +1064,16 @@ let replay_history tactic_normalisation =
 	  let k = if b then negone else one in
 	  let p_initial = [P_APP 1;P_TYPE] in
 	  let tac= shuffle_mult_right p_initial e1.body k e2.body in
-	  tclTHENLIST [
-	    (generalize_tac
+	  Tacticals.New.tclTHENLIST [
+	    Proofview.V82.tactic (generalize_tac
 	      [mkApp (Lazy.force coq_OMEGA17, [|
 		val_of eq1;
 		val_of eq2;
 		mk_integer k;
 		mkVar id1; mkVar id2 |])]);
-	    (mk_then tac);
+	    Proofview.V82.tactic (mk_then tac);
 	    (intros_using [aux]);
-	    (resolve_id aux);
+	    Proofview.V82.tactic (resolve_id aux);
             reflexivity
           ]
       | CONTRADICTION (e1,e2) :: l ->
@@ -1098,15 +1082,16 @@ let replay_history tactic_normalisation =
 	  let p_initial = [P_APP 2;P_TYPE] in
 	  let tac = shuffle_cancel p_initial e1.body in
 	  let solve_le =
-            let not_sup_sup = mkApp (build_coq_eq (), [|
+            let not_sup_sup = mkApp (Universes.constr_of_global (build_coq_eq ()),
+				     [|
 					Lazy.force coq_comparison;
 					Lazy.force coq_Gt;
 					Lazy.force coq_Gt |])
 	    in
-            tclTHENS
-	      (tclTHENLIST [
-		(unfold sp_Zle);
-		(simpl_in_concl);
+            Tacticals.New.tclTHENS
+	      (Tacticals.New.tclTHENLIST [
+		Proofview.V82.tactic (unfold sp_Zle);
+		Proofview.V82.tactic (simpl_in_concl);
 		intro;
 		(absurd not_sup_sup) ])
 	      [ assumption ; reflexivity ]
@@ -1117,7 +1102,7 @@ let replay_history tactic_normalisation =
 		      mkVar (hyp_of_tag e1.id);
 		      mkVar (hyp_of_tag e2.id) |])
 	  in
-	  tclTHEN (tclTHEN (generalize_tac [theorem]) (mk_then tac)) (solve_le)
+	  Proofview.tclTHEN (Proofview.V82.tactic (tclTHEN (generalize_tac [theorem]) (mk_then tac))) (solve_le)
       | DIVIDE_AND_APPROX (e1,e2,k,d) :: l ->
 	  let id = hyp_of_tag e1.id in
 	  let eq1 = val_of(decompile e1)
@@ -1127,34 +1112,34 @@ let replay_history tactic_normalisation =
 	  let rhs = mk_plus (mk_times eq2 kk) dd in
 	  let state_eg = mk_eq eq1 rhs in
 	  let tac = scalar_norm_add [P_APP 3] e2.body in
-	  tclTHENS
+	  Tacticals.New.tclTHENS
 	    (cut state_eg)
-	    [ tclTHENS
-	        (tclTHENLIST [
+	    [ Tacticals.New.tclTHENS
+	        (Tacticals.New.tclTHENLIST [
 		  (intros_using [aux]);
-		  (generalize_tac
+		  Proofview.V82.tactic (generalize_tac
 		    [mkApp (Lazy.force coq_OMEGA1,
 		      [| eq1; rhs; mkVar aux; mkVar id |])]);
-		  (clear [aux;id]);
+		  Proofview.V82.tactic (clear [aux;id]);
 		  (intros_using [id]);
 		  (cut (mk_gt kk dd)) ])
-	        [ tclTHENS
+	        [ Tacticals.New.tclTHENS
 		    (cut (mk_gt kk izero))
-		    [ tclTHENLIST [
+		    [ Tacticals.New.tclTHENLIST [
 		        (intros_using [aux1; aux2]);
-		        (generalize_tac
+		        (Proofview.V82.tactic (generalize_tac
 			  [mkApp (Lazy.force coq_Zmult_le_approx,
-			    [| kk;eq2;dd;mkVar aux1;mkVar aux2; mkVar id |])]);
-		        (clear [aux1;aux2;id]);
+			    [| kk;eq2;dd;mkVar aux1;mkVar aux2; mkVar id |])]));
+		        Proofview.V82.tactic (clear [aux1;aux2;id]);
 		        (intros_using [id]);
 		        (loop l) ];
-		      tclTHENLIST [
-			(unfold sp_Zgt);
-			(simpl_in_concl);
+		      Tacticals.New.tclTHENLIST [
+			(Proofview.V82.tactic (unfold sp_Zgt));
+			(Proofview.V82.tactic simpl_in_concl);
 			reflexivity ] ];
-		  tclTHENLIST [ (unfold sp_Zgt); simpl_in_concl; reflexivity ]
+		  Tacticals.New.tclTHENLIST [ Proofview.V82.tactic (unfold sp_Zgt); Proofview.V82.tactic simpl_in_concl; reflexivity ]
                 ];
-	      tclTHEN (mk_then tac) reflexivity ]
+	      Tacticals.New.tclTHEN (Proofview.V82.tactic (mk_then tac)) reflexivity ]
 
       | NOT_EXACT_DIVIDE (e1,k) :: l ->
 	  let c = floor_div e1.constant k in
@@ -1165,27 +1150,27 @@ let replay_history tactic_normalisation =
 	  let kk = mk_integer k
 	  and dd = mk_integer d in
 	  let tac = scalar_norm_add [P_APP 2] e2.body in
-	  tclTHENS
+	  Tacticals.New.tclTHENS
 	    (cut (mk_gt dd izero))
-	    [ tclTHENS (cut (mk_gt kk dd))
-		[tclTHENLIST [
+	    [ Tacticals.New.tclTHENS (cut (mk_gt kk dd))
+		[Tacticals.New.tclTHENLIST [
 		  (intros_using [aux2;aux1]);
-		  (generalize_tac
+		  Proofview.V82.tactic (generalize_tac
 		    [mkApp (Lazy.force coq_OMEGA4,
                       [| dd;kk;eq2;mkVar aux1; mkVar aux2 |])]);
-		  (clear [aux1;aux2]);
-		  (unfold sp_not);
+		  Proofview.V82.tactic (clear [aux1;aux2]);
+		  Proofview.V82.tactic (unfold sp_not);
 		  (intros_using [aux]);
-		  (resolve_id aux);
-		  (mk_then tac);
+		  Proofview.V82.tactic (resolve_id aux);
+		  Proofview.V82.tactic (mk_then tac);
 		  assumption ] ;
-		 tclTHENLIST [
-		   (unfold sp_Zgt);
-		   simpl_in_concl;
+		 Tacticals.New.tclTHENLIST [
+		   Proofview.V82.tactic (unfold sp_Zgt);
+		   Proofview.V82.tactic simpl_in_concl;
 		   reflexivity ] ];
-              tclTHENLIST [
-		(unfold sp_Zgt);
-                simpl_in_concl;
+              Tacticals.New.tclTHENLIST [
+		Proofview.V82.tactic (unfold sp_Zgt);
+                Proofview.V82.tactic simpl_in_concl;
 		reflexivity ] ]
       | EXACT_DIVIDE (e1,k) :: l ->
 	  let id = hyp_of_tag e1.id in
@@ -1194,38 +1179,38 @@ let replay_history tactic_normalisation =
 	  and eq2 = val_of(decompile e2) in
 	  let kk = mk_integer k in
 	  let state_eq = mk_eq eq1 (mk_times eq2 kk) in
-	  if e1.kind = DISE then
+	  if e1.kind == DISE then
             let tac = scalar_norm [P_APP 3] e2.body in
-            tclTHENS
+            Tacticals.New.tclTHENS
 	      (cut state_eq)
-	      [tclTHENLIST [
+	      [Tacticals.New.tclTHENLIST [
 		(intros_using [aux1]);
-		(generalize_tac
+		Proofview.V82.tactic (generalize_tac
 		  [mkApp (Lazy.force coq_OMEGA18,
                     [| eq1;eq2;kk;mkVar aux1; mkVar id |])]);
-		(clear [aux1;id]);
+		Proofview.V82.tactic (clear [aux1;id]);
 		(intros_using [id]);
 		(loop l) ];
-	       tclTHEN (mk_then tac) reflexivity ]
+	       Tacticals.New.tclTHEN (Proofview.V82.tactic (mk_then tac)) reflexivity ]
 	  else
             let tac = scalar_norm [P_APP 3] e2.body in
-            tclTHENS (cut state_eq)
+            Tacticals.New.tclTHENS (cut state_eq)
 	      [
-		tclTHENS
+		Tacticals.New.tclTHENS
 		 (cut (mk_gt kk izero))
-		 [tclTHENLIST [
+		 [Tacticals.New.tclTHENLIST [
 		   (intros_using [aux2;aux1]);
-		   (generalize_tac
+		   Proofview.V82.tactic (generalize_tac
 		     [mkApp (Lazy.force coq_OMEGA3,
 		       [| eq1; eq2; kk; mkVar aux2; mkVar aux1;mkVar id|])]);
-		   (clear [aux1;aux2;id]);
+		   Proofview.V82.tactic (clear [aux1;aux2;id]);
 		   (intros_using [id]);
 		   (loop l) ];
-		  tclTHENLIST [
-		    (unfold sp_Zgt);
-                    simpl_in_concl;
+		  Tacticals.New.tclTHENLIST [
+		    Proofview.V82.tactic (unfold sp_Zgt);
+                    Proofview.V82.tactic simpl_in_concl;
 		    reflexivity ] ];
-		tclTHEN (mk_then tac) reflexivity ]
+		Tacticals.New.tclTHEN (Proofview.V82.tactic (mk_then tac)) reflexivity ]
       | (MERGE_EQ(e3,e1,e2)) :: l ->
 	  let id = new_identifier () in
 	  tag_hypothesis id e3;
@@ -1238,16 +1223,16 @@ let replay_history tactic_normalisation =
 	      (Lazy.force coq_fast_Zopp_eq_mult_neg_1) ::
             scalar_norm [P_APP 3] e1.body
 	  in
-	  tclTHENS
+	  Tacticals.New.tclTHENS
 	    (cut (mk_eq eq1 (mk_inv eq2)))
-	    [tclTHENLIST [
+	    [Tacticals.New.tclTHENLIST [
 	      (intros_using [aux]);
-	      (generalize_tac [mkApp (Lazy.force coq_OMEGA8,
+	      Proofview.V82.tactic (generalize_tac [mkApp (Lazy.force coq_OMEGA8,
 	        [| eq1;eq2;mkVar id1;mkVar id2; mkVar aux|])]);
-	      (clear [id1;id2;aux]);
+	      Proofview.V82.tactic (clear [id1;id2;aux]);
 	      (intros_using [id]);
 	      (loop l) ];
-            tclTHEN (mk_then tac) reflexivity]
+            Tacticals.New.tclTHEN (Proofview.V82.tactic (mk_then tac)) reflexivity]
 
       | STATE {st_new_eq=e;st_def=def;st_orig=orig;st_coef=m;st_var=v} :: l ->
 	  let id = new_identifier ()
@@ -1271,21 +1256,21 @@ let replay_history tactic_normalisation =
               [[P_APP 1]] (Lazy.force coq_fast_Zopp_eq_mult_neg_1) ::
             shuffle_mult_right p_initial
               orig.body m ({c= negone;v= v}::def.body) in
-	  tclTHENS
+	  Tacticals.New.tclTHENS
 	    (cut theorem)
-	    [tclTHENLIST [
+	    [Tacticals.New.tclTHENLIST [
 	      (intros_using [aux]);
 	      (elim_id aux);
-	      (clear [aux]);
+	      Proofview.V82.tactic (clear [aux]);
 	      (intros_using [vid; aux]);
-	      (generalize_tac
+	      Proofview.V82.tactic (generalize_tac
 		[mkApp (Lazy.force coq_OMEGA9,
 		  [| mkVar vid;eq2;eq1;mm; mkVar id2;mkVar aux |])]);
-	      (mk_then tac);
-	      (clear [aux]);
+	      Proofview.V82.tactic (mk_then tac);
+	      Proofview.V82.tactic (clear [aux]);
 	      (intros_using [id]);
 	      (loop l) ];
-            tclTHEN (exists_tac eq1) reflexivity ]
+            Tacticals.New.tclTHEN (exists_tac eq1) reflexivity ]
       | SPLIT_INEQ(e,(e1,act1),(e2,act2)) :: l ->
 	  let id1 = new_identifier ()
 	  and id2 = new_identifier () in
@@ -1294,10 +1279,10 @@ let replay_history tactic_normalisation =
 	  let tac1 = norm_add [P_APP 2;P_TYPE] e.body in
 	  let tac2 = scalar_norm_add [P_APP 2;P_TYPE] e.body in
 	  let eq = val_of(decompile e) in
-	  tclTHENS
+	  Tacticals.New.tclTHENS
 	    (simplest_elim (applist (Lazy.force coq_OMEGA19, [eq; mkVar id])))
-	    [tclTHENLIST [ (mk_then tac1); (intros_using [id1]); (loop act1) ];
-             tclTHENLIST [ (mk_then tac2); (intros_using [id2]); (loop act2) ]]
+	    [Tacticals.New.tclTHENLIST [ Proofview.V82.tactic (mk_then tac1); (intros_using [id1]); (loop act1) ];
+             Tacticals.New.tclTHENLIST [ Proofview.V82.tactic (mk_then tac2); (intros_using [id2]); (loop act2) ]]
       | SUM(e3,(k1,e1),(k2,e2)) :: l ->
 	  let id = new_identifier () in
 	  tag_hypothesis id e3;
@@ -1305,7 +1290,7 @@ let replay_history tactic_normalisation =
 	  and id2 = hyp_of_tag e2.id in
 	  let eq1 = val_of(decompile e1)
 	  and eq2 = val_of(decompile e2) in
-	  if k1 =? one & e2.kind = EQUA then
+	  if k1 =? one && e2.kind == EQUA then
             let tac_thm =
               match e1.kind with
 		| EQUA -> Lazy.force coq_OMEGA5
@@ -1314,12 +1299,12 @@ let replay_history tactic_normalisation =
 	    in
             let kk = mk_integer k2 in
             let p_initial =
-              if e1.kind=DISE then [P_APP 1; P_TYPE] else [P_APP 2; P_TYPE] in
+              if e1.kind == DISE then [P_APP 1; P_TYPE] else [P_APP 2; P_TYPE] in
             let tac = shuffle_mult_right p_initial e1.body k2 e2.body in
-            tclTHENLIST [
-	      (generalize_tac
+            Tacticals.New.tclTHENLIST [
+	      Proofview.V82.tactic (generalize_tac
                 [mkApp (tac_thm, [| eq1; eq2; kk; mkVar id1; mkVar id2 |])]);
-	      (mk_then tac);
+	      Proofview.V82.tactic (mk_then tac);
 	      (intros_using [id]);
 	      (loop l)
             ]
@@ -1328,43 +1313,43 @@ let replay_history tactic_normalisation =
 	    and kk2 = mk_integer k2 in
 	    let p_initial = [P_APP 2;P_TYPE] in
 	    let tac= shuffle_mult p_initial k1 e1.body k2 e2.body in
-            tclTHENS (cut (mk_gt kk1 izero))
-	      [tclTHENS
+            Tacticals.New.tclTHENS (cut (mk_gt kk1 izero))
+	      [Tacticals.New.tclTHENS
 		 (cut (mk_gt kk2 izero))
-		 [tclTHENLIST [
+		 [Tacticals.New.tclTHENLIST [
 		   (intros_using [aux2;aux1]);
-		   (generalize_tac
+		   Proofview.V82.tactic (generalize_tac
 		     [mkApp (Lazy.force coq_OMEGA7, [|
 		       eq1;eq2;kk1;kk2;
 		       mkVar aux1;mkVar aux2;
 		       mkVar id1;mkVar id2 |])]);
-		   (clear [aux1;aux2]);
-		   (mk_then tac);
+		   Proofview.V82.tactic (clear [aux1;aux2]);
+		   Proofview.V82.tactic (mk_then tac);
 		   (intros_using [id]);
 		   (loop l) ];
-		 tclTHENLIST [
-		   (unfold sp_Zgt);
-                   simpl_in_concl;
+		 Tacticals.New.tclTHENLIST [
+		   Proofview.V82.tactic (unfold sp_Zgt);
+                   Proofview.V82.tactic simpl_in_concl;
 		   reflexivity ] ];
-	      tclTHENLIST [
-		(unfold sp_Zgt);
-                simpl_in_concl;
+	      Tacticals.New.tclTHENLIST [
+		Proofview.V82.tactic (unfold sp_Zgt);
+                Proofview.V82.tactic simpl_in_concl;
 		reflexivity ] ]
       | CONSTANT_NOT_NUL(e,k) :: l ->
-	  tclTHEN (generalize_tac [mkVar (hyp_of_tag e)]) Equality.discrConcl
+	  Tacticals.New.tclTHEN (Proofview.V82.tactic (generalize_tac [mkVar (hyp_of_tag e)])) Equality.discrConcl
       | CONSTANT_NUL(e) :: l ->
-	  tclTHEN (resolve_id (hyp_of_tag e)) reflexivity
+	  Tacticals.New.tclTHEN (Proofview.V82.tactic (resolve_id (hyp_of_tag e))) reflexivity
       | CONSTANT_NEG(e,k) :: l ->
-	  tclTHENLIST [
-	    (generalize_tac [mkVar (hyp_of_tag e)]);
-            (unfold sp_Zle);
-	    simpl_in_concl;
-	    (unfold sp_not);
+	  Tacticals.New.tclTHENLIST [
+	    Proofview.V82.tactic (generalize_tac [mkVar (hyp_of_tag e)]);
+            Proofview.V82.tactic (unfold sp_Zle);
+	    Proofview.V82.tactic simpl_in_concl;
+	    Proofview.V82.tactic (unfold sp_not);
 	    (intros_using [aux]);
-	    (resolve_id aux);
+	    Proofview.V82.tactic (resolve_id aux);
 	    reflexivity
           ]
-      | _ -> tclIDTAC
+      | _ -> Proofview.tclUNIT ()
   in
   loop
 
@@ -1382,21 +1367,21 @@ let normalize_equation id flag theorem pos t t1 t2 (tactic,defs) =
       (generalize_tac [mkApp (theorem, [| t1; t2; mkVar id |]) ])
       (tclTRY (clear [id]))
   in
-  if tac <> [] then
+  if not (List.is_empty tac) then
     let id' = new_identifier () in
-    ((id',(tclTHENLIST [ (shift_left); (mk_then tac); (intros_using [id']) ]))
+    ((id',(Tacticals.New.tclTHENLIST [ Proofview.V82.tactic (shift_left); Proofview.V82.tactic (mk_then tac); (intros_using [id']) ]))
           :: tactic,
      compile id' flag t' :: defs)
   else
     (tactic,defs)
 
 let destructure_omega gl tac_def (id,c) =
-  if atompart_of_id id = "State" then
+  if String.equal (atompart_of_id id) "State" then
     tac_def
   else
     try match destructurate_prop c with
       | Kapp(Eq,[typ;t1;t2])
-	when destructurate_type (pf_nf gl typ) = Kapp(Z,[]) ->
+	when begin match destructurate_type (pf_nf gl typ) with Kapp(Z,[]) -> true | _ -> false end ->
 	  let t = mk_plus t1 (mk_inv t2) in
 	  normalize_equation
 	    id EQUA (Lazy.force coq_Zegal_left) 2 t t1 t2 tac_def
@@ -1425,12 +1410,18 @@ let destructure_omega gl tac_def (id,c) =
 
 let reintroduce id =
   (* [id] cannot be cleared if dependent: protect it by a try *)
-  tclTHEN (tclTRY (clear [id])) (intro_using id)
+  Tacticals.New.tclTHEN (Proofview.V82.tactic (tclTRY (clear [id]))) (intro_using id)
+
 
-let coq_omega gl =
+open Proofview.Notations
+
+let coq_omega =
+  Proofview.Goal.nf_enter begin fun gl ->
   clear_constr_tables ();
+  let hyps_types = Tacmach.New.pf_hyps_types gl in
+  let destructure_omega = Tacmach.New.of_old destructure_omega gl in
   let tactic_normalisation, system =
-    List.fold_left (destructure_omega gl) ([],[]) (pf_hyps_types gl) in
+    List.fold_left destructure_omega ([],[]) hyps_types in
   let prelude,sys =
     List.fold_left
       (fun (tac,sys) (t,(v,th,b)) ->
@@ -1438,78 +1429,81 @@ let coq_omega gl =
            let id = new_identifier () in
            let i = new_id () in
            tag_hypothesis id i;
-           (tclTHENLIST [
+           (Tacticals.New.tclTHENLIST [
 	     (simplest_elim (applist (Lazy.force coq_intro_Z, [t])));
 	     (intros_using [v; id]);
 	     (elim_id id);
-	     (clear [id]);
+	     Proofview.V82.tactic (clear [id]);
 	     (intros_using [th;id]);
 	     tac ]),
            {kind = INEQ;
 	    body = [{v=intern_id v; c=one}];
             constant = zero; id = i} :: sys
 	 else
-           (tclTHENLIST [
+           (Tacticals.New.tclTHENLIST [
 	     (simplest_elim (applist (Lazy.force coq_new_var, [t])));
 	     (intros_using [v;th]);
 	     tac ]),
            sys)
-      (tclIDTAC,[]) (dump_tables ())
+      (Proofview.tclUNIT (),[]) (dump_tables ())
   in
   let system = system @ sys in
   if !display_system_flag then display_system display_var system;
   if !old_style_flag then begin
     try
       let _ = simplify (new_id,new_var_num,display_var) false system in
-      tclIDTAC gl
+      Proofview.tclUNIT ()
     with UNSOLVABLE ->
       let _,path = depend [] [] (history ()) in
       if !display_action_flag then display_action display_var path;
-      (tclTHEN prelude (replay_history tactic_normalisation path)) gl
+      (Tacticals.New.tclTHEN prelude (replay_history tactic_normalisation path))
   end else begin
     try
       let path = simplify_strong (new_id,new_var_num,display_var) system in
       if !display_action_flag then display_action display_var path;
-      (tclTHEN prelude (replay_history tactic_normalisation path)) gl
-    with NO_CONTRADICTION -> error "Omega can't solve this system"
+      Tacticals.New.tclTHEN prelude (replay_history tactic_normalisation path)
+    with NO_CONTRADICTION -> Proofview.tclZERO (UserError ("" , Pp.str"Omega can't solve this system"))
+  end
   end
 
-let coq_omega = solver_time coq_omega
+let coq_omega = coq_omega
 
-let nat_inject gl =
-  let rec explore p t =
+let nat_inject =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let is_conv = Tacmach.New.pf_apply Reductionops.is_conv gl in
+  let rec explore p t : unit Proofview.tactic =
     try match destructurate_term t with
       | Kapp(Plus,[t1;t2]) ->
-          tclTHENLIST [
-	    (clever_rewrite_gen p (mk_plus (mk_inj t1) (mk_inj t2))
+          Tacticals.New.tclTHENLIST [
+	    Proofview.V82.tactic (clever_rewrite_gen p (mk_plus (mk_inj t1) (mk_inj t2))
               ((Lazy.force coq_inj_plus),[t1;t2]));
 	    (explore (P_APP 1 :: p) t1);
 	    (explore (P_APP 2 :: p) t2)
           ]
       | Kapp(Mult,[t1;t2]) ->
-          tclTHENLIST [
-	    (clever_rewrite_gen p (mk_times (mk_inj t1) (mk_inj t2))
+          Tacticals.New.tclTHENLIST [
+	    Proofview.V82.tactic (clever_rewrite_gen p (mk_times (mk_inj t1) (mk_inj t2))
               ((Lazy.force coq_inj_mult),[t1;t2]));
 	    (explore (P_APP 1 :: p) t1);
 	    (explore (P_APP 2 :: p) t2)
           ]
       | Kapp(Minus,[t1;t2]) ->
           let id = new_identifier () in
-          tclTHENS
-            (tclTHEN
+          Tacticals.New.tclTHENS
+            (Tacticals.New.tclTHEN
 	       (simplest_elim (applist (Lazy.force coq_le_gt_dec, [t2;t1])))
 	       (intros_using [id]))
 	    [
-	      tclTHENLIST [
-	        (clever_rewrite_gen p
+	      Tacticals.New.tclTHENLIST [
+	        Proofview.V82.tactic (clever_rewrite_gen p
 		  (mk_minus (mk_inj t1) (mk_inj t2))
                   ((Lazy.force coq_inj_minus1),[t1;t2;mkVar id]));
 		(loop [id,mkApp (Lazy.force coq_le, [| t2;t1 |])]);
 		(explore (P_APP 1 :: p) t1);
 		(explore (P_APP 2 :: p) t2) ];
-	      (tclTHEN
-		 (clever_rewrite_gen p (mk_integer zero)
-                    ((Lazy.force coq_inj_minus2),[t1;t2;mkVar id]))
+	      (Tacticals.New.tclTHEN
+		 (Proofview.V82.tactic (clever_rewrite_gen p (mk_integer zero)
+                    ((Lazy.force coq_inj_minus2),[t1;t2;mkVar id])))
 		 (loop [id,mkApp (Lazy.force coq_gt, [| t2;t1 |])]))
 	    ]
       | Kapp(S,[t']) ->
@@ -1520,37 +1514,37 @@ let nat_inject gl =
               | _ -> false
             with e when catchable_exception e -> false
 	  in
-          let rec loop p t =
+          let rec loop p t : unit Proofview.tactic =
             try match destructurate_term t with
 		Kapp(S,[t]) ->
-                  (tclTHEN
-                     (clever_rewrite_gen p
+                  (Tacticals.New.tclTHEN
+                     (Proofview.V82.tactic (clever_rewrite_gen p
 			(mkApp (Lazy.force coq_Zsucc, [| mk_inj t |]))
-			((Lazy.force coq_inj_S),[t]))
+			((Lazy.force coq_inj_S),[t])))
 		     (loop (P_APP 1 :: p) t))
               | _ -> explore p t
             with e when catchable_exception e -> explore p t
 	  in
-          if is_number t' then focused_simpl p else loop p t
+          if is_number t' then Proofview.V82.tactic (focused_simpl p) else loop p t
       | Kapp(Pred,[t]) ->
           let t_minus_one =
 	    mkApp (Lazy.force coq_minus, [| t;
 		      mkApp (Lazy.force coq_S, [| Lazy.force coq_O |]) |]) in
-          tclTHEN
-            (clever_rewrite_gen_nat (P_APP 1 :: p) t_minus_one
-               ((Lazy.force coq_pred_of_minus),[t]))
+          Tacticals.New.tclTHEN
+            (Proofview.V82.tactic (clever_rewrite_gen_nat (P_APP 1 :: p) t_minus_one
+               ((Lazy.force coq_pred_of_minus),[t])))
             (explore p t_minus_one)
-      | Kapp(O,[]) -> focused_simpl p
-      | _ -> tclIDTAC
-    with e when catchable_exception e -> tclIDTAC
+      | Kapp(O,[]) -> Proofview.V82.tactic (focused_simpl p)
+      | _ -> Proofview.tclUNIT ()
+    with e when catchable_exception e -> Proofview.tclUNIT ()
 
   and loop = function
-    | [] -> tclIDTAC
+    | [] -> Proofview.tclUNIT ()
     | (i,t)::lit ->
 	  begin try match destructurate_prop t with
               Kapp(Le,[t1;t2]) ->
-		tclTHENLIST [
-		  (generalize_tac
+		Tacticals.New.tclTHENLIST [
+		  Proofview.V82.tactic (generalize_tac
 		    [mkApp (Lazy.force coq_inj_le, [| t1;t2;mkVar i |]) ]);
 		  (explore [P_APP 1; P_TYPE] t1);
 		  (explore [P_APP 2; P_TYPE] t2);
@@ -1558,8 +1552,8 @@ let nat_inject gl =
 		  (loop lit)
                 ]
             | Kapp(Lt,[t1;t2]) ->
-		tclTHENLIST [
-		  (generalize_tac
+		Tacticals.New.tclTHENLIST [
+		  Proofview.V82.tactic (generalize_tac
 		    [mkApp (Lazy.force coq_inj_lt, [| t1;t2;mkVar i |]) ]);
 		  (explore [P_APP 1; P_TYPE] t1);
 		  (explore [P_APP 2; P_TYPE] t2);
@@ -1567,8 +1561,8 @@ let nat_inject gl =
 		  (loop lit)
                 ]
             | Kapp(Ge,[t1;t2]) ->
-		tclTHENLIST [
-		  (generalize_tac
+		Tacticals.New.tclTHENLIST [
+		  Proofview.V82.tactic (generalize_tac
 		    [mkApp (Lazy.force coq_inj_ge, [| t1;t2;mkVar i |]) ]);
 		  (explore [P_APP 1; P_TYPE] t1);
 		  (explore [P_APP 2; P_TYPE] t2);
@@ -1576,8 +1570,8 @@ let nat_inject gl =
 		  (loop lit)
                 ]
             | Kapp(Gt,[t1;t2]) ->
-		tclTHENLIST [
-		  (generalize_tac
+		Tacticals.New.tclTHENLIST [
+		  Proofview.V82.tactic (generalize_tac
                     [mkApp (Lazy.force coq_inj_gt, [| t1;t2;mkVar i |]) ]);
 		  (explore [P_APP 1; P_TYPE] t1);
 		  (explore [P_APP 2; P_TYPE] t2);
@@ -1585,8 +1579,8 @@ let nat_inject gl =
 		  (loop lit)
                 ]
             | Kapp(Neq,[t1;t2]) ->
-		tclTHENLIST [
-		  (generalize_tac
+		Tacticals.New.tclTHENLIST [
+		  Proofview.V82.tactic (generalize_tac
 		    [mkApp (Lazy.force coq_inj_neq, [| t1;t2;mkVar i |]) ]);
 		  (explore [P_APP 1; P_TYPE] t1);
 		  (explore [P_APP 2; P_TYPE] t2);
@@ -1594,9 +1588,9 @@ let nat_inject gl =
 		  (loop lit)
                 ]
             | Kapp(Eq,[typ;t1;t2]) ->
-		if pf_conv_x gl typ (Lazy.force coq_nat) then
-                  tclTHENLIST [
-		    (generalize_tac
+		if is_conv typ (Lazy.force coq_nat) then
+                  Tacticals.New.tclTHENLIST [
+		    Proofview.V82.tactic (generalize_tac
 		      [mkApp (Lazy.force coq_inj_eq, [| t1;t2;mkVar i |]) ]);
 		    (explore [P_APP 2; P_TYPE] t1);
 		    (explore [P_APP 3; P_TYPE] t2);
@@ -1607,7 +1601,9 @@ let nat_inject gl =
 	    | _ -> loop lit
 	  with e when catchable_exception e -> loop lit end
   in
-  loop (List.rev (pf_hyps_types gl)) gl
+  let hyps_types = Tacmach.New.pf_hyps_types gl in
+  loop (List.rev hyps_types)
+  end
 
 let dec_binop = function
   | Zne -> coq_dec_Zne
@@ -1675,51 +1671,57 @@ let rec decidability gl t =
 let onClearedName id tac =
   (* We cannot ensure that hyps can be cleared (because of dependencies), *)
   (* so renaming may be necessary *)
-  tclTHEN
-    (tclTRY (clear [id]))
-    (fun gl ->
-      let id = fresh_id [] id gl in
-      tclTHEN (introduction id) (tac id) gl)
+  Tacticals.New.tclTHEN
+    (Proofview.V82.tactic (tclTRY (clear [id])))
+    (Proofview.Goal.nf_enter begin fun gl ->
+     let id = Tacmach.New.of_old (fresh_id [] id) gl in
+     Tacticals.New.tclTHEN (introduction id) (tac id)
+    end)
 
 let onClearedName2 id tac =
-  tclTHEN
-    (tclTRY (clear [id]))
-    (fun gl ->
-      let id1 = fresh_id [] (add_suffix id "_left") gl in
-      let id2 = fresh_id [] (add_suffix id "_right") gl in
-      tclTHENLIST [ introduction id1; introduction id2; tac id1 id2 ] gl)
-
-let destructure_hyps gl =
-  let rec loop = function
-    | [] -> (tclTHEN nat_inject coq_omega)
-    | (i,body,t)::lit ->
-	begin try match destructurate_prop t with
+  Tacticals.New.tclTHEN
+    (Proofview.V82.tactic (tclTRY (clear [id])))
+    (Proofview.Goal.nf_enter begin fun gl ->
+     let id1 = Tacmach.New.of_old (fresh_id [] (add_suffix id "_left")) gl in
+     let id2 = Tacmach.New.of_old (fresh_id [] (add_suffix id "_right")) gl in
+      Tacticals.New.tclTHENLIST [ introduction id1; introduction id2; tac id1 id2 ]
+    end)
+
+let destructure_hyps =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let type_of = Tacmach.New.pf_type_of gl in
+  let decidability = Tacmach.New.of_old decidability gl in
+  let pf_nf = Tacmach.New.of_old pf_nf gl in
+    let rec loop = function
+      | [] -> (Tacticals.New.tclTHEN nat_inject coq_omega)
+      | (i,body,t)::lit ->
+	  begin try match destructurate_prop t with
 	  | Kapp(False,[]) -> elim_id i
           | Kapp((Zle|Zge|Zgt|Zlt|Zne),[t1;t2]) -> loop lit
           | Kapp(Or,[t1;t2]) ->
-              (tclTHENS
-                (elim_id i)
-                [ onClearedName i (fun i -> (loop ((i,None,t1)::lit)));
-                  onClearedName i (fun i -> (loop ((i,None,t2)::lit))) ])
+              (Tacticals.New.tclTHENS
+                 (elim_id i)
+                 [ onClearedName i (fun i -> (loop ((i,None,t1)::lit)));
+                   onClearedName i (fun i -> (loop ((i,None,t2)::lit))) ])
           | Kapp(And,[t1;t2]) ->
-              tclTHEN
+              Tacticals.New.tclTHEN
 		(elim_id i)
 		(onClearedName2 i (fun i1 i2 ->
 		  loop ((i1,None,t1)::(i2,None,t2)::lit)))
           | Kapp(Iff,[t1;t2]) ->
-	      tclTHEN
+	      Tacticals.New.tclTHEN
 		(elim_id i)
 		(onClearedName2 i (fun i1 i2 ->
 		  loop ((i1,None,mkArrow t1 t2)::(i2,None,mkArrow t2 t1)::lit)))
           | Kimp(t1,t2) ->
 	      (* t1 and t2 might be in Type rather than Prop.
 		 For t1, the decidability check will ensure being Prop. *)
-              if is_Prop (pf_type_of gl t2)
+              if is_Prop (type_of t2)
               then
-		let d1 = decidability gl t1 in
-		tclTHENLIST [
-		  (generalize_tac [mkApp (Lazy.force coq_imp_simp,
-                    [| t1; t2; d1; mkVar i|])]);
+		let d1 = decidability t1 in
+		Tacticals.New.tclTHENLIST [
+		  Proofview.V82.tactic (generalize_tac [mkApp (Lazy.force coq_imp_simp,
+                                                               [| t1; t2; d1; mkVar i|])]);
 		  (onClearedName i (fun i ->
 		    (loop ((i,None,mk_or (mk_not t1) t2)::lit))))
                 ]
@@ -1727,135 +1729,138 @@ let destructure_hyps gl =
 		loop lit
           | Kapp(Not,[t]) ->
               begin match destructurate_prop t with
-		  Kapp(Or,[t1;t2]) ->
-                    tclTHENLIST [
-		      (generalize_tac
-                        [mkApp (Lazy.force coq_not_or,[| t1; t2; mkVar i |])]);
-		      (onClearedName i (fun i ->
-                        (loop ((i,None,mk_and (mk_not t1) (mk_not t2)):: lit))))
-                    ]
-		| Kapp(And,[t1;t2]) ->
-		    let d1 = decidability gl t1 in
-                    tclTHENLIST [
-		      (generalize_tac
-		        [mkApp (Lazy.force coq_not_and,
-				[| t1; t2; d1; mkVar i |])]);
-		      (onClearedName i (fun i ->
-                        (loop ((i,None,mk_or (mk_not t1) (mk_not t2))::lit))))
-                    ]
-		| Kapp(Iff,[t1;t2]) ->
-		    let d1 = decidability gl t1 in
-		    let d2 = decidability gl t2 in
-                    tclTHENLIST [
-		      (generalize_tac
-		        [mkApp (Lazy.force coq_not_iff,
-				[| t1; t2; d1; d2; mkVar i |])]);
-		      (onClearedName i (fun i ->
-                        (loop ((i,None,
-			        mk_or (mk_and t1 (mk_not t2))
-				      (mk_and (mk_not t1) t2))::lit))))
-                    ]
-		| Kimp(t1,t2) ->
+		Kapp(Or,[t1;t2]) ->
+                  Tacticals.New.tclTHENLIST [
+		    Proofview.V82.tactic (generalize_tac
+                                            [mkApp (Lazy.force coq_not_or,[| t1; t2; mkVar i |])]);
+		    (onClearedName i (fun i ->
+                      (loop ((i,None,mk_and (mk_not t1) (mk_not t2)):: lit))))
+                  ]
+	      | Kapp(And,[t1;t2]) ->
+		  let d1 = decidability t1 in
+                  Tacticals.New.tclTHENLIST [
+		    Proofview.V82.tactic (generalize_tac
+		                            [mkApp (Lazy.force coq_not_and,
+				                    [| t1; t2; d1; mkVar i |])]);
+		    (onClearedName i (fun i ->
+                      (loop ((i,None,mk_or (mk_not t1) (mk_not t2))::lit))))
+                  ]
+	      | Kapp(Iff,[t1;t2]) ->
+		  let d1 = decidability t1 in
+		  let d2 = decidability t2 in
+                  Tacticals.New.tclTHENLIST [
+		    Proofview.V82.tactic (generalize_tac
+		                            [mkApp (Lazy.force coq_not_iff,
+				                    [| t1; t2; d1; d2; mkVar i |])]);
+		    (onClearedName i (fun i ->
+                      (loop ((i,None,
+			      mk_or (mk_and t1 (mk_not t2))
+				(mk_and (mk_not t1) t2))::lit))))
+                  ]
+	      | Kimp(t1,t2) ->
 		    (* t2 must be in Prop otherwise ~(t1->t2) wouldn't be ok.
 		       For t1, being decidable implies being Prop. *)
-		    let d1 = decidability gl t1 in
-                    tclTHENLIST [
-		      (generalize_tac
-		        [mkApp (Lazy.force coq_not_imp,
-				[| t1; t2; d1; mkVar i |])]);
-		      (onClearedName i (fun i ->
-                        (loop ((i,None,mk_and t1 (mk_not t2)) :: lit))))
-                    ]
-		| Kapp(Not,[t]) ->
-		    let d = decidability gl t in
-                    tclTHENLIST [
-		      (generalize_tac
-			[mkApp (Lazy.force coq_not_not, [| t; d; mkVar i |])]);
-		      (onClearedName i (fun i -> (loop ((i,None,t)::lit))))
-                    ]
-		| Kapp(op,[t1;t2]) ->
-		    (try
-		      let thm = not_binop op in
-                      tclTHENLIST [
-			(generalize_tac
-			   [mkApp (Lazy.force thm, [| t1;t2;mkVar i|])]);
-			(onClearedName i (fun _ -> loop lit))
-                      ]
-		     with Not_found -> loop lit)
-		| Kapp(Eq,[typ;t1;t2]) ->
-                    if !old_style_flag then begin
-		      match destructurate_type (pf_nf gl typ) with
-			| Kapp(Nat,_) ->
-                            tclTHENLIST [
-			      (simplest_elim
-				(mkApp
-                                  (Lazy.force coq_not_eq, [|t1;t2;mkVar i|])));
-			      (onClearedName i (fun _ -> loop lit))
-                            ]
-			| Kapp(Z,_) ->
-                            tclTHENLIST [
-			      (simplest_elim
-				(mkApp
-				  (Lazy.force coq_not_Zeq, [|t1;t2;mkVar i|])));
-			      (onClearedName i (fun _ -> loop lit))
-                            ]
-			| _ -> loop lit
-                    end else begin
-		      match destructurate_type (pf_nf gl typ) with
-			| Kapp(Nat,_) ->
-                               (tclTHEN
-			       (convert_hyp_no_check
-                                  (i,body,
-				  (mkApp (Lazy.force coq_neq, [| t1;t2|]))))
-			       (loop lit))
-			| Kapp(Z,_) ->
-                               (tclTHEN
-			       (convert_hyp_no_check
-                                  (i,body,
-				  (mkApp (Lazy.force coq_Zne, [| t1;t2|]))))
-			       (loop lit))
-			| _ -> loop lit
-                    end
-		| _ -> loop lit
+		  let d1 = decidability t1 in
+                  Tacticals.New.tclTHENLIST [
+		    Proofview.V82.tactic (generalize_tac
+		                            [mkApp (Lazy.force coq_not_imp,
+				                    [| t1; t2; d1; mkVar i |])]);
+		    (onClearedName i (fun i ->
+                      (loop ((i,None,mk_and t1 (mk_not t2)) :: lit))))
+                  ]
+	      | Kapp(Not,[t]) ->
+		  let d = decidability t in
+                  Tacticals.New.tclTHENLIST [
+		    Proofview.V82.tactic (generalize_tac
+			                    [mkApp (Lazy.force coq_not_not, [| t; d; mkVar i |])]);
+		    (onClearedName i (fun i -> (loop ((i,None,t)::lit))))
+                  ]
+	      | Kapp(op,[t1;t2]) ->
+		  (try
+		     let thm = not_binop op in
+                     Tacticals.New.tclTHENLIST [
+		       Proofview.V82.tactic (generalize_tac
+			                       [mkApp (Lazy.force thm, [| t1;t2;mkVar i|])]);
+		       (onClearedName i (fun _ -> loop lit))
+                     ]
+		   with Not_found -> loop lit)
+	      | Kapp(Eq,[typ;t1;t2]) ->
+                  if !old_style_flag then begin
+		    match destructurate_type (pf_nf typ) with
+		    | Kapp(Nat,_) ->
+                        Tacticals.New.tclTHENLIST [
+			  (simplest_elim
+			     (mkApp
+                                (Lazy.force coq_not_eq, [|t1;t2;mkVar i|])));
+			  (onClearedName i (fun _ -> loop lit))
+                        ]
+		    | Kapp(Z,_) ->
+                        Tacticals.New.tclTHENLIST [
+			  (simplest_elim
+			     (mkApp
+				(Lazy.force coq_not_Zeq, [|t1;t2;mkVar i|])));
+			  (onClearedName i (fun _ -> loop lit))
+                        ]
+		    | _ -> loop lit
+                  end else begin
+		    match destructurate_type (pf_nf typ) with
+		    | Kapp(Nat,_) ->
+                        (Tacticals.New.tclTHEN
+			   (convert_hyp_no_check
+                                                    (i,body,
+				                     (mkApp (Lazy.force coq_neq, [| t1;t2|]))))
+			   (loop lit))
+		    | Kapp(Z,_) ->
+                        (Tacticals.New.tclTHEN
+			   (convert_hyp_no_check
+                                                    (i,body,
+				                     (mkApp (Lazy.force coq_Zne, [| t1;t2|]))))
+			   (loop lit))
+		    | _ -> loop lit
+                  end
+	      | _ -> loop lit
               end
           | _ -> loop lit
-	with
-	  | Undecidable -> loop lit
-	  | e when catchable_exception e -> loop lit
-	end
-  in
-  loop (pf_hyps gl) gl
+	    with
+	    | Undecidable -> loop lit
+	    | e when catchable_exception e -> loop lit
+	  end
+    in
+    let hyps = Proofview.Goal.hyps gl in
+    loop hyps
+  end
 
-let destructure_goal gl =
-  let concl = pf_concl gl in
-  let rec loop t =
-    match destructurate_prop t with
+let destructure_goal =
+  Proofview.Goal.nf_enter begin fun gl ->
+    let concl = Proofview.Goal.concl gl in
+    let decidability = Tacmach.New.of_old decidability gl in
+    let rec loop t =
+      match destructurate_prop t with
       | Kapp(Not,[t]) ->
-          (tclTHEN
-	     (tclTHEN (unfold sp_not) intro)
+          (Tacticals.New.tclTHEN
+	     (Tacticals.New.tclTHEN (Proofview.V82.tactic (unfold sp_not)) intro)
 	     destructure_hyps)
-      | Kimp(a,b) -> (tclTHEN intro (loop b))
+      | Kimp(a,b) -> (Tacticals.New.tclTHEN intro (loop b))
       | Kapp(False,[]) -> destructure_hyps
       | _ ->
-	let goal_tac =
-	  try
-	    let dec = decidability gl t in
-	    tclTHEN
-	      (Tactics.refine
-		 (mkApp (Lazy.force coq_dec_not_not, [| t; dec; mkNewMeta () |])))
-	      intro
-	  with Undecidable -> Tactics.elim_type (build_coq_False ())
-	in
-	tclTHEN goal_tac destructure_hyps
-  in
-  (loop concl) gl
+	  let goal_tac =
+	    try
+	      let dec = decidability t in
+	      Tacticals.New.tclTHEN
+                (Proofview.V82.tactic (Tactics.refine
+		                         (mkApp (Lazy.force coq_dec_not_not, [| t; dec; mkNewMeta () |]))))
+	        intro
+	    with Undecidable -> Tactics.elim_type (build_coq_False ())
+	  in
+	  Tacticals.New.tclTHEN goal_tac destructure_hyps
+    in
+    (loop concl)
+  end
 
-let destructure_goal = all_time (destructure_goal)
+let destructure_goal = destructure_goal
 
-let omega_solver gl =
+let omega_solver =
+  Proofview.tclUNIT () >>= fun () -> (* delay for [check_required_library] *)
   Coqlib.check_required_library ["Coq";"omega";"Omega"];
   reset_all ();
-  let result = destructure_goal gl in
-  (* if !display_time_flag then begin text_time ();
-     flush Pervasives.stdout end; *)
-  result
+  destructure_goal
diff --git a/plugins/omega/g_omega.ml4 b/plugins/omega/g_omega.ml4
index b2a5b5dc..46bbe2fd 100644
--- a/plugins/omega/g_omega.ml4
+++ b/plugins/omega/g_omega.ml4
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -9,14 +9,15 @@
 (*                                                                        *)
 (* Omega: a solver of quantifier-free problems in Presburger Arithmetic   *)
 (*                                                                        *)
-(* Pierre Crégut (CNET, Lannion, France)                                  *)
+(* Pierre Crégut (CNET, Lannion, France)                                  *)
 (*                                                                        *)
 (**************************************************************************)
 
-(*i camlp4deps: "parsing/grammar.cma" i*)
+(*i camlp4deps: "grammar/grammar.cma" i*)
+
+DECLARE PLUGIN "omega_plugin"
 
 open Coq_omega
-open Refiner
 
 let omega_tactic l =
   let tacs = List.map
@@ -25,12 +26,12 @@ let omega_tactic l =
        | "positive" -> Tacinterp.interp <:tactic<zify_positive>>
        | "N" -> Tacinterp.interp <:tactic<zify_N>>
        | "Z" -> Tacinterp.interp <:tactic<zify_op>>
-       | s -> Util.error ("No Omega knowledge base for type "^s))
-    (Util.list_uniquize (List.sort compare l))
+       | s -> Errors.error ("No Omega knowledge base for type "^s))
+    (Util.List.sort_uniquize String.compare l)
   in
-  tclTHEN
-    (tclREPEAT (tclPROGRESS (tclTHENLIST tacs)))
-    omega_solver
+  Tacticals.New.tclTHEN
+    (Tacticals.New.tclREPEAT (Tacticals.New.tclTHENLIST tacs))
+    (omega_solver)
 
 
 TACTIC EXTEND omega
@@ -39,7 +40,7 @@ END
 
 TACTIC EXTEND omega'
 | [ "omega" "with" ne_ident_list(l) ] ->
-    [ omega_tactic (List.map Names.string_of_id l) ]
+    [ omega_tactic (List.map Names.Id.to_string l) ]
 | [ "omega" "with" "*" ] -> [ omega_tactic ["nat";"positive";"N";"Z"] ]
 END
 
diff --git a/plugins/omega/omega.ml b/plugins/omega/omega.ml
index 94ce4d50..67a1ff96 100644
--- a/plugins/omega/omega.ml
+++ b/plugins/omega/omega.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -9,7 +9,7 @@
 (*                                                                        *)
 (* Omega: a solver of quantifier-free problems in Presburger Arithmetic   *)
 (*                                                                        *)
-(* Pierre Crégut (CNET, Lannion, France)                                  *)
+(* Pierre Crégut (CNET, Lannion, France)                                  *)
 (*                                                                        *)
 (* 13/10/2002 : modified to cope with an external numbering of equations  *)
 (*   and hypothesis. Its use for Omega is not more complex and it makes   *)
@@ -17,10 +17,9 @@
 (*   the number of source of numbering.                                   *)
 (**************************************************************************)
 
-open Names
-
 module type INT = sig
   type bigint
+  val equal : bigint -> bigint -> bool
   val less_than : bigint -> bigint -> bool
   val add : bigint -> bigint -> bigint
   val sub : bigint -> bigint -> bigint
@@ -34,26 +33,26 @@ end
 
 let debug = ref false
 
-module MakeOmegaSolver (Int:INT) = struct
-
-type bigint = Int.bigint
-let (<?) = Int.less_than
-let (<=?) x y = Int.less_than x y or x = y
-let (>?) x y = Int.less_than y x
-let (>=?) x y = Int.less_than y x or x = y
-let (=?) = (=)
-let (+) = Int.add
-let (-) = Int.sub
-let ( * ) = Int.mult
-let (/) x y = fst (Int.euclid x y)
-let (mod) x y = snd (Int.euclid x y)
-let zero = Int.zero
-let one = Int.one
+module MakeOmegaSolver (I:INT) = struct
+
+type bigint = I.bigint
+let (=?) = I.equal
+let (<?) = I.less_than
+let (<=?) x y = I.less_than x y || x = y
+let (>?) x y = I.less_than y x
+let (>=?) x y = I.less_than y x || x = y
+let (+) = I.add
+let (-) = I.sub
+let ( * ) = I.mult
+let (/) x y = fst (I.euclid x y)
+let (mod) x y = snd (I.euclid x y)
+let zero = I.zero
+let one = I.one
 let two = one + one
-let negone = Int.neg one
-let abs x = if Int.less_than x zero then Int.neg x else x
-let string_of_bigint = Int.to_string
-let neg = Int.neg
+let negone = I.neg one
+let abs x = if I.less_than x zero then I.neg x else x
+let string_of_bigint = I.to_string
+let neg = I.neg
 
 (* To ensure that polymorphic (<) is not used mistakenly on big integers *)
 (* Warning: do not use (=) either on big int *)
@@ -241,7 +240,7 @@ let add_event, history, clear_history =
   (fun () -> !accu),
   (fun () -> accu := [])
 
-let nf_linear = Sort.list (fun x y -> x.v > y.v)
+let nf_linear = List.sort (fun x y -> Pervasives.(-) y.v x.v)
 
 let nf ((b : bool),(e,(x : int))) = (b,(nf_linear e,x))
 
@@ -303,16 +302,16 @@ let normalize ({id=id; kind=eq_flag; body=e; constant =x} as eq) =
           end
   end else
     let gcd = pgcd_l (List.map (fun f -> abs f.c) e) in
-    if eq_flag=EQUA & x mod gcd <> zero then begin
+    if eq_flag=EQUA && x mod gcd <> zero then begin
       add_event (NOT_EXACT_DIVIDE (eq,gcd)); raise UNSOLVABLE
-    end else if eq_flag=DISE & x mod gcd <> zero then begin
+    end else if eq_flag=DISE && x mod gcd <> zero then begin
       add_event (FORGET_C eq.id); []
     end else if gcd <> one then begin
       let c = floor_div x gcd in
       let d = x - c * gcd in
       let new_eq = {id=id; kind=eq_flag; constant=c;
                     body=map_eq_linear (fun c -> c / gcd) e} in
-      add_event (if eq_flag=EQUA or eq_flag = DISE then EXACT_DIVIDE(eq,gcd)
+      add_event (if eq_flag=EQUA || eq_flag = DISE then EXACT_DIVIDE(eq,gcd)
                  else DIVIDE_AND_APPROX(eq,new_eq,gcd,d));
       [new_eq]
     end else [eq]
@@ -352,11 +351,11 @@ let banerjee_step (new_eq_id,new_var_id,print_var) original l1 l2 =
   let new_eq = List.hd (normalize new_eq) in
   let eliminated_var, def = chop_var var new_eq.body in
   let other_equations =
-    Util.list_map_append
+    Util.List.map_append
       (fun e ->
         normalize (eliminate_with_in new_eq_id eliminated_var new_eq e)) l1 in
   let inequations =
-    Util.list_map_append
+    Util.List.map_append
       (fun e ->
         normalize (eliminate_with_in new_eq_id eliminated_var new_eq e)) l2 in
   let original' = eliminate_with_in new_eq_id eliminated_var new_eq original in
@@ -368,9 +367,9 @@ let rec eliminate_one_equation ((new_eq_id,new_var_id,print_var) as new_ids) (e,
   if !debug then display_system print_var (e::other);
   try
     let v,def = chop_factor_1 e.body in
-    (Util.list_map_append
+    (Util.List.map_append
       (fun e' -> normalize (eliminate_with_in new_eq_id v e e')) other,
-     Util.list_map_append
+     Util.List.map_append
        (fun e' -> normalize (eliminate_with_in new_eq_id v e e')) ineqs)
   with FACTOR1 ->
     eliminate_one_equation new_ids (banerjee_step new_ids e other ineqs)
@@ -474,7 +473,7 @@ let select_variable system =
   Hashtbl.iter
     (fun v ({contents =  c}) ->
        incr var_cpt;
-       if c <? !cmin or !vmin = (-1) then begin vmin := v; cmin := c end)
+       if c <? !cmin || !vmin = (-1) then begin vmin := v; cmin := c end)
     table;
   if !var_cpt < 1 then raise SOLVED_SYSTEM;
   !vmin
@@ -523,7 +522,7 @@ let simplify ((new_eq_id,new_var_id,print_var) as new_ids) dark_shadow system =
     failwith "disequation in simplify";
   clear_history ();
   List.iter (fun e -> add_event (HYP e)) system;
-  let system = Util.list_map_append normalize system in
+  let system = Util.List.map_append normalize system in
   let eqs,ineqs = List.partition (fun e -> e.kind=EQUA) system in
   let simp_eq,simp_ineq = redundancy_elimination new_eq_id ineqs in
   let system = (eqs @ simp_eq,simp_ineq) in
@@ -547,30 +546,30 @@ let rec depend relie_on accu = function
   | act :: l ->
       begin match act with
 	| DIVIDE_AND_APPROX (e,_,_,_) ->
-            if List.mem e.id relie_on then depend relie_on (act::accu) l
+            if Int.List.mem e.id relie_on then depend relie_on (act::accu) l
             else depend relie_on accu l
 	| EXACT_DIVIDE (e,_) ->
-            if List.mem e.id relie_on then depend relie_on (act::accu) l
+            if Int.List.mem e.id relie_on then depend relie_on (act::accu) l
             else depend relie_on accu l
 	| WEAKEN (e,_) ->
-            if List.mem e relie_on then depend relie_on (act::accu) l
+            if Int.List.mem e relie_on then depend relie_on (act::accu) l
             else depend relie_on accu l
 	| SUM (e,(_,e1),(_,e2)) ->
-            if List.mem e relie_on then
+            if Int.List.mem e relie_on then
 	      depend (e1.id::e2.id::relie_on) (act::accu) l
             else
 	      depend relie_on accu l
 	| STATE {st_new_eq=e;st_orig=o} ->
-            if List.mem e.id relie_on then depend (o.id::relie_on) (act::accu) l
+            if Int.List.mem e.id relie_on then depend (o.id::relie_on) (act::accu) l
             else depend relie_on accu l
 	| HYP e ->
-            if List.mem e.id relie_on then depend relie_on (act::accu) l
+            if Int.List.mem e.id relie_on then depend relie_on (act::accu) l
             else depend relie_on accu l
 	| FORGET_C _ -> depend relie_on accu l
 	| FORGET _ -> depend relie_on accu l
 	| FORGET_I _ -> depend relie_on accu l
 	| MERGE_EQ (e,e1,e2) ->
-            if List.mem e relie_on then
+            if Int.List.mem e relie_on then
 	      depend (e1.id::e2::relie_on) (act::accu) l
             else
 	      depend relie_on accu l
@@ -586,15 +585,6 @@ let rec depend relie_on accu = function
       end
   | [] -> relie_on, accu
 
-(*
-let depend relie_on accu trace =
-  Printf.printf "Longueur de la trace initiale : %d\n"
-    (trace_length trace + trace_length accu);
-  let rel',trace' = depend relie_on accu trace in
-  Printf.printf "Longueur de la trace simplifiée : %d\n" (trace_length trace');
-  rel',trace'
-*)
-
 let solve (new_eq_id,new_eq_var,print_var) system =
   try let _ = simplify new_eq_id false system in failwith "no contradiction"
   with UNSOLVABLE -> display_action print_var (snd (depend [] [] (history ())))
@@ -658,7 +648,7 @@ let simplify_strong ((new_eq_id,new_var_id,print_var) as new_ids) system =
     | ([],ineqs,expl_map) -> ineqs,expl_map
   in
   try
-    let system = Util.list_map_append normalize system in
+    let system = Util.List.map_append normalize system in
     let eqs,ineqs = List.partition (fun e -> e.kind=EQUA) system in
     let dise,ine = List.partition (fun e -> e.kind = DISE) ineqs in
     let simp_eq,simp_ineq = redundancy_elimination new_eq_id ine in
@@ -674,7 +664,7 @@ let simplify_strong ((new_eq_id,new_var_id,print_var) as new_ids) system =
            try let _ = loop2 sys in raise NO_CONTRADICTION
            with UNSOLVABLE ->
              let relie_on,path = depend [] [] (history ()) in
-             let dc,_ = List.partition (fun (_,id,_) -> List.mem id relie_on) decomp in
+             let dc,_ = List.partition (fun (_,id,_) -> Int.List.mem id relie_on) decomp in
              let red = List.map (fun (x,_,_) -> x) dc in
              (red,relie_on,decomp,path))
         sys_exploded
@@ -699,14 +689,16 @@ let simplify_strong ((new_eq_id,new_var_id,print_var) as new_ids) system =
           | [] -> failwith "solve" in
         let s1,s2 =
           List.partition (fun (_,_,decomp,_) -> sign decomp) systems in
-        let s1' =
-	  List.map (fun (dep,ro,dc,pa) -> (Util.list_except id dep,ro,dc,pa)) s1 in
-        let s2' =
-	  List.map (fun (dep,ro,dc,pa) -> (Util.list_except id dep,ro,dc,pa)) s2 in
+        let remove_int (dep,ro,dc,pa) =
+          (Util.List.except Int.equal id dep,ro,dc,pa)
+        in
+        let s1' = List.map remove_int s1 in
+        let s2' = List.map remove_int s2 in
         let (r1,relie1) = solve s1'
 	and (r2,relie2) = solve s2' in
-	let (eq,id1,id2) = List.assoc id explode_map in
-	[SPLIT_INEQ(eq,(id1,r1),(id2, r2))], eq.id :: Util.list_union relie1 relie2
+	let (eq,id1,id2) = Int.List.assoc id explode_map in
+	[SPLIT_INEQ(eq,(id1,r1),(id2, r2))],
+        eq.id :: Util.List.union Int.equal relie1 relie2
       with FULL_SOLUTION (x0,x1) -> (x0,x1)
     in
     let act,relie_on = solve all_solutions in
diff --git a/plugins/pluginsbyte.itarget b/plugins/pluginsbyte.itarget
index 787995ed..d8752f8b 100644
--- a/plugins/pluginsbyte.itarget
+++ b/plugins/pluginsbyte.itarget
@@ -1,4 +1,4 @@
-field/field_plugin.cma
+btauto/btauto_plugin.cma
 setoid_ring/newring_plugin.cma
 extraction/extraction_plugin.cma
 decl_mode/decl_mode_plugin.cma
@@ -8,9 +8,6 @@ fourier/fourier_plugin.cma
 romega/romega_plugin.cma
 omega/omega_plugin.cma
 micromega/micromega_plugin.cma
-xml/xml_plugin.cma
-subtac/subtac_plugin.cma
-ring/ring_plugin.cma
 cc/cc_plugin.cma
 nsatz/nsatz_plugin.cma
 funind/recdef_plugin.cma
@@ -21,3 +18,4 @@ syntax/r_syntax_plugin.cma
 syntax/string_syntax_plugin.cma
 syntax/z_syntax_plugin.cma
 quote/quote_plugin.cma
+derive/derive_plugin.cma
\ No newline at end of file
diff --git a/plugins/pluginsdyn.itarget b/plugins/pluginsdyn.itarget
index bd3cec01..220e5182 100644
--- a/plugins/pluginsdyn.itarget
+++ b/plugins/pluginsdyn.itarget
@@ -1,3 +1,4 @@
+btauto/btauto_plugin.cmxs
 field/field_plugin.cmxs
 setoid_ring/newring_plugin.cmxs
 extraction/extraction_plugin.cmxs
@@ -8,7 +9,6 @@ fourier/fourier_plugin.cmxs
 romega/romega_plugin.cmxs
 omega/omega_plugin.cmxs
 micromega/micromega_plugin.cmxs
-xml/xml_plugin.cmxs
 subtac/subtac_plugin.cmxs
 ring/ring_plugin.cmxs
 cc/cc_plugin.cmxs
@@ -21,3 +21,4 @@ syntax/r_syntax_plugin.cmxs
 syntax/string_syntax_plugin.cmxs
 syntax/z_syntax_plugin.cmxs
 quote/quote_plugin.cmxs
+derive/derive_plugin.cmxs
diff --git a/plugins/pluginsopt.itarget b/plugins/pluginsopt.itarget
index 5264ba37..04a1e711 100644
--- a/plugins/pluginsopt.itarget
+++ b/plugins/pluginsopt.itarget
@@ -1,4 +1,4 @@
-field/field_plugin.cmxa
+btauto/btauto_plugin.cmxa
 setoid_ring/newring_plugin.cmxa
 extraction/extraction_plugin.cmxa
 decl_mode/decl_mode_plugin.cmxa
@@ -8,9 +8,6 @@ fourier/fourier_plugin.cmxa
 romega/romega_plugin.cmxa
 omega/omega_plugin.cmxa
 micromega/micromega_plugin.cmxa
-xml/xml_plugin.cmxa
-subtac/subtac_plugin.cmxa
-ring/ring_plugin.cmxa
 cc/cc_plugin.cmxa
 nsatz/nsatz_plugin.cmxa
 funind/recdef_plugin.cmxa
@@ -21,3 +18,4 @@ syntax/r_syntax_plugin.cmxa
 syntax/string_syntax_plugin.cmxa
 syntax/z_syntax_plugin.cmxa
 quote/quote_plugin.cmxa
+derive/derive_plugin.cmxa
diff --git a/plugins/pluginsvo.itarget b/plugins/pluginsvo.itarget
index bab15ad0..a59bf29c 100644
--- a/plugins/pluginsvo.itarget
+++ b/plugins/pluginsvo.itarget
@@ -1,12 +1,12 @@
-field/vo.otarget
+btauto/vo.otarget
 fourier/vo.otarget
 funind/vo.otarget
 nsatz/vo.otarget
 micromega/vo.otarget
 omega/vo.otarget
 quote/vo.otarget
-ring/vo.otarget
 romega/vo.otarget
 rtauto/vo.otarget
 setoid_ring/vo.otarget
 extraction/vo.otarget
+derive/vo.otarget
\ No newline at end of file
diff --git a/plugins/quote/Quote.v b/plugins/quote/Quote.v
index 92e5c75c..ca1a18e8 100644
--- a/plugins/quote/Quote.v
+++ b/plugins/quote/Quote.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/plugins/quote/g_quote.ml4 b/plugins/quote/g_quote.ml4
index e2c9dbaa..e27fe7f4 100644
--- a/plugins/quote/g_quote.ml4
+++ b/plugins/quote/g_quote.ml4
@@ -1,22 +1,31 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i camlp4deps: "parsing/grammar.cma" i*)
+(*i camlp4deps: "grammar/grammar.cma" i*)
 
-open Util
+open Names
+open Misctypes
 open Tacexpr
+open Geninterp
 open Quote
 
-let make_cont k x =
-  let k = TacDynamic(dummy_loc, Tacinterp.tactic_in (fun _ -> k)) in
-  let x = TacDynamic(dummy_loc, Pretyping.constr_in x) in
-  let tac = <:tactic<let cont := $k in cont $x>> in
-  Tacinterp.interp tac
+DECLARE PLUGIN "quote_plugin"
+
+let loc = Loc.ghost
+let cont = (loc, Id.of_string "cont")
+let x = (loc, Id.of_string "x")
+
+let make_cont (k : glob_tactic_expr) (c : Constr.t) =
+  let c = Tacinterp.Value.of_constr c in
+  let tac = TacCall (loc, ArgVar cont, [Reference (ArgVar x)]) in
+  let tac = TacLetIn (false, [(cont, Tacexp k)], TacArg (loc, tac)) in
+  let ist = { lfun = Id.Map.singleton (snd x) c; extra = TacStore.empty; } in
+  Tacinterp.eval_tactic_ist ist tac
 
 TACTIC EXTEND quote
   [ "quote" ident(f) ] -> [ quote f [] ]
diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml
index 48c67089..637e0e28 100644
--- a/plugins/quote/quote.ml
+++ b/plugins/quote/quote.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -101,15 +101,14 @@
 
 
 (*i*)
-open Pp
+open Errors
 open Util
 open Names
 open Term
 open Pattern
-open Matching
+open Patternops
+open Constr_matching
 open Tacmach
-open Tactics
-open Tacexpr
 (*i*)
 
 (*s First, we need to access some Coq constants
@@ -190,16 +189,16 @@ let decomp_term c = kind_of_term (strip_outer_cast c)
   type [typ] *)
 
 let coerce_meta_out id =
-  let s = string_of_id id in
+  let s = Id.to_string id in
   int_of_string (String.sub s 1 (String.length s - 1))
 let coerce_meta_in n =
-  id_of_string ("M" ^ string_of_int n)
+  Id.of_string ("M" ^ string_of_int n)
 
 let compute_lhs typ i nargsi =
   match kind_of_term typ with
-    | Ind(sp,0) ->
+    | Ind((sp,0),u) ->
         let argsi = Array.init nargsi (fun j -> mkMeta (nargsi - j)) in
-        mkApp (mkConstruct ((sp,0),i+1), argsi)
+        mkApp (mkConstructU (((sp,0),i+1),u), argsi)
     | _ -> i_can't_do_that ()
 
 (*s This function builds the pattern from the RHS. Recursive calls are
@@ -208,29 +207,29 @@ let compute_lhs typ i nargsi =
 let compute_rhs bodyi index_of_f =
   let rec aux c =
     match kind_of_term c with
-      | App (j, args) when isRel j && destRel j = index_of_f (* recursive call *) ->
-          let i = destRel (array_last args) in
+      | App (j, args) when isRel j && Int.equal (destRel j) index_of_f (* recursive call *) ->
+          let i = destRel (Array.last args) in
 	  PMeta (Some (coerce_meta_in i))
       | App (f,args) ->
-          PApp (snd (pattern_of_constr Evd.empty f), Array.map aux args)
+          PApp (snd (pattern_of_constr (Global.env()) Evd.empty f), Array.map aux args)
       | Cast (c,_,_) -> aux c
-      | _ -> snd (pattern_of_constr Evd.empty c)
+      | _ -> snd (pattern_of_constr (Global.env())(*FIXME*) Evd.empty c)
   in
   aux bodyi
 
 (*s Now the function [compute_ivs] itself *)
 
-let compute_ivs gl f cs =
-  let cst =
-    try destConst f
-    with e when Errors.noncritical e -> i_can't_do_that ()
-  in
-  let body = Environ.constant_value (Global.env()) cst in
+let compute_ivs f cs gl =
+  let cst = try destConst f with DestKO -> i_can't_do_that () in
+  let body = Environ.constant_value_in (Global.env()) cst in
   match decomp_term body with
     | Fix(([| len |], 0), ([| name |], [| typ |], [| body2 |])) ->
         let (args3, body3) = decompose_lam body2 in
         let nargs3 = List.length args3 in
-        begin match decomp_term body3 with
+        let env = Proofview.Goal.env gl in
+        let sigma = Proofview.Goal.sigma gl in
+        let is_conv = Reductionops.is_conv env sigma in
+          begin match decomp_term body3 with
           | Case(_,p,c,lci) -> (* <p> Case c of c1 ... cn end *)
               let n_lhs_rhs = ref []
               and v_lhs = ref (None : constr option)
@@ -243,14 +242,13 @@ let compute_ivs gl f cs =
            (* REL nargsi+1 to REL nargsi + nargs3 are arguments of f *)
            (* REL 1 to REL nargsi are argsi (reverse order) *)
            (* First we test if the RHS is the RHS for constants *)
-                   if isRel bodyi && destRel bodyi = 1 then
+                   if isRel bodyi && Int.equal (destRel bodyi) 1 then
                      c_lhs := Some (compute_lhs (snd (List.hd args3))
                                       i nargsi)
            (* Then we test if the RHS is the RHS for variables *)
                    else begin match decompose_app bodyi with
                      | vmf, [_; _; a3; a4 ]
-                         when isRel a3 & isRel a4 &
-			   pf_conv_x gl vmf
+                         when isRel a3 && isRel a4 && is_conv vmf
                            (Lazy.force coq_varmap_find)->
                              v_lhs := Some (compute_lhs
                                               (snd (List.hd args3))
@@ -264,7 +262,7 @@ let compute_ivs gl f cs =
                    end)
                 lci;
 
-              if !c_lhs = None & !v_lhs = None then i_can't_do_that ();
+              if Option.is_empty !c_lhs && Option.is_empty !v_lhs then i_can't_do_that ();
 
 	      (* The Cases predicate is a lambda; we assume no dependency *)
 	      let p = match kind_of_term p with
@@ -299,10 +297,10 @@ binary search trees (see file \texttt{Quote.v}) *)
    and variables (open terms) *)
 
 let rec closed_under cset t =
-  (ConstrSet.mem t cset) or
+  (ConstrSet.mem t cset) ||
   (match (kind_of_term t) with
      | Cast(c,_,_) -> closed_under cset c
-     | App(f,l) -> closed_under cset f && array_for_all (closed_under cset) l
+     | App(f,l) -> closed_under cset f && Array.for_all (closed_under cset) l
      | _ -> false)
 
 (*s [btree_of_array [| c1; c2; c3; c4; c5 |]] builds the complete
@@ -342,8 +340,8 @@ let path_of_int n =
   (* returns the list of digits of n in reverse order with
      initial 1 removed *)
   let rec digits_of_int n =
-    if n=1 then []
-    else (n mod 2 = 1)::(digits_of_int (n lsr 1))
+    if Int.equal n 1 then []
+    else (Int.equal (n mod 2) 1)::(digits_of_int (n lsr 1))
   in
   List.fold_right
     (fun b c -> mkApp ((if b then Lazy.force coq_Right_idx
@@ -361,9 +359,9 @@ let path_of_int n =
 (* This function does not descend under binders (lambda and Cases) *)
 
 let rec subterm gl (t : constr) (t' : constr) =
-  (pf_conv_x gl t t') or
+  (pf_conv_x gl t t') ||
   (match (kind_of_term t) with
-     | App (f,args) -> array_exists (fun t -> subterm gl t t') args
+     | App (f,args) -> Array.exists (fun t -> subterm gl t t') args
      | Cast(t,_,_) -> (subterm gl t t')
      | _ -> false)
 
@@ -393,7 +391,7 @@ module Constrhash = Hashtbl.Make
   [ivs : inversion_scheme]\\
   [lc: constr list]\\
   [gl: goal sigma]\\ *)
-let quote_terms ivs lc gl =
+let quote_terms ivs lc =
   Coqlib.check_required_library ["Coq";"quote";"Quote"];
   let varhash  = (Constrhash.create 17 : constr Constrhash.t) in
   let varlist = ref ([] : constr list) in (* list of variables *)
@@ -403,7 +401,7 @@ let quote_terms ivs lc gl =
       match l with
         | (lhs, rhs)::tail ->
             begin try
-              let s1 = matches rhs c in
+              let s1 = Id.Map.bindings (matches (Global.env ()) Evd.empty rhs c) in
               let s2 = List.map (fun (i,c_i) -> (coerce_meta_out i,aux c_i)) s1
 	      in
               Termops.subst_meta s2 lhs
@@ -414,7 +412,7 @@ let quote_terms ivs lc gl =
                | None ->
                    begin match ivs.constant_lhs with
                      | Some c_lhs -> Termops.subst_meta [1, c] c_lhs
-                     | None -> anomaly "invalid inversion scheme for quote"
+                     | None -> anomaly (Pp.str "invalid inversion scheme for quote")
                    end
                | Some var_lhs ->
                    begin match ivs.constant_lhs with
@@ -440,36 +438,43 @@ let quote_terms ivs lc gl =
     auxl ivs.normal_lhs_rhs
   in
   let lp = List.map aux lc in
-  (lp, (btree_of_array (Array.of_list (List.rev !varlist))
-          ivs.return_type ))
+    (lp, (btree_of_array (Array.of_list (List.rev !varlist))
+            ivs.return_type ))
 
 (*s actually we could "quote" a list of terms instead of a single
   term. Ring for example needs that, but Ring doesn't use Quote
   yet. *)
 
-let quote f lid gl =
-  let f = pf_global gl f in
-  let cl = List.map (pf_global gl) lid in
-  let ivs = compute_ivs gl f cl in
-  let (p, vm) = match quote_terms ivs [(pf_concl gl)] gl with
-    | [p], vm -> (p,vm)
-    | _ -> assert false
-  in
-  match ivs.variable_lhs with
-    | None -> Tactics.convert_concl (mkApp (f, [| p |])) DEFAULTcast gl
-    | Some _ -> Tactics.convert_concl (mkApp (f, [| vm; p |])) DEFAULTcast gl
-
-let gen_quote cont c f lid gl =
-  let f = pf_global gl f in
-  let cl = List.map (pf_global gl) lid in
-  let ivs = compute_ivs gl f cl in
-  let (p, vm) = match quote_terms ivs [c] gl with
+let quote f lid =
+  Proofview.Goal.nf_enter begin fun gl ->
+    let f = Tacmach.New.pf_global f gl in
+    let cl = List.map (fun id -> Tacmach.New.pf_global id gl) lid in
+    let ivs = compute_ivs f cl gl in
+    let concl = Proofview.Goal.concl gl in
+    let quoted_terms = quote_terms ivs [concl] in
+    let (p, vm) = match quoted_terms with
+      | [p], vm -> (p,vm)
+      | _ -> assert false
+    in
+    match ivs.variable_lhs with
+    | None -> Tactics.convert_concl (mkApp (f, [| p |])) DEFAULTcast
+    | Some _ -> Tactics.convert_concl (mkApp (f, [| vm; p |])) DEFAULTcast
+  end
+
+let gen_quote cont c f lid =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let f = Tacmach.New.pf_global f gl in
+  let cl = List.map (fun id -> Tacmach.New.pf_global id gl) lid in
+  let ivs = compute_ivs f cl gl in
+  let quoted_terms = quote_terms ivs [c] in
+  let (p, vm) = match quoted_terms with
     | [p], vm -> (p,vm)
     | _ -> assert false
   in
   match ivs.variable_lhs with
-    | None -> cont (mkApp (f, [| p |])) gl
-    | Some _ -> cont (mkApp (f, [| vm; p |])) gl
+    | None -> cont (mkApp (f, [| p |]))
+    | Some _ -> cont (mkApp (f, [| vm; p |]))
+  end
 
 (*i
 
diff --git a/plugins/ring/LegacyArithRing.v b/plugins/ring/LegacyArithRing.v
deleted file mode 100644
index 0d92973e..00000000
--- a/plugins/ring/LegacyArithRing.v
+++ /dev/null
@@ -1,88 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* Instantiation of the Ring tactic for the naturals of Arith $*)
-
-Require Import Bool.
-Require Export LegacyRing.
-Require Export Arith.
-Require Import Eqdep_dec.
-
-Local Open Scope nat_scope.
-
-Fixpoint nateq (n m:nat) {struct m} : bool :=
-  match n, m with
-  | O, O => true
-  | S n', S m' => nateq n' m'
-  | _, _ => false
-  end.
-
-Lemma nateq_prop : forall n m:nat, Is_true (nateq n m) -> n = m.
-Proof.
-  simple induction n; simple induction m; intros; try contradiction.
-  trivial.
-  unfold Is_true in H1.
-  rewrite (H n1 H1).
-  trivial.
-Qed.
-
-Hint Resolve nateq_prop: arithring.
-
-Definition NatTheory : Semi_Ring_Theory plus mult 1 0 nateq.
-  split; intros; auto with arith arithring.
-(*  apply (fun n m p:nat => plus_reg_l m p n) with (n := n).
-  trivial.*)
-Defined.
-
-
-Add Legacy Semi Ring nat plus mult 1 0 nateq NatTheory [ 0 S ].
-
-Goal forall n:nat, S n = 1 + n.
-intro; reflexivity.
-Save S_to_plus_one.
-
-(* Replace all occurrences of (S exp) by (plus (S O) exp), except when
-   exp is already O and only for those occurrences than can be reached by going
-   down plus and mult operations  *)
-Ltac rewrite_S_to_plus_term t :=
-  match constr:t with
-  | 1 => constr:1
-  | (S ?X1) =>
-      let t1 := rewrite_S_to_plus_term X1 in
-      constr:(1 + t1)
-  | (?X1 + ?X2) =>
-      let t1 := rewrite_S_to_plus_term X1
-      with t2 := rewrite_S_to_plus_term X2 in
-      constr:(t1 + t2)
-  | (?X1 * ?X2) =>
-      let t1 := rewrite_S_to_plus_term X1
-      with t2 := rewrite_S_to_plus_term X2 in
-      constr:(t1 * t2)
-  | _ => constr:t
-  end.
-
-(* Apply S_to_plus on both sides of an equality *)
-Ltac rewrite_S_to_plus :=
-  match goal with
-  |  |- (?X1 = ?X2) =>
-      try
-       let t1 :=
-       (**)  (**)
-       rewrite_S_to_plus_term X1
-       with t2 := rewrite_S_to_plus_term X2 in
-       change (t1 = t2)
-  |  |- (?X1 = ?X2) =>
-      try
-       let t1 :=
-       (**)  (**)
-       rewrite_S_to_plus_term X1
-       with t2 := rewrite_S_to_plus_term X2 in
-       change (t1 = t2)
-  end.
-
-Ltac ring_nat := rewrite_S_to_plus; ring.
diff --git a/plugins/ring/LegacyNArithRing.v b/plugins/ring/LegacyNArithRing.v
deleted file mode 100644
index b358251a..00000000
--- a/plugins/ring/LegacyNArithRing.v
+++ /dev/null
@@ -1,43 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* Instantiation of the Ring tactic for the binary natural numbers *)
-
-Require Import Bool.
-Require Export LegacyRing.
-Require Export ZArith_base.
-Require Import NArith.
-Require Import Eqdep_dec.
-
-Definition Neq (n m:N) :=
-  match (n ?= m)%N with
-  | Datatypes.Eq => true
-  | _ => false
-  end.
-
-Lemma Neq_prop : forall n m:N, Is_true (Neq n m) -> n = m.
-  intros n m H; unfold Neq in H.
-  apply N.compare_eq.
-  destruct (n ?= m)%N; [ reflexivity | contradiction | contradiction ].
-Qed.
-
-Definition NTheory : Semi_Ring_Theory N.add N.mul 1%N 0%N Neq.
-  split.
-    apply N.add_comm.
-    apply N.add_assoc.
-    apply N.mul_comm.
-    apply N.mul_assoc.
-    apply N.add_0_l.
-    apply N.mul_1_l.
-    apply N.mul_0_l.
-    apply N.mul_add_distr_r.
-    apply Neq_prop.
-Qed.
-
-Add Legacy Semi Ring
-  N N.add N.mul 1%N 0%N Neq NTheory [ Npos 0%N xO xI 1%positive ].
diff --git a/plugins/ring/LegacyRing.v b/plugins/ring/LegacyRing.v
deleted file mode 100644
index 31b7cd7c..00000000
--- a/plugins/ring/LegacyRing.v
+++ /dev/null
@@ -1,35 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-Require Export Bool.
-Require Export LegacyRing_theory.
-Require Export Quote.
-Require Export Ring_normalize.
-Require Export Ring_abstract.
-Declare ML Module "ring_plugin".
-
-(* As an example, we provide an instantation for bool. *)
-(* Other instatiations are given in ArithRing and ZArithRing in the
-   same directory *)
-
-Definition BoolTheory :
-  Ring_Theory xorb andb true false (fun b:bool => b) eqb.
-split; simpl.
-destruct n; destruct m; reflexivity.
-destruct n; destruct m; destruct p; reflexivity.
-destruct n; destruct m; reflexivity.
-destruct n; destruct m; destruct p; reflexivity.
-destruct n; reflexivity.
-destruct n; reflexivity.
-destruct n; reflexivity.
-destruct n; destruct m; destruct p; reflexivity.
-destruct x; destruct y; reflexivity || simpl; tauto.
-Defined.
-
-Add Legacy Ring bool xorb andb true false (fun b:bool => b) eqb BoolTheory
- [ true false ].
diff --git a/plugins/ring/LegacyRing_theory.v b/plugins/ring/LegacyRing_theory.v
deleted file mode 100644
index 8f07ad26..00000000
--- a/plugins/ring/LegacyRing_theory.v
+++ /dev/null
@@ -1,374 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-Require Export Bool.
-
-Set Implicit Arguments.
-
-Section Theory_of_semi_rings.
-
-Variable A : Type.
-Variable Aplus : A -> A -> A.
-Variable Amult : A -> A -> A.
-Variable Aone : A.
-Variable Azero : A.
-(* There is also a "weakly decidable" equality on A. That means
-  that if (A_eq x y)=true then x=y but x=y can arise when
-  (A_eq x y)=false. On an abstract ring the function [x,y:A]false
-  is a good choice. The proof of A_eq_prop is in this case easy. *)
-Variable Aeq : A -> A -> bool.
-
-Infix "+" := Aplus (at level 50, left associativity).
-Infix "*" := Amult (at level 40, left associativity).
-Notation "0" := Azero.
-Notation "1" := Aone.
-
-Record Semi_Ring_Theory : Prop :=
-  {SR_plus_comm : forall n m:A, n + m = m + n;
-   SR_plus_assoc : forall n m p:A, n + (m + p) = n + m + p;
-   SR_mult_comm : forall n m:A, n * m = m * n;
-   SR_mult_assoc : forall n m p:A, n * (m * p) = n * m * p;
-   SR_plus_zero_left : forall n:A, 0 + n = n;
-   SR_mult_one_left : forall n:A, 1 * n = n;
-   SR_mult_zero_left : forall n:A, 0 * n = 0;
-   SR_distr_left : forall n m p:A, (n + m) * p = n * p + m * p;
-(*   SR_plus_reg_left : forall n m p:A, n + m = n + p -> m = p;*)
-   SR_eq_prop : forall x y:A, Is_true (Aeq x y) -> x = y}.
-
-Variable T : Semi_Ring_Theory.
-
-Let plus_comm := SR_plus_comm T.
-Let plus_assoc := SR_plus_assoc T.
-Let mult_comm := SR_mult_comm T.
-Let mult_assoc := SR_mult_assoc T.
-Let plus_zero_left := SR_plus_zero_left T.
-Let mult_one_left := SR_mult_one_left T.
-Let mult_zero_left := SR_mult_zero_left T.
-Let distr_left := SR_distr_left T.
-(*Let plus_reg_left := SR_plus_reg_left T.*)
-
-Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left
-  mult_one_left mult_zero_left distr_left (*plus_reg_left*).
-
-(* Lemmas whose form is x=y are also provided in form y=x because Auto does
-  not symmetry *)
-Lemma SR_mult_assoc2 : forall n m p:A, n * m * p = n * (m * p).
-symmetry ; eauto. Qed.
-
-Lemma SR_plus_assoc2 : forall n m p:A, n + m + p = n + (m + p).
-symmetry ; eauto. Qed.
-
-Lemma SR_plus_zero_left2 : forall n:A, n = 0 + n.
-symmetry ; eauto. Qed.
-
-Lemma SR_mult_one_left2 : forall n:A, n = 1 * n.
-symmetry ; eauto. Qed.
-
-Lemma SR_mult_zero_left2 : forall n:A, 0 = 0 * n.
-symmetry ; eauto. Qed.
-
-Lemma SR_distr_left2 : forall n m p:A, n * p + m * p = (n + m) * p.
-symmetry ; eauto. Qed.
-
-Lemma SR_plus_permute : forall n m p:A, n + (m + p) = m + (n + p).
-intros.
-rewrite plus_assoc.
-elim (plus_comm m n).
-rewrite <- plus_assoc.
-reflexivity.
-Qed.
-
-Lemma SR_mult_permute : forall n m p:A, n * (m * p) = m * (n * p).
-intros.
-rewrite mult_assoc.
-elim (mult_comm m n).
-rewrite <- mult_assoc.
-reflexivity.
-Qed.
-
-Hint Resolve SR_plus_permute SR_mult_permute.
-
-Lemma SR_distr_right : forall n m p:A, n * (m + p) = n * m + n * p.
-intros.
-repeat rewrite (mult_comm n).
-eauto.
-Qed.
-
-Lemma SR_distr_right2 : forall n m p:A, n * m + n * p = n * (m + p).
-symmetry ; apply SR_distr_right. Qed.
-
-Lemma SR_mult_zero_right : forall n:A, n * 0 = 0.
-intro; rewrite mult_comm; eauto.
-Qed.
-
-Lemma SR_mult_zero_right2 : forall n:A, 0 = n * 0.
-intro; rewrite mult_comm; eauto.
-Qed.
-
-Lemma SR_plus_zero_right : forall n:A, n + 0 = n.
-intro; rewrite plus_comm; eauto.
-Qed.
-Lemma SR_plus_zero_right2 : forall n:A, n = n + 0.
-intro; rewrite plus_comm; eauto.
-Qed.
-
-Lemma SR_mult_one_right : forall n:A, n * 1 = n.
-intro; elim mult_comm; auto.
-Qed.
-
-Lemma SR_mult_one_right2 : forall n:A, n = n * 1.
-intro; elim mult_comm; auto.
-Qed.
-(*
-Lemma SR_plus_reg_right : forall n m p:A, m + n = p + n -> m = p.
-intros n m p; rewrite (plus_comm m n); rewrite (plus_comm p n); eauto.
-Qed.
-*)
-End Theory_of_semi_rings.
-
-Section Theory_of_rings.
-
-Variable A : Type.
-
-Variable Aplus : A -> A -> A.
-Variable Amult : A -> A -> A.
-Variable Aone : A.
-Variable Azero : A.
-Variable Aopp : A -> A.
-Variable Aeq : A -> A -> bool.
-
-Infix "+" := Aplus (at level 50, left associativity).
-Infix "*" := Amult (at level 40, left associativity).
-Notation "0" := Azero.
-Notation "1" := Aone.
-Notation "- x" := (Aopp x).
-
-Record Ring_Theory : Prop :=
-  {Th_plus_comm : forall n m:A, n + m = m + n;
-   Th_plus_assoc : forall n m p:A, n + (m + p) = n + m + p;
-   Th_mult_comm : forall n m:A, n * m = m * n;
-   Th_mult_assoc : forall n m p:A, n * (m * p) = n * m * p;
-   Th_plus_zero_left : forall n:A, 0 + n = n;
-   Th_mult_one_left : forall n:A, 1 * n = n;
-   Th_opp_def : forall n:A, n + - n = 0;
-   Th_distr_left : forall n m p:A, (n + m) * p = n * p + m * p;
-   Th_eq_prop : forall x y:A, Is_true (Aeq x y) -> x = y}.
-
-Variable T : Ring_Theory.
-
-Let plus_comm := Th_plus_comm T.
-Let plus_assoc := Th_plus_assoc T.
-Let mult_comm := Th_mult_comm T.
-Let mult_assoc := Th_mult_assoc T.
-Let plus_zero_left := Th_plus_zero_left T.
-Let mult_one_left := Th_mult_one_left T.
-Let opp_def := Th_opp_def T.
-Let distr_left := Th_distr_left T.
-
-Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left
-  mult_one_left opp_def distr_left.
-
-(* Lemmas whose form is x=y are also provided in form y=x because Auto does
-  not symmetry *)
-Lemma Th_mult_assoc2 : forall n m p:A, n * m * p = n * (m * p).
-symmetry ; eauto. Qed.
-
-Lemma Th_plus_assoc2 : forall n m p:A, n + m + p = n + (m + p).
-symmetry ; eauto. Qed.
-
-Lemma Th_plus_zero_left2 : forall n:A, n = 0 + n.
-symmetry ; eauto. Qed.
-
-Lemma Th_mult_one_left2 : forall n:A, n = 1 * n.
-symmetry ; eauto. Qed.
-
-Lemma Th_distr_left2 : forall n m p:A, n * p + m * p = (n + m) * p.
-symmetry ; eauto. Qed.
-
-Lemma Th_opp_def2 : forall n:A, 0 = n + - n.
-symmetry ; eauto. Qed.
-
-Lemma Th_plus_permute : forall n m p:A, n + (m + p) = m + (n + p).
-intros.
-rewrite plus_assoc.
-elim (plus_comm m n).
-rewrite <- plus_assoc.
-reflexivity.
-Qed.
-
-Lemma Th_mult_permute : forall n m p:A, n * (m * p) = m * (n * p).
-intros.
-rewrite mult_assoc.
-elim (mult_comm m n).
-rewrite <- mult_assoc.
-reflexivity.
-Qed.
-
-Hint Resolve Th_plus_permute Th_mult_permute.
-
-Lemma aux1 : forall a:A, a + a = a -> a = 0.
-intros.
-generalize (opp_def a).
-pattern a at 1.
-rewrite <- H.
-rewrite <- plus_assoc.
-rewrite opp_def.
-elim plus_comm.
-rewrite plus_zero_left.
-trivial.
-Qed.
-
-Lemma Th_mult_zero_left : forall n:A, 0 * n = 0.
-intros.
-apply aux1.
-rewrite <- distr_left.
-rewrite plus_zero_left.
-reflexivity.
-Qed.
-Hint Resolve Th_mult_zero_left.
-
-Lemma Th_mult_zero_left2 : forall n:A, 0 = 0 * n.
-symmetry ; eauto. Qed.
-
-Lemma aux2 : forall x y z:A, x + y = 0 -> x + z = 0 -> y = z.
-intros.
-rewrite <- (plus_zero_left y).
-elim H0.
-elim plus_assoc.
-elim (plus_comm y z).
-rewrite plus_assoc.
-rewrite H.
-rewrite plus_zero_left.
-reflexivity.
-Qed.
-
-Lemma Th_opp_mult_left : forall x y:A, - (x * y) = - x * y.
-intros.
-apply (aux2 (x:=(x * y)));
- [ apply opp_def | rewrite <- distr_left; rewrite opp_def; auto ].
-Qed.
-Hint Resolve Th_opp_mult_left.
-
-Lemma Th_opp_mult_left2 : forall x y:A, - x * y = - (x * y).
-symmetry ; eauto. Qed.
-
-Lemma Th_mult_zero_right : forall n:A, n * 0 = 0.
-intro; elim mult_comm; eauto.
-Qed.
-
-Lemma Th_mult_zero_right2 : forall n:A, 0 = n * 0.
-intro; elim mult_comm; eauto.
-Qed.
-
-Lemma Th_plus_zero_right : forall n:A, n + 0 = n.
-intro; rewrite plus_comm; eauto.
-Qed.
-
-Lemma Th_plus_zero_right2 : forall n:A, n = n + 0.
-intro; rewrite plus_comm; eauto.
-Qed.
-
-Lemma Th_mult_one_right : forall n:A, n * 1 = n.
-intro; elim mult_comm; eauto.
-Qed.
-
-Lemma Th_mult_one_right2 : forall n:A, n = n * 1.
-intro; elim mult_comm; eauto.
-Qed.
-
-Lemma Th_opp_mult_right : forall x y:A, - (x * y) = x * - y.
-intros; do 2 rewrite (mult_comm x); auto.
-Qed.
-
-Lemma Th_opp_mult_right2 : forall x y:A, x * - y = - (x * y).
-intros; do 2 rewrite (mult_comm x); auto.
-Qed.
-
-Lemma Th_plus_opp_opp : forall x y:A, - x + - y = - (x + y).
-intros.
-apply (aux2 (x:=(x + y)));
- [ elim plus_assoc; rewrite (Th_plus_permute y (- x)); rewrite plus_assoc;
-    rewrite opp_def; rewrite plus_zero_left; auto
- | auto ].
-Qed.
-
-Lemma Th_plus_permute_opp : forall n m p:A, - m + (n + p) = n + (- m + p).
-eauto. Qed.
-
-Lemma Th_opp_opp : forall n:A, - - n = n.
-intro; apply (aux2 (x:=(- n))); [ auto | elim plus_comm; auto ].
-Qed.
-Hint Resolve Th_opp_opp.
-
-Lemma Th_opp_opp2 : forall n:A, n = - - n.
-symmetry ; eauto. Qed.
-
-Lemma Th_mult_opp_opp : forall x y:A, - x * - y = x * y.
-intros; rewrite <- Th_opp_mult_left; rewrite <- Th_opp_mult_right; auto.
-Qed.
-
-Lemma Th_mult_opp_opp2 : forall x y:A, x * y = - x * - y.
-symmetry ; apply Th_mult_opp_opp. Qed.
-
-Lemma Th_opp_zero : - 0 = 0.
-rewrite <- (plus_zero_left (- 0)).
-auto. Qed.
-(*
-Lemma Th_plus_reg_left : forall n m p:A, n + m = n + p -> m = p.
-intros; generalize (f_equal (fun z => - n + z) H).
-repeat rewrite plus_assoc.
-rewrite (plus_comm (- n) n).
-rewrite opp_def.
-repeat rewrite Th_plus_zero_left; eauto.
-Qed.
-
-Lemma Th_plus_reg_right : forall n m p:A, m + n = p + n -> m = p.
-intros.
-eapply Th_plus_reg_left with n.
-rewrite (plus_comm n m).
-rewrite (plus_comm n p).
-auto.
-Qed.
-*)
-Lemma Th_distr_right : forall n m p:A, n * (m + p) = n * m + n * p.
-intros.
-repeat rewrite (mult_comm n).
-eauto.
-Qed.
-
-Lemma Th_distr_right2 : forall n m p:A, n * m + n * p = n * (m + p).
-symmetry ; apply Th_distr_right.
-Qed.
-
-End Theory_of_rings.
-
-Hint Resolve Th_mult_zero_left (*Th_plus_reg_left*): core.
-
-Unset Implicit Arguments.
-
-Definition Semi_Ring_Theory_of :
-  forall (A:Type) (Aplus Amult:A -> A -> A) (Aone Azero:A)
-    (Aopp:A -> A) (Aeq:A -> A -> bool),
-    Ring_Theory Aplus Amult Aone Azero Aopp Aeq ->
-    Semi_Ring_Theory Aplus Amult Aone Azero Aeq.
-intros until 1; case H.
-split; intros; simpl; eauto.
-Defined.
-
-(* Every ring can be viewed as a semi-ring : this property will be used
-  in Abstract_polynom. *)
-Coercion Semi_Ring_Theory_of : Ring_Theory >-> Semi_Ring_Theory.
-
-
-Section product_ring.
-
-End product_ring.
-
-Section power_ring.
-
-End power_ring.
diff --git a/plugins/ring/LegacyZArithRing.v b/plugins/ring/LegacyZArithRing.v
deleted file mode 100644
index 472c91b4..00000000
--- a/plugins/ring/LegacyZArithRing.v
+++ /dev/null
@@ -1,35 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* Instantiation of the Ring tactic for the binary integers of ZArith *)
-
-Require Export LegacyArithRing.
-Require Export ZArith_base.
-Require Import Eqdep_dec.
-Require Import LegacyRing.
-
-Definition Zeq (x y:Z) :=
-  match (x ?= y)%Z with
-  | Datatypes.Eq => true
-  | _ => false
-  end.
-
-Lemma Zeq_prop : forall x y:Z, Is_true (Zeq x y) -> x = y.
-  intros x y H; unfold Zeq in H.
-  apply Z.compare_eq.
-  destruct (x ?= y)%Z; [ reflexivity | contradiction | contradiction ].
-Qed.
-
-Definition ZTheory : Ring_Theory Z.add Z.mul 1%Z 0%Z Z.opp Zeq.
-  split; intros; eauto with zarith.
-  apply Zeq_prop; assumption.
-Qed.
-
-(* NatConstants and NatTheory are defined in Ring_theory.v *)
-Add Legacy Ring Z Z.add Z.mul 1%Z 0%Z Z.opp Zeq ZTheory
- [ Zpos Zneg 0%Z xO xI 1%positive ].
diff --git a/plugins/ring/Ring_abstract.v b/plugins/ring/Ring_abstract.v
deleted file mode 100644
index 4aec3893..00000000
--- a/plugins/ring/Ring_abstract.v
+++ /dev/null
@@ -1,700 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-Require Import LegacyRing_theory.
-Require Import Quote.
-Require Import Ring_normalize.
-
-Section abstract_semi_rings.
-
-Inductive aspolynomial : Type :=
-  | ASPvar : index -> aspolynomial
-  | ASP0 : aspolynomial
-  | ASP1 : aspolynomial
-  | ASPplus : aspolynomial -> aspolynomial -> aspolynomial
-  | ASPmult : aspolynomial -> aspolynomial -> aspolynomial.
-
-Inductive abstract_sum : Type :=
-  | Nil_acs : abstract_sum
-  | Cons_acs : varlist -> abstract_sum -> abstract_sum.
-
-Fixpoint abstract_sum_merge (s1:abstract_sum) :
- abstract_sum -> abstract_sum :=
-  match s1 with
-  | Cons_acs l1 t1 =>
-      (fix asm_aux (s2:abstract_sum) : abstract_sum :=
-         match s2 with
-         | Cons_acs l2 t2 =>
-             if varlist_lt l1 l2
-             then Cons_acs l1 (abstract_sum_merge t1 s2)
-             else Cons_acs l2 (asm_aux t2)
-         | Nil_acs => s1
-         end)
-  | Nil_acs => fun s2 => s2
-  end.
-
-Fixpoint abstract_varlist_insert (l1:varlist) (s2:abstract_sum) {struct s2} :
- abstract_sum :=
-  match s2 with
-  | Cons_acs l2 t2 =>
-      if varlist_lt l1 l2
-      then Cons_acs l1 s2
-      else Cons_acs l2 (abstract_varlist_insert l1 t2)
-  | Nil_acs => Cons_acs l1 Nil_acs
-  end.
-
-Fixpoint abstract_sum_scalar (l1:varlist) (s2:abstract_sum) {struct s2} :
- abstract_sum :=
-  match s2 with
-  | Cons_acs l2 t2 =>
-      abstract_varlist_insert (varlist_merge l1 l2)
-        (abstract_sum_scalar l1 t2)
-  | Nil_acs => Nil_acs
-  end.
-
-Fixpoint abstract_sum_prod (s1 s2:abstract_sum) {struct s1} : abstract_sum :=
-  match s1 with
-  | Cons_acs l1 t1 =>
-      abstract_sum_merge (abstract_sum_scalar l1 s2)
-        (abstract_sum_prod t1 s2)
-  | Nil_acs => Nil_acs
-  end.
-
-Fixpoint aspolynomial_normalize (p:aspolynomial) : abstract_sum :=
-  match p with
-  | ASPvar i => Cons_acs (Cons_var i Nil_var) Nil_acs
-  | ASP1 => Cons_acs Nil_var Nil_acs
-  | ASP0 => Nil_acs
-  | ASPplus l r =>
-      abstract_sum_merge (aspolynomial_normalize l)
-        (aspolynomial_normalize r)
-  | ASPmult l r =>
-      abstract_sum_prod (aspolynomial_normalize l) (aspolynomial_normalize r)
-  end.
-
-
-
-Variable A : Type.
-Variable Aplus : A -> A -> A.
-Variable Amult : A -> A -> A.
-Variable Aone : A.
-Variable Azero : A.
-Variable Aeq : A -> A -> bool.
-Variable vm : varmap A.
-Variable T : Semi_Ring_Theory Aplus Amult Aone Azero Aeq.
-
-Fixpoint interp_asp (p:aspolynomial) : A :=
-  match p with
-  | ASPvar i => interp_var Azero vm i
-  | ASP0 => Azero
-  | ASP1 => Aone
-  | ASPplus l r => Aplus (interp_asp l) (interp_asp r)
-  | ASPmult l r => Amult (interp_asp l) (interp_asp r)
-  end.
-
-(* Local *) Definition iacs_aux :=
-              (fix iacs_aux (a:A) (s:abstract_sum) {struct s} : A :=
-                 match s with
-                 | Nil_acs => a
-                 | Cons_acs l t =>
-                     Aplus a (iacs_aux (interp_vl Amult Aone Azero vm l) t)
-                 end).
-
-Definition interp_acs (s:abstract_sum) : A :=
-  match s with
-  | Cons_acs l t => iacs_aux (interp_vl Amult Aone Azero vm l) t
-  | Nil_acs => Azero
-  end.
-
-Hint Resolve (SR_plus_comm T).
-Hint Resolve (SR_plus_assoc T).
-Hint Resolve (SR_plus_assoc2 T).
-Hint Resolve (SR_mult_comm T).
-Hint Resolve (SR_mult_assoc T).
-Hint Resolve (SR_mult_assoc2 T).
-Hint Resolve (SR_plus_zero_left T).
-Hint Resolve (SR_plus_zero_left2 T).
-Hint Resolve (SR_mult_one_left T).
-Hint Resolve (SR_mult_one_left2 T).
-Hint Resolve (SR_mult_zero_left T).
-Hint Resolve (SR_mult_zero_left2 T).
-Hint Resolve (SR_distr_left T).
-Hint Resolve (SR_distr_left2 T).
-(*Hint Resolve (SR_plus_reg_left T).*)
-Hint Resolve (SR_plus_permute T).
-Hint Resolve (SR_mult_permute T).
-Hint Resolve (SR_distr_right T).
-Hint Resolve (SR_distr_right2 T).
-Hint Resolve (SR_mult_zero_right T).
-Hint Resolve (SR_mult_zero_right2 T).
-Hint Resolve (SR_plus_zero_right T).
-Hint Resolve (SR_plus_zero_right2 T).
-Hint Resolve (SR_mult_one_right T).
-Hint Resolve (SR_mult_one_right2 T).
-(*Hint Resolve (SR_plus_reg_right T).*)
-Hint Resolve eq_refl eq_sym eq_trans.
-Hint Immediate T.
-
-Remark iacs_aux_ok :
- forall (x:A) (s:abstract_sum), iacs_aux x s = Aplus x (interp_acs s).
-Proof.
-  simple induction s; simpl; intros.
-  trivial.
-  reflexivity.
-Qed.
-
-Hint Extern 10 (_ = _ :>A) => rewrite iacs_aux_ok: core.
-
-Lemma abstract_varlist_insert_ok :
- forall (l:varlist) (s:abstract_sum),
-   interp_acs (abstract_varlist_insert l s) =
-   Aplus (interp_vl Amult Aone Azero vm l) (interp_acs s).
-
-  simple induction s.
-  trivial.
-
-  simpl; intros.
-  elim (varlist_lt l v); simpl.
-  eauto.
-  rewrite iacs_aux_ok.
-  rewrite H; auto.
-
-Qed.
-
-Lemma abstract_sum_merge_ok :
- forall x y:abstract_sum,
-   interp_acs (abstract_sum_merge x y) = Aplus (interp_acs x) (interp_acs y).
-
-Proof.
-  simple induction x.
-  trivial.
-  simple induction y; intros.
-
-  auto.
-
-  simpl; elim (varlist_lt v v0); simpl.
-  repeat rewrite iacs_aux_ok.
-  rewrite H; simpl; auto.
-
-  simpl in H0.
-  repeat rewrite iacs_aux_ok.
-  rewrite H0. simpl; auto.
-Qed.
-
-Lemma abstract_sum_scalar_ok :
- forall (l:varlist) (s:abstract_sum),
-   interp_acs (abstract_sum_scalar l s) =
-   Amult (interp_vl Amult Aone Azero vm l) (interp_acs s).
-Proof.
-  simple induction s.
-  simpl; eauto.
-
-  simpl; intros.
-  rewrite iacs_aux_ok.
-  rewrite abstract_varlist_insert_ok.
-  rewrite H.
-  rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T).
-  auto.
-Qed.
-
-Lemma abstract_sum_prod_ok :
- forall x y:abstract_sum,
-   interp_acs (abstract_sum_prod x y) = Amult (interp_acs x) (interp_acs y).
-
-Proof.
-  simple induction x.
-  intros; simpl; eauto.
-
-  destruct y as [| v0 a0]; intros.
-
-  simpl; rewrite H; eauto.
-
-  unfold abstract_sum_prod; fold abstract_sum_prod.
-  rewrite abstract_sum_merge_ok.
-  rewrite abstract_sum_scalar_ok.
-  rewrite H; simpl; auto.
-Qed.
-
-Theorem aspolynomial_normalize_ok :
- forall x:aspolynomial, interp_asp x = interp_acs (aspolynomial_normalize x).
-Proof.
-  simple induction x; simpl; intros; trivial.
-  rewrite abstract_sum_merge_ok.
-  rewrite H; rewrite H0; eauto.
-  rewrite abstract_sum_prod_ok.
-  rewrite H; rewrite H0; eauto.
-Qed.
-
-End abstract_semi_rings.
-
-Section abstract_rings.
-
-(* In abstract polynomials there is no constants other
-   than 0 and 1. An abstract ring is a ring whose operations plus,
-   and mult are not functions but  constructors. In other words,
-   when c1 and c2 are closed,  (plus c1 c2) doesn't reduce to a closed
-   term. "closed" mean here "without plus and mult". *)
-
-(* this section is not parametrized by a (semi-)ring.
-   Nevertheless, they are two different types for semi-rings and rings
-   and there will be 2 correction theorems *)
-
-Inductive apolynomial : Type :=
-  | APvar : index -> apolynomial
-  | AP0 : apolynomial
-  | AP1 : apolynomial
-  | APplus : apolynomial -> apolynomial -> apolynomial
-  | APmult : apolynomial -> apolynomial -> apolynomial
-  | APopp : apolynomial -> apolynomial.
-
-(* A canonical "abstract" sum is a list of varlist with the sign "+" or "-".
-   Invariant : the list is sorted and there is no varlist is present
-   with both signs. +x +x +x -x is forbidden => the canonical form is +x+x *)
-
-Inductive signed_sum : Type :=
-  | Nil_varlist : signed_sum
-  | Plus_varlist : varlist -> signed_sum -> signed_sum
-  | Minus_varlist : varlist -> signed_sum -> signed_sum.
-
-Fixpoint signed_sum_merge (s1:signed_sum) : signed_sum -> signed_sum :=
-  match s1 with
-  | Plus_varlist l1 t1 =>
-      (fix ssm_aux (s2:signed_sum) : signed_sum :=
-         match s2 with
-         | Plus_varlist l2 t2 =>
-             if varlist_lt l1 l2
-             then Plus_varlist l1 (signed_sum_merge t1 s2)
-             else Plus_varlist l2 (ssm_aux t2)
-         | Minus_varlist l2 t2 =>
-             if varlist_eq l1 l2
-             then signed_sum_merge t1 t2
-             else
-              if varlist_lt l1 l2
-              then Plus_varlist l1 (signed_sum_merge t1 s2)
-              else Minus_varlist l2 (ssm_aux t2)
-         | Nil_varlist => s1
-         end)
-  | Minus_varlist l1 t1 =>
-      (fix ssm_aux2 (s2:signed_sum) : signed_sum :=
-         match s2 with
-         | Plus_varlist l2 t2 =>
-             if varlist_eq l1 l2
-             then signed_sum_merge t1 t2
-             else
-              if varlist_lt l1 l2
-              then Minus_varlist l1 (signed_sum_merge t1 s2)
-              else Plus_varlist l2 (ssm_aux2 t2)
-         | Minus_varlist l2 t2 =>
-             if varlist_lt l1 l2
-             then Minus_varlist l1 (signed_sum_merge t1 s2)
-             else Minus_varlist l2 (ssm_aux2 t2)
-         | Nil_varlist => s1
-         end)
-  | Nil_varlist => fun s2 => s2
-  end.
-
-Fixpoint plus_varlist_insert (l1:varlist) (s2:signed_sum) {struct s2} :
- signed_sum :=
-  match s2 with
-  | Plus_varlist l2 t2 =>
-      if varlist_lt l1 l2
-      then Plus_varlist l1 s2
-      else Plus_varlist l2 (plus_varlist_insert l1 t2)
-  | Minus_varlist l2 t2 =>
-      if varlist_eq l1 l2
-      then t2
-      else
-       if varlist_lt l1 l2
-       then Plus_varlist l1 s2
-       else Minus_varlist l2 (plus_varlist_insert l1 t2)
-  | Nil_varlist => Plus_varlist l1 Nil_varlist
-  end.
-
-Fixpoint minus_varlist_insert (l1:varlist) (s2:signed_sum) {struct s2} :
- signed_sum :=
-  match s2 with
-  | Plus_varlist l2 t2 =>
-      if varlist_eq l1 l2
-      then t2
-      else
-       if varlist_lt l1 l2
-       then Minus_varlist l1 s2
-       else Plus_varlist l2 (minus_varlist_insert l1 t2)
-  | Minus_varlist l2 t2 =>
-      if varlist_lt l1 l2
-      then Minus_varlist l1 s2
-      else Minus_varlist l2 (minus_varlist_insert l1 t2)
-  | Nil_varlist => Minus_varlist l1 Nil_varlist
-  end.
-
-Fixpoint signed_sum_opp (s:signed_sum) : signed_sum :=
-  match s with
-  | Plus_varlist l2 t2 => Minus_varlist l2 (signed_sum_opp t2)
-  | Minus_varlist l2 t2 => Plus_varlist l2 (signed_sum_opp t2)
-  | Nil_varlist => Nil_varlist
-  end.
-
-
-Fixpoint plus_sum_scalar (l1:varlist) (s2:signed_sum) {struct s2} :
- signed_sum :=
-  match s2 with
-  | Plus_varlist l2 t2 =>
-      plus_varlist_insert (varlist_merge l1 l2) (plus_sum_scalar l1 t2)
-  | Minus_varlist l2 t2 =>
-      minus_varlist_insert (varlist_merge l1 l2) (plus_sum_scalar l1 t2)
-  | Nil_varlist => Nil_varlist
-  end.
-
-Fixpoint minus_sum_scalar (l1:varlist) (s2:signed_sum) {struct s2} :
- signed_sum :=
-  match s2 with
-  | Plus_varlist l2 t2 =>
-      minus_varlist_insert (varlist_merge l1 l2) (minus_sum_scalar l1 t2)
-  | Minus_varlist l2 t2 =>
-      plus_varlist_insert (varlist_merge l1 l2) (minus_sum_scalar l1 t2)
-  | Nil_varlist => Nil_varlist
-  end.
-
-Fixpoint signed_sum_prod (s1 s2:signed_sum) {struct s1} : signed_sum :=
-  match s1 with
-  | Plus_varlist l1 t1 =>
-      signed_sum_merge (plus_sum_scalar l1 s2) (signed_sum_prod t1 s2)
-  | Minus_varlist l1 t1 =>
-      signed_sum_merge (minus_sum_scalar l1 s2) (signed_sum_prod t1 s2)
-  | Nil_varlist => Nil_varlist
-  end.
-
-Fixpoint apolynomial_normalize (p:apolynomial) : signed_sum :=
-  match p with
-  | APvar i => Plus_varlist (Cons_var i Nil_var) Nil_varlist
-  | AP1 => Plus_varlist Nil_var Nil_varlist
-  | AP0 => Nil_varlist
-  | APplus l r =>
-      signed_sum_merge (apolynomial_normalize l) (apolynomial_normalize r)
-  | APmult l r =>
-      signed_sum_prod (apolynomial_normalize l) (apolynomial_normalize r)
-  | APopp q => signed_sum_opp (apolynomial_normalize q)
-  end.
-
-
-Variable A : Type.
-Variable Aplus : A -> A -> A.
-Variable Amult : A -> A -> A.
-Variable Aone : A.
-Variable Azero : A.
-Variable Aopp : A -> A.
-Variable Aeq : A -> A -> bool.
-Variable vm : varmap A.
-Variable T : Ring_Theory Aplus Amult Aone Azero Aopp Aeq.
-
-(* Local *) Definition isacs_aux :=
-              (fix isacs_aux (a:A) (s:signed_sum) {struct s} : A :=
-                 match s with
-                 | Nil_varlist => a
-                 | Plus_varlist l t =>
-                     Aplus a (isacs_aux (interp_vl Amult Aone Azero vm l) t)
-                 | Minus_varlist l t =>
-                     Aplus a
-                       (isacs_aux (Aopp (interp_vl Amult Aone Azero vm l)) t)
-                 end).
-
-Definition interp_sacs (s:signed_sum) : A :=
-  match s with
-  | Plus_varlist l t => isacs_aux (interp_vl Amult Aone Azero vm l) t
-  | Minus_varlist l t => isacs_aux (Aopp (interp_vl Amult Aone Azero vm l)) t
-  | Nil_varlist => Azero
-  end.
-
-Fixpoint interp_ap (p:apolynomial) : A :=
-  match p with
-  | APvar i => interp_var Azero vm i
-  | AP0 => Azero
-  | AP1 => Aone
-  | APplus l r => Aplus (interp_ap l) (interp_ap r)
-  | APmult l r => Amult (interp_ap l) (interp_ap r)
-  | APopp q => Aopp (interp_ap q)
-  end.
-
-Hint Resolve (Th_plus_comm T).
-Hint Resolve (Th_plus_assoc T).
-Hint Resolve (Th_plus_assoc2 T).
-Hint Resolve (Th_mult_comm T).
-Hint Resolve (Th_mult_assoc T).
-Hint Resolve (Th_mult_assoc2 T).
-Hint Resolve (Th_plus_zero_left T).
-Hint Resolve (Th_plus_zero_left2 T).
-Hint Resolve (Th_mult_one_left T).
-Hint Resolve (Th_mult_one_left2 T).
-Hint Resolve (Th_mult_zero_left T).
-Hint Resolve (Th_mult_zero_left2 T).
-Hint Resolve (Th_distr_left T).
-Hint Resolve (Th_distr_left2 T).
-(*Hint Resolve (Th_plus_reg_left T).*)
-Hint Resolve (Th_plus_permute T).
-Hint Resolve (Th_mult_permute T).
-Hint Resolve (Th_distr_right T).
-Hint Resolve (Th_distr_right2 T).
-Hint Resolve (Th_mult_zero_right2 T).
-Hint Resolve (Th_plus_zero_right T).
-Hint Resolve (Th_plus_zero_right2 T).
-Hint Resolve (Th_mult_one_right T).
-Hint Resolve (Th_mult_one_right2 T).
-(*Hint Resolve (Th_plus_reg_right T).*)
-Hint Resolve eq_refl eq_sym eq_trans.
-Hint Immediate T.
-
-Lemma isacs_aux_ok :
- forall (x:A) (s:signed_sum), isacs_aux x s = Aplus x (interp_sacs s).
-Proof.
-  simple induction s; simpl; intros.
-  trivial.
-  reflexivity.
-  reflexivity.
-Qed.
-
-Hint Extern 10 (_ = _ :>A) => rewrite isacs_aux_ok: core.
-
-Ltac solve1 v v0 H H0 :=
-  simpl; elim (varlist_lt v v0); simpl; rewrite isacs_aux_ok;
-   [ rewrite H; simpl; auto | simpl in H0; rewrite H0; auto ].
-
-Lemma signed_sum_merge_ok :
- forall x y:signed_sum,
-   interp_sacs (signed_sum_merge x y) = Aplus (interp_sacs x) (interp_sacs y).
-
-  simple induction x.
-  intro; simpl; auto.
-
-  simple induction y; intros.
-
-  auto.
-
-  solve1 v v0 H H0.
-
-  simpl; generalize (varlist_eq_prop v v0).
-  elim (varlist_eq v v0); simpl.
-
-  intro Heq; rewrite (Heq I).
-  rewrite H.
-  repeat rewrite isacs_aux_ok.
-  rewrite (Th_plus_permute T).
-  repeat rewrite (Th_plus_assoc T).
-  rewrite
-   (Th_plus_comm T (Aopp (interp_vl Amult Aone Azero vm v0))
-      (interp_vl Amult Aone Azero vm v0)).
-  rewrite (Th_opp_def T).
-  rewrite (Th_plus_zero_left T).
-  reflexivity.
-
-  solve1 v v0 H H0.
-
-  simple induction y; intros.
-
-  auto.
-
-  simpl; generalize (varlist_eq_prop v v0).
-  elim (varlist_eq v v0); simpl.
-
-  intro Heq; rewrite (Heq I).
-  rewrite H.
-  repeat rewrite isacs_aux_ok.
-  rewrite (Th_plus_permute T).
-  repeat rewrite (Th_plus_assoc T).
-  rewrite (Th_opp_def T).
-  rewrite (Th_plus_zero_left T).
-  reflexivity.
-
-  solve1 v v0 H H0.
-
-  solve1 v v0 H H0.
-
-Qed.
-
-Ltac solve2 l v H :=
-  elim (varlist_lt l v); simpl; rewrite isacs_aux_ok;
-   [ auto | rewrite H; auto ].
-
-Lemma plus_varlist_insert_ok :
- forall (l:varlist) (s:signed_sum),
-   interp_sacs (plus_varlist_insert l s) =
-   Aplus (interp_vl Amult Aone Azero vm l) (interp_sacs s).
-Proof.
-
-  simple induction s.
-  trivial.
-
-  simpl; intros.
-  solve2 l v H.
-
-  simpl; intros.
-  generalize (varlist_eq_prop l v).
-  elim (varlist_eq l v); simpl.
-
-  intro Heq; rewrite (Heq I).
-  repeat rewrite isacs_aux_ok.
-  repeat rewrite (Th_plus_assoc T).
-  rewrite (Th_opp_def T).
-  rewrite (Th_plus_zero_left T).
-  reflexivity.
-
-  solve2 l v H.
-
-Qed.
-
-Lemma minus_varlist_insert_ok :
- forall (l:varlist) (s:signed_sum),
-   interp_sacs (minus_varlist_insert l s) =
-   Aplus (Aopp (interp_vl Amult Aone Azero vm l)) (interp_sacs s).
-Proof.
-
-  simple induction s.
-  trivial.
-
-  simpl; intros.
-  generalize (varlist_eq_prop l v).
-  elim (varlist_eq l v); simpl.
-
-  intro Heq; rewrite (Heq I).
-  repeat rewrite isacs_aux_ok.
-  repeat rewrite (Th_plus_assoc T).
-  rewrite
-   (Th_plus_comm T (Aopp (interp_vl Amult Aone Azero vm v))
-      (interp_vl Amult Aone Azero vm v)).
-  rewrite (Th_opp_def T).
-  auto.
-
-  simpl; intros.
-  solve2 l v H.
-
-  simpl; intros; solve2 l v H.
-
-Qed.
-
-Lemma signed_sum_opp_ok :
- forall s:signed_sum, interp_sacs (signed_sum_opp s) = Aopp (interp_sacs s).
-Proof.
-
-  simple induction s; simpl; intros.
-
-  symmetry ; apply (Th_opp_zero T).
-
-  repeat rewrite isacs_aux_ok.
-  rewrite H.
-  rewrite (Th_plus_opp_opp T).
-  reflexivity.
-
-  repeat rewrite isacs_aux_ok.
-  rewrite H.
-  rewrite <- (Th_plus_opp_opp T).
-  rewrite (Th_opp_opp T).
-  reflexivity.
-
-Qed.
-
-Lemma plus_sum_scalar_ok :
- forall (l:varlist) (s:signed_sum),
-   interp_sacs (plus_sum_scalar l s) =
-   Amult (interp_vl Amult Aone Azero vm l) (interp_sacs s).
-Proof.
-
-  simple induction s.
-  trivial.
-
-  simpl; intros.
-  rewrite plus_varlist_insert_ok.
-  rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T).
-  repeat rewrite isacs_aux_ok.
-  rewrite H.
-  auto.
-
-  simpl; intros.
-  rewrite minus_varlist_insert_ok.
-  repeat rewrite isacs_aux_ok.
-  rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T).
-  rewrite H.
-  rewrite (Th_distr_right T).
-  rewrite <- (Th_opp_mult_right T).
-  reflexivity.
-
-Qed.
-
-Lemma minus_sum_scalar_ok :
- forall (l:varlist) (s:signed_sum),
-   interp_sacs (minus_sum_scalar l s) =
-   Aopp (Amult (interp_vl Amult Aone Azero vm l) (interp_sacs s)).
-Proof.
-
-  simple induction s; simpl; intros.
-
-  rewrite (Th_mult_zero_right T); symmetry ; apply (Th_opp_zero T).
-
-  simpl; intros.
-  rewrite minus_varlist_insert_ok.
-  rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T).
-  repeat rewrite isacs_aux_ok.
-  rewrite H.
-  rewrite (Th_distr_right T).
-  rewrite (Th_plus_opp_opp T).
-  reflexivity.
-
-  simpl; intros.
-  rewrite plus_varlist_insert_ok.
-  repeat rewrite isacs_aux_ok.
-  rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T).
-  rewrite H.
-  rewrite (Th_distr_right T).
-  rewrite <- (Th_opp_mult_right T).
-  rewrite <- (Th_plus_opp_opp T).
-  rewrite (Th_opp_opp T).
-  reflexivity.
-
-Qed.
-
-Lemma signed_sum_prod_ok :
- forall x y:signed_sum,
-   interp_sacs (signed_sum_prod x y) = Amult (interp_sacs x) (interp_sacs y).
-Proof.
-
-  simple induction x.
-
-  simpl; eauto 1.
-
-  intros; simpl.
-  rewrite signed_sum_merge_ok.
-  rewrite plus_sum_scalar_ok.
-  repeat rewrite isacs_aux_ok.
-  rewrite H.
-  auto.
-
-  intros; simpl.
-  repeat rewrite isacs_aux_ok.
-  rewrite signed_sum_merge_ok.
-  rewrite minus_sum_scalar_ok.
-  rewrite H.
-  rewrite (Th_distr_left T).
-  rewrite (Th_opp_mult_left T).
-  reflexivity.
-
-Qed.
-
-Theorem apolynomial_normalize_ok :
- forall p:apolynomial, interp_sacs (apolynomial_normalize p) = interp_ap p.
-Proof.
-  simple induction p; simpl; auto 1.
-  intros.
-    rewrite signed_sum_merge_ok.
-    rewrite H; rewrite H0; reflexivity.
-  intros.
-    rewrite signed_sum_prod_ok.
-    rewrite H; rewrite H0; reflexivity.
-  intros.
-    rewrite signed_sum_opp_ok.
-    rewrite H; reflexivity.
-Qed.
-
-End abstract_rings.
diff --git a/plugins/ring/Ring_normalize.v b/plugins/ring/Ring_normalize.v
deleted file mode 100644
index 6306c4a7..00000000
--- a/plugins/ring/Ring_normalize.v
+++ /dev/null
@@ -1,897 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-Require Import LegacyRing_theory.
-Require Import Quote.
-
-Set Implicit Arguments.
-
-Lemma index_eq_prop : forall n m:index, Is_true (index_eq n m) -> n = m.
-Proof.
-  intros.
-  apply index_eq_prop.
-  generalize H.
-  case (index_eq n m); simpl; trivial; intros.
-  contradiction.
-Qed.
-
-Section semi_rings.
-
-Variable A : Type.
-Variable Aplus : A -> A -> A.
-Variable Amult : A -> A -> A.
-Variable Aone : A.
-Variable Azero : A.
-Variable Aeq : A -> A -> bool.
-
-(* Section definitions. *)
-
-
-(******************************************)
-(* Normal abtract Polynomials             *)
-(******************************************)
-(* DEFINITIONS :
-- A varlist is a sorted product of one or more variables : x, x*y*z
-- A monom is a constant, a varlist or the product of a constant by a varlist
-  variables. 2*x*y, x*y*z, 3 are monoms : 2*3, x*3*y, 4*x*3 are NOT.
-- A canonical sum is either a monom or an ordered sum of monoms
-  (the order on monoms is defined later)
-- A normal polynomial it either a constant or a canonical sum or a constant
-  plus a canonical sum
-*)
-
-(* varlist is isomorphic to (list var), but we built a special inductive
-   for efficiency *)
-Inductive varlist : Type :=
-  | Nil_var : varlist
-  | Cons_var : index -> varlist -> varlist.
-
-Inductive canonical_sum : Type :=
-  | Nil_monom : canonical_sum
-  | Cons_monom : A -> varlist -> canonical_sum -> canonical_sum
-  | Cons_varlist : varlist -> canonical_sum -> canonical_sum.
-
-(* Order on monoms *)
-
-(* That's the lexicographic order on varlist, extended by :
-  - A constant is less than every monom
-  - The relation between two varlist is preserved by multiplication by a
-  constant.
-
-  Examples :
-  3 < x < y
-  x*y < x*y*y*z
-  2*x*y < x*y*y*z
-  x*y < 54*x*y*y*z
-  4*x*y < 59*x*y*y*z
-*)
-
-Fixpoint varlist_eq (x y:varlist) {struct y} : bool :=
-  match x, y with
-  | Nil_var, Nil_var => true
-  | Cons_var i xrest, Cons_var j yrest =>
-      andb (index_eq i j) (varlist_eq xrest yrest)
-  | _, _ => false
-  end.
-
-Fixpoint varlist_lt (x y:varlist) {struct y} : bool :=
-  match x, y with
-  | Nil_var, Cons_var _ _ => true
-  | Cons_var i xrest, Cons_var j yrest =>
-      if index_lt i j
-      then true
-      else andb (index_eq i j) (varlist_lt xrest yrest)
-  | _, _ => false
-  end.
-
-(* merges two variables lists *)
-Fixpoint varlist_merge (l1:varlist) : varlist -> varlist :=
-  match l1 with
-  | Cons_var v1 t1 =>
-      (fix vm_aux (l2:varlist) : varlist :=
-         match l2 with
-         | Cons_var v2 t2 =>
-             if index_lt v1 v2
-             then Cons_var v1 (varlist_merge t1 l2)
-             else Cons_var v2 (vm_aux t2)
-         | Nil_var => l1
-         end)
-  | Nil_var => fun l2 => l2
-  end.
-
-(* returns the sum of two canonical sums  *)
-Fixpoint canonical_sum_merge (s1:canonical_sum) :
- canonical_sum -> canonical_sum :=
-  match s1 with
-  | Cons_monom c1 l1 t1 =>
-      (fix csm_aux (s2:canonical_sum) : canonical_sum :=
-         match s2 with
-         | Cons_monom c2 l2 t2 =>
-             if varlist_eq l1 l2
-             then Cons_monom (Aplus c1 c2) l1 (canonical_sum_merge t1 t2)
-             else
-              if varlist_lt l1 l2
-              then Cons_monom c1 l1 (canonical_sum_merge t1 s2)
-              else Cons_monom c2 l2 (csm_aux t2)
-         | Cons_varlist l2 t2 =>
-             if varlist_eq l1 l2
-             then Cons_monom (Aplus c1 Aone) l1 (canonical_sum_merge t1 t2)
-             else
-              if varlist_lt l1 l2
-              then Cons_monom c1 l1 (canonical_sum_merge t1 s2)
-              else Cons_varlist l2 (csm_aux t2)
-         | Nil_monom => s1
-         end)
-  | Cons_varlist l1 t1 =>
-      (fix csm_aux2 (s2:canonical_sum) : canonical_sum :=
-         match s2 with
-         | Cons_monom c2 l2 t2 =>
-             if varlist_eq l1 l2
-             then Cons_monom (Aplus Aone c2) l1 (canonical_sum_merge t1 t2)
-             else
-              if varlist_lt l1 l2
-              then Cons_varlist l1 (canonical_sum_merge t1 s2)
-              else Cons_monom c2 l2 (csm_aux2 t2)
-         | Cons_varlist l2 t2 =>
-             if varlist_eq l1 l2
-             then Cons_monom (Aplus Aone Aone) l1 (canonical_sum_merge t1 t2)
-             else
-              if varlist_lt l1 l2
-              then Cons_varlist l1 (canonical_sum_merge t1 s2)
-              else Cons_varlist l2 (csm_aux2 t2)
-         | Nil_monom => s1
-         end)
-  | Nil_monom => fun s2 => s2
-  end.
-
-(* Insertion of a monom in a canonical sum *)
-Fixpoint monom_insert (c1:A) (l1:varlist) (s2:canonical_sum) {struct s2} :
- canonical_sum :=
-  match s2 with
-  | Cons_monom c2 l2 t2 =>
-      if varlist_eq l1 l2
-      then Cons_monom (Aplus c1 c2) l1 t2
-      else
-       if varlist_lt l1 l2
-       then Cons_monom c1 l1 s2
-       else Cons_monom c2 l2 (monom_insert c1 l1 t2)
-  | Cons_varlist l2 t2 =>
-      if varlist_eq l1 l2
-      then Cons_monom (Aplus c1 Aone) l1 t2
-      else
-       if varlist_lt l1 l2
-       then Cons_monom c1 l1 s2
-       else Cons_varlist l2 (monom_insert c1 l1 t2)
-  | Nil_monom => Cons_monom c1 l1 Nil_monom
-  end.
-
-Fixpoint varlist_insert (l1:varlist) (s2:canonical_sum) {struct s2} :
- canonical_sum :=
-  match s2 with
-  | Cons_monom c2 l2 t2 =>
-      if varlist_eq l1 l2
-      then Cons_monom (Aplus Aone c2) l1 t2
-      else
-       if varlist_lt l1 l2
-       then Cons_varlist l1 s2
-       else Cons_monom c2 l2 (varlist_insert l1 t2)
-  | Cons_varlist l2 t2 =>
-      if varlist_eq l1 l2
-      then Cons_monom (Aplus Aone Aone) l1 t2
-      else
-       if varlist_lt l1 l2
-       then Cons_varlist l1 s2
-       else Cons_varlist l2 (varlist_insert l1 t2)
-  | Nil_monom => Cons_varlist l1 Nil_monom
-  end.
-
-(* Computes c0*s *)
-Fixpoint canonical_sum_scalar (c0:A) (s:canonical_sum) {struct s} :
- canonical_sum :=
-  match s with
-  | Cons_monom c l t => Cons_monom (Amult c0 c) l (canonical_sum_scalar c0 t)
-  | Cons_varlist l t => Cons_monom c0 l (canonical_sum_scalar c0 t)
-  | Nil_monom => Nil_monom
-  end.
-
-(* Computes l0*s  *)
-Fixpoint canonical_sum_scalar2 (l0:varlist) (s:canonical_sum) {struct s} :
- canonical_sum :=
-  match s with
-  | Cons_monom c l t =>
-      monom_insert c (varlist_merge l0 l) (canonical_sum_scalar2 l0 t)
-  | Cons_varlist l t =>
-      varlist_insert (varlist_merge l0 l) (canonical_sum_scalar2 l0 t)
-  | Nil_monom => Nil_monom
-  end.
-
-(* Computes c0*l0*s  *)
-Fixpoint canonical_sum_scalar3 (c0:A) (l0:varlist)
- (s:canonical_sum) {struct s} : canonical_sum :=
-  match s with
-  | Cons_monom c l t =>
-      monom_insert (Amult c0 c) (varlist_merge l0 l)
-        (canonical_sum_scalar3 c0 l0 t)
-  | Cons_varlist l t =>
-      monom_insert c0 (varlist_merge l0 l) (canonical_sum_scalar3 c0 l0 t)
-  | Nil_monom => Nil_monom
-  end.
-
-(* returns the product of two canonical sums *)
-Fixpoint canonical_sum_prod (s1 s2:canonical_sum) {struct s1} :
- canonical_sum :=
-  match s1 with
-  | Cons_monom c1 l1 t1 =>
-      canonical_sum_merge (canonical_sum_scalar3 c1 l1 s2)
-        (canonical_sum_prod t1 s2)
-  | Cons_varlist l1 t1 =>
-      canonical_sum_merge (canonical_sum_scalar2 l1 s2)
-        (canonical_sum_prod t1 s2)
-  | Nil_monom => Nil_monom
-  end.
-
-(* The type to represent concrete semi-ring polynomials *)
-Inductive spolynomial : Type :=
-  | SPvar : index -> spolynomial
-  | SPconst : A -> spolynomial
-  | SPplus : spolynomial -> spolynomial -> spolynomial
-  | SPmult : spolynomial -> spolynomial -> spolynomial.
-
-Fixpoint spolynomial_normalize (p:spolynomial) : canonical_sum :=
-  match p with
-  | SPvar i => Cons_varlist (Cons_var i Nil_var) Nil_monom
-  | SPconst c => Cons_monom c Nil_var Nil_monom
-  | SPplus l r =>
-      canonical_sum_merge (spolynomial_normalize l) (spolynomial_normalize r)
-  | SPmult l r =>
-      canonical_sum_prod (spolynomial_normalize l) (spolynomial_normalize r)
-  end.
-
-(* Deletion of useless 0 and 1 in canonical sums *)
-Fixpoint canonical_sum_simplify (s:canonical_sum) : canonical_sum :=
-  match s with
-  | Cons_monom c l t =>
-      if Aeq c Azero
-      then canonical_sum_simplify t
-      else
-       if Aeq c Aone
-       then Cons_varlist l (canonical_sum_simplify t)
-       else Cons_monom c l (canonical_sum_simplify t)
-  | Cons_varlist l t => Cons_varlist l (canonical_sum_simplify t)
-  | Nil_monom => Nil_monom
-  end.
-
-Definition spolynomial_simplify (x:spolynomial) :=
-  canonical_sum_simplify (spolynomial_normalize x).
-
-(* End definitions. *)
-
-(* Section interpretation. *)
-
-(*** Here a variable map is defined and the interpetation of a spolynom
-  acording to a certain variables map. Once again the choosen definition
-  is generic and could be changed ****)
-
-Variable vm : varmap A.
-
-(* Interpretation of list of variables
- * [x1; ... ; xn ] is interpreted as (find v x1)* ... *(find v xn)
- * The unbound variables are mapped to 0. Normally this case sould
- * never occur. Since we want only to prove correctness theorems, which form
- * is : for any varmap and any spolynom ... this is a safe and pain-saving
- * choice *)
-Definition interp_var (i:index) := varmap_find Azero i vm.
-
-(* Local *) Definition ivl_aux :=
-              (fix ivl_aux (x:index) (t:varlist) {struct t} : A :=
-                 match t with
-                 | Nil_var => interp_var x
-                 | Cons_var x' t' => Amult (interp_var x) (ivl_aux x' t')
-                 end).
-
-Definition interp_vl (l:varlist) :=
-  match l with
-  | Nil_var => Aone
-  | Cons_var x t => ivl_aux x t
-  end.
-
-(* Local *) Definition interp_m (c:A) (l:varlist) :=
-              match l with
-              | Nil_var => c
-              | Cons_var x t => Amult c (ivl_aux x t)
-              end.
-
-(* Local *) Definition ics_aux :=
-              (fix ics_aux (a:A) (s:canonical_sum) {struct s} : A :=
-                 match s with
-                 | Nil_monom => a
-                 | Cons_varlist l t => Aplus a (ics_aux (interp_vl l) t)
-                 | Cons_monom c l t => Aplus a (ics_aux (interp_m c l) t)
-                 end).
-
-(* Interpretation of a canonical sum *)
-Definition interp_cs (s:canonical_sum) : A :=
-  match s with
-  | Nil_monom => Azero
-  | Cons_varlist l t => ics_aux (interp_vl l) t
-  | Cons_monom c l t => ics_aux (interp_m c l) t
-  end.
-
-Fixpoint interp_sp (p:spolynomial) : A :=
-  match p with
-  | SPconst c => c
-  | SPvar i => interp_var i
-  | SPplus p1 p2 => Aplus (interp_sp p1) (interp_sp p2)
-  | SPmult p1 p2 => Amult (interp_sp p1) (interp_sp p2)
-  end.
-
-
-(* End interpretation. *)
-
-Unset Implicit Arguments.
-
-(* Section properties. *)
-
-Variable T : Semi_Ring_Theory Aplus Amult Aone Azero Aeq.
-
-Hint Resolve (SR_plus_comm T).
-Hint Resolve (SR_plus_assoc T).
-Hint Resolve (SR_plus_assoc2 T).
-Hint Resolve (SR_mult_comm T).
-Hint Resolve (SR_mult_assoc T).
-Hint Resolve (SR_mult_assoc2 T).
-Hint Resolve (SR_plus_zero_left T).
-Hint Resolve (SR_plus_zero_left2 T).
-Hint Resolve (SR_mult_one_left T).
-Hint Resolve (SR_mult_one_left2 T).
-Hint Resolve (SR_mult_zero_left T).
-Hint Resolve (SR_mult_zero_left2 T).
-Hint Resolve (SR_distr_left T).
-Hint Resolve (SR_distr_left2 T).
-(*Hint Resolve (SR_plus_reg_left T).*)
-Hint Resolve (SR_plus_permute T).
-Hint Resolve (SR_mult_permute T).
-Hint Resolve (SR_distr_right T).
-Hint Resolve (SR_distr_right2 T).
-Hint Resolve (SR_mult_zero_right T).
-Hint Resolve (SR_mult_zero_right2 T).
-Hint Resolve (SR_plus_zero_right T).
-Hint Resolve (SR_plus_zero_right2 T).
-Hint Resolve (SR_mult_one_right T).
-Hint Resolve (SR_mult_one_right2 T).
-(*Hint Resolve (SR_plus_reg_right T).*)
-Hint Resolve eq_refl eq_sym eq_trans.
-Hint Immediate T.
-
-Lemma varlist_eq_prop : forall x y:varlist, Is_true (varlist_eq x y) -> x = y.
-Proof.
-  simple induction x; simple induction y; contradiction || (try reflexivity).
-  simpl; intros.
-  generalize (andb_prop2 _ _ H1); intros; elim H2; intros.
-  rewrite (index_eq_prop _ _ H3); rewrite (H v0 H4); reflexivity.
-Qed.
-
-Remark ivl_aux_ok :
- forall (v:varlist) (i:index),
-   ivl_aux i v = Amult (interp_var i) (interp_vl v).
-Proof.
-  simple induction v; simpl; intros.
-  trivial.
-  rewrite H; trivial.
-Qed.
-
-Lemma varlist_merge_ok :
- forall x y:varlist,
-   interp_vl (varlist_merge x y) = Amult (interp_vl x) (interp_vl y).
-Proof.
-  simple induction x.
-  simpl; trivial.
-  simple induction y.
-  simpl; trivial.
-  simpl; intros.
-  elim (index_lt i i0); simpl; intros.
-
-  repeat rewrite ivl_aux_ok.
-  rewrite H. simpl.
-  rewrite ivl_aux_ok.
-  eauto.
-
-  repeat rewrite ivl_aux_ok.
-  rewrite H0.
-  rewrite ivl_aux_ok.
-  eauto.
-Qed.
-
-Remark ics_aux_ok :
- forall (x:A) (s:canonical_sum), ics_aux x s = Aplus x (interp_cs s).
-Proof.
-  simple induction s; simpl; intros.
-  trivial.
-  reflexivity.
-  reflexivity.
-Qed.
-
-Remark interp_m_ok :
- forall (x:A) (l:varlist), interp_m x l = Amult x (interp_vl l).
-Proof.
-  destruct l as [| i v].
-  simpl; trivial.
-  reflexivity.
-Qed.
-
-Lemma canonical_sum_merge_ok :
- forall x y:canonical_sum,
-   interp_cs (canonical_sum_merge x y) = Aplus (interp_cs x) (interp_cs y).
-
-simple induction x; simpl.
-trivial.
-
-simple induction y; simpl; intros.
-(* monom and nil *)
-eauto.
-
-(* monom and monom *)
-generalize (varlist_eq_prop v v0).
-elim (varlist_eq v v0).
-intros; rewrite (H1 I).
-simpl; repeat rewrite ics_aux_ok; rewrite H.
-repeat rewrite interp_m_ok.
-rewrite (SR_distr_left T).
-repeat rewrite <- (SR_plus_assoc T).
-apply f_equal with (f := Aplus (Amult a (interp_vl v0))).
-trivial.
-
-elim (varlist_lt v v0); simpl.
-repeat rewrite ics_aux_ok.
-rewrite H; simpl; rewrite ics_aux_ok; eauto.
-
-rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl;
- eauto.
-
-(* monom and varlist *)
-generalize (varlist_eq_prop v v0).
-elim (varlist_eq v v0).
-intros; rewrite (H1 I).
-simpl; repeat rewrite ics_aux_ok; rewrite H.
-repeat rewrite interp_m_ok.
-rewrite (SR_distr_left T).
-repeat rewrite <- (SR_plus_assoc T).
-apply f_equal with (f := Aplus (Amult a (interp_vl v0))).
-rewrite (SR_mult_one_left T).
-trivial.
-
-elim (varlist_lt v v0); simpl.
-repeat rewrite ics_aux_ok.
-rewrite H; simpl; rewrite ics_aux_ok; eauto.
-rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl;
- eauto.
-
-simple induction y; simpl; intros.
-(* varlist and nil *)
-trivial.
-
-(* varlist and monom *)
-generalize (varlist_eq_prop v v0).
-elim (varlist_eq v v0).
-intros; rewrite (H1 I).
-simpl; repeat rewrite ics_aux_ok; rewrite H.
-repeat rewrite interp_m_ok.
-rewrite (SR_distr_left T).
-repeat rewrite <- (SR_plus_assoc T).
-rewrite (SR_mult_one_left T).
-apply f_equal with (f := Aplus (interp_vl v0)).
-trivial.
-
-elim (varlist_lt v v0); simpl.
-repeat rewrite ics_aux_ok.
-rewrite H; simpl; rewrite ics_aux_ok; eauto.
-rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl;
- eauto.
-
-(* varlist and varlist *)
-generalize (varlist_eq_prop v v0).
-elim (varlist_eq v v0).
-intros; rewrite (H1 I).
-simpl; repeat rewrite ics_aux_ok; rewrite H.
-repeat rewrite interp_m_ok.
-rewrite (SR_distr_left T).
-repeat rewrite <- (SR_plus_assoc T).
-rewrite (SR_mult_one_left T).
-apply f_equal with (f := Aplus (interp_vl v0)).
-trivial.
-
-elim (varlist_lt v v0); simpl.
-repeat rewrite ics_aux_ok.
-rewrite H; simpl; rewrite ics_aux_ok; eauto.
-rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl;
- eauto.
-Qed.
-
-Lemma monom_insert_ok :
- forall (a:A) (l:varlist) (s:canonical_sum),
-   interp_cs (monom_insert a l s) =
-   Aplus (Amult a (interp_vl l)) (interp_cs s).
-intros; generalize s; simple induction s0.
-
-simpl; rewrite interp_m_ok; trivial.
-
-simpl; intros.
-generalize (varlist_eq_prop l v); elim (varlist_eq l v).
-intro Hr; rewrite (Hr I); simpl; rewrite interp_m_ok;
- repeat rewrite ics_aux_ok; rewrite interp_m_ok; rewrite (SR_distr_left T);
- eauto.
-elim (varlist_lt l v); simpl;
- [ repeat rewrite interp_m_ok; rewrite ics_aux_ok; eauto
- | repeat rewrite interp_m_ok; rewrite ics_aux_ok; rewrite H;
-    rewrite ics_aux_ok; eauto ].
-
-simpl; intros.
-generalize (varlist_eq_prop l v); elim (varlist_eq l v).
-intro Hr; rewrite (Hr I); simpl; rewrite interp_m_ok;
- repeat rewrite ics_aux_ok; rewrite (SR_distr_left T);
- rewrite (SR_mult_one_left T); eauto.
-elim (varlist_lt l v); simpl;
- [ repeat rewrite interp_m_ok; rewrite ics_aux_ok; eauto
- | repeat rewrite interp_m_ok; rewrite ics_aux_ok; rewrite H;
-    rewrite ics_aux_ok; eauto ].
-Qed.
-
-Lemma varlist_insert_ok :
- forall (l:varlist) (s:canonical_sum),
-   interp_cs (varlist_insert l s) = Aplus (interp_vl l) (interp_cs s).
-intros; generalize s; simple induction s0.
-
-simpl; trivial.
-
-simpl; intros.
-generalize (varlist_eq_prop l v); elim (varlist_eq l v).
-intro Hr; rewrite (Hr I); simpl; rewrite interp_m_ok;
- repeat rewrite ics_aux_ok; rewrite interp_m_ok; rewrite (SR_distr_left T);
- rewrite (SR_mult_one_left T); eauto.
-elim (varlist_lt l v); simpl;
- [ repeat rewrite interp_m_ok; rewrite ics_aux_ok; eauto
- | repeat rewrite interp_m_ok; rewrite ics_aux_ok; rewrite H;
-    rewrite ics_aux_ok; eauto ].
-
-simpl; intros.
-generalize (varlist_eq_prop l v); elim (varlist_eq l v).
-intro Hr; rewrite (Hr I); simpl; rewrite interp_m_ok;
- repeat rewrite ics_aux_ok; rewrite (SR_distr_left T);
- rewrite (SR_mult_one_left T); eauto.
-elim (varlist_lt l v); simpl;
- [ repeat rewrite interp_m_ok; rewrite ics_aux_ok; eauto
- | repeat rewrite interp_m_ok; rewrite ics_aux_ok; rewrite H;
-    rewrite ics_aux_ok; eauto ].
-Qed.
-
-Lemma canonical_sum_scalar_ok :
- forall (a:A) (s:canonical_sum),
-   interp_cs (canonical_sum_scalar a s) = Amult a (interp_cs s).
-simple induction s.
-simpl; eauto.
-
-simpl; intros.
-repeat rewrite ics_aux_ok.
-repeat rewrite interp_m_ok.
-rewrite H.
-rewrite (SR_distr_right T).
-repeat rewrite <- (SR_mult_assoc T).
-reflexivity.
-
-simpl; intros.
-repeat rewrite ics_aux_ok.
-repeat rewrite interp_m_ok.
-rewrite H.
-rewrite (SR_distr_right T).
-repeat rewrite <- (SR_mult_assoc T).
-reflexivity.
-Qed.
-
-Lemma canonical_sum_scalar2_ok :
- forall (l:varlist) (s:canonical_sum),
-   interp_cs (canonical_sum_scalar2 l s) = Amult (interp_vl l) (interp_cs s).
-simple induction s.
-simpl; trivial.
-
-simpl; intros.
-rewrite monom_insert_ok.
-repeat rewrite ics_aux_ok.
-repeat rewrite interp_m_ok.
-rewrite H.
-rewrite varlist_merge_ok.
-repeat rewrite (SR_distr_right T).
-repeat rewrite <- (SR_mult_assoc T).
-repeat rewrite <- (SR_plus_assoc T).
-rewrite (SR_mult_permute T a (interp_vl l) (interp_vl v)).
-reflexivity.
-
-simpl; intros.
-rewrite varlist_insert_ok.
-repeat rewrite ics_aux_ok.
-repeat rewrite interp_m_ok.
-rewrite H.
-rewrite varlist_merge_ok.
-repeat rewrite (SR_distr_right T).
-repeat rewrite <- (SR_mult_assoc T).
-repeat rewrite <- (SR_plus_assoc T).
-reflexivity.
-Qed.
-
-Lemma canonical_sum_scalar3_ok :
- forall (c:A) (l:varlist) (s:canonical_sum),
-   interp_cs (canonical_sum_scalar3 c l s) =
-   Amult c (Amult (interp_vl l) (interp_cs s)).
-simple induction s.
-simpl; repeat rewrite (SR_mult_zero_right T); reflexivity.
-
-simpl; intros.
-rewrite monom_insert_ok.
-repeat rewrite ics_aux_ok.
-repeat rewrite interp_m_ok.
-rewrite H.
-rewrite varlist_merge_ok.
-repeat rewrite (SR_distr_right T).
-repeat rewrite <- (SR_mult_assoc T).
-repeat rewrite <- (SR_plus_assoc T).
-rewrite (SR_mult_permute T a (interp_vl l) (interp_vl v)).
-reflexivity.
-
-simpl; intros.
-rewrite monom_insert_ok.
-repeat rewrite ics_aux_ok.
-repeat rewrite interp_m_ok.
-rewrite H.
-rewrite varlist_merge_ok.
-repeat rewrite (SR_distr_right T).
-repeat rewrite <- (SR_mult_assoc T).
-repeat rewrite <- (SR_plus_assoc T).
-rewrite (SR_mult_permute T c (interp_vl l) (interp_vl v)).
-reflexivity.
-Qed.
-
-Lemma canonical_sum_prod_ok :
- forall x y:canonical_sum,
-   interp_cs (canonical_sum_prod x y) = Amult (interp_cs x) (interp_cs y).
-simple induction x; simpl; intros.
-trivial.
-
-rewrite canonical_sum_merge_ok.
-rewrite canonical_sum_scalar3_ok.
-rewrite ics_aux_ok.
-rewrite interp_m_ok.
-rewrite H.
-rewrite (SR_mult_assoc T a (interp_vl v) (interp_cs y)).
-symmetry .
-eauto.
-
-rewrite canonical_sum_merge_ok.
-rewrite canonical_sum_scalar2_ok.
-rewrite ics_aux_ok.
-rewrite H.
-trivial.
-Qed.
-
-Theorem spolynomial_normalize_ok :
- forall p:spolynomial, interp_cs (spolynomial_normalize p) = interp_sp p.
-simple induction p; simpl; intros.
-
-reflexivity.
-reflexivity.
-
-rewrite canonical_sum_merge_ok.
-rewrite H; rewrite H0.
-reflexivity.
-
-rewrite canonical_sum_prod_ok.
-rewrite H; rewrite H0.
-reflexivity.
-Qed.
-
-Lemma canonical_sum_simplify_ok :
- forall s:canonical_sum, interp_cs (canonical_sum_simplify s) = interp_cs s.
-simple induction s.
-
-reflexivity.
-
-(* cons_monom *)
-simpl; intros.
-generalize (SR_eq_prop T a Azero).
-elim (Aeq a Azero).
-intro Heq; rewrite (Heq I).
-rewrite H.
-rewrite ics_aux_ok.
-rewrite interp_m_ok.
-rewrite (SR_mult_zero_left T).
-trivial.
-
-intros; simpl.
-generalize (SR_eq_prop T a Aone).
-elim (Aeq a Aone).
-intro Heq; rewrite (Heq I).
-simpl.
-repeat rewrite ics_aux_ok.
-rewrite interp_m_ok.
-rewrite H.
-rewrite (SR_mult_one_left T).
-reflexivity.
-
-simpl.
-repeat rewrite ics_aux_ok.
-rewrite interp_m_ok.
-rewrite H.
-reflexivity.
-
-(* cons_varlist *)
-simpl; intros.
-repeat rewrite ics_aux_ok.
-rewrite H.
-reflexivity.
-
-Qed.
-
-Theorem spolynomial_simplify_ok :
- forall p:spolynomial, interp_cs (spolynomial_simplify p) = interp_sp p.
-intro.
-unfold spolynomial_simplify.
-rewrite canonical_sum_simplify_ok.
-apply spolynomial_normalize_ok.
-Qed.
-
-(* End properties. *)
-End semi_rings.
-
-Arguments Cons_varlist : default implicits.
-Arguments Cons_monom : default implicits.
-Arguments SPconst : default implicits.
-Arguments SPplus : default implicits.
-Arguments SPmult : default implicits.
-
-Section rings.
-
-(* Here the coercion between Ring and Semi-Ring will be useful *)
-
-Set Implicit Arguments.
-
-Variable A : Type.
-Variable Aplus : A -> A -> A.
-Variable Amult : A -> A -> A.
-Variable Aone : A.
-Variable Azero : A.
-Variable Aopp : A -> A.
-Variable Aeq : A -> A -> bool.
-Variable vm : varmap A.
-Variable T : Ring_Theory Aplus Amult Aone Azero Aopp Aeq.
-
-Hint Resolve (Th_plus_comm T).
-Hint Resolve (Th_plus_assoc T).
-Hint Resolve (Th_plus_assoc2 T).
-Hint Resolve (Th_mult_comm T).
-Hint Resolve (Th_mult_assoc T).
-Hint Resolve (Th_mult_assoc2 T).
-Hint Resolve (Th_plus_zero_left T).
-Hint Resolve (Th_plus_zero_left2 T).
-Hint Resolve (Th_mult_one_left T).
-Hint Resolve (Th_mult_one_left2 T).
-Hint Resolve (Th_mult_zero_left T).
-Hint Resolve (Th_mult_zero_left2 T).
-Hint Resolve (Th_distr_left T).
-Hint Resolve (Th_distr_left2 T).
-(*Hint Resolve (Th_plus_reg_left T).*)
-Hint Resolve (Th_plus_permute T).
-Hint Resolve (Th_mult_permute T).
-Hint Resolve (Th_distr_right T).
-Hint Resolve (Th_distr_right2 T).
-Hint Resolve (Th_mult_zero_right T).
-Hint Resolve (Th_mult_zero_right2 T).
-Hint Resolve (Th_plus_zero_right T).
-Hint Resolve (Th_plus_zero_right2 T).
-Hint Resolve (Th_mult_one_right T).
-Hint Resolve (Th_mult_one_right2 T).
-(*Hint Resolve (Th_plus_reg_right T).*)
-Hint Resolve eq_refl eq_sym eq_trans.
-Hint Immediate T.
-
-(*** Definitions *)
-
-Inductive polynomial : Type :=
-  | Pvar : index -> polynomial
-  | Pconst : A -> polynomial
-  | Pplus : polynomial -> polynomial -> polynomial
-  | Pmult : polynomial -> polynomial -> polynomial
-  | Popp : polynomial -> polynomial.
-
-Fixpoint polynomial_normalize (x:polynomial) : canonical_sum A :=
-  match x with
-  | Pplus l r =>
-      canonical_sum_merge Aplus Aone (polynomial_normalize l)
-        (polynomial_normalize r)
-  | Pmult l r =>
-      canonical_sum_prod Aplus Amult Aone (polynomial_normalize l)
-        (polynomial_normalize r)
-  | Pconst c => Cons_monom c Nil_var (Nil_monom A)
-  | Pvar i => Cons_varlist (Cons_var i Nil_var) (Nil_monom A)
-  | Popp p =>
-      canonical_sum_scalar3 Aplus Amult Aone (Aopp Aone) Nil_var
-        (polynomial_normalize p)
-  end.
-
-Definition polynomial_simplify (x:polynomial) :=
-  canonical_sum_simplify Aone Azero Aeq (polynomial_normalize x).
-
-Fixpoint spolynomial_of (x:polynomial) : spolynomial A :=
-  match x with
-  | Pplus l r => SPplus (spolynomial_of l) (spolynomial_of r)
-  | Pmult l r => SPmult (spolynomial_of l) (spolynomial_of r)
-  | Pconst c => SPconst c
-  | Pvar i => SPvar A i
-  | Popp p => SPmult (SPconst (Aopp Aone)) (spolynomial_of p)
-  end.
-
-(*** Interpretation *)
-
-Fixpoint interp_p (p:polynomial) : A :=
-  match p with
-  | Pconst c => c
-  | Pvar i => varmap_find Azero i vm
-  | Pplus p1 p2 => Aplus (interp_p p1) (interp_p p2)
-  | Pmult p1 p2 => Amult (interp_p p1) (interp_p p2)
-  | Popp p1 => Aopp (interp_p p1)
-  end.
-
-(*** Properties *)
-
-Unset Implicit Arguments.
-
-Lemma spolynomial_of_ok :
- forall p:polynomial,
-   interp_p p = interp_sp Aplus Amult Azero vm (spolynomial_of p).
-simple induction p; reflexivity || (simpl; intros).
-rewrite H; rewrite H0; reflexivity.
-rewrite H; rewrite H0; reflexivity.
-rewrite H.
-rewrite (Th_opp_mult_left2 T).
-rewrite (Th_mult_one_left T).
-reflexivity.
-Qed.
-
-Theorem polynomial_normalize_ok :
- forall p:polynomial,
-   polynomial_normalize p =
-   spolynomial_normalize Aplus Amult Aone (spolynomial_of p).
-simple induction p; reflexivity || (simpl; intros).
-rewrite H; rewrite H0; reflexivity.
-rewrite H; rewrite H0; reflexivity.
-rewrite H; simpl.
-elim
- (canonical_sum_scalar3 Aplus Amult Aone (Aopp Aone) Nil_var
-    (spolynomial_normalize Aplus Amult Aone (spolynomial_of p0)));
- [ reflexivity
- | simpl; intros; rewrite H0; reflexivity
- | simpl; intros; rewrite H0; reflexivity ].
-Qed.
-
-Theorem polynomial_simplify_ok :
- forall p:polynomial,
-   interp_cs Aplus Amult Aone Azero vm (polynomial_simplify p) = interp_p p.
-intro.
-unfold polynomial_simplify.
-rewrite spolynomial_of_ok.
-rewrite polynomial_normalize_ok.
-rewrite (canonical_sum_simplify_ok A Aplus Amult Aone Azero Aeq vm T).
-rewrite (spolynomial_normalize_ok A Aplus Amult Aone Azero Aeq vm T).
-reflexivity.
-Qed.
-
-End rings.
-
-Infix "+" := Pplus : ring_scope.
-Infix "*" := Pmult : ring_scope.
-Notation "- x" := (Popp x) : ring_scope.
-Notation "[ x ]" := (Pvar x) (at level 0) : ring_scope.
-
-Delimit Scope ring_scope with ring.
diff --git a/plugins/ring/Setoid_ring_normalize.v b/plugins/ring/Setoid_ring_normalize.v
deleted file mode 100644
index e71be89a..00000000
--- a/plugins/ring/Setoid_ring_normalize.v
+++ /dev/null
@@ -1,1160 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-Require Import Setoid_ring_theory.
-Require Import Quote.
-
-Set Implicit Arguments.
-
-Lemma index_eq_prop : forall n m:index, Is_true (index_eq n m) -> n = m.
-Proof.
-  simple induction n; simple induction m; simpl;
-   try reflexivity || contradiction.
-  intros; rewrite (H i0); trivial.
-  intros; rewrite (H i0); trivial.
-Qed.
-
-Section setoid.
-
-Variable A : Type.
-Variable Aequiv : A -> A -> Prop.
-Variable Aplus : A -> A -> A.
-Variable Amult : A -> A -> A.
-Variable Aone : A.
-Variable Azero : A.
-Variable Aopp : A -> A.
-Variable Aeq : A -> A -> bool.
-
-Variable S : Setoid_Theory A Aequiv.
-
-Add Setoid A Aequiv S as Asetoid.
-
-Variable plus_morph :
- forall a a0:A, Aequiv a a0 ->
-   forall a1 a2:A, Aequiv a1 a2 ->
-     Aequiv (Aplus a a1)  (Aplus a0 a2).
-Variable mult_morph :
- forall a a0:A, Aequiv a a0 ->
-   forall a1 a2:A, Aequiv a1 a2 ->
-     Aequiv (Amult a a1) (Amult a0 a2).
-Variable opp_morph : forall a a0:A, Aequiv a a0 -> Aequiv (Aopp a) (Aopp a0).
-
-Add Morphism Aplus : Aplus_ext.
-intros; apply plus_morph; assumption.
-Qed.
-
-Add Morphism Amult : Amult_ext.
-intros; apply mult_morph; assumption.
-Qed.
-
-Add Morphism Aopp : Aopp_ext.
-exact opp_morph.
-Qed.
-
-Let equiv_refl := Seq_refl A Aequiv S.
-Let equiv_sym := Seq_sym A Aequiv S.
-Let equiv_trans := Seq_trans A Aequiv S.
-
-Hint Resolve equiv_refl equiv_trans.
-Hint Immediate equiv_sym.
-
-Section semi_setoid_rings.
-
-(* Section definitions. *)
-
-
-(******************************************)
-(* Normal abtract Polynomials             *)
-(******************************************)
-(* DEFINITIONS :
-- A varlist is a sorted product of one or more variables : x, x*y*z
-- A monom is a constant, a varlist or the product of a constant by a varlist
-  variables. 2*x*y, x*y*z, 3 are monoms : 2*3, x*3*y, 4*x*3 are NOT.
-- A canonical sum is either a monom or an ordered sum of monoms
-  (the order on monoms is defined later)
-- A normal polynomial it either a constant or a canonical sum or a constant
-  plus a canonical sum
-*)
-
-(* varlist is isomorphic to (list var), but we built a special inductive
-   for efficiency *)
-Inductive varlist : Type :=
-  | Nil_var : varlist
-  | Cons_var : index -> varlist -> varlist.
-
-Inductive canonical_sum : Type :=
-  | Nil_monom : canonical_sum
-  | Cons_monom : A -> varlist -> canonical_sum -> canonical_sum
-  | Cons_varlist : varlist -> canonical_sum -> canonical_sum.
-
-(* Order on monoms *)
-
-(* That's the lexicographic order on varlist, extended by :
-  - A constant is less than every monom
-  - The relation between two varlist is preserved by multiplication by a
-  constant.
-
-  Examples :
-  3 < x < y
-  x*y < x*y*y*z
-  2*x*y < x*y*y*z
-  x*y < 54*x*y*y*z
-  4*x*y < 59*x*y*y*z
-*)
-
-Fixpoint varlist_eq (x y:varlist) {struct y} : bool :=
-  match x, y with
-  | Nil_var, Nil_var => true
-  | Cons_var i xrest, Cons_var j yrest =>
-      andb (index_eq i j) (varlist_eq xrest yrest)
-  | _, _ => false
-  end.
-
-Fixpoint varlist_lt (x y:varlist) {struct y} : bool :=
-  match x, y with
-  | Nil_var, Cons_var _ _ => true
-  | Cons_var i xrest, Cons_var j yrest =>
-      if index_lt i j
-      then true
-      else andb (index_eq i j) (varlist_lt xrest yrest)
-  | _, _ => false
-  end.
-
-(* merges two variables lists *)
-Fixpoint varlist_merge (l1:varlist) : varlist -> varlist :=
-  match l1 with
-  | Cons_var v1 t1 =>
-      (fix vm_aux (l2:varlist) : varlist :=
-         match l2 with
-         | Cons_var v2 t2 =>
-             if index_lt v1 v2
-             then Cons_var v1 (varlist_merge t1 l2)
-             else Cons_var v2 (vm_aux t2)
-         | Nil_var => l1
-         end)
-  | Nil_var => fun l2 => l2
-  end.
-
-(* returns the sum of two canonical sums  *)
-Fixpoint canonical_sum_merge (s1:canonical_sum) :
- canonical_sum -> canonical_sum :=
-  match s1 with
-  | Cons_monom c1 l1 t1 =>
-      (fix csm_aux (s2:canonical_sum) : canonical_sum :=
-         match s2 with
-         | Cons_monom c2 l2 t2 =>
-             if varlist_eq l1 l2
-             then Cons_monom (Aplus c1 c2) l1 (canonical_sum_merge t1 t2)
-             else
-              if varlist_lt l1 l2
-              then Cons_monom c1 l1 (canonical_sum_merge t1 s2)
-              else Cons_monom c2 l2 (csm_aux t2)
-         | Cons_varlist l2 t2 =>
-             if varlist_eq l1 l2
-             then Cons_monom (Aplus c1 Aone) l1 (canonical_sum_merge t1 t2)
-             else
-              if varlist_lt l1 l2
-              then Cons_monom c1 l1 (canonical_sum_merge t1 s2)
-              else Cons_varlist l2 (csm_aux t2)
-         | Nil_monom => s1
-         end)
-  | Cons_varlist l1 t1 =>
-      (fix csm_aux2 (s2:canonical_sum) : canonical_sum :=
-         match s2 with
-         | Cons_monom c2 l2 t2 =>
-             if varlist_eq l1 l2
-             then Cons_monom (Aplus Aone c2) l1 (canonical_sum_merge t1 t2)
-             else
-              if varlist_lt l1 l2
-              then Cons_varlist l1 (canonical_sum_merge t1 s2)
-              else Cons_monom c2 l2 (csm_aux2 t2)
-         | Cons_varlist l2 t2 =>
-             if varlist_eq l1 l2
-             then Cons_monom (Aplus Aone Aone) l1 (canonical_sum_merge t1 t2)
-             else
-              if varlist_lt l1 l2
-              then Cons_varlist l1 (canonical_sum_merge t1 s2)
-              else Cons_varlist l2 (csm_aux2 t2)
-         | Nil_monom => s1
-         end)
-  | Nil_monom => fun s2 => s2
-  end.
-
-(* Insertion of a monom in a canonical sum *)
-Fixpoint monom_insert (c1:A) (l1:varlist) (s2:canonical_sum) {struct s2} :
- canonical_sum :=
-  match s2 with
-  | Cons_monom c2 l2 t2 =>
-      if varlist_eq l1 l2
-      then Cons_monom (Aplus c1 c2) l1 t2
-      else
-       if varlist_lt l1 l2
-       then Cons_monom c1 l1 s2
-       else Cons_monom c2 l2 (monom_insert c1 l1 t2)
-  | Cons_varlist l2 t2 =>
-      if varlist_eq l1 l2
-      then Cons_monom (Aplus c1 Aone) l1 t2
-      else
-       if varlist_lt l1 l2
-       then Cons_monom c1 l1 s2
-       else Cons_varlist l2 (monom_insert c1 l1 t2)
-  | Nil_monom => Cons_monom c1 l1 Nil_monom
-  end.
-
-Fixpoint varlist_insert (l1:varlist) (s2:canonical_sum) {struct s2} :
- canonical_sum :=
-  match s2 with
-  | Cons_monom c2 l2 t2 =>
-      if varlist_eq l1 l2
-      then Cons_monom (Aplus Aone c2) l1 t2
-      else
-       if varlist_lt l1 l2
-       then Cons_varlist l1 s2
-       else Cons_monom c2 l2 (varlist_insert l1 t2)
-  | Cons_varlist l2 t2 =>
-      if varlist_eq l1 l2
-      then Cons_monom (Aplus Aone Aone) l1 t2
-      else
-       if varlist_lt l1 l2
-       then Cons_varlist l1 s2
-       else Cons_varlist l2 (varlist_insert l1 t2)
-  | Nil_monom => Cons_varlist l1 Nil_monom
-  end.
-
-(* Computes c0*s *)
-Fixpoint canonical_sum_scalar (c0:A) (s:canonical_sum) {struct s} :
- canonical_sum :=
-  match s with
-  | Cons_monom c l t => Cons_monom (Amult c0 c) l (canonical_sum_scalar c0 t)
-  | Cons_varlist l t => Cons_monom c0 l (canonical_sum_scalar c0 t)
-  | Nil_monom => Nil_monom
-  end.
-
-(* Computes l0*s  *)
-Fixpoint canonical_sum_scalar2 (l0:varlist) (s:canonical_sum) {struct s} :
- canonical_sum :=
-  match s with
-  | Cons_monom c l t =>
-      monom_insert c (varlist_merge l0 l) (canonical_sum_scalar2 l0 t)
-  | Cons_varlist l t =>
-      varlist_insert (varlist_merge l0 l) (canonical_sum_scalar2 l0 t)
-  | Nil_monom => Nil_monom
-  end.
-
-(* Computes c0*l0*s  *)
-Fixpoint canonical_sum_scalar3 (c0:A) (l0:varlist)
- (s:canonical_sum) {struct s} : canonical_sum :=
-  match s with
-  | Cons_monom c l t =>
-      monom_insert (Amult c0 c) (varlist_merge l0 l)
-        (canonical_sum_scalar3 c0 l0 t)
-  | Cons_varlist l t =>
-      monom_insert c0 (varlist_merge l0 l) (canonical_sum_scalar3 c0 l0 t)
-  | Nil_monom => Nil_monom
-  end.
-
-(* returns the product of two canonical sums *)
-Fixpoint canonical_sum_prod (s1 s2:canonical_sum) {struct s1} :
- canonical_sum :=
-  match s1 with
-  | Cons_monom c1 l1 t1 =>
-      canonical_sum_merge (canonical_sum_scalar3 c1 l1 s2)
-        (canonical_sum_prod t1 s2)
-  | Cons_varlist l1 t1 =>
-      canonical_sum_merge (canonical_sum_scalar2 l1 s2)
-        (canonical_sum_prod t1 s2)
-  | Nil_monom => Nil_monom
-  end.
-
-(* The type to represent concrete semi-setoid-ring polynomials *)
-
-Inductive setspolynomial : Type :=
-  | SetSPvar : index -> setspolynomial
-  | SetSPconst : A -> setspolynomial
-  | SetSPplus : setspolynomial -> setspolynomial -> setspolynomial
-  | SetSPmult : setspolynomial -> setspolynomial -> setspolynomial.
-
-Fixpoint setspolynomial_normalize (p:setspolynomial) : canonical_sum :=
-  match p with
-  | SetSPplus l r =>
-      canonical_sum_merge (setspolynomial_normalize l)
-        (setspolynomial_normalize r)
-  | SetSPmult l r =>
-      canonical_sum_prod (setspolynomial_normalize l)
-        (setspolynomial_normalize r)
-  | SetSPconst c => Cons_monom c Nil_var Nil_monom
-  | SetSPvar i => Cons_varlist (Cons_var i Nil_var) Nil_monom
-  end.
-
-Fixpoint canonical_sum_simplify (s:canonical_sum) : canonical_sum :=
-  match s with
-  | Cons_monom c l t =>
-      if Aeq c Azero
-      then canonical_sum_simplify t
-      else
-       if Aeq c Aone
-       then Cons_varlist l (canonical_sum_simplify t)
-       else Cons_monom c l (canonical_sum_simplify t)
-  | Cons_varlist l t => Cons_varlist l (canonical_sum_simplify t)
-  | Nil_monom => Nil_monom
-  end.
-
-Definition setspolynomial_simplify (x:setspolynomial) :=
-  canonical_sum_simplify (setspolynomial_normalize x).
-
-Variable vm : varmap A.
-
-Definition interp_var (i:index) := varmap_find Azero i vm.
-
-Definition ivl_aux :=
-  (fix ivl_aux (x:index) (t:varlist) {struct t} : A :=
-     match t with
-     | Nil_var => interp_var x
-     | Cons_var x' t' => Amult (interp_var x) (ivl_aux x' t')
-     end).
-
-Definition interp_vl (l:varlist) :=
-  match l with
-  | Nil_var => Aone
-  | Cons_var x t => ivl_aux x t
-  end.
-
-Definition interp_m (c:A) (l:varlist) :=
-  match l with
-  | Nil_var => c
-  | Cons_var x t => Amult c (ivl_aux x t)
-  end.
-
-Definition ics_aux :=
-  (fix ics_aux (a:A) (s:canonical_sum) {struct s} : A :=
-     match s with
-     | Nil_monom => a
-     | Cons_varlist l t => Aplus a (ics_aux (interp_vl l) t)
-     | Cons_monom c l t => Aplus a (ics_aux (interp_m c l) t)
-     end).
-
-Definition interp_setcs (s:canonical_sum) : A :=
-  match s with
-  | Nil_monom => Azero
-  | Cons_varlist l t => ics_aux (interp_vl l) t
-  | Cons_monom c l t => ics_aux (interp_m c l) t
-  end.
-
-Fixpoint interp_setsp (p:setspolynomial) : A :=
-  match p with
-  | SetSPconst c => c
-  | SetSPvar i => interp_var i
-  | SetSPplus p1 p2 => Aplus (interp_setsp p1) (interp_setsp p2)
-  | SetSPmult p1 p2 => Amult (interp_setsp p1) (interp_setsp p2)
-  end.
-
-(* End interpretation. *)
-
-Unset Implicit Arguments.
-
-(* Section properties. *)
-
-Variable T : Semi_Setoid_Ring_Theory Aequiv Aplus Amult Aone Azero Aeq.
-
-Hint Resolve (SSR_plus_comm T).
-Hint Resolve (SSR_plus_assoc T).
-Hint Resolve (SSR_plus_assoc2 S T).
-Hint Resolve (SSR_mult_comm T).
-Hint Resolve (SSR_mult_assoc T).
-Hint Resolve (SSR_mult_assoc2 S T).
-Hint Resolve (SSR_plus_zero_left T).
-Hint Resolve (SSR_plus_zero_left2 S T).
-Hint Resolve (SSR_mult_one_left T).
-Hint Resolve (SSR_mult_one_left2 S T).
-Hint Resolve (SSR_mult_zero_left T).
-Hint Resolve (SSR_mult_zero_left2 S T).
-Hint Resolve (SSR_distr_left T).
-Hint Resolve (SSR_distr_left2 S T).
-Hint Resolve (SSR_plus_reg_left T).
-Hint Resolve (SSR_plus_permute S plus_morph T).
-Hint Resolve (SSR_mult_permute S mult_morph T).
-Hint Resolve (SSR_distr_right S plus_morph T).
-Hint Resolve (SSR_distr_right2 S plus_morph T).
-Hint Resolve (SSR_mult_zero_right S T).
-Hint Resolve (SSR_mult_zero_right2 S T).
-Hint Resolve (SSR_plus_zero_right S T).
-Hint Resolve (SSR_plus_zero_right2 S T).
-Hint Resolve (SSR_mult_one_right S T).
-Hint Resolve (SSR_mult_one_right2 S T).
-Hint Resolve (SSR_plus_reg_right S T).
-Hint Resolve eq_refl eq_sym eq_trans.
-Hint Immediate T.
-
-Lemma varlist_eq_prop : forall x y:varlist, Is_true (varlist_eq x y) -> x = y.
-Proof.
-  simple induction x; simple induction y; contradiction || (try reflexivity).
-  simpl; intros.
-  generalize (andb_prop2 _ _ H1); intros; elim H2; intros.
-  rewrite (index_eq_prop _ _ H3); rewrite (H v0 H4); reflexivity.
-Qed.
-
-Remark ivl_aux_ok :
- forall (v:varlist) (i:index),
-   Aequiv (ivl_aux i v) (Amult (interp_var i) (interp_vl v)).
-Proof.
-  simple induction v; simpl; intros.
-  trivial.
-  rewrite (H i); trivial.
-Qed.
-
-Lemma varlist_merge_ok :
- forall x y:varlist,
-   Aequiv (interp_vl (varlist_merge x y)) (Amult (interp_vl x) (interp_vl y)).
-Proof.
-  simple induction x.
-  simpl; trivial.
-  simple induction y.
-  simpl; trivial.
-  simpl; intros.
-  elim (index_lt i i0); simpl; intros.
-
-  rewrite (ivl_aux_ok v i).
-  rewrite (ivl_aux_ok v0 i0).
-  rewrite (ivl_aux_ok (varlist_merge v (Cons_var i0 v0)) i).
-  rewrite (H (Cons_var i0 v0)).
-  simpl.
-  rewrite (ivl_aux_ok v0 i0).
-  eauto.
-
-  rewrite (ivl_aux_ok v i).
-  rewrite (ivl_aux_ok v0 i0).
-  rewrite
-   (ivl_aux_ok
-      ((fix vm_aux (l2:varlist) : varlist :=
-          match l2 with
-          | Nil_var => Cons_var i v
-          | Cons_var v2 t2 =>
-              if index_lt i v2
-              then Cons_var i (varlist_merge v l2)
-              else Cons_var v2 (vm_aux t2)
-          end) v0) i0).
-  rewrite H0.
-  rewrite (ivl_aux_ok v i).
-  eauto.
-Qed.
-
-Remark ics_aux_ok :
- forall (x:A) (s:canonical_sum),
-   Aequiv (ics_aux x s) (Aplus x (interp_setcs s)).
-Proof.
- simple induction s; simpl; intros; trivial.
-Qed.
-
-Remark interp_m_ok :
- forall (x:A) (l:varlist), Aequiv (interp_m x l) (Amult x (interp_vl l)).
-Proof.
-  destruct l as [| i v]; trivial.
-Qed.
-
-Hint Resolve ivl_aux_ok.
-Hint Resolve ics_aux_ok.
-Hint Resolve interp_m_ok.
-
-(* Hints Resolve ivl_aux_ok ics_aux_ok interp_m_ok. *)
-
-Lemma canonical_sum_merge_ok :
- forall x y:canonical_sum,
-   Aequiv (interp_setcs (canonical_sum_merge x y))
-     (Aplus (interp_setcs x) (interp_setcs y)).
-Proof.
-simple induction x; simpl.
-trivial.
-
-simple induction y; simpl; intros.
-eauto.
-
-generalize (varlist_eq_prop v v0).
-elim (varlist_eq v v0).
-intros; rewrite (H1 I).
-simpl.
-rewrite (ics_aux_ok (interp_m a v0) c).
-rewrite (ics_aux_ok (interp_m a0 v0) c0).
-rewrite (ics_aux_ok (interp_m (Aplus a a0) v0) (canonical_sum_merge c c0)).
-rewrite (H c0).
-rewrite (interp_m_ok (Aplus a a0) v0).
-rewrite (interp_m_ok a v0).
-rewrite (interp_m_ok a0 v0).
-setoid_replace (Amult (Aplus a a0) (interp_vl v0)) with
- (Aplus (Amult a (interp_vl v0)) (Amult a0 (interp_vl v0)));
- [ idtac | trivial ].
-setoid_replace
- (Aplus (Aplus (Amult a (interp_vl v0)) (Amult a0 (interp_vl v0)))
-    (Aplus (interp_setcs c) (interp_setcs c0))) with
- (Aplus (Amult a (interp_vl v0))
-    (Aplus (Amult a0 (interp_vl v0))
-       (Aplus (interp_setcs c) (interp_setcs c0))));
- [ idtac | trivial ].
-setoid_replace
- (Aplus (Aplus (Amult a (interp_vl v0)) (interp_setcs c))
-    (Aplus (Amult a0 (interp_vl v0)) (interp_setcs c0))) with
- (Aplus (Amult a (interp_vl v0))
-    (Aplus (interp_setcs c)
-       (Aplus (Amult a0 (interp_vl v0)) (interp_setcs c0))));
- [ idtac | trivial ].
-auto.
-
-elim (varlist_lt v v0); simpl.
-intro.
-rewrite
- (ics_aux_ok (interp_m a v) (canonical_sum_merge c (Cons_monom a0 v0 c0)))
- .
-rewrite (ics_aux_ok (interp_m a v) c).
-rewrite (ics_aux_ok (interp_m a0 v0) c0).
-rewrite (H (Cons_monom a0 v0 c0)); simpl.
-rewrite (ics_aux_ok (interp_m a0 v0) c0); auto.
-
-intro.
-rewrite
- (ics_aux_ok (interp_m a0 v0)
-    ((fix csm_aux (s2:canonical_sum) : canonical_sum :=
-        match s2 with
-        | Nil_monom => Cons_monom a v c
-        | Cons_monom c2 l2 t2 =>
-            if varlist_eq v l2
-            then Cons_monom (Aplus a c2) v (canonical_sum_merge c t2)
-            else
-             if varlist_lt v l2
-             then Cons_monom a v (canonical_sum_merge c s2)
-             else Cons_monom c2 l2 (csm_aux t2)
-        | Cons_varlist l2 t2 =>
-            if varlist_eq v l2
-            then Cons_monom (Aplus a Aone) v (canonical_sum_merge c t2)
-            else
-             if varlist_lt v l2
-             then Cons_monom a v (canonical_sum_merge c s2)
-             else Cons_varlist l2 (csm_aux t2)
-        end) c0)).
-rewrite H0.
-rewrite (ics_aux_ok (interp_m a v) c);
- rewrite (ics_aux_ok (interp_m a0 v0) c0); simpl;
- auto.
-
-generalize (varlist_eq_prop v v0).
-elim (varlist_eq v v0).
-intros; rewrite (H1 I).
-simpl.
-rewrite (ics_aux_ok (interp_m (Aplus a Aone) v0) (canonical_sum_merge c c0));
- rewrite (ics_aux_ok (interp_m a v0) c);
- rewrite (ics_aux_ok (interp_vl v0) c0).
-rewrite (H c0).
-rewrite (interp_m_ok (Aplus a Aone) v0).
-rewrite (interp_m_ok a v0).
-setoid_replace (Amult (Aplus a Aone) (interp_vl v0)) with
- (Aplus (Amult a (interp_vl v0)) (Amult Aone (interp_vl v0)));
- [ idtac | trivial ].
-setoid_replace
- (Aplus (Aplus (Amult a (interp_vl v0)) (Amult Aone (interp_vl v0)))
-    (Aplus (interp_setcs c) (interp_setcs c0))) with
- (Aplus (Amult a (interp_vl v0))
-    (Aplus (Amult Aone (interp_vl v0))
-       (Aplus (interp_setcs c) (interp_setcs c0))));
- [ idtac | trivial ].
-setoid_replace
- (Aplus (Aplus (Amult a (interp_vl v0)) (interp_setcs c))
-    (Aplus (interp_vl v0) (interp_setcs c0))) with
- (Aplus (Amult a (interp_vl v0))
-    (Aplus (interp_setcs c) (Aplus (interp_vl v0) (interp_setcs c0))));
- [ idtac | trivial ].
-setoid_replace (Amult Aone (interp_vl v0)) with (interp_vl v0);
- [ idtac | trivial ].
-auto.
-
-elim (varlist_lt v v0); simpl.
-intro.
-rewrite
- (ics_aux_ok (interp_m a v) (canonical_sum_merge c (Cons_varlist v0 c0)))
- ; rewrite (ics_aux_ok (interp_m a v) c);
- rewrite (ics_aux_ok (interp_vl v0) c0).
-rewrite (H (Cons_varlist v0 c0)); simpl.
-rewrite (ics_aux_ok (interp_vl v0) c0).
-auto.
-
-intro.
-rewrite
- (ics_aux_ok (interp_vl v0)
-    ((fix csm_aux (s2:canonical_sum) : canonical_sum :=
-        match s2 with
-        | Nil_monom => Cons_monom a v c
-        | Cons_monom c2 l2 t2 =>
-            if varlist_eq v l2
-            then Cons_monom (Aplus a c2) v (canonical_sum_merge c t2)
-            else
-             if varlist_lt v l2
-             then Cons_monom a v (canonical_sum_merge c s2)
-             else Cons_monom c2 l2 (csm_aux t2)
-        | Cons_varlist l2 t2 =>
-            if varlist_eq v l2
-            then Cons_monom (Aplus a Aone) v (canonical_sum_merge c t2)
-            else
-             if varlist_lt v l2
-             then Cons_monom a v (canonical_sum_merge c s2)
-             else Cons_varlist l2 (csm_aux t2)
-        end) c0)); rewrite H0.
-rewrite (ics_aux_ok (interp_m a v) c); rewrite (ics_aux_ok (interp_vl v0) c0);
- simpl.
-auto.
-
-simple induction y; simpl; intros.
-trivial.
-
-generalize (varlist_eq_prop v v0).
-elim (varlist_eq v v0).
-intros; rewrite (H1 I).
-simpl.
-rewrite (ics_aux_ok (interp_m (Aplus Aone a) v0) (canonical_sum_merge c c0));
- rewrite (ics_aux_ok (interp_vl v0) c);
- rewrite (ics_aux_ok (interp_m a v0) c0); rewrite (H c0).
-rewrite (interp_m_ok (Aplus Aone a) v0); rewrite (interp_m_ok a v0).
-setoid_replace (Amult (Aplus Aone a) (interp_vl v0)) with
- (Aplus (Amult Aone (interp_vl v0)) (Amult a (interp_vl v0)));
- [ idtac | trivial ].
-setoid_replace
- (Aplus (Aplus (Amult Aone (interp_vl v0)) (Amult a (interp_vl v0)))
-    (Aplus (interp_setcs c) (interp_setcs c0))) with
- (Aplus (Amult Aone (interp_vl v0))
-    (Aplus (Amult a (interp_vl v0))
-       (Aplus (interp_setcs c) (interp_setcs c0))));
- [ idtac | trivial ].
-setoid_replace
- (Aplus (Aplus (interp_vl v0) (interp_setcs c))
-    (Aplus (Amult a (interp_vl v0)) (interp_setcs c0))) with
- (Aplus (interp_vl v0)
-    (Aplus (interp_setcs c)
-       (Aplus (Amult a (interp_vl v0)) (interp_setcs c0))));
- [ idtac | trivial ].
-auto.
-
-elim (varlist_lt v v0); simpl; intros.
-rewrite
- (ics_aux_ok (interp_vl v) (canonical_sum_merge c (Cons_monom a v0 c0)))
- ; rewrite (ics_aux_ok (interp_vl v) c);
- rewrite (ics_aux_ok (interp_m a v0) c0).
-rewrite (H (Cons_monom a v0 c0)); simpl.
-rewrite (ics_aux_ok (interp_m a v0) c0); auto.
-
-rewrite
- (ics_aux_ok (interp_m a v0)
-    ((fix csm_aux2 (s2:canonical_sum) : canonical_sum :=
-        match s2 with
-        | Nil_monom => Cons_varlist v c
-        | Cons_monom c2 l2 t2 =>
-            if varlist_eq v l2
-            then Cons_monom (Aplus Aone c2) v (canonical_sum_merge c t2)
-            else
-             if varlist_lt v l2
-             then Cons_varlist v (canonical_sum_merge c s2)
-             else Cons_monom c2 l2 (csm_aux2 t2)
-        | Cons_varlist l2 t2 =>
-            if varlist_eq v l2
-            then Cons_monom (Aplus Aone Aone) v (canonical_sum_merge c t2)
-            else
-             if varlist_lt v l2
-             then Cons_varlist v (canonical_sum_merge c s2)
-             else Cons_varlist l2 (csm_aux2 t2)
-        end) c0)); rewrite H0.
-rewrite (ics_aux_ok (interp_vl v) c); rewrite (ics_aux_ok (interp_m a v0) c0);
- simpl; auto.
-
-generalize (varlist_eq_prop v v0).
-elim (varlist_eq v v0); intros.
-rewrite (H1 I); simpl.
-rewrite
- (ics_aux_ok (interp_m (Aplus Aone Aone) v0) (canonical_sum_merge c c0))
- ; rewrite (ics_aux_ok (interp_vl v0) c);
- rewrite (ics_aux_ok (interp_vl v0) c0); rewrite (H c0).
-rewrite (interp_m_ok (Aplus Aone Aone) v0).
-setoid_replace (Amult (Aplus Aone Aone) (interp_vl v0)) with
- (Aplus (Amult Aone (interp_vl v0)) (Amult Aone (interp_vl v0)));
- [ idtac | trivial ].
-setoid_replace
- (Aplus (Aplus (Amult Aone (interp_vl v0)) (Amult Aone (interp_vl v0)))
-    (Aplus (interp_setcs c) (interp_setcs c0))) with
- (Aplus (Amult Aone (interp_vl v0))
-    (Aplus (Amult Aone (interp_vl v0))
-       (Aplus (interp_setcs c) (interp_setcs c0))));
- [ idtac | trivial ].
-setoid_replace
- (Aplus (Aplus (interp_vl v0) (interp_setcs c))
-    (Aplus (interp_vl v0) (interp_setcs c0))) with
- (Aplus (interp_vl v0)
-    (Aplus (interp_setcs c) (Aplus (interp_vl v0) (interp_setcs c0))));
-[ idtac | trivial ].
-setoid_replace (Amult Aone (interp_vl v0)) with (interp_vl v0); auto.
-
-elim (varlist_lt v v0); simpl.
-rewrite
- (ics_aux_ok (interp_vl v) (canonical_sum_merge c (Cons_varlist v0 c0)))
- ; rewrite (ics_aux_ok (interp_vl v) c);
- rewrite (ics_aux_ok (interp_vl v0) c0); rewrite (H (Cons_varlist v0 c0));
- simpl.
-rewrite (ics_aux_ok (interp_vl v0) c0); auto.
-
-rewrite
- (ics_aux_ok (interp_vl v0)
-    ((fix csm_aux2 (s2:canonical_sum) : canonical_sum :=
-        match s2 with
-        | Nil_monom => Cons_varlist v c
-        | Cons_monom c2 l2 t2 =>
-            if varlist_eq v l2
-            then Cons_monom (Aplus Aone c2) v (canonical_sum_merge c t2)
-            else
-             if varlist_lt v l2
-             then Cons_varlist v (canonical_sum_merge c s2)
-             else Cons_monom c2 l2 (csm_aux2 t2)
-        | Cons_varlist l2 t2 =>
-            if varlist_eq v l2
-            then Cons_monom (Aplus Aone Aone) v (canonical_sum_merge c t2)
-            else
-             if varlist_lt v l2
-             then Cons_varlist v (canonical_sum_merge c s2)
-             else Cons_varlist l2 (csm_aux2 t2)
-        end) c0)); rewrite H0.
-rewrite (ics_aux_ok (interp_vl v) c); rewrite (ics_aux_ok (interp_vl v0) c0);
- simpl; auto.
-Qed.
-
-Lemma monom_insert_ok :
- forall (a:A) (l:varlist) (s:canonical_sum),
-   Aequiv (interp_setcs (monom_insert a l s))
-     (Aplus (Amult a (interp_vl l)) (interp_setcs s)).
-Proof.
-simple induction s; intros.
-simpl; rewrite (interp_m_ok a l); trivial.
-
-simpl; generalize (varlist_eq_prop l v); elim (varlist_eq l v).
-intro Hr; rewrite (Hr I); simpl.
-rewrite (ics_aux_ok (interp_m (Aplus a a0) v) c);
- rewrite (ics_aux_ok (interp_m a0 v) c).
-rewrite (interp_m_ok (Aplus a a0) v); rewrite (interp_m_ok a0 v).
-setoid_replace (Amult (Aplus a a0) (interp_vl v)) with
- (Aplus (Amult a (interp_vl v)) (Amult a0 (interp_vl v)));
- [ idtac | trivial ].
-auto.
-
-elim (varlist_lt l v); simpl; intros.
-rewrite (ics_aux_ok (interp_m a0 v) c).
-rewrite (interp_m_ok a0 v); rewrite (interp_m_ok a l).
-auto.
-
-rewrite (ics_aux_ok (interp_m a0 v) (monom_insert a l c));
- rewrite (ics_aux_ok (interp_m a0 v) c); rewrite H.
-auto.
-
-simpl.
-generalize (varlist_eq_prop l v); elim (varlist_eq l v).
-intro Hr; rewrite (Hr I); simpl.
-rewrite (ics_aux_ok (interp_m (Aplus a Aone) v) c);
- rewrite (ics_aux_ok (interp_vl v) c).
-rewrite (interp_m_ok (Aplus a Aone) v).
-setoid_replace (Amult (Aplus a Aone) (interp_vl v)) with
- (Aplus (Amult a (interp_vl v)) (Amult Aone (interp_vl v)));
- [ idtac | trivial ].
-setoid_replace (Amult Aone (interp_vl v)) with (interp_vl v);
- [ idtac | trivial ].
-auto.
-
-elim (varlist_lt l v); simpl; intros; auto.
-rewrite (ics_aux_ok (interp_vl v) (monom_insert a l c)); rewrite H.
-rewrite (ics_aux_ok (interp_vl v) c); auto.
-Qed.
-
-Lemma varlist_insert_ok :
- forall (l:varlist) (s:canonical_sum),
-   Aequiv (interp_setcs (varlist_insert l s))
-     (Aplus (interp_vl l) (interp_setcs s)).
-Proof.
-simple induction s; simpl; intros.
-trivial.
-
-generalize (varlist_eq_prop l v); elim (varlist_eq l v).
-intro Hr; rewrite (Hr I); simpl.
-rewrite (ics_aux_ok (interp_m (Aplus Aone a) v) c);
- rewrite (ics_aux_ok (interp_m a v) c).
-rewrite (interp_m_ok (Aplus Aone a) v); rewrite (interp_m_ok a v).
-setoid_replace (Amult (Aplus Aone a) (interp_vl v)) with
- (Aplus (Amult Aone (interp_vl v)) (Amult a (interp_vl v)));
- [ idtac | trivial ].
-setoid_replace (Amult Aone (interp_vl v)) with (interp_vl v); auto.
-
-elim (varlist_lt l v); simpl; intros; auto.
-rewrite (ics_aux_ok (interp_m a v) (varlist_insert l c));
- rewrite (ics_aux_ok (interp_m a v) c).
-rewrite (interp_m_ok a v).
-rewrite H; auto.
-
-generalize (varlist_eq_prop l v); elim (varlist_eq l v).
-intro Hr; rewrite (Hr I); simpl.
-rewrite (ics_aux_ok (interp_m (Aplus Aone Aone) v) c);
- rewrite (ics_aux_ok (interp_vl v) c).
-rewrite (interp_m_ok (Aplus Aone Aone) v).
-setoid_replace (Amult (Aplus Aone Aone) (interp_vl v)) with
- (Aplus (Amult Aone (interp_vl v)) (Amult Aone (interp_vl v)));
- [ idtac | trivial ].
-setoid_replace (Amult Aone (interp_vl v)) with (interp_vl v); auto.
-
-elim (varlist_lt l v); simpl; intros; auto.
-rewrite (ics_aux_ok (interp_vl v) (varlist_insert l c)).
-rewrite H.
-rewrite (ics_aux_ok (interp_vl v) c); auto.
-Qed.
-
-Lemma canonical_sum_scalar_ok :
- forall (a:A) (s:canonical_sum),
-   Aequiv (interp_setcs (canonical_sum_scalar a s))
-     (Amult a (interp_setcs s)).
-Proof.
-simple induction s; simpl; intros.
-trivial.
-
-rewrite (ics_aux_ok (interp_m (Amult a a0) v) (canonical_sum_scalar a c));
- rewrite (ics_aux_ok (interp_m a0 v) c).
-rewrite (interp_m_ok (Amult a a0) v); rewrite (interp_m_ok a0 v).
-rewrite H.
-setoid_replace (Amult a (Aplus (Amult a0 (interp_vl v)) (interp_setcs c)))
- with (Aplus (Amult a (Amult a0 (interp_vl v))) (Amult a (interp_setcs c)));
- [ idtac | trivial ].
-auto.
-
-rewrite (ics_aux_ok (interp_m a v) (canonical_sum_scalar a c));
- rewrite (ics_aux_ok (interp_vl v) c); rewrite H.
-rewrite (interp_m_ok a v).
-auto.
-Qed.
-
-Lemma canonical_sum_scalar2_ok :
- forall (l:varlist) (s:canonical_sum),
-   Aequiv (interp_setcs (canonical_sum_scalar2 l s))
-     (Amult (interp_vl l) (interp_setcs s)).
-Proof.
-simple induction s; simpl; intros; auto.
-rewrite (monom_insert_ok a (varlist_merge l v) (canonical_sum_scalar2 l c)).
-rewrite (ics_aux_ok (interp_m a v) c).
-rewrite (interp_m_ok a v).
-rewrite H.
-rewrite (varlist_merge_ok l v).
-setoid_replace
- (Amult (interp_vl l) (Aplus (Amult a (interp_vl v)) (interp_setcs c))) with
- (Aplus (Amult (interp_vl l) (Amult a (interp_vl v)))
-    (Amult (interp_vl l) (interp_setcs c)));
- [ idtac | trivial ].
-auto.
-
-rewrite (varlist_insert_ok (varlist_merge l v) (canonical_sum_scalar2 l c)).
-rewrite (ics_aux_ok (interp_vl v) c).
-rewrite H.
-rewrite (varlist_merge_ok l v).
-auto.
-Qed.
-
-Lemma canonical_sum_scalar3_ok :
- forall (c:A) (l:varlist) (s:canonical_sum),
-   Aequiv (interp_setcs (canonical_sum_scalar3 c l s))
-     (Amult c (Amult (interp_vl l) (interp_setcs s))).
-Proof.
-simple induction s; simpl; intros.
-rewrite (SSR_mult_zero_right S T (interp_vl l)).
-auto.
-
-rewrite
- (monom_insert_ok (Amult c a) (varlist_merge l v)
-    (canonical_sum_scalar3 c l c0)).
-rewrite (ics_aux_ok (interp_m a v) c0).
-rewrite (interp_m_ok a v).
-rewrite H.
-rewrite (varlist_merge_ok l v).
-setoid_replace
- (Amult (interp_vl l) (Aplus (Amult a (interp_vl v)) (interp_setcs c0))) with
- (Aplus (Amult (interp_vl l) (Amult a (interp_vl v)))
-    (Amult (interp_vl l) (interp_setcs c0)));
- [ idtac | trivial ].
-setoid_replace
- (Amult c
-    (Aplus (Amult (interp_vl l) (Amult a (interp_vl v)))
-       (Amult (interp_vl l) (interp_setcs c0)))) with
- (Aplus (Amult c (Amult (interp_vl l) (Amult a (interp_vl v))))
-    (Amult c (Amult (interp_vl l) (interp_setcs c0))));
- [ idtac | trivial ].
-setoid_replace (Amult (Amult c a) (Amult (interp_vl l) (interp_vl v))) with
- (Amult c (Amult a (Amult (interp_vl l) (interp_vl v))));
- [ idtac | trivial ].
-auto.
-
-rewrite
- (monom_insert_ok c (varlist_merge l v) (canonical_sum_scalar3 c l c0))
- .
-rewrite (ics_aux_ok (interp_vl v) c0).
-rewrite H.
-rewrite (varlist_merge_ok l v).
-setoid_replace
- (Aplus (Amult c (Amult (interp_vl l) (interp_vl v)))
-    (Amult c (Amult (interp_vl l) (interp_setcs c0)))) with
- (Amult c
-    (Aplus (Amult (interp_vl l) (interp_vl v))
-       (Amult (interp_vl l) (interp_setcs c0))));
- [ idtac | trivial ].
-auto.
-Qed.
-
-Lemma canonical_sum_prod_ok :
- forall x y:canonical_sum,
-   Aequiv (interp_setcs (canonical_sum_prod x y))
-     (Amult (interp_setcs x) (interp_setcs y)).
-Proof.
-simple induction x; simpl; intros.
-trivial.
-
-rewrite
- (canonical_sum_merge_ok (canonical_sum_scalar3 a v y)
-    (canonical_sum_prod c y)).
-rewrite (canonical_sum_scalar3_ok a v y).
-rewrite (ics_aux_ok (interp_m a v) c).
-rewrite (interp_m_ok a v).
-rewrite (H y).
-setoid_replace (Amult a (Amult (interp_vl v) (interp_setcs y))) with
- (Amult (Amult a (interp_vl v)) (interp_setcs y));
- [ idtac | trivial ].
-setoid_replace
- (Amult (Aplus (Amult a (interp_vl v)) (interp_setcs c)) (interp_setcs y))
- with
- (Aplus (Amult (Amult a (interp_vl v)) (interp_setcs y))
-    (Amult (interp_setcs c) (interp_setcs y)));
- [ idtac | trivial ].
-trivial.
-
-rewrite
- (canonical_sum_merge_ok (canonical_sum_scalar2 v y) (canonical_sum_prod c y))
- .
-rewrite (canonical_sum_scalar2_ok v y).
-rewrite (ics_aux_ok (interp_vl v) c).
-rewrite (H y).
-trivial.
-Qed.
-
-Theorem setspolynomial_normalize_ok :
- forall p:setspolynomial,
-   Aequiv (interp_setcs (setspolynomial_normalize p)) (interp_setsp p).
-Proof.
-simple induction p; simpl; intros; trivial.
-rewrite
- (canonical_sum_merge_ok (setspolynomial_normalize s)
-    (setspolynomial_normalize s0)).
-rewrite H; rewrite H0; trivial.
-
-rewrite
- (canonical_sum_prod_ok (setspolynomial_normalize s)
-    (setspolynomial_normalize s0)).
-rewrite H; rewrite H0; trivial.
-Qed.
-
-Lemma canonical_sum_simplify_ok :
- forall s:canonical_sum,
-   Aequiv (interp_setcs (canonical_sum_simplify s)) (interp_setcs s).
-Proof.
-simple induction s; simpl; intros.
-trivial.
-
-generalize (SSR_eq_prop T a Azero).
-elim (Aeq a Azero).
-simpl.
-intros.
-rewrite (ics_aux_ok (interp_m a v) c).
-rewrite (interp_m_ok a v).
-rewrite (H0 I).
-setoid_replace (Amult Azero (interp_vl v)) with Azero;
- [ idtac | trivial ].
-rewrite H.
-trivial.
-
-intros; simpl.
-generalize (SSR_eq_prop T a Aone).
-elim (Aeq a Aone).
-intros.
-rewrite (ics_aux_ok (interp_m a v) c).
-rewrite (interp_m_ok a v).
-rewrite (H1 I).
-simpl.
-rewrite (ics_aux_ok (interp_vl v) (canonical_sum_simplify c)).
-rewrite H.
-auto.
-
-simpl.
-intros.
-rewrite (ics_aux_ok (interp_m a v) (canonical_sum_simplify c)).
-rewrite (ics_aux_ok (interp_m a v) c).
-rewrite H; trivial.
-
-rewrite (ics_aux_ok (interp_vl v) (canonical_sum_simplify c)).
-rewrite H.
-auto.
-Qed.
-
-Theorem setspolynomial_simplify_ok :
- forall p:setspolynomial,
-   Aequiv (interp_setcs (setspolynomial_simplify p)) (interp_setsp p).
-Proof.
-intro.
-unfold setspolynomial_simplify.
-rewrite (canonical_sum_simplify_ok (setspolynomial_normalize p)).
-exact (setspolynomial_normalize_ok p).
-Qed.
-
-End semi_setoid_rings.
-
-Arguments Cons_varlist : default implicits.
-Arguments Cons_monom : default implicits.
-Arguments SetSPconst : default implicits.
-Arguments SetSPplus : default implicits.
-Arguments SetSPmult : default implicits.
-
-
-
-Section setoid_rings.
-
-Set Implicit Arguments.
-
-Variable vm : varmap A.
-Variable T : Setoid_Ring_Theory Aequiv Aplus Amult Aone Azero Aopp Aeq.
-
-Hint Resolve (STh_plus_comm T).
-Hint Resolve (STh_plus_assoc T).
-Hint Resolve (STh_plus_assoc2 S T).
-Hint Resolve (STh_mult_comm T).
-Hint Resolve (STh_mult_assoc T).
-Hint Resolve (STh_mult_assoc2 S T).
-Hint Resolve (STh_plus_zero_left T).
-Hint Resolve (STh_plus_zero_left2 S T).
-Hint Resolve (STh_mult_one_left T).
-Hint Resolve (STh_mult_one_left2 S T).
-Hint Resolve (STh_mult_zero_left S plus_morph mult_morph T).
-Hint Resolve (STh_mult_zero_left2 S plus_morph mult_morph T).
-Hint Resolve (STh_distr_left T).
-Hint Resolve (STh_distr_left2 S T).
-Hint Resolve (STh_plus_reg_left S plus_morph T).
-Hint Resolve (STh_plus_permute S plus_morph T).
-Hint Resolve (STh_mult_permute S mult_morph T).
-Hint Resolve (STh_distr_right S plus_morph T).
-Hint Resolve (STh_distr_right2 S plus_morph T).
-Hint Resolve (STh_mult_zero_right S plus_morph mult_morph T).
-Hint Resolve (STh_mult_zero_right2 S plus_morph mult_morph T).
-Hint Resolve (STh_plus_zero_right S T).
-Hint Resolve (STh_plus_zero_right2 S T).
-Hint Resolve (STh_mult_one_right S T).
-Hint Resolve (STh_mult_one_right2 S T).
-Hint Resolve (STh_plus_reg_right S plus_morph T).
-Hint Resolve eq_refl eq_sym eq_trans.
-Hint Immediate T.
-
-
-(*** Definitions *)
-
-Inductive setpolynomial : Type :=
-  | SetPvar : index -> setpolynomial
-  | SetPconst : A -> setpolynomial
-  | SetPplus : setpolynomial -> setpolynomial -> setpolynomial
-  | SetPmult : setpolynomial -> setpolynomial -> setpolynomial
-  | SetPopp : setpolynomial -> setpolynomial.
-
-Fixpoint setpolynomial_normalize (x:setpolynomial) : canonical_sum :=
-  match x with
-  | SetPplus l r =>
-      canonical_sum_merge (setpolynomial_normalize l)
-        (setpolynomial_normalize r)
-  | SetPmult l r =>
-      canonical_sum_prod (setpolynomial_normalize l)
-        (setpolynomial_normalize r)
-  | SetPconst c => Cons_monom c Nil_var Nil_monom
-  | SetPvar i => Cons_varlist (Cons_var i Nil_var) Nil_monom
-  | SetPopp p =>
-      canonical_sum_scalar3 (Aopp Aone) Nil_var (setpolynomial_normalize p)
-  end.
-
-Definition setpolynomial_simplify (x:setpolynomial) :=
-  canonical_sum_simplify (setpolynomial_normalize x).
-
-Fixpoint setspolynomial_of (x:setpolynomial) : setspolynomial :=
-  match x with
-  | SetPplus l r => SetSPplus (setspolynomial_of l) (setspolynomial_of r)
-  | SetPmult l r => SetSPmult (setspolynomial_of l) (setspolynomial_of r)
-  | SetPconst c => SetSPconst c
-  | SetPvar i => SetSPvar i
-  | SetPopp p => SetSPmult (SetSPconst (Aopp Aone)) (setspolynomial_of p)
-  end.
-
-(*** Interpretation *)
-
-Fixpoint interp_setp (p:setpolynomial) : A :=
-  match p with
-  | SetPconst c => c
-  | SetPvar i => varmap_find Azero i vm
-  | SetPplus p1 p2 => Aplus (interp_setp p1) (interp_setp p2)
-  | SetPmult p1 p2 => Amult (interp_setp p1) (interp_setp p2)
-  | SetPopp p1 => Aopp (interp_setp p1)
-  end.
-
-(*** Properties *)
-
-Unset Implicit Arguments.
-
-Lemma setspolynomial_of_ok :
- forall p:setpolynomial,
-   Aequiv (interp_setp p) (interp_setsp vm (setspolynomial_of p)).
-simple induction p; trivial; simpl; intros.
-rewrite H; rewrite H0; trivial.
-rewrite H; rewrite H0; trivial.
-rewrite H.
-rewrite
- (STh_opp_mult_left2 S plus_morph mult_morph T Aone
-    (interp_setsp vm (setspolynomial_of s))).
-rewrite (STh_mult_one_left T (interp_setsp vm (setspolynomial_of s))).
-trivial.
-Qed.
-
-Theorem setpolynomial_normalize_ok :
- forall p:setpolynomial,
-   setpolynomial_normalize p = setspolynomial_normalize (setspolynomial_of p).
-simple induction p; trivial; simpl; intros.
-rewrite H; rewrite H0; reflexivity.
-rewrite H; rewrite H0; reflexivity.
-rewrite H; simpl.
-elim
- (canonical_sum_scalar3 (Aopp Aone) Nil_var
-    (setspolynomial_normalize (setspolynomial_of s)));
- [ reflexivity
- | simpl; intros; rewrite H0; reflexivity
- | simpl; intros; rewrite H0; reflexivity ].
-Qed.
-
-Theorem setpolynomial_simplify_ok :
- forall p:setpolynomial,
-   Aequiv (interp_setcs vm (setpolynomial_simplify p)) (interp_setp p).
-intro.
-unfold setpolynomial_simplify.
-rewrite (setspolynomial_of_ok p).
-rewrite setpolynomial_normalize_ok.
-rewrite
- (canonical_sum_simplify_ok vm
-    (Semi_Setoid_Ring_Theory_of A Aequiv S Aplus Amult Aone Azero Aopp Aeq
-       plus_morph mult_morph T)
-    (setspolynomial_normalize (setspolynomial_of p)))
- .
-rewrite
- (setspolynomial_normalize_ok vm
-    (Semi_Setoid_Ring_Theory_of A Aequiv S Aplus Amult Aone Azero Aopp Aeq
-       plus_morph mult_morph T) (setspolynomial_of p))
- .
-trivial.
-Qed.
-
-End setoid_rings.
-
-End setoid.
diff --git a/plugins/ring/Setoid_ring_theory.v b/plugins/ring/Setoid_ring_theory.v
deleted file mode 100644
index bb88f646..00000000
--- a/plugins/ring/Setoid_ring_theory.v
+++ /dev/null
@@ -1,425 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-Require Export Bool.
-Require Export Setoid.
-
-Set Implicit Arguments.
-
-Section Setoid_rings.
-
-Variable A : Type.
-Variable Aequiv : A -> A -> Prop.
-
-Infix Local "==" := Aequiv (at level 70, no associativity).
-
-Variable S : Setoid_Theory A Aequiv.
-
-Add Setoid A Aequiv S as Asetoid.
-
-Variable Aplus : A -> A -> A.
-Variable Amult : A -> A -> A.
-Variable Aone : A.
-Variable Azero : A.
-Variable Aopp : A -> A.
-Variable Aeq : A -> A -> bool.
-
-Infix "+" := Aplus (at level 50, left associativity).
-Infix "*" := Amult (at level 40, left associativity).
-Notation "0" := Azero.
-Notation "1" := Aone.
-Notation "- x" := (Aopp x).
-
-Variable plus_morph :
- forall a a0:A, a == a0 -> forall a1 a2:A, a1 == a2 -> a + a1 == a0 + a2.
-Variable mult_morph :
-  forall a a0:A, a == a0 -> forall a1 a2:A, a1 == a2 -> a * a1 == a0 * a2.
-Variable opp_morph : forall a a0:A, a == a0 -> - a == - a0.
-
-Add Morphism Aplus : Aplus_ext.
-intros; apply plus_morph; assumption.
-Qed.
-
-Add Morphism Amult : Amult_ext.
-intros; apply mult_morph; assumption.
-Qed.
-
-Add Morphism Aopp : Aopp_ext.
-exact opp_morph.
-Qed.
-
-Section Theory_of_semi_setoid_rings.
-
-Record Semi_Setoid_Ring_Theory : Prop :=
-  {SSR_plus_comm : forall n m:A, n + m == m + n;
-   SSR_plus_assoc : forall n m p:A, n + (m + p) == n + m + p;
-   SSR_mult_comm : forall n m:A, n * m == m * n;
-   SSR_mult_assoc : forall n m p:A, n * (m * p) == n * m * p;
-   SSR_plus_zero_left : forall n:A, 0 + n == n;
-   SSR_mult_one_left : forall n:A, 1 * n == n;
-   SSR_mult_zero_left : forall n:A, 0 * n == 0;
-   SSR_distr_left : forall n m p:A, (n + m) * p == n * p + m * p;
-   SSR_plus_reg_left : forall n m p:A, n + m == n + p -> m == p;
-   SSR_eq_prop : forall x y:A, Is_true (Aeq x y) -> x == y}.
-
-Variable T : Semi_Setoid_Ring_Theory.
-
-Let plus_comm := SSR_plus_comm T.
-Let plus_assoc := SSR_plus_assoc T.
-Let mult_comm := SSR_mult_comm T.
-Let mult_assoc := SSR_mult_assoc T.
-Let plus_zero_left := SSR_plus_zero_left T.
-Let mult_one_left := SSR_mult_one_left T.
-Let mult_zero_left := SSR_mult_zero_left T.
-Let distr_left := SSR_distr_left T.
-Let plus_reg_left := SSR_plus_reg_left T.
-Let equiv_refl := Seq_refl A Aequiv S.
-Let equiv_sym := Seq_sym A Aequiv S.
-Let equiv_trans := Seq_trans A Aequiv S.
-
-Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left
-  mult_one_left mult_zero_left distr_left plus_reg_left
-  equiv_refl (*equiv_sym*).
-Hint Immediate equiv_sym.
-
-(* Lemmas whose form is x=y are also provided in form y=x because
-  Auto does not symmetry *)
-Lemma SSR_mult_assoc2 : forall n m p:A, n * m * p == n * (m * p).
-auto. Qed.
-
-Lemma SSR_plus_assoc2 : forall n m p:A, n + m + p == n + (m + p).
-auto. Qed.
-
-Lemma SSR_plus_zero_left2 : forall n:A, n == 0 + n.
-auto. Qed.
-
-Lemma SSR_mult_one_left2 : forall n:A, n == 1 * n.
-auto. Qed.
-
-Lemma SSR_mult_zero_left2 : forall n:A, 0 == 0 * n.
-auto. Qed.
-
-Lemma SSR_distr_left2 : forall n m p:A, n * p + m * p == (n + m) * p.
-auto. Qed.
-
-Lemma SSR_plus_permute : forall n m p:A, n + (m + p) == m + (n + p).
-intros.
-rewrite (plus_assoc n m p).
-rewrite (plus_comm n m).
-rewrite <- (plus_assoc m n p).
-trivial.
-Qed.
-
-Lemma SSR_mult_permute : forall n m p:A, n * (m * p) == m * (n * p).
-intros.
-rewrite (mult_assoc n m p).
-rewrite (mult_comm n m).
-rewrite <- (mult_assoc m n p).
-trivial.
-Qed.
-
-Hint Resolve SSR_plus_permute SSR_mult_permute.
-
-Lemma SSR_distr_right : forall n m p:A, n * (m + p) == n * m + n * p.
-intros.
-rewrite (mult_comm n (m + p)).
-rewrite (mult_comm n m).
-rewrite (mult_comm n p).
-auto.
-Qed.
-
-Lemma SSR_distr_right2 : forall n m p:A, n * m + n * p == n * (m + p).
-intros.
-apply equiv_sym.
-apply SSR_distr_right.
-Qed.
-
-Lemma SSR_mult_zero_right : forall n:A, n * 0 == 0.
-intro; rewrite (mult_comm n 0); auto.
-Qed.
-
-Lemma SSR_mult_zero_right2 : forall n:A, 0 == n * 0.
-intro; rewrite (mult_comm n 0); auto.
-Qed.
-
-Lemma SSR_plus_zero_right : forall n:A, n + 0 == n.
-intro; rewrite (plus_comm n 0); auto.
-Qed.
-
-Lemma SSR_plus_zero_right2 : forall n:A, n == n + 0.
-intro; rewrite (plus_comm n 0); auto.
-Qed.
-
-Lemma SSR_mult_one_right : forall n:A, n * 1 == n.
-intro; rewrite (mult_comm n 1); auto.
-Qed.
-
-Lemma SSR_mult_one_right2 : forall n:A, n == n * 1.
-intro; rewrite (mult_comm n 1); auto.
-Qed.
-
-Lemma SSR_plus_reg_right : forall n m p:A, m + n == p + n -> m == p.
-intros n m p; rewrite (plus_comm m n); rewrite (plus_comm p n).
-intro; apply plus_reg_left with n; trivial.
-Qed.
-
-End Theory_of_semi_setoid_rings.
-
-Section Theory_of_setoid_rings.
-
-Record Setoid_Ring_Theory : Prop :=
-  {STh_plus_comm : forall n m:A, n + m == m + n;
-   STh_plus_assoc : forall n m p:A, n + (m + p) == n + m + p;
-   STh_mult_comm : forall n m:A, n * m == m * n;
-   STh_mult_assoc : forall n m p:A, n * (m * p) == n * m * p;
-   STh_plus_zero_left : forall n:A, 0 + n == n;
-   STh_mult_one_left : forall n:A, 1 * n == n;
-   STh_opp_def : forall n:A, n + - n == 0;
-   STh_distr_left : forall n m p:A, (n + m) * p == n * p + m * p;
-   STh_eq_prop : forall x y:A, Is_true (Aeq x y) -> x == y}.
-
-Variable T : Setoid_Ring_Theory.
-
-Let plus_comm := STh_plus_comm T.
-Let plus_assoc := STh_plus_assoc T.
-Let mult_comm := STh_mult_comm T.
-Let mult_assoc := STh_mult_assoc T.
-Let plus_zero_left := STh_plus_zero_left T.
-Let mult_one_left := STh_mult_one_left T.
-Let opp_def := STh_opp_def T.
-Let distr_left := STh_distr_left T.
-Let equiv_refl := Seq_refl A Aequiv S.
-Let equiv_sym := Seq_sym A Aequiv S.
-Let equiv_trans := Seq_trans A Aequiv S.
-
-Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left
-  mult_one_left opp_def distr_left equiv_refl equiv_sym.
-
-(* Lemmas whose form is x=y are also provided in form y=x because Auto does
-  not symmetry *)
-
-Lemma STh_mult_assoc2 : forall n m p:A, n * m * p == n * (m * p).
-auto. Qed.
-
-Lemma STh_plus_assoc2 : forall n m p:A, n + m + p == n + (m + p).
-auto. Qed.
-
-Lemma STh_plus_zero_left2 : forall n:A, n == 0 + n.
-auto. Qed.
-
-Lemma STh_mult_one_left2 : forall n:A, n == 1 * n.
-auto. Qed.
-
-Lemma STh_distr_left2 : forall n m p:A, n * p + m * p == (n + m) * p.
-auto. Qed.
-
-Lemma STh_opp_def2 : forall n:A, 0 == n + - n.
-auto. Qed.
-
-Lemma STh_plus_permute : forall n m p:A, n + (m + p) == m + (n + p).
-intros.
-rewrite (plus_assoc n m p).
-rewrite (plus_comm n m).
-rewrite <- (plus_assoc m n p).
-trivial.
-Qed.
-
-Lemma STh_mult_permute : forall n m p:A, n * (m * p) == m * (n * p).
-intros.
-rewrite (mult_assoc n m p).
-rewrite (mult_comm n m).
-rewrite <- (mult_assoc m n p).
-trivial.
-Qed.
-
-Hint Resolve STh_plus_permute STh_mult_permute.
-
-Lemma Saux1 : forall a:A, a + a == a -> a == 0.
-intros.
-rewrite <- (plus_zero_left a).
-rewrite (plus_comm 0 a).
-setoid_replace (a + 0) with (a + (a + - a)) by auto.
-rewrite (plus_assoc a a (- a)).
-rewrite H.
-apply opp_def.
-Qed.
-
-Lemma STh_mult_zero_left : forall n:A, 0 * n == 0.
-intros.
-apply Saux1.
-rewrite <- (distr_left 0 0 n).
-rewrite (plus_zero_left 0).
-trivial.
-Qed.
-Hint Resolve STh_mult_zero_left.
-
-Lemma STh_mult_zero_left2 : forall n:A, 0 == 0 * n.
-auto.
-Qed.
-
-Lemma Saux2 : forall x y z:A, x + y == 0 -> x + z == 0 -> y == z.
-intros.
-rewrite <- (plus_zero_left y).
-rewrite <- H0.
-rewrite <- (plus_assoc x z y).
-rewrite (plus_comm z y).
-rewrite (plus_assoc x y z).
-rewrite H.
-auto.
-Qed.
-
-Lemma STh_opp_mult_left : forall x y:A, - (x * y) == - x * y.
-intros.
-apply Saux2 with (x * y); auto.
-rewrite <- (distr_left x (- x) y).
-rewrite (opp_def x).
-auto.
-Qed.
-Hint Resolve STh_opp_mult_left.
-
-Lemma STh_opp_mult_left2 : forall x y:A, - x * y == - (x * y).
-auto.
-Qed.
-
-Lemma STh_mult_zero_right : forall n:A, n * 0 == 0.
-intro; rewrite (mult_comm n 0); auto.
-Qed.
-
-Lemma STh_mult_zero_right2 : forall n:A, 0 == n * 0.
-intro; rewrite (mult_comm n 0); auto.
-Qed.
-
-Lemma STh_plus_zero_right : forall n:A, n + 0 == n.
-intro; rewrite (plus_comm n 0); auto.
-Qed.
-
-Lemma STh_plus_zero_right2 : forall n:A, n == n + 0.
-intro; rewrite (plus_comm n 0); auto.
-Qed.
-
-Lemma STh_mult_one_right : forall n:A, n * 1 == n.
-intro; rewrite (mult_comm n 1); auto.
-Qed.
-
-Lemma STh_mult_one_right2 : forall n:A, n == n * 1.
-intro; rewrite (mult_comm n 1); auto.
-Qed.
-
-Lemma STh_opp_mult_right : forall x y:A, - (x * y) == x * - y.
-intros.
-rewrite (mult_comm x y).
-rewrite (mult_comm x (- y)).
-auto.
-Qed.
-
-Lemma STh_opp_mult_right2 : forall x y:A, x * - y == - (x * y).
-intros.
-rewrite (mult_comm x y).
-rewrite (mult_comm x (- y)).
-auto.
-Qed.
-
-Lemma STh_plus_opp_opp : forall x y:A, - x + - y == - (x + y).
-intros.
-apply Saux2 with (x + y); auto.
-rewrite (STh_plus_permute (x + y) (- x) (- y)).
-rewrite <- (plus_assoc x y (- y)).
-rewrite (opp_def y); rewrite (STh_plus_zero_right x).
-rewrite (STh_opp_def2 x); trivial.
-Qed.
-
-Lemma STh_plus_permute_opp : forall n m p:A, - m + (n + p) == n + (- m + p).
-auto.
-Qed.
-
-Lemma STh_opp_opp : forall n:A, - - n == n.
-intro.
-apply Saux2 with (- n); auto.
-rewrite (plus_comm (- n) n); auto.
-Qed.
-Hint Resolve STh_opp_opp.
-
-Lemma STh_opp_opp2 : forall n:A, n == - - n.
-auto.
-Qed.
-
-Lemma STh_mult_opp_opp : forall x y:A, - x * - y == x * y.
-intros.
-rewrite (STh_opp_mult_left2 x (- y)).
-rewrite (STh_opp_mult_right2 x y).
-trivial.
-Qed.
-
-Lemma STh_mult_opp_opp2 : forall x y:A, x * y == - x * - y.
-intros.
-apply equiv_sym.
-apply STh_mult_opp_opp.
-Qed.
-
-Lemma STh_opp_zero : - 0 == 0.
-rewrite <- (plus_zero_left (- 0)).
-trivial.
-Qed.
-
-Lemma STh_plus_reg_left : forall n m p:A, n + m == n + p -> m == p.
-intros.
-rewrite <- (plus_zero_left m).
-rewrite <- (plus_zero_left p).
-rewrite <- (opp_def n).
-rewrite (plus_comm n (- n)).
-rewrite <- (plus_assoc (- n) n m).
-rewrite <- (plus_assoc (- n) n p).
-auto.
-Qed.
-
-Lemma STh_plus_reg_right : forall n m p:A, m + n == p + n -> m == p.
-intros.
-apply STh_plus_reg_left with n.
-rewrite (plus_comm n m); rewrite (plus_comm n p); assumption.
-Qed.
-
-Lemma STh_distr_right : forall n m p:A, n * (m + p) == n * m + n * p.
-intros.
-rewrite (mult_comm n (m + p)).
-rewrite (mult_comm n m).
-rewrite (mult_comm n p).
-trivial.
-Qed.
-
-Lemma STh_distr_right2 : forall n m p:A, n * m + n * p == n * (m + p).
-intros.
-apply equiv_sym.
-apply STh_distr_right.
-Qed.
-
-End Theory_of_setoid_rings.
-
-Hint Resolve STh_mult_zero_left STh_plus_reg_left: core.
-
-Unset Implicit Arguments.
-
-Definition Semi_Setoid_Ring_Theory_of :
-  Setoid_Ring_Theory -> Semi_Setoid_Ring_Theory.
-intros until 1; case H.
-split; intros; simpl; eauto.
-Defined.
-
-Coercion Semi_Setoid_Ring_Theory_of : Setoid_Ring_Theory >->
- Semi_Setoid_Ring_Theory.
-
-
-
-Section product_ring.
-
-End product_ring.
-
-Section power_ring.
-
-End power_ring.
-
-End Setoid_rings.
diff --git a/plugins/ring/g_ring.ml4 b/plugins/ring/g_ring.ml4
deleted file mode 100644
index f2e904b1..00000000
--- a/plugins/ring/g_ring.ml4
+++ /dev/null
@@ -1,134 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(*i camlp4deps: "parsing/grammar.cma" i*)
-
-open Quote
-open Ring
-open Tacticals
-
-TACTIC EXTEND ring
-| [ "legacy" "ring" constr_list(l) ] -> [ polynom l ]
-END
-
-(* The vernac commands "Add Ring" and co *)
-
-let cset_of_constrarg_list l =
-  List.fold_right ConstrSet.add (List.map constr_of l) ConstrSet.empty
-
-VERNAC COMMAND EXTEND AddRing
-  [ "Add" "Legacy" "Ring"
-          constr(a) constr(aplus) constr(amult) constr(aone) constr(azero)
-          constr(aopp) constr(aeq) constr(t) "[" ne_constr_list(l) "]" ]
-  -> [ add_theory true false false
-			 (constr_of a)
-			 None
-			 None
-			 None
-			 (constr_of aplus)
-			 (constr_of amult)
-			 (constr_of aone)
-			 (constr_of azero)
-			 (Some (constr_of aopp))
-			 (constr_of aeq)
-			 (constr_of t)
-			 (cset_of_constrarg_list l) ]
-
-| [ "Add" "Legacy" "Semi" "Ring"
-      	  constr(a) constr(aplus) constr(amult) constr(aone) constr(azero)
-          constr(aeq) constr(t) "[" ne_constr_list(l) "]" ]
-  -> [ add_theory false false false
-			 (constr_of a)
-			 None
-			 None
-			 None
-			 (constr_of aplus)
-			 (constr_of amult)
-			 (constr_of aone)
-			 (constr_of azero)
-			 None
-			 (constr_of aeq)
-			 (constr_of t)
-			 (cset_of_constrarg_list l) ]
-
-| [ "Add" "Legacy" "Abstract" "Ring"
-    	  constr(a) constr(aplus) constr(amult) constr(aone)
-          constr(azero) constr(aopp) constr(aeq) constr(t) ]
-  -> [ add_theory true true false
-			 (constr_of a)
-			 None
-			 None
-			 None
-			 (constr_of aplus)
-			 (constr_of amult)
-			 (constr_of aone)
-			 (constr_of azero)
-			 (Some (constr_of aopp))
-			 (constr_of aeq)
-			 (constr_of t)
-			 ConstrSet.empty ]
-
-| [ "Add" "Legacy" "Abstract" "Semi" "Ring"
-          constr(a) constr(aplus) constr(amult) constr(aone)
-          constr(azero) constr(aeq) constr(t) ]
-  -> [ add_theory false true false
-			 (constr_of a)
-			 None
-			 None
-			 None
-			 (constr_of aplus)
-			 (constr_of amult)
-			 (constr_of aone)
-			 (constr_of azero)
-			 None
-			 (constr_of aeq)
-			 (constr_of t)
-			 ConstrSet.empty ]
-
-| [ "Add" "Legacy" "Setoid" "Ring"
-      	  constr(a) constr(aequiv) constr(asetth) constr(aplus) constr(amult)
-	  constr(aone) constr(azero) constr(aopp) constr(aeq) constr(pm)
-	  constr(mm) constr(om) constr(t) "[" ne_constr_list(l) "]" ]
-  -> [ add_theory true false true
-			 (constr_of a)
-			 (Some (constr_of aequiv))
-			 (Some (constr_of asetth))
-			 (Some {
-			    plusm = (constr_of pm);
-			    multm = (constr_of mm);
-			    oppm = Some (constr_of om) })
-			 (constr_of aplus)
-			 (constr_of amult)
-			 (constr_of aone)
-			 (constr_of azero)
-			 (Some (constr_of aopp))
-			 (constr_of aeq)
-			 (constr_of t)
-			 (cset_of_constrarg_list l) ]
-
-| [ "Add" "Legacy" "Semi" "Setoid" "Ring"
-          constr(a) constr(aequiv) constr(asetth) constr(aplus)
-	  constr(amult) constr(aone) constr(azero) constr(aeq)
-          constr(pm) constr(mm) constr(t) "[" ne_constr_list(l) "]" ]
-  -> [ add_theory false false true
-			 (constr_of a)
-			 (Some (constr_of aequiv))
-			 (Some (constr_of asetth))
-			 (Some {
-			    plusm = (constr_of pm);
-			    multm = (constr_of mm);
-			    oppm = None })
-			 (constr_of aplus)
-			 (constr_of amult)
-			 (constr_of aone)
-			 (constr_of azero)
-			 None
-			 (constr_of aeq)
-			 (constr_of t)
-			 (cset_of_constrarg_list l) ]
-END
diff --git a/plugins/ring/ring.ml b/plugins/ring/ring.ml
deleted file mode 100644
index db88a05c..00000000
--- a/plugins/ring/ring.ml
+++ /dev/null
@@ -1,928 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* ML part of the Ring tactic *)
-
-open Pp
-open Util
-open Flags
-open Term
-open Names
-open Libnames
-open Nameops
-open Reductionops
-open Tacticals
-open Tacexpr
-open Tacmach
-open Printer
-open Equality
-open Vernacinterp
-open Vernacexpr
-open Libobject
-open Closure
-open Tacred
-open Tactics
-open Pattern
-open Hiddentac
-open Nametab
-open Quote
-open Mod_subst
-
-let mt_evd = Evd.empty
-let constr_of c = Constrintern.interp_constr mt_evd (Global.env()) c
-
-let ring_dir = ["Coq";"ring"]
-let setoids_dir = ["Coq";"Setoids"]
-
-let ring_constant = Coqlib.gen_constant_in_modules "Ring"
-  [ring_dir@["LegacyRing_theory"];
-   ring_dir@["Setoid_ring_theory"];
-   ring_dir@["Ring_normalize"];
-   ring_dir@["Ring_abstract"];
-   setoids_dir@["Setoid"];
-   ring_dir@["Setoid_ring_normalize"]]
-
-(* Ring theory *)
-let coq_Ring_Theory = lazy (ring_constant "Ring_Theory")
-let coq_Semi_Ring_Theory = lazy (ring_constant "Semi_Ring_Theory")
-
-(* Setoid ring theory *)
-let coq_Setoid_Ring_Theory = lazy (ring_constant "Setoid_Ring_Theory")
-let coq_Semi_Setoid_Ring_Theory = lazy(ring_constant "Semi_Setoid_Ring_Theory")
-
-(* Ring normalize *)
-let coq_SPplus = lazy (ring_constant "SPplus")
-let coq_SPmult = lazy (ring_constant "SPmult")
-let coq_SPvar = lazy (ring_constant "SPvar")
-let coq_SPconst = lazy (ring_constant "SPconst")
-let coq_Pplus = lazy (ring_constant "Pplus")
-let coq_Pmult = lazy (ring_constant "Pmult")
-let coq_Pvar = lazy (ring_constant "Pvar")
-let coq_Pconst = lazy (ring_constant "Pconst")
-let coq_Popp = lazy (ring_constant "Popp")
-let coq_interp_sp = lazy (ring_constant "interp_sp")
-let coq_interp_p = lazy (ring_constant "interp_p")
-let coq_interp_cs = lazy (ring_constant "interp_cs")
-let coq_spolynomial_simplify = lazy (ring_constant "spolynomial_simplify")
-let coq_polynomial_simplify = lazy (ring_constant "polynomial_simplify")
-let coq_spolynomial_simplify_ok = lazy(ring_constant "spolynomial_simplify_ok")
-let coq_polynomial_simplify_ok = lazy (ring_constant "polynomial_simplify_ok")
-
-(* Setoid theory *)
-let coq_Setoid_Theory = lazy(ring_constant "Setoid_Theory")
-
-let coq_seq_refl = lazy(ring_constant "Seq_refl")
-let coq_seq_sym = lazy(ring_constant "Seq_sym")
-let coq_seq_trans = lazy(ring_constant "Seq_trans")
-
-(* Setoid Ring normalize *)
-let coq_SetSPplus = lazy (ring_constant "SetSPplus")
-let coq_SetSPmult = lazy (ring_constant "SetSPmult")
-let coq_SetSPvar = lazy (ring_constant "SetSPvar")
-let coq_SetSPconst = lazy (ring_constant "SetSPconst")
-let coq_SetPplus = lazy (ring_constant "SetPplus")
-let coq_SetPmult = lazy (ring_constant "SetPmult")
-let coq_SetPvar = lazy (ring_constant "SetPvar")
-let coq_SetPconst = lazy (ring_constant "SetPconst")
-let coq_SetPopp = lazy (ring_constant "SetPopp")
-let coq_interp_setsp = lazy (ring_constant "interp_setsp")
-let coq_interp_setp = lazy (ring_constant "interp_setp")
-let coq_interp_setcs = lazy (ring_constant "interp_setcs")
-let coq_setspolynomial_simplify =
-  lazy (ring_constant "setspolynomial_simplify")
-let coq_setpolynomial_simplify =
-  lazy (ring_constant "setpolynomial_simplify")
-let coq_setspolynomial_simplify_ok =
-  lazy (ring_constant "setspolynomial_simplify_ok")
-let coq_setpolynomial_simplify_ok =
-  lazy (ring_constant "setpolynomial_simplify_ok")
-
-(* Ring abstract *)
-let coq_ASPplus = lazy (ring_constant "ASPplus")
-let coq_ASPmult = lazy (ring_constant "ASPmult")
-let coq_ASPvar = lazy (ring_constant "ASPvar")
-let coq_ASP0 = lazy (ring_constant "ASP0")
-let coq_ASP1 = lazy (ring_constant "ASP1")
-let coq_APplus = lazy (ring_constant "APplus")
-let coq_APmult = lazy (ring_constant "APmult")
-let coq_APvar = lazy (ring_constant "APvar")
-let coq_AP0 = lazy (ring_constant "AP0")
-let coq_AP1 = lazy (ring_constant "AP1")
-let coq_APopp = lazy (ring_constant "APopp")
-let coq_interp_asp = lazy (ring_constant "interp_asp")
-let coq_interp_ap = lazy (ring_constant "interp_ap")
-let coq_interp_acs = lazy (ring_constant "interp_acs")
-let coq_interp_sacs = lazy (ring_constant "interp_sacs")
-let coq_aspolynomial_normalize = lazy (ring_constant "aspolynomial_normalize")
-let coq_apolynomial_normalize = lazy (ring_constant "apolynomial_normalize")
-let coq_aspolynomial_normalize_ok =
-  lazy (ring_constant "aspolynomial_normalize_ok")
-let coq_apolynomial_normalize_ok =
-  lazy (ring_constant "apolynomial_normalize_ok")
-
-(* Logic --> to be found in Coqlib *)
-open Coqlib
-
-let mkLApp(fc,v) = mkApp(Lazy.force fc, v)
-
-(*********** Useful types and functions ************)
-
-module OperSet =
-  Set.Make (struct
-	      type t = global_reference
-	      let compare = (RefOrdered.compare : t->t->int)
-	    end)
-
-type morph =
-    { plusm : constr;
-      multm : constr;
-      oppm : constr option;
-    }
-
-type theory =
-    { th_ring : bool;                  (* false for a semi-ring *)
-      th_abstract : bool;
-      th_setoid : bool;                (* true for a setoid ring *)
-      th_equiv : constr option;
-      th_setoid_th : constr option;
-      th_morph : morph option;
-      th_a : constr;                   (* e.g. nat *)
-      th_plus : constr;
-      th_mult : constr;
-      th_one : constr;
-      th_zero : constr;
-      th_opp : constr option;          (* None if semi-ring *)
-      th_eq : constr;
-      th_t : constr;                   (* e.g. NatTheory *)
-      th_closed : ConstrSet.t;         (* e.g. [S; O] *)
-                                       (* Must be empty for an abstract ring *)
-    }
-
-(* Theories are stored in a table which is synchronised with the Reset
-   mechanism. *)
-
-module Cmap = Map.Make(struct type t = constr let compare = constr_ord end)
-
-let theories_map = ref Cmap.empty
-
-let theories_map_add (c,t) = theories_map := Cmap.add c t !theories_map
-let theories_map_find c = Cmap.find c !theories_map
-let theories_map_mem c = Cmap.mem c !theories_map
-
-let _ =
-  Summary.declare_summary "tactic-ring-table"
-    { Summary.freeze_function = (fun () -> !theories_map);
-      Summary.unfreeze_function = (fun t -> theories_map := t);
-      Summary.init_function = (fun () -> theories_map := Cmap.empty) }
-
-(* declare a new type of object in the environment, "tactic-ring-theory"
-   The functions theory_to_obj and obj_to_theory do the conversions
-   between theories and environement objects. *)
-
-
-let subst_morph subst morph =
-  let plusm' = subst_mps subst morph.plusm in
-  let multm' = subst_mps subst morph.multm in
-  let oppm' = Option.smartmap (subst_mps subst) morph.oppm in
-    if plusm' == morph.plusm
-      && multm' == morph.multm
-      && oppm' == morph.oppm then
-	morph
-    else
-      { plusm = plusm' ;
-	multm = multm' ;
-	oppm = oppm' ;
-      }
-
-let subst_set subst cset =
-  let same = ref true in
-  let copy_subst c newset =
-    let c' = subst_mps subst c in
-      if not (c' == c) then same := false;
-      ConstrSet.add c' newset
-  in
-  let cset' = ConstrSet.fold copy_subst cset ConstrSet.empty in
-    if !same then cset else cset'
-
-let subst_theory subst th =
-  let th_equiv' = Option.smartmap (subst_mps subst) th.th_equiv in
-  let th_setoid_th' = Option.smartmap (subst_mps subst) th.th_setoid_th in
-  let th_morph' = Option.smartmap (subst_morph subst) th.th_morph in
-  let th_a' = subst_mps subst th.th_a in
-  let th_plus' = subst_mps subst th.th_plus in
-  let th_mult' = subst_mps subst th.th_mult in
-  let th_one' = subst_mps subst th.th_one in
-  let th_zero' = subst_mps subst th.th_zero in
-  let th_opp' = Option.smartmap (subst_mps subst) th.th_opp in
-  let th_eq' = subst_mps subst th.th_eq in
-  let th_t' = subst_mps subst th.th_t in
-  let th_closed' = subst_set subst th.th_closed in
-    if th_equiv' == th.th_equiv
-      && th_setoid_th' == th.th_setoid_th
-      && th_morph' == th.th_morph
-      && th_a' == th.th_a
-      && th_plus' == th.th_plus
-      && th_mult' == th.th_mult
-      && th_one' == th.th_one
-      && th_zero' == th.th_zero
-      && th_opp' == th.th_opp
-      && th_eq' == th.th_eq
-      && th_t' == th.th_t
-      && th_closed' == th.th_closed
-    then
-      th
-    else
-    { th_ring = th.th_ring ;
-      th_abstract = th.th_abstract ;
-      th_setoid = th.th_setoid ;
-      th_equiv = th_equiv' ;
-      th_setoid_th = th_setoid_th' ;
-      th_morph = th_morph' ;
-      th_a = th_a' ;
-      th_plus = th_plus' ;
-      th_mult = th_mult' ;
-      th_one = th_one' ;
-      th_zero = th_zero' ;
-      th_opp = th_opp' ;
-      th_eq = th_eq' ;
-      th_t = th_t' ;
-      th_closed = th_closed' ;
-    }
-
-
-let subst_th (subst,(c,th as obj)) =
-  let c' = subst_mps subst c in
-  let th' = subst_theory subst th in
-    if c' == c && th' == th then obj else
-      (c',th')
-
-
-let theory_to_obj : constr * theory -> obj =
-  let cache_th (_,(c, th)) = theories_map_add (c,th) in
-  declare_object {(default_object "tactic-ring-theory") with
-		    open_function = (fun i o -> if i=1 then cache_th o);
-                    cache_function = cache_th;
-		    subst_function = subst_th;
-		    classify_function = (fun x -> Substitute x) }
-
-(* from the set A, guess the associated theory *)
-(* With this simple solution, the theory to use is automatically guessed *)
-(* But only one theory can be declared for a given Set *)
-
-let guess_theory a =
-  try
-    theories_map_find a
-  with Not_found ->
-    errorlabstrm "Ring"
-      (str "No Declared Ring Theory for " ++
-	 pr_lconstr a ++ fnl () ++
-	 str "Use Add [Semi] Ring to declare it")
-
-(* Looks up an option *)
-
-let unbox = function
-  | Some w -> w
-  | None -> anomaly "Ring : Not in case of a setoid ring."
-
-(* Protects the convertibility test against undue exceptions when using it
-   with untyped terms *)
-
-let safe_pf_conv_x gl c1 c2 =
-  try pf_conv_x gl c1 c2 with e when Errors.noncritical e -> false
-
-
-(* Add a Ring or a Semi-Ring to the database after a type verification *)
-
-let implement_theory env t th args =
-  is_conv env Evd.empty (Typing.type_of env Evd.empty t) (mkLApp (th, args))
-
-(* (\* The following test checks whether the provided morphism is the default *)
-(*    one for the given operation. In principle the test is too strict, since *)
-(*    it should possible to provide another proof for the same fact (proof *)
-(*    irrelevance). In particular, the error message is be not very explicative. *\) *)
-let states_compatibility_for env plus mult opp morphs =
- let check op compat = true in
-(*   is_conv env Evd.empty (Setoid_replace.default_morphism op).Setoid_replace.lem *)
-(*    compat in *)
- check plus morphs.plusm &&
- check mult morphs.multm &&
- (match (opp,morphs.oppm) with
-     None, None -> true
-   | Some opp, Some compat -> check opp compat
-   | _,_ -> assert false)
-
-let add_theory want_ring want_abstract want_setoid a aequiv asetth amorph aplus amult aone azero aopp aeq t cset =
-  if theories_map_mem a then errorlabstrm "Add Semi Ring"
-    (str "A (Semi-)(Setoid-)Ring Structure is already declared for " ++
-       pr_lconstr a);
-  let env = Global.env () in
-    if (want_ring & want_setoid & (
-	not (implement_theory env t coq_Setoid_Ring_Theory
-	  [| a; (unbox aequiv); aplus; amult; aone; azero; (unbox aopp); aeq|])
-        ||
-	not (implement_theory env (unbox asetth) coq_Setoid_Theory
-	  [| a; (unbox aequiv) |]) ||
-        not (states_compatibility_for env aplus amult aopp (unbox amorph))
-        )) then
-      errorlabstrm "addring" (str "Not a valid Setoid-Ring theory");
-    if (not want_ring & want_setoid & (
-        not (implement_theory env t coq_Semi_Setoid_Ring_Theory
-	  [| a; (unbox aequiv); aplus; amult; aone; azero; aeq|]) ||
-	not (implement_theory env (unbox asetth) coq_Setoid_Theory
-	  [| a; (unbox aequiv) |]) ||
-        not (states_compatibility_for env aplus amult aopp (unbox amorph))))
-    then
-      errorlabstrm "addring" (str "Not a valid Semi-Setoid-Ring theory");
-    if (want_ring & not want_setoid &
-	not (implement_theory env t coq_Ring_Theory
-	  [| a; aplus; amult; aone; azero; (unbox aopp); aeq |])) then
-      errorlabstrm "addring" (str "Not a valid Ring theory");
-    if (not want_ring & not want_setoid &
-	not (implement_theory env t coq_Semi_Ring_Theory
-	  [| a; aplus; amult; aone; azero; aeq |])) then
-      errorlabstrm "addring" (str "Not a valid Semi-Ring theory");
-    Lib.add_anonymous_leaf
-      (theory_to_obj
-	 (a, { th_ring = want_ring;
-	       th_abstract = want_abstract;
-	       th_setoid = want_setoid;
-	       th_equiv = aequiv;
-	       th_setoid_th = asetth;
-	       th_morph = amorph;
-	       th_a = a;
-	       th_plus = aplus;
-	       th_mult = amult;
-	       th_one = aone;
-	       th_zero = azero;
-	       th_opp = aopp;
-	       th_eq = aeq;
-	       th_t = t;
-	       th_closed = cset }))
-
-(******** The tactic itself *********)
-
-(*
-   gl : goal sigma
-   th : semi-ring theory (concrete)
-   cl : constr list [c1; c2; ...]
-
-Builds
-   - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ]
-  where c'i is convertible with ci and
-  c'i_eq_c''i is a proof of equality of c'i and c''i
-
-*)
-
-module Constrhash = Hashtbl.Make
-  (struct type t = constr
-	  let equal = eq_constr
-	  let hash = hash_constr
-   end)
-
-let build_spolynom gl th lc =
-  let varhash  = (Constrhash.create 17 : constr Constrhash.t) in
-  let varlist = ref ([] : constr list) in (* list of variables *)
-  let counter = ref 1 in (* number of variables created + 1 *)
-  (* aux creates the spolynom p by a recursive destructuration of c
-     and builds the varmap with side-effects *)
-  let rec aux c =
-    match (kind_of_term (strip_outer_cast c)) with
-      | App (binop,[|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus ->
-	  mkLApp(coq_SPplus, [|th.th_a; aux c1; aux c2 |])
-      | App (binop,[|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult ->
-	  mkLApp(coq_SPmult, [|th.th_a; aux c1; aux c2 |])
-      | _ when closed_under th.th_closed c ->
-	  mkLApp(coq_SPconst, [|th.th_a; c |])
-      | _ ->
-	  try Constrhash.find varhash c
-	  with Not_found ->
-	    let newvar =
-              mkLApp(coq_SPvar, [|th.th_a; (path_of_int !counter) |]) in
-	    begin
-	      incr counter;
-	      varlist := c :: !varlist;
-	      Constrhash.add varhash c newvar;
-	      newvar
-	    end
-  in
-  let lp = List.map aux lc in
-  let v = btree_of_array (Array.of_list (List.rev !varlist)) th.th_a in
-  List.map
-    (fun p ->
-       (mkLApp (coq_interp_sp,
-               [|th.th_a; th.th_plus; th.th_mult; th.th_zero; v; p |]),
-	mkLApp (coq_interp_cs,
-               [|th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v;
-		  pf_reduce cbv_betadeltaiota gl
-		    (mkLApp (coq_spolynomial_simplify,
-			    [| th.th_a; th.th_plus; th.th_mult;
-			       th.th_one; th.th_zero;
-			       th.th_eq; p|])) |]),
-	mkLApp (coq_spolynomial_simplify_ok,
-	        [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero;
-		  th.th_eq; v; th.th_t; p |])))
-    lp
-
-(*
-   gl : goal sigma
-   th : ring theory (concrete)
-   cl : constr list [c1; c2; ...]
-
-Builds
-   - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ]
-  where c'i is convertible with ci and
-  c'i_eq_c''i is a proof of equality of c'i and c''i
-
-*)
-
-let build_polynom gl th lc =
-  let varhash  = (Constrhash.create 17 : constr Constrhash.t) in
-  let varlist = ref ([] : constr list) in (* list of variables *)
-  let counter = ref 1 in (* number of variables created + 1 *)
-  let rec aux c =
-    match (kind_of_term (strip_outer_cast c)) with
-      | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus ->
-	  mkLApp(coq_Pplus, [|th.th_a; aux c1; aux c2 |])
-      | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult ->
-	  mkLApp(coq_Pmult, [|th.th_a; aux c1; aux c2 |])
-      (* The special case of Z.sub *)
-      | App (binop, [|c1; c2|])
-	  when safe_pf_conv_x gl c
-            (mkApp (th.th_plus, [|c1; mkApp(unbox th.th_opp, [|c2|])|])) ->
-	    mkLApp(coq_Pplus,
-                  [|th.th_a; aux c1;
-	            mkLApp(coq_Popp, [|th.th_a; aux c2|]) |])
-      | App (unop, [|c1|]) when safe_pf_conv_x gl unop (unbox th.th_opp) ->
-	  mkLApp(coq_Popp, [|th.th_a; aux c1|])
-      | _ when closed_under th.th_closed c ->
-	  mkLApp(coq_Pconst, [|th.th_a; c |])
-      | _ ->
-	  try Constrhash.find varhash c
-	  with Not_found ->
-	    let newvar =
-              mkLApp(coq_Pvar, [|th.th_a; (path_of_int !counter) |]) in
-	    begin
-	      incr counter;
-	      varlist := c :: !varlist;
-	      Constrhash.add varhash c newvar;
-	      newvar
-	    end
-  in
-  let lp = List.map aux lc in
-  let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in
-  List.map
-    (fun p ->
-       (mkLApp(coq_interp_p,
-	       [| th.th_a; th.th_plus; th.th_mult; th.th_zero;
-                 (unbox th.th_opp); v; p |])),
-	mkLApp(coq_interp_cs,
-	       [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v;
-		  pf_reduce cbv_betadeltaiota gl
-		    (mkLApp(coq_polynomial_simplify,
-			    [| th.th_a; th.th_plus; th.th_mult;
-			       th.th_one; th.th_zero;
-			       (unbox th.th_opp); th.th_eq; p |])) |]),
-	mkLApp(coq_polynomial_simplify_ok,
-	       [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero;
-		  (unbox th.th_opp); th.th_eq; v; th.th_t; p |]))
-    lp
-
-(*
-   gl : goal sigma
-   th : semi-ring theory (abstract)
-   cl : constr list [c1; c2; ...]
-
-Builds
-   - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ]
-  where c'i is convertible with ci and
-  c'i_eq_c''i is a proof of equality of c'i and c''i
-
-*)
-
-let build_aspolynom gl th lc =
-  let varhash  = (Constrhash.create 17 : constr Constrhash.t) in
-  let varlist = ref ([] : constr list) in (* list of variables *)
-  let counter = ref 1 in (* number of variables created + 1 *)
-  (* aux creates the aspolynom p by a recursive destructuration of c
-     and builds the varmap with side-effects *)
-  let rec aux c =
-    match (kind_of_term (strip_outer_cast c)) with
-      | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus ->
-	  mkLApp(coq_ASPplus, [| aux c1; aux c2 |])
-      | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult ->
-	  mkLApp(coq_ASPmult, [| aux c1; aux c2 |])
-      | _ when safe_pf_conv_x gl c th.th_zero -> Lazy.force coq_ASP0
-      | _ when safe_pf_conv_x gl c th.th_one -> Lazy.force coq_ASP1
-      | _ ->
-	  try Constrhash.find varhash c
-	  with Not_found ->
-	    let newvar = mkLApp(coq_ASPvar, [|(path_of_int !counter) |]) in
-	    begin
-	      incr counter;
-	      varlist := c :: !varlist;
-	      Constrhash.add varhash c newvar;
-	      newvar
-	    end
-  in
-  let lp = List.map aux lc in
-  let v = btree_of_array (Array.of_list (List.rev !varlist)) th.th_a in
-  List.map
-    (fun p ->
-       (mkLApp(coq_interp_asp,
-               [| th.th_a; th.th_plus; th.th_mult;
-		  th.th_one; th.th_zero; v; p |]),
-	mkLApp(coq_interp_acs,
-               [| th.th_a; th.th_plus; th.th_mult;
-		  th.th_one; th.th_zero; v;
-		  pf_reduce cbv_betadeltaiota gl
-		    (mkLApp(coq_aspolynomial_normalize,[|p|])) |]),
-	mkLApp(coq_spolynomial_simplify_ok,
-	       [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero;
-		  th.th_eq; v; th.th_t; p |])))
-    lp
-
-(*
-   gl : goal sigma
-   th : ring theory (abstract)
-   cl : constr list [c1; c2; ...]
-
-Builds
-   - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ]
-  where c'i is convertible with ci and
-  c'i_eq_c''i is a proof of equality of c'i and c''i
-
-*)
-
-let build_apolynom gl th lc =
-  let varhash  = (Constrhash.create 17 : constr Constrhash.t) in
-  let varlist = ref ([] : constr list) in (* list of variables *)
-  let counter = ref 1 in (* number of variables created + 1 *)
-  let rec aux c =
-    match (kind_of_term (strip_outer_cast c)) with
-      | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus ->
-	  mkLApp(coq_APplus, [| aux c1; aux c2 |])
-      | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult ->
-	  mkLApp(coq_APmult, [| aux c1; aux c2 |])
-      (* The special case of Z.sub *)
-      | App (binop, [|c1; c2|])
-	  when safe_pf_conv_x gl c
-            (mkApp(th.th_plus, [|c1; mkApp(unbox th.th_opp,[|c2|]) |])) ->
-	    mkLApp(coq_APplus,
-                   [|aux c1; mkLApp(coq_APopp,[|aux c2|]) |])
-      | App (unop, [|c1|]) when safe_pf_conv_x gl unop (unbox th.th_opp) ->
-	  mkLApp(coq_APopp, [| aux c1 |])
-      | _ when safe_pf_conv_x gl c th.th_zero -> Lazy.force coq_AP0
-      | _ when safe_pf_conv_x gl c th.th_one -> Lazy.force coq_AP1
-      | _ ->
-	  try Constrhash.find varhash c
-	  with Not_found ->
-	    let newvar =
-              mkLApp(coq_APvar, [| path_of_int !counter |]) in
-	    begin
-	      incr counter;
-	      varlist := c :: !varlist;
-	      Constrhash.add varhash c newvar;
-	      newvar
-	    end
-  in
-  let lp = List.map aux lc in
-  let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in
-  List.map
-    (fun p ->
-       (mkLApp(coq_interp_ap,
-	       [| th.th_a; th.th_plus; th.th_mult; th.th_one;
-		  th.th_zero; (unbox th.th_opp); v; p |]),
-	mkLApp(coq_interp_sacs,
-	       [| th.th_a; th.th_plus; th.th_mult;
-		  th.th_one; th.th_zero; (unbox th.th_opp); v;
-		  pf_reduce cbv_betadeltaiota gl
-		    (mkLApp(coq_apolynomial_normalize, [|p|])) |]),
-	mkLApp(coq_apolynomial_normalize_ok,
-	       [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero;
-		  (unbox th.th_opp); th.th_eq; v; th.th_t; p |])))
-    lp
-
-(*
-   gl : goal sigma
-   th : setoid ring theory (concrete)
-   cl : constr list [c1; c2; ...]
-
-Builds
-   - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ]
-  where c'i is convertible with ci and
-  c'i_eq_c''i is a proof of equality of c'i and c''i
-
-*)
-
-let build_setpolynom gl th lc =
-  let varhash  = (Constrhash.create 17 : constr Constrhash.t) in
-  let varlist = ref ([] : constr list) in (* list of variables *)
-  let counter = ref 1 in (* number of variables created + 1 *)
-  let rec aux c =
-    match (kind_of_term (strip_outer_cast c)) with
-      | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus ->
-	  mkLApp(coq_SetPplus, [|th.th_a; aux c1; aux c2 |])
-      | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult ->
-	  mkLApp(coq_SetPmult, [|th.th_a; aux c1; aux c2 |])
-      (* The special case of Z.sub *)
-      | App (binop, [|c1; c2|])
-	  when safe_pf_conv_x gl c
-	    (mkApp(th.th_plus, [|c1; mkApp(unbox th.th_opp,[|c2|])|])) ->
-	      mkLApp(coq_SetPplus,
-                     [| th.th_a; aux c1;
-			mkLApp(coq_SetPopp, [|th.th_a; aux c2|]) |])
-      | App (unop, [|c1|]) when safe_pf_conv_x gl unop (unbox th.th_opp) ->
-	  mkLApp(coq_SetPopp, [| th.th_a; aux c1 |])
-      | _ when closed_under th.th_closed c ->
-	  mkLApp(coq_SetPconst, [| th.th_a; c |])
-      | _ ->
-	  try Constrhash.find varhash c
-	  with Not_found ->
-	    let newvar =
-              mkLApp(coq_SetPvar, [| th.th_a; path_of_int !counter |]) in
-	    begin
-	      incr counter;
-	      varlist := c :: !varlist;
-	      Constrhash.add varhash c newvar;
-	      newvar
-	    end
-  in
-  let lp = List.map aux lc in
-  let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in
-  List.map
-    (fun p ->
-       (mkLApp(coq_interp_setp,
-	       [| th.th_a; th.th_plus; th.th_mult; th.th_zero;
-                  (unbox th.th_opp); v; p |]),
-	mkLApp(coq_interp_setcs,
-	       [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v;
-		  pf_reduce cbv_betadeltaiota gl
-		    (mkLApp(coq_setpolynomial_simplify,
-			    [| th.th_a; th.th_plus; th.th_mult;
-			       th.th_one; th.th_zero;
-			       (unbox th.th_opp); th.th_eq; p |])) |]),
-	mkLApp(coq_setpolynomial_simplify_ok,
-	       [| th.th_a; (unbox th.th_equiv); th.th_plus;
-                  th.th_mult; th.th_one; th.th_zero;(unbox th.th_opp);
-                  th.th_eq; (unbox th.th_setoid_th);
-		  (unbox th.th_morph).plusm; (unbox th.th_morph).multm;
-		  (unbox (unbox th.th_morph).oppm); v; th.th_t; p |])))
-    lp
-
-(*
-   gl : goal sigma
-   th : semi setoid ring theory (concrete)
-   cl : constr list [c1; c2; ...]
-
-Builds
-   - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ]
-  where c'i is convertible with ci and
-  c'i_eq_c''i is a proof of equality of c'i and c''i
-
-*)
-
-let build_setspolynom gl th lc =
-  let varhash  = (Constrhash.create 17 : constr Constrhash.t) in
-  let varlist = ref ([] : constr list) in (* list of variables *)
-  let counter = ref 1 in (* number of variables created + 1 *)
-  let rec aux c =
-    match (kind_of_term (strip_outer_cast c)) with
-      | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus ->
-	  mkLApp(coq_SetSPplus, [|th.th_a; aux c1; aux c2 |])
-      | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult ->
-	  mkLApp(coq_SetSPmult, [| th.th_a; aux c1; aux c2 |])
-      | _ when closed_under th.th_closed c ->
-	  mkLApp(coq_SetSPconst, [| th.th_a; c |])
-      | _ ->
-	  try Constrhash.find varhash c
-	  with Not_found ->
-	    let newvar =
-              mkLApp(coq_SetSPvar, [|th.th_a; path_of_int !counter |]) in
-	    begin
-	      incr counter;
-	      varlist := c :: !varlist;
-	      Constrhash.add varhash c newvar;
-	      newvar
-	    end
-  in
-  let lp = List.map aux lc in
-  let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in
-  List.map
-    (fun p ->
-       (mkLApp(coq_interp_setsp,
-	       [| th.th_a; th.th_plus; th.th_mult; th.th_zero; v; p |]),
-	mkLApp(coq_interp_setcs,
-               [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v;
-		  pf_reduce cbv_betadeltaiota gl
-		    (mkLApp(coq_setspolynomial_simplify,
-			    [| th.th_a; th.th_plus; th.th_mult;
-			       th.th_one; th.th_zero;
-			       th.th_eq; p |])) |]),
-	mkLApp(coq_setspolynomial_simplify_ok,
-	       [| th.th_a; (unbox th.th_equiv); th.th_plus;
-                  th.th_mult; th.th_one; th.th_zero; th.th_eq;
-                  (unbox th.th_setoid_th);
-		  (unbox th.th_morph).plusm;
-                  (unbox th.th_morph).multm; v; th.th_t; p |])))
-    lp
-
-module SectionPathSet =
-  Set.Make(struct
-	     type t = full_path
-	     let compare = Pervasives.compare
-	   end)
-
-(* Avec l'uniformisation des red_kind, on perd ici sur la structure
-   SectionPathSet; peut-être faudra-t-il la déplacer dans Closure *)
-let constants_to_unfold =
-(*  List.fold_right SectionPathSet.add *)
-  let transform s =
-    let sp = path_of_string s in
-    let dir, id = repr_path sp in
-      Libnames.encode_con dir id
-  in
-  List.map transform
-    [ "Coq.ring.Ring_normalize.interp_cs";
-      "Coq.ring.Ring_normalize.interp_var";
-      "Coq.ring.Ring_normalize.interp_vl";
-      "Coq.ring.Ring_abstract.interp_acs";
-      "Coq.ring.Ring_abstract.interp_sacs";
-      "Coq.quote.Quote.varmap_find";
-      (* anciennement des Local devenus Definition *)
-      "Coq.ring.Ring_normalize.ics_aux";
-      "Coq.ring.Ring_normalize.ivl_aux";
-      "Coq.ring.Ring_normalize.interp_m";
-      "Coq.ring.Ring_abstract.iacs_aux";
-      "Coq.ring.Ring_abstract.isacs_aux";
-      "Coq.ring.Setoid_ring_normalize.interp_cs";
-      "Coq.ring.Setoid_ring_normalize.interp_var";
-      "Coq.ring.Setoid_ring_normalize.interp_vl";
-      "Coq.ring.Setoid_ring_normalize.ics_aux";
-      "Coq.ring.Setoid_ring_normalize.ivl_aux";
-      "Coq.ring.Setoid_ring_normalize.interp_m";
-    ]
-(*    SectionPathSet.empty *)
-
-(* Unfolds the functions interp and find_btree in the term c of goal gl *)
-open RedFlags
-let polynom_unfold_tac =
-  let flags =
-    (mkflags(fBETA::fIOTA::(List.map fCONST constants_to_unfold))) in
-  reduct_in_concl (cbv_norm_flags flags,DEFAULTcast)
-
-let polynom_unfold_tac_in_term gl =
-  let flags =
-    (mkflags(fBETA::fIOTA::fZETA::(List.map fCONST constants_to_unfold)))
-  in
-  cbv_norm_flags flags (pf_env gl) (project gl)
-
-(* lc : constr list *)
-(* th : theory associated to t *)
-(* op : clause (None for conclusion or Some id for hypothesis id) *)
-(* gl : goal  *)
-(* Does the rewriting c_i -> (interp R RC v (polynomial_simplify p_i))
-   where the ring R, the Ring theory RC, the varmap v and the polynomials p_i
-   are guessed and such that c_i = (interp R RC v p_i) *)
-let raw_polynom th op lc gl =
-  (* first we sort the terms : if t' is a subterm of t it must appear
-     after t in the list. This is to avoid that the normalization of t'
-     modifies t in a non-desired way *)
-  let lc = sort_subterm gl lc in
-  let ltriplets =
-    if th.th_setoid then
-      if th.th_ring
-      then build_setpolynom gl th lc
-      else build_setspolynom gl th lc
-    else
-      if th.th_ring then
-	if th.th_abstract
-	then build_apolynom gl th lc
-	else build_polynom gl th lc
-      else
-	if th.th_abstract
-	then build_aspolynom gl th lc
-	else build_spolynom gl th lc in
-  let polynom_tac =
-    List.fold_right2
-      (fun ci (c'i, c''i, c'i_eq_c''i) tac ->
-         let c'''i =
-	   if !term_quality then polynom_unfold_tac_in_term gl c''i else c''i
-	 in
-         if !term_quality && safe_pf_conv_x gl c'''i ci then
-	   tac (* convertible terms *)
-         else if th.th_setoid
-	 then
-           (tclORELSE
-              (tclORELSE
-		 (h_exact c'i_eq_c''i)
-		 (h_exact (mkLApp(coq_seq_sym,
-				  [| th.th_a; (unbox th.th_equiv);
-                                     (unbox th.th_setoid_th);
-				     c'''i; ci; c'i_eq_c''i |]))))
-	      (tclTHENS
-		 (tclORELSE
-                   (Equality.general_rewrite true
-		     Termops.all_occurrences true false c'i_eq_c''i)
-                   (Equality.general_rewrite false
-		     Termops.all_occurrences true false c'i_eq_c''i))
-                 [tac]))
-	 else
-           (tclORELSE
-              (tclORELSE
-		 (h_exact c'i_eq_c''i)
-		 (h_exact (mkApp(build_coq_eq_sym (),
-				 [|th.th_a; c'''i; ci; c'i_eq_c''i |]))))
-	      (tclTHENS
-		 (elim_type
-		    (mkApp(build_coq_eq (), [|th.th_a; c'''i; ci |])))
-		 [ tac;
-                   h_exact c'i_eq_c''i ]))
-)
-      lc ltriplets polynom_unfold_tac
-  in
-  polynom_tac gl
-
-let guess_eq_tac th =
-  (tclORELSE reflexivity
-     (tclTHEN
-	polynom_unfold_tac
-        (tclTHEN
-	   (* Normalized sums associate on the right *)
-	   (tclREPEAT
-	      (tclTHENFIRST
-		 (apply (mkApp(build_coq_f_equal2 (),
-		               [| th.th_a; th.th_a; th.th_a;
-				  th.th_plus |])))
-		 reflexivity))
-	   (tclTRY
-	      (tclTHENLAST
-		 (apply (mkApp(build_coq_f_equal2 (),
-			       [| th.th_a; th.th_a; th.th_a;
-				  th.th_plus |])))
-		 reflexivity)))))
-
-let guess_equiv_tac th =
-  (tclORELSE (apply (mkLApp(coq_seq_refl,
-			    [| th.th_a; (unbox th.th_equiv);
-			       (unbox th.th_setoid_th)|])))
-     (tclTHEN
-	polynom_unfold_tac
-	(tclREPEAT
-	   (tclORELSE
-	      (apply (unbox th.th_morph).plusm)
-	      (apply (unbox th.th_morph).multm)))))
-
-let match_with_equiv c = match (kind_of_term c) with
-  | App (e,a) ->
-      if (List.mem e []) (*  (Setoid_replace.equiv_list ())) *)
-      then Some (decompose_app c)
-      else None
-  | _ -> None
-
-let polynom lc gl =
-  Coqlib.check_required_library ["Coq";"ring";"LegacyRing"];
-  match lc with
-   (* If no argument is given, try to recognize either an equality or
-      a declared relation with arguments c1 ... cn,
-      do "Ring c1 c2 ... cn" and then try to apply the simplification
-      theorems declared for the relation *)
-    | [] ->
-	(try
-	  match Hipattern.match_with_equation (pf_concl gl) with
-	   | _,_,Hipattern.PolymorphicLeibnizEq (t,c1,c2) ->
-	       let th = guess_theory t in
-	       (tclTHEN (raw_polynom th None [c1;c2]) (guess_eq_tac th)) gl
-	   | _,_,Hipattern.HeterogenousEq (t1,c1,t2,c2)
-	       when safe_pf_conv_x gl t1 t2 ->
-	       let th = guess_theory t1 in
-	       (tclTHEN (raw_polynom th None [c1;c2]) (guess_eq_tac th)) gl
-	   | _ -> raise Exit
-	  with Hipattern.NoEquationFound | Exit ->
-	          (match match_with_equiv (pf_concl gl) with
-		     | Some (equiv, c1::args) ->
-			 let t = (pf_type_of gl c1) in
-			 let th = (guess_theory t) in
-			   if List.exists
-			     (fun c2 -> not (safe_pf_conv_x gl t (pf_type_of gl c2))) args
-			   then
-			     errorlabstrm "Ring :"
-			       (str" All terms must have the same type");
-			   (tclTHEN (raw_polynom th None (c1::args)) (guess_equiv_tac th)) gl
-		     | _ -> errorlabstrm "polynom :"
-			 (str" This goal is not an equality nor a setoid equivalence")))
-    (* Elsewhere, guess the theory, check that all terms have the same type
-       and apply raw_polynom *)
-    | c :: lc' ->
-	let t = pf_type_of gl c in
-	let th = guess_theory t in
-	  if List.exists
-	    (fun c1 -> not (safe_pf_conv_x gl t (pf_type_of gl c1))) lc'
-	  then
-	    errorlabstrm "Ring :"
-	      (str" All terms must have the same type");
-	  (tclTHEN (raw_polynom th None lc) polynom_unfold_tac) gl
diff --git a/plugins/ring/ring_plugin.mllib b/plugins/ring/ring_plugin.mllib
deleted file mode 100644
index 3c5f995f..00000000
--- a/plugins/ring/ring_plugin.mllib
+++ /dev/null
@@ -1,3 +0,0 @@
-Ring
-G_ring
-Ring_plugin_mod
diff --git a/plugins/ring/vo.itarget b/plugins/ring/vo.itarget
deleted file mode 100644
index da387be8..00000000
--- a/plugins/ring/vo.itarget
+++ /dev/null
@@ -1,10 +0,0 @@
-LegacyArithRing.vo
-LegacyNArithRing.vo
-LegacyRing_theory.vo
-LegacyRing.vo
-LegacyZArithRing.vo
-Ring_abstract.vo
-Ring_normalize.vo
-Setoid_ring_normalize.vo
-Setoid_ring_theory.vo
-Setoid_ring.vo
diff --git a/plugins/romega/ReflOmegaCore.v b/plugins/romega/ReflOmegaCore.v
index ab424c22..b84cf254 100644
--- a/plugins/romega/ReflOmegaCore.v
+++ b/plugins/romega/ReflOmegaCore.v
@@ -980,9 +980,9 @@ Inductive p_step : Set :=
   | P_STEP : step -> p_step
   | P_NOP : p_step.
 
-(* List of normalizations to perform : with a constructor of type
-   [p_step] allowing to visit both left and right branches, we would be
-   able to restrict to only one normalization by hypothesis.
+(* List of normalizations to perform : if the type [p_step] had a constructor
+   that indicated visiting both left and right branches, we would be able to
+   restrict ourselves to the case of only one normalization by hypothesis.
    And since all hypothesis are useful (otherwise they wouldn't be included),
    we would be able to replace [h_step] by a simple list. *)
 
@@ -990,7 +990,7 @@ Inductive h_step : Set :=
     pair_step : nat -> p_step -> h_step.
 
 (* \subsubsection{Rules for decomposing the hypothesis} *)
-(* This type allows to navigate in the logical constructors that
+(* This type allows navigation in the logical constructors that
    form the predicats of the hypothesis in order to decompose them.
    This allows in particular to extract one hypothesis from a
    conjunction with possibly the right level of negations. *)
@@ -1000,7 +1000,7 @@ Inductive direction : Set :=
   | D_right : direction
   | D_mono : direction.
 
-(* This type allows to extract useful components from hypothesis, either
+(* This type allows extracting useful components from hypothesis, either
    hypothesis generated by splitting a disjonction, or equations.
    The last constructor indicates how to solve the obtained system
    via the use of the trace type of Omega [t_omega] *)
@@ -1014,7 +1014,7 @@ Inductive e_step : Set :=
 (* For each reified data-type, we define an efficient equality test.
    It is not the one produced by [Decide Equality].
 
-   Then we prove two theorem allowing to eliminate such equalities :
+   Then we prove two theorem allowing elimination of such equalities :
    \begin{verbatim}
    (t1,t2: typ) (eq_typ t1 t2) = true -> t1 = t2.
    (t1,t2: typ) (eq_typ t1 t2) = false -> ~ t1 = t2.
@@ -1284,7 +1284,7 @@ Qed.
 
 (* Extraire une hypothèse de la liste *)
 Definition nth_hyps (n : nat) (l : hyps) := nth n l TrueTerm.
-
+Unset Printing Notations.
 Theorem nth_valid :
  forall (ep : list Prop) (e : list int) (i : nat) (l : hyps),
  interp_hyps ep e l -> interp_proposition ep e (nth_hyps i l).
diff --git a/plugins/romega/const_omega.ml b/plugins/romega/const_omega.ml
index fb45e816..21b0f78b 100644
--- a/plugins/romega/const_omega.ml
+++ b/plugins/romega/const_omega.ml
@@ -1,7 +1,7 @@
 (*************************************************************************
 
    PROJET RNRT Calife - 2001
-   Author: Pierre Crégut - France Télécom R&D
+   Author: Pierre Crégut - France Télécom R&D
    Licence : LGPL version 2.1
 
  *************************************************************************)
@@ -19,27 +19,27 @@ let meaningful_submodule = [ "Z"; "N"; "Pos" ]
 
 let string_of_global r =
   let dp = Nametab.dirpath_of_global r in
-  let prefix = match Names.repr_dirpath dp with
+  let prefix = match Names.DirPath.repr dp with
     | [] -> ""
     | m::_ ->
-      let s = Names.string_of_id m in
-      if List.mem s meaningful_submodule then s^"." else ""
+      let s = Names.Id.to_string m in
+      if Util.String.List.mem s meaningful_submodule then s^"." else ""
   in
-  prefix^(Names.string_of_id (Nametab.basename_of_global r))
+  prefix^(Names.Id.to_string (Nametab.basename_of_global r))
 
 let destructurate t =
   let c, args = Term.decompose_app t in
   match Term.kind_of_term c, args with
-    | Term.Const sp, args ->
-	Kapp (string_of_global (Libnames.ConstRef sp), args)
-    | Term.Construct csp , args ->
-	Kapp (string_of_global (Libnames.ConstructRef csp), args)
-    | Term.Ind isp, args ->
-	Kapp (string_of_global (Libnames.IndRef isp), args)
-    | Term.Var id,[] -> Kvar(Names.string_of_id id)
+    | Term.Const (sp,_), args ->
+	Kapp (string_of_global (Globnames.ConstRef sp), args)
+    | Term.Construct (csp,_) , args ->
+	Kapp (string_of_global (Globnames.ConstructRef csp), args)
+    | Term.Ind (isp,_), args ->
+	Kapp (string_of_global (Globnames.IndRef isp), args)
+    | Term.Var id,[] -> Kvar(Names.Id.to_string id)
     | Term.Prod (Names.Anonymous,typ,body), [] -> Kimp(typ,body)
     | Term.Prod (Names.Name _,_,_),[] ->
-	Util.error "Omega: Not a quantifier-free goal"
+	Errors.error "Omega: Not a quantifier-free goal"
     | _ -> Kufo
 
 exception Destruct
@@ -48,9 +48,9 @@ let dest_const_apply t =
   let f,args = Term.decompose_app t in
   let ref =
   match Term.kind_of_term f with
-    | Term.Const sp      -> Libnames.ConstRef sp
-    | Term.Construct csp -> Libnames.ConstructRef csp
-    | Term.Ind isp       -> Libnames.IndRef isp
+    | Term.Const (sp,_)      -> Globnames.ConstRef sp
+    | Term.Construct (csp,_) -> Globnames.ConstructRef csp
+    | Term.Ind (isp,_)       -> Globnames.IndRef isp
     | _ -> raise Destruct
   in  Nametab.basename_of_global ref, args
 
@@ -71,7 +71,6 @@ let z_constant = Coqlib.gen_constant_in_modules "Omega" z_module
 let bin_constant = Coqlib.gen_constant_in_modules "Omega" bin_module
 
 (* Logic *)
-let coq_eq = lazy(init_constant  "eq")
 let coq_refl_equal = lazy(init_constant  "eq_refl")
 let coq_and = lazy(init_constant "and")
 let coq_not = lazy(init_constant "not")
@@ -211,19 +210,31 @@ let rec mk_nat = function
 
 (* Lists *)
 
-let coq_cons =  lazy (constant "cons")
-let coq_nil =  lazy (constant "nil")
+let mkListConst c = 
+  let r = 
+    Coqlib.gen_reference "" ["Init";"Datatypes"] c
+  in 
+  let inst = 
+    if Global.is_polymorphic r then fun u -> Univ.Instance.of_array [|u|]
+    else fun _ -> Univ.Instance.empty
+  in
+    fun u -> Term.mkConstructU (Globnames.destConstructRef r, inst u)
+
+let coq_cons univ typ = Term.mkApp (mkListConst "cons" univ, [|typ|])
+let coq_nil univ typ =  Term.mkApp (mkListConst "nil" univ, [|typ|])
 
-let mk_list typ l =
+let mk_list univ typ l =
   let rec loop = function
-    | [] ->
-	Term.mkApp (Lazy.force coq_nil, [|typ|])
+    | [] -> coq_nil univ typ
     | (step :: l) ->
-	Term.mkApp (Lazy.force coq_cons, [|typ; step; loop l |]) in
+	Term.mkApp (coq_cons univ typ, [| step; loop l |]) in
   loop l
 
-let mk_plist l = mk_list Term.mkProp l
+let mk_plist = 
+  let type1lev = Universes.new_univ_level (Global.current_dirpath ()) in
+    fun l -> mk_list type1lev Term.mkProp l
 
+let mk_list = mk_list Univ.Level.set
 let mk_shuffle_list l = mk_list (Lazy.force coq_t_fusion) l
 
 
@@ -297,13 +308,13 @@ let coq_Zneg = lazy (bin_constant "Zneg")
 let recognize t =
   let rec loop t =
     let f,l = dest_const_apply t in
-    match Names.string_of_id f,l with
+    match Names.Id.to_string f,l with
        "xI",[t] -> Bigint.add Bigint.one (Bigint.mult Bigint.two (loop t))
      | "xO",[t] -> Bigint.mult Bigint.two (loop t)
      | "xH",[] -> Bigint.one
      | _ -> failwith "not a number" in
   let f,l = dest_const_apply t in
-    match Names.string_of_id f,l with
+    match Names.Id.to_string f,l with
         "Zpos",[t] -> loop t
       | "Zneg",[t] -> Bigint.neg (loop t)
       | "Z0",[] -> Bigint.zero
@@ -353,7 +364,7 @@ let parse_rel gl t =
 
 let is_scalar t =
   let rec aux t = match destructurate t with
-    | Kapp(("Z.add"|"Z.sub"|"Z.mul"),[t1;t2]) -> aux t1 & aux t2
+    | Kapp(("Z.add"|"Z.sub"|"Z.mul"),[t1;t2]) -> aux t1 && aux t2
     | Kapp(("Z.opp"|"Z.succ"|"Z.pred"),[t]) -> aux t
     | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> let _ = recognize t in true
     | _ -> false in
diff --git a/plugins/romega/const_omega.mli b/plugins/romega/const_omega.mli
index b8db71e4..af50ea0f 100644
--- a/plugins/romega/const_omega.mli
+++ b/plugins/romega/const_omega.mli
@@ -1,7 +1,7 @@
 (*************************************************************************
 
    PROJET RNRT Calife - 2001
-   Author: Pierre Crégut - France Télécom R&D
+   Author: Pierre Crégut - France Télécom R&D
    Licence : LGPL version 2.1
 
  *************************************************************************)
@@ -117,6 +117,7 @@ val do_seq : Term.constr -> Term.constr -> Term.constr
 val do_list : Term.constr list -> Term.constr
 
 val mk_nat : int -> Term.constr
+(** Precondition: the type of the list is in Set *)
 val mk_list : Term.constr -> Term.constr list -> Term.constr
 val mk_plist : Term.types list -> Term.types
 val mk_shuffle_list : Term.constr list -> Term.constr
diff --git a/plugins/romega/g_romega.ml4 b/plugins/romega/g_romega.ml4
index 2db86e00..0a99a26b 100644
--- a/plugins/romega/g_romega.ml4
+++ b/plugins/romega/g_romega.ml4
@@ -1,15 +1,16 @@
 (*************************************************************************
 
    PROJET RNRT Calife - 2001
-   Author: Pierre Crégut - France Télécom R&D
+   Author: Pierre Crégut - France Télécom R&D
    Licence : LGPL version 2.1
 
  *************************************************************************)
 
-(*i camlp4deps: "parsing/grammar.cma" i*)
+(*i camlp4deps: "grammar/grammar.cma" i*)
+
+DECLARE PLUGIN "romega_plugin"
 
 open Refl_omega
-open Refiner
 
 let romega_tactic l =
   let tacs = List.map
@@ -18,17 +19,17 @@ let romega_tactic l =
        | "positive" -> Tacinterp.interp <:tactic<zify_positive>>
        | "N" -> Tacinterp.interp <:tactic<zify_N>>
        | "Z" -> Tacinterp.interp <:tactic<zify_op>>
-       | s -> Util.error ("No ROmega knowledge base for type "^s))
-    (Util.list_uniquize (List.sort compare l))
+       | s -> Errors.error ("No ROmega knowledge base for type "^s))
+    (Util.List.sort_uniquize String.compare l)
   in
-  tclTHEN
-    (tclREPEAT (tclPROGRESS (tclTHENLIST tacs)))
-    (tclTHEN
+  Tacticals.New.tclTHEN
+    (Tacticals.New.tclREPEAT (Proofview.tclPROGRESS (Tacticals.New.tclTHENLIST tacs)))
+    (Tacticals.New.tclTHEN
        (* because of the contradiction process in (r)omega,
           we'd better leave as little as possible in the conclusion,
           for an easier decidability argument. *)
-       Tactics.intros
-       total_reflexive_omega_tactic)
+       (Tactics.intros)
+       (Proofview.V82.tactic total_reflexive_omega_tactic))
 
 
 TACTIC EXTEND romega
@@ -37,6 +38,6 @@ END
 
 TACTIC EXTEND romega'
 | [ "romega" "with" ne_ident_list(l) ] ->
-    [ romega_tactic (List.map Names.string_of_id l) ]
+    [ romega_tactic (List.map Names.Id.to_string l) ]
 | [ "romega" "with" "*" ] -> [ romega_tactic ["nat";"positive";"N";"Z"] ]
 END
diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml
index e57230cb..8156e841 100644
--- a/plugins/romega/refl_omega.ml
+++ b/plugins/romega/refl_omega.ml
@@ -1,11 +1,12 @@
 (*************************************************************************
 
    PROJET RNRT Calife - 2001
-   Author: Pierre Crégut - France Télécom R&D
+   Author: Pierre Crégut - France Télécom R&D
    Licence : LGPL version 2.1
 
  *************************************************************************)
 
+open Pp
 open Util
 open Const_omega
 module OmegaSolver = Omega.MakeOmegaSolver (Bigint)
@@ -16,7 +17,7 @@ open OmegaSolver
 let debug = ref false
 
 let show_goal gl =
-  if !debug then Pp.ppnl (Tacmach.pr_gls gl); Tacticals.tclIDTAC gl
+  if !debug then (); Tacticals.tclIDTAC gl
 
 let pp i = print_int i; print_newline (); flush stdout
 
@@ -37,9 +38,13 @@ type direction = Left of int | Right of int
 type occ_step = O_left | O_right | O_mono
 type occ_path = occ_step list
 
-(* chemin identifiant une proposition sous forme du nom de l'hypothèse et
-   d'une liste de pas à partir de la racine de l'hypothèse *)
-type occurence = {o_hyp : Names.identifier; o_path : occ_path}
+let occ_step_eq s1 s2 = match s1, s2 with
+| O_left, O_left | O_right, O_right | O_mono, O_mono -> true
+| _ -> false
+
+(* chemin identifiant une proposition sous forme du nom de l'hypothèse et
+   d'une liste de pas à partir de la racine de l'hypothèse *)
+type occurence = {o_hyp : Names.Id.t; o_path : occ_path}
 
 (* \subsection{refiable formulas} *)
 type oformula =
@@ -58,7 +63,7 @@ type oformula =
 (* Operators for comparison recognized by Omega *)
 type comparaison = Eq | Leq | Geq | Gt | Lt | Neq
 
-(* Type des prédicats réifiés (fragment de calcul propositionnel. Les
+(* Type des prédicats réifiés (fragment de calcul propositionnel. Les
  * quantifications sont externes au langage) *)
 type oproposition =
     Pequa of Term.constr * oequation
@@ -70,19 +75,19 @@ type oproposition =
   | Pimp of int * oproposition * oproposition
   | Pprop of Term.constr
 
-(* Les équations ou proposiitions atomiques utiles du calcul *)
+(* Les équations ou proposiitions atomiques utiles du calcul *)
 and oequation = {
     e_comp: comparaison;		(* comparaison *)
     e_left: oformula;			(* formule brute gauche *)
     e_right: oformula;			(* formule brute droite *)
     e_trace: Term.constr;		(* tactique de normalisation *)
-    e_origin: occurence;		(* l'hypothèse dont vient le terme *)
-    e_negated: bool;			(* vrai si apparait en position nié
-					   après normalisation *)
+    e_origin: occurence;		(* l'hypothèse dont vient le terme *)
+    e_negated: bool;			(* vrai si apparait en position nié
+					   après normalisation *)
     e_depends: direction  list;		(* liste des points de disjonction dont
-					   dépend l'accès à l'équation avec la
-					   direction (branche) pour y accéder *)
-    e_omega: afine		(* la fonction normalisée *)
+					   dépend l'accès à l'équation avec la
+					   direction (branche) pour y accéder *)
+    e_omega: afine		(* la fonction normalisée *)
   }
 
 (* \subsection{Proof context}
@@ -101,8 +106,8 @@ type environment = {
   mutable props : Term.constr list;
   (* Les variables introduites par omega *)
   mutable om_vars : (oformula * int) list;
-  (* Traduction des indices utilisés ici en les indices finaux utilisés par
-   * la tactique Omega après dénombrement des variables utiles *)
+  (* Traduction des indices utilisés ici en les indices finaux utilisés par
+   * la tactique Omega après dénombrement des variables utiles *)
   real_indices : (int,int) Hashtbl.t;
   mutable cnt_connectors : int;
   equations : (int,oequation) Hashtbl.t;
@@ -110,35 +115,35 @@ type environment = {
 }
 
 (* \subsection{Solution tree}
-   Définition d'une solution trouvée par Omega sous la forme d'un identifiant,
-   d'un ensemble d'équation dont dépend la solution et d'une trace *)
-(* La liste des dépendances est triée et sans redondance *)
+   Définition d'une solution trouvée par Omega sous la forme d'un identifiant,
+   d'un ensemble d'équation dont dépend la solution et d'une trace *)
+(* La liste des dépendances est triée et sans redondance *)
 type solution = {
   s_index : int;
   s_equa_deps : int list;
   s_trace : action list }
 
-(* Arbre de solution résolvant complètement un ensemble de systèmes *)
+(* Arbre de solution résolvant complètement un ensemble de systèmes *)
 type solution_tree =
     Leaf of solution
-    (* un noeud interne représente un point de branchement correspondant à
-       l'élimination d'un connecteur générant plusieurs buts
+    (* un noeud interne représente un point de branchement correspondant à
+       l'élimination d'un connecteur générant plusieurs buts
        (typ. disjonction). Le premier argument
        est l'identifiant du connecteur *)
   | Tree of int * solution_tree * solution_tree
 
-(* Représentation de l'environnement extrait du but initial sous forme de
-   chemins pour extraire des equations ou d'hypothèses *)
+(* Représentation de l'environnement extrait du but initial sous forme de
+   chemins pour extraire des equations ou d'hypothèses *)
 
 type context_content =
     CCHyp of occurence
   | CCEqua of int
 
 (* \section{Specific utility functions to handle base types} *)
-(* Nom arbitraire de l'hypothèse codant la négation du but final *)
-let id_concl = Names.id_of_string "__goal__"
+(* Nom arbitraire de l'hypothèse codant la négation du but final *)
+let id_concl = Names.Id.of_string "__goal__"
 
-(* Initialisation de l'environnement de réification de la tactique *)
+(* Initialisation de l'environnement de réification de la tactique *)
 let new_environment () = {
   terms = []; props = []; om_vars = []; cnt_connectors = 0;
   real_indices = Hashtbl.create 7;
@@ -146,29 +151,28 @@ let new_environment () = {
   constructors = Hashtbl.create 7;
 }
 
-(* Génération d'un nom d'équation *)
+(* Génération d'un nom d'équation *)
 let new_connector_id env =
    env.cnt_connectors <- succ env.cnt_connectors; env.cnt_connectors
 
-(* Calcul de la branche complémentaire *)
+(* Calcul de la branche complémentaire *)
 let barre = function Left x -> Right x | Right x -> Left x
 
-(* Identifiant associé à une branche *)
+(* Identifiant associé à une branche *)
 let indice = function Left x | Right x -> x
 
-(* Affichage de l'environnement de réification (termes et propositions) *)
+(* Affichage de l'environnement de réification (termes et propositions) *)
 let print_env_reification env =
   let rec loop c i = function
-      [] -> Printf.printf "  ===============================\n\n"
+      [] ->  str "  ===============================\n\n"
     | t :: l ->
-	Printf.printf "  (%c%02d) := " c i;
-	Pp.ppnl (Printer.pr_lconstr t);
-	Pp.flush_all ();
-	loop c (succ i) l in
-  print_newline ();
-  Printf.printf "  ENVIRONMENT OF PROPOSITIONS :\n\n"; loop 'P' 0 env.props;
-  Printf.printf "  ENVIRONMENT OF TERMS :\n\n"; loop 'V' 0 env.terms
-
+      let s = Printf.sprintf "(%c%02d)" c i in
+      spc () ++ str s ++ str " := " ++ Printer.pr_lconstr t ++ fnl () ++
+      loop c (succ i) l
+  in
+  let prop_info = str "ENVIRONMENT OF PROPOSITIONS :" ++ fnl () ++ loop 'P' 0 env.props in
+  let term_info = str "ENVIRONMENT OF TERMS :" ++ fnl () ++ loop 'V' 0 env.terms in
+  msg_debug (prop_info ++ fnl () ++ term_info)
 
 (* \subsection{Gestion des environnements de variable pour Omega} *)
 (* generation d'identifiant d'equation pour Omega *)
@@ -185,75 +189,73 @@ let new_omega_var, rst_omega_var =
   (function () -> incr cpt; !cpt),
   (function () -> cpt:=0)
 
-(* Affichage des variables d'un système *)
+(* Affichage des variables d'un système *)
 
 let display_omega_var i = Printf.sprintf "OV%d" i
 
-(* Recherche la variable codant un terme pour Omega et crée la variable dans
-   l'environnement si il n'existe pas. Cas ou la variable dans Omega représente
+(* Recherche la variable codant un terme pour Omega et crée la variable dans
+   l'environnement si il n'existe pas. Cas ou la variable dans Omega représente
    le terme d'un monome (le plus souvent un atome) *)
 
 let intern_omega env t =
-  begin try List.assoc t env.om_vars
+  begin try List.assoc_f Pervasives.(=) t env.om_vars (* FIXME *)
   with Not_found ->
     let v = new_omega_var () in
     env.om_vars <- (t,v) :: env.om_vars; v
   end
 
-(* Ajout forcé d'un lien entre un terme et une variable  Cas où la
-   variable est créée par Omega et où il faut la lier après coup à un atome
-   réifié introduit de force *)
+(* Ajout forcé d'un lien entre un terme et une variable  Cas où la
+   variable est créée par Omega et où il faut la lier après coup à un atome
+   réifié introduit de force *)
 let intern_omega_force env t v = env.om_vars <- (t,v) :: env.om_vars
 
-(* Récupère le terme associé à une variable *)
+(* Récupère le terme associé à une variable *)
 let unintern_omega env id =
   let rec loop = function
 	[] -> failwith "unintern"
-      | ((t,j)::l) -> if id = j then t else loop l in
+      | ((t,j)::l) -> if Int.equal id j then t else loop l in
   loop env.om_vars
 
-(* \subsection{Gestion des environnements de variable pour la réflexion}
+(* \subsection{Gestion des environnements de variable pour la réflexion}
    Gestion des environnements de traduction entre termes des constructions
-   non réifiés et variables des termes reifies. Attention il s'agit de
-   l'environnement initial contenant tout. Il faudra le réduire après
+   non réifiés et variables des termes reifies. Attention il s'agit de
+   l'environnement initial contenant tout. Il faudra le réduire après
    calcul des variables utiles. *)
 
 let add_reified_atom t env =
-  try list_index0_f Term.eq_constr t env.terms
+  try List.index0 Term.eq_constr t env.terms
   with Not_found ->
     let i = List.length env.terms in
     env.terms <- env.terms @ [t]; i
 
 let get_reified_atom env =
-  try List.nth env.terms
-  with e when Errors.noncritical e -> failwith "get_reified_atom"
+  try List.nth env.terms with Invalid_argument _ -> failwith "get_reified_atom"
 
 (* \subsection{Gestion de l'environnement de proposition pour Omega} *)
 (* ajout d'une proposition *)
 let add_prop env t =
-  try list_index0_f Term.eq_constr t env.props
+  try List.index0 Term.eq_constr t env.props
   with Not_found ->
     let i = List.length env.props in  env.props <- env.props @ [t]; i
 
-(* accès a une proposition *)
+(* accès a une proposition *)
 let get_prop v env =
-  try List.nth v env
-  with e when Errors.noncritical e -> failwith "get_prop"
+  try List.nth v env with Invalid_argument _ -> failwith "get_prop"
 
-(* \subsection{Gestion du nommage des équations} *)
+(* \subsection{Gestion du nommage des équations} *)
 (* Ajout d'une equation dans l'environnement de reification *)
 let add_equation env e =
   let id = e.e_omega.id in
   try let _ = Hashtbl.find env.equations id in ()
   with Not_found -> Hashtbl.add env.equations id e
 
-(* accès a une equation *)
+(* accès a une equation *)
 let get_equation env id =
   try Hashtbl.find env.equations id
   with Not_found as e ->
-    Printf.printf "Omega Equation %d non trouvée\n" id; raise e
+    Printf.printf "Omega Equation %d non trouvée\n" id; raise e
 
-(* Affichage des termes réifiés *)
+(* Affichage des termes réifiés *)
 let rec oprint ch = function
   | Oint n -> Printf.fprintf ch "%s" (Bigint.to_string n)
   | Oplus (t1,t2) -> Printf.fprintf ch "(%a + %a)" oprint t1 oprint t2
@@ -287,7 +289,7 @@ let rec weight env = function
   | Oufo _ -> -1
   | Oatom _ as c -> (intern_omega env c)
 
-(* \section{Passage entre oformules et représentation interne de Omega} *)
+(* \section{Passage entre oformules et représentation interne de Omega} *)
 
 (* \subsection{Oformula vers Omega} *)
 
@@ -305,7 +307,7 @@ let omega_of_oformula env kind =
 
 (* \subsection{Omega vers Oformula} *)
 
-let rec oformula_of_omega env af =
+let oformula_of_omega env af =
   let rec loop = function
     | ({v=v; c=n}::r) ->
 	Oplus(Omult(unintern_omega env v,Oint n),loop r)
@@ -316,7 +318,7 @@ let app f v = mkApp(Lazy.force f,v)
 
 (* \subsection{Oformula vers COQ reel} *)
 
-let rec coq_of_formula env t =
+let coq_of_formula env t =
   let rec loop = function
   | Oplus (t1,t2) -> app Z.plus [| loop t1; loop t2 |]
   | Oopp t -> app Z.opp [| loop t |]
@@ -330,12 +332,12 @@ let rec coq_of_formula env t =
   | Ominus(t1,t2) -> app Z.minus [| loop t1; loop t2 |] in
   loop t
 
-(* \subsection{Oformula vers COQ reifié} *)
+(* \subsection{Oformula vers COQ reifié} *)
 
 let reified_of_atom env i =
   try Hashtbl.find env.real_indices i
   with Not_found ->
-    Printf.printf "Atome %d non trouvé\n" i;
+    Printf.printf "Atome %d non trouvé\n" i;
     Hashtbl.iter (fun k v -> Printf.printf "%d -> %d\n" k v) env.real_indices;
     raise Not_found
 
@@ -388,7 +390,7 @@ let reified_of_proposition env f =
   try reified_of_proposition env f
   with reraise -> pprint stderr f; raise reraise
 
-(* \subsection{Omega vers COQ réifié} *)
+(* \subsection{Omega vers COQ réifié} *)
 
 let reified_of_omega env body constant =
   let coeff_constant =
@@ -402,21 +404,18 @@ let reified_of_omega env body constant =
   List.fold_right mk_coeff body coeff_constant
 
 let reified_of_omega env body c  =
-  try
-    reified_of_omega env body c
-  with reraise ->
-    display_eq display_omega_var (body,c); raise reraise
+  try reified_of_omega env body c
+  with reraise -> display_eq display_omega_var (body,c); raise reraise
 
+(* \section{Opérations sur les équations}
+Ces fonctions préparent les traces utilisées par la tactique réfléchie
+pour faire des opérations de normalisation sur les équations.  *)
 
-(* \section{Opérations sur les équations}
-Ces fonctions préparent les traces utilisées par la tactique réfléchie
-pour faire des opérations de normalisation sur les équations.  *)
+(* \subsection{Extractions des variables d'une équation} *)
+(* Extraction des variables d'une équation. *)
+(* Chaque fonction retourne une liste triée sans redondance *)
 
-(* \subsection{Extractions des variables d'une équation} *)
-(* Extraction des variables d'une équation. *)
-(* Chaque fonction retourne une liste triée sans redondance *)
-
-let (@@) = list_merge_uniq compare
+let (@@) = List.merge_uniq compare
 
 let rec vars_of_formula = function
   | Oint _ -> []
@@ -455,7 +454,7 @@ let rec scalar n = function
  | Omult(t1,Oint x) ->
      do_list [Lazy.force coq_c_mult_assoc_reduced], Omult(t1,Oint (n*x))
  | Omult(t1,t2) ->
-     Util.error "Omega: Can't solve a goal with non-linear products"
+     Errors.error "Omega: Can't solve a goal with non-linear products"
  | (Oatom _ as t) -> do_list [], Omult(t,Oint n)
  | Oint i -> do_list [Lazy.force coq_c_reduce],Oint(n*i)
  | (Oufo _ as t)-> do_list [], Oufo (Omult(t,Oint n))
@@ -474,23 +473,23 @@ let rec negate = function
  | Omult(t1,Oint x) ->
      do_list [Lazy.force coq_c_opp_mult_r], Omult(t1,Oint (Bigint.neg x))
  | Omult(t1,t2) ->
-     Util.error "Omega: Can't solve a goal with non-linear products"
+     Errors.error "Omega: Can't solve a goal with non-linear products"
  | (Oatom _ as t) ->
      do_list [Lazy.force coq_c_opp_one], Omult(t,Oint(negone))
  | Oint i -> do_list [Lazy.force coq_c_reduce] ,Oint(Bigint.neg i)
  | Oufo c -> do_list [], Oufo (Oopp c)
  | Ominus _ -> failwith "negate minus"
 
-let rec norm l = (List.length l)
+let norm l = (List.length l)
 
-(* \subsection{Mélange (fusion) de deux équations} *)
+(* \subsection{Mélange (fusion) de deux équations} *)
 (* \subsubsection{Version avec coefficients} *)
-let rec shuffle_path k1 e1 k2 e2 =
+let shuffle_path k1 e1 k2 e2 =
   let rec loop = function
       (({c=c1;v=v1}::l1) as l1'),
       (({c=c2;v=v2}::l2) as l2') ->
-	if v1 = v2 then
-          if k1*c1 + k2 * c2 = zero then (
+	if Int.equal v1 v2 then
+          if Bigint.equal (k1 * c1 + k2 * c2) zero then (
             Lazy.force coq_f_cancel :: loop (l1,l2))
           else (
             Lazy.force coq_f_equal :: loop (l1,l2) )
@@ -532,7 +531,7 @@ let rec shuffle env (t1,t2) =
 	do_list [Lazy.force coq_c_plus_comm], Oplus(t2,t1)
       else do_list [],Oplus(t1,t2)
 
-(* \subsection{Fusion avec réduction} *)
+(* \subsection{Fusion avec réduction} *)
 
 let shrink_pair f1 f2 =
   begin match f1,f2 with
@@ -546,7 +545,7 @@ let shrink_pair f1 f2 =
        Lazy.force coq_c_red4, Omult(Oatom v,Oplus(c1,c2))
    | t1,t2 ->
        oprint stdout t1; print_newline (); oprint stdout t2; print_newline ();
-       flush Pervasives.stdout; Util.error "shrink.1"
+       flush Pervasives.stdout; Errors.error "shrink.1"
   end
 
 (* \subsection{Calcul d'une sous formule constante} *)
@@ -560,15 +559,15 @@ let reduce_factor = function
       let rec compute = function
           Oint n -> n
 	| Oplus(t1,t2) -> compute t1 + compute t2
-	| _ -> Util.error "condense.1" in
+	| _ -> Errors.error "condense.1" in
 	[Lazy.force coq_c_reduce], Omult(Oatom v,Oint(compute c))
-  | t -> Util.error "reduce_factor.1"
+  | t -> Errors.error "reduce_factor.1"
 
-(* \subsection{Réordonnancement} *)
+(* \subsection{Réordonnancement} *)
 
 let rec condense env = function
     Oplus(f1,(Oplus(f2,r) as t)) ->
-      if weight env f1 = weight env f2 then begin
+      if Int.equal (weight env f1) (weight env f2) then begin
 	let shrink_tac,t = shrink_pair f1 f2 in
 	let assoc_tac = Lazy.force coq_c_plus_assoc_l in
 	let tac_list,t' = condense env (Oplus(t,r)) in
@@ -582,7 +581,7 @@ let rec condense env = function
       let tac,f1' = reduce_factor f1 in
       [do_left (do_list tac)],Oplus(f1',Oint n)
   | Oplus(f1,f2) ->
-      if weight env f1 = weight env f2 then begin
+      if Int.equal (weight env f1) (weight env f2) then begin
 	let tac_shrink,t = shrink_pair f1 f2 in
 	let tac,t' = condense env t in
 	tac_shrink :: tac,t'
@@ -597,18 +596,18 @@ let rec condense env = function
       let final = Oplus(t',Oint zero) in
       tac @ [Lazy.force coq_c_red6], final
 
-(* \subsection{Elimination des zéros} *)
+(* \subsection{Elimination des zéros} *)
 
 let rec clear_zero = function
-   Oplus(Omult(Oatom v,Oint n),r) when n=zero ->
+   Oplus(Omult(Oatom v,Oint n),r) when Bigint.equal n zero ->
      let tac',t = clear_zero r in
      Lazy.force coq_c_red5 :: tac',t
   | Oplus(f,r) ->
       let tac,t = clear_zero r in
-      (if tac = [] then [] else [do_right (do_list tac)]),Oplus(f,t)
+      (if List.is_empty tac then [] else [do_right (do_list tac)]),Oplus(f,t)
   | t -> [],t;;
 
-(* \subsection{Transformation des hypothèses} *)
+(* \subsection{Transformation des hypothèses} *)
 
 let rec reduce env = function
     Oplus(t1,t2) ->
@@ -643,7 +642,7 @@ let normalize_linear_term env t =
   let trace3,t3 = clear_zero t2 in
   do_list [trace1; do_list trace2; do_list trace3], t3
 
-(* Cette fonction reproduit très exactement le comportement de [p_invert] *)
+(* Cette fonction reproduit très exactement le comportement de [p_invert] *)
 let negate_oper = function
     Eq -> Neq | Neq -> Eq | Leq -> Gt | Geq -> Lt | Lt -> Geq | Gt -> Leq
 
@@ -669,7 +668,7 @@ let normalize_equation env (negated,depends,origin,path) (oper,t1,t2) =
 	  INEQ
   with e when Logic.catchable_exception e -> raise e
 
-(* \section{Compilation des hypothèses} *)
+(* \section{Compilation des hypothèses} *)
 
 let rec oformula_of_constr env t =
   match Z.parse_term t with
@@ -698,7 +697,7 @@ and binprop env (neg2,depends,origin,path)
     oproposition_of_constr env (neg1,depends1,origin,O_left::path) gl t1 in
   let t2' =
     oproposition_of_constr env (neg2,depends2,origin,O_right::path) gl t2 in
-  (* On numérote le connecteur dans l'environnement. *)
+  (* On numérote le connecteur dans l'environnement. *)
   c i t1' t2'
 
 and mk_equation env ctxt c connector t1 t2 =
@@ -737,7 +736,7 @@ and oproposition_of_constr env ((negated,depends,origin,path) as ctxt) gl c =
 	  (fun i x y -> Pand(i,x,y)) (Term.mkArrow t1 t2) (Term.mkArrow t2 t1)
     | _ -> Pprop c
 
-(* Destructuration des hypothèses et de la conclusion *)
+(* Destructuration des hypothèses et de la conclusion *)
 
 let reify_gl env gl =
   let concl = Tacmach.pf_concl gl in
@@ -751,7 +750,7 @@ let reify_gl env gl =
       (i,t) :: lhyps ->
 	let t' = oproposition_of_constr env (false,[],i,[]) gl t in
 	if !debug then begin
-	  Printf.printf "  %s: " (Names.string_of_id i);
+	  Printf.printf "  %s: " (Names.Id.to_string i);
 	  pprint stdout t';
 	  Printf.printf "\n"
 	end;
@@ -816,13 +815,13 @@ let destructurate_hyps syst =
       (i,t) :: l ->
 	let l_syst1 = destructurate_pos_hyp i []  [] t in
 	let l_syst2 = loop l in
-	list_cartesian (@) l_syst1 l_syst2
+	List.cartesian (@) l_syst1 l_syst2
     | [] -> [[]] in
   loop syst
 
-(* \subsection{Affichage d'un système d'équation} *)
+(* \subsection{Affichage d'un système d'équation} *)
 
-(* Affichage des dépendances de système *)
+(* Affichage des dépendances de système *)
 let display_depend = function
     Left i -> Printf.printf " L%d" i
   | Right i -> Printf.printf " R%d" i
@@ -845,7 +844,7 @@ let display_systems syst_list =
 	 (List.map (function O_left -> "L" | O_right -> "R" | O_mono -> "M")
 	    oformula_eq.e_origin.o_path));
     Printf.printf "\n  Origin: %s (negated : %s)\n\n"
-      (Names.string_of_id oformula_eq.e_origin.o_hyp)
+      (Names.Id.to_string oformula_eq.e_origin.o_hyp)
       (if oformula_eq.e_negated then "yes" else "no") in
 
   let display_system syst =
@@ -853,8 +852,8 @@ let display_systems syst_list =
     List.iter display_equation syst in
   List.iter display_system syst_list
 
-(* Extraction des prédicats utilisées dans une trace. Permet ensuite le
-   calcul des hypothèses *)
+(* Extraction des prédicats utilisées dans une trace. Permet ensuite le
+   calcul des hypothèses *)
 
 let rec hyps_used_in_trace = function
   | act :: l ->
@@ -866,9 +865,9 @@ let rec hyps_used_in_trace = function
       end
   | [] -> []
 
-(* Extraction des variables déclarées dans une équation. Permet ensuite
-   de les déclarer dans l'environnement de la procédure réflexive et
-   éviter les créations de variable au vol *)
+(* Extraction des variables déclarées dans une équation. Permet ensuite
+   de les déclarer dans l'environnement de la procédure réflexive et
+   éviter les créations de variable au vol *)
 
 let rec variable_stated_in_trace = function
   | act :: l ->
@@ -886,7 +885,7 @@ let rec variable_stated_in_trace = function
 
 let add_stated_equations env tree =
   (* Il faut trier les variables par ordre d'introduction pour ne pas risquer
-     de définir dans le mauvais ordre *)
+     de définir dans le mauvais ordre *)
   let stated_equations =
     let cmpvar x y = Pervasives.(-) x.st_var y.st_var in
     let rec loop = function
@@ -895,15 +894,15 @@ let add_stated_equations env tree =
     in loop tree
   in
   let add_env st =
-    (* On retransforme la définition de v en formule reifiée *)
+    (* On retransforme la définition de v en formule reifiée *)
     let v_def = oformula_of_omega env st.st_def in
-    (* Notez que si l'ordre de création des variables n'est pas respecté,
+    (* Notez que si l'ordre de création des variables n'est pas respecté,
      * ca va planter *)
     let coq_v = coq_of_formula env v_def in
     let v = add_reified_atom coq_v env in
     (* Le terme qu'il va falloir introduire *)
     let term_to_generalize = app coq_refl_equal [|Lazy.force Z.typ; coq_v|] in
-    (* sa représentation sous forme d'équation mais non réifié car on n'a pas
+    (* sa représentation sous forme d'équation mais non réifié car on n'a pas
      * l'environnement pour le faire correctement *)
     let term_to_reify = (v_def,Oatom v) in
     (* enregistre le lien entre la variable omega et la variable Coq *)
@@ -911,18 +910,18 @@ let add_stated_equations env tree =
     (v, term_to_generalize,term_to_reify,st.st_def.id) in
  List.map add_env stated_equations
 
-(* Calcule la liste des éclatements à réaliser sur les hypothèses
-   nécessaires pour extraire une liste d'équations donnée *)
+(* Calcule la liste des éclatements à réaliser sur les hypothèses
+   nécessaires pour extraire une liste d'équations donnée *)
 
 (* PL: experimentally, the result order of the following function seems
    _very_ crucial for efficiency. No idea why. Do not remove the List.rev
-   or modify the current semantics of Util.list_union (some elements of first
+   or modify the current semantics of Util.List.union (some elements of first
    arg, then second arg), unless you know what you're doing. *)
 
 let rec get_eclatement env = function
     i :: r ->
       let l = try (get_equation env i).e_depends with Not_found -> [] in
-      list_union (List.rev l) (get_eclatement env r)
+      List.union Pervasives.(=) (List.rev l) (get_eclatement env r)
   | [] -> []
 
 let select_smaller l =
@@ -933,10 +932,14 @@ let filter_compatible_systems required systems =
   let rec select = function
       (x::l) ->
 	if List.mem x required then select l
-	else if List.mem (barre x) required then failwith "Exit"
+	else if List.mem (barre x) required then raise Exit
 	else x :: select l
-    | [] -> [] in
-  map_succeed (function (sol,splits) -> (sol,select splits)) systems
+    | [] -> []
+  in
+  List.map_filter
+    (function (sol, splits) ->
+      try Some (sol, select splits) with Exit -> None)
+    systems
 
 let rec equas_of_solution_tree = function
     Tree(_,t1,t2) -> (equas_of_solution_tree t1)@@(equas_of_solution_tree t2)
@@ -955,7 +958,7 @@ let really_useful_prop l_equa c =
     | Pnot t1 -> app coq_not [|real_of t1|]
     | Por(_,t1,t2) -> app coq_or [|real_of t1; real_of t2|]
     | Pand(_,t1,t2) -> app coq_and [|real_of t1; real_of t2|]
-    (* Attention : implications sur le lifting des variables à comprendre ! *)
+    (* Attention : implications sur le lifting des variables à comprendre ! *)
     | Pimp(_,t1,t2) -> Term.mkArrow (real_of t1) (real_of t2)
     | Pprop t -> t in
   let rec loop c =
@@ -1015,10 +1018,10 @@ let rec solve_with_constraints all_solutions path =
 let find_path {o_hyp=id;o_path=p} env =
   let rec loop_path = function
       ([],l) -> Some l
-    | (x1::l1,x2::l2) when x1 = x2 -> loop_path (l1,l2)
+    | (x1::l1,x2::l2) when occ_step_eq x1 x2 -> loop_path (l1,l2)
     | _ -> None in
   let rec loop_id i = function
-      CCHyp{o_hyp=id';o_path=p'} :: l when id = id' ->
+      CCHyp{o_hyp=id';o_path=p'} :: l when Names.Id.equal id id' ->
 	begin match loop_path (p',p) with
 	  Some r -> i,r
 	| None -> loop_id (succ i) l
@@ -1036,7 +1039,7 @@ let mk_direction_list l =
 (* \section{Rejouer l'historique} *)
 
 let get_hyp env_hyp i =
-  try list_index0 (CCEqua i) env_hyp
+  try List.index0 Pervasives.(=) (CCEqua i) env_hyp
   with Not_found -> failwith (Printf.sprintf "get_hyp %d" i)
 
 let replay_history env env_hyp =
@@ -1163,11 +1166,11 @@ and decompose_tree_hyps trace env ctxt = function
 
 (* \section{La fonction principale} *)
  (* Cette fonction construit la
-trace pour la procédure de décision réflexive.  A partir des résultats
-de l'extraction des systèmes, elle lance la résolution par Omega, puis
+trace pour la procédure de décision réflexive.  A partir des résultats
+de l'extraction des systèmes, elle lance la résolution par Omega, puis
 l'extraction d'un ensemble minimal de solutions permettant la
-résolution globale du système et enfin construit la trace qui permet
-de faire rejouer cette solution par la tactique réflexive. *)
+résolution globale du système et enfin construit la trace qui permet
+de faire rejouer cette solution par la tactique réflexive. *)
 
 let resolution env full_reified_goal systems_list =
   let num = ref 0 in
@@ -1178,7 +1181,7 @@ let resolution env full_reified_goal systems_list =
       simplify_strong
 	(new_omega_eq,new_omega_var,display_omega_var)
 	system in
-    (* calcule les hypotheses utilisées pour la solution *)
+    (* calcule les hypotheses utilisées pour la solution *)
     let vars = hyps_used_in_trace trace in
     let splits = get_eclatement env vars in
     if !debug then begin
@@ -1199,17 +1202,21 @@ let resolution env full_reified_goal systems_list =
     display_solution_tree stdout solution_tree;
     print_newline()
   end;
-  (* calcule la liste de toutes les hypothèses utilisées dans l'arbre de solution *)
+  (* calcule la liste de toutes les hypothèses utilisées dans l'arbre de solution *)
   let useful_equa_id = equas_of_solution_tree solution_tree in
   (* recupere explicitement ces equations *)
   let equations = List.map (get_equation env) useful_equa_id in
-  let l_hyps' = list_uniquize (List.map (fun e -> e.e_origin.o_hyp) equations) in
-  let l_hyps = id_concl :: list_remove id_concl l_hyps' in
+  let l_hyps' = List.uniquize (List.map (fun e -> e.e_origin.o_hyp) equations) in
+  let l_hyps = id_concl :: List.remove Names.Id.equal id_concl l_hyps' in
   let useful_hyps =
-    List.map (fun id -> List.assoc id full_reified_goal) l_hyps in
+    List.map
+      (fun id -> List.assoc_f Names.Id.equal id full_reified_goal) l_hyps
+  in
   let useful_vars =
     let really_useful_vars = vars_of_equations equations in
-    let concl_vars = vars_of_prop (List.assoc id_concl full_reified_goal) in
+    let concl_vars =
+      vars_of_prop (List.assoc_f Names.Id.equal id_concl full_reified_goal)
+    in
     really_useful_vars @@ concl_vars
   in
   (* variables a introduire *)
@@ -1218,8 +1225,8 @@ let resolution env full_reified_goal systems_list =
   let l_generalize_arg = List.map (fun (_,t,_,_) -> t) to_introduce in
   let hyp_stated_vars = List.map (fun (_,_,_,id) -> CCEqua id) to_introduce in
   (* L'environnement de base se construit en deux morceaux :
-     - les variables des équations utiles (et de la conclusion)
-     - les nouvelles variables declarées durant les preuves *)
+     - les variables des équations utiles (et de la conclusion)
+     - les nouvelles variables declarées durant les preuves *)
   let all_vars_env = useful_vars @ stated_vars in
   let basic_env =
     let rec loop i = function
@@ -1229,7 +1236,7 @@ let resolution env full_reified_goal systems_list =
       |	[] -> [] in
     loop 0 all_vars_env in
   let env_terms_reified = mk_list (Lazy.force Z.typ) basic_env in
-  (* On peut maintenant généraliser le but : env est a jour *)
+  (* On peut maintenant généraliser le but : env est a jour *)
   let l_reified_stated =
      List.map (fun (_,_,(l,r),_) ->
                  app coq_p_eq [| reified_of_formula env l;
@@ -1258,10 +1265,10 @@ let resolution env full_reified_goal systems_list =
       |	((O_left | O_mono) :: l) -> app coq_p_left [| loop l |]
       |	(O_right :: l) -> app coq_p_right [| loop l |] in
     let correct_index =
-      let i = list_index0 e.e_origin.o_hyp l_hyps in
+      let i = List.index0 Names.Id.equal e.e_origin.o_hyp l_hyps in
       (* PL: it seems that additionnally introduced hyps are in the way during
              normalization, hence this index shifting... *)
-      if i=0 then 0 else Pervasives.(+) i (List.length to_introduce)
+      if Int.equal i 0 then 0 else Pervasives.(+) i (List.length to_introduce)
     in
     app coq_pair_step [| mk_nat correct_index; loop e.e_origin.o_path |] in
   let normalization_trace =
@@ -1275,8 +1282,8 @@ let resolution env full_reified_goal systems_list =
 
   Tactics.generalize
     (l_generalize_arg @ List.map Term.mkVar (List.tl l_hyps)) >>
-  Tactics.change_in_concl None reified >>
-  Tactics.apply (app coq_do_omega [|decompose_tactic; normalization_trace|]) >>
+  Proofview.V82.of_tactic (Tactics.change_concl reified) >>
+  Proofview.V82.of_tactic (Tactics.apply (app coq_do_omega [|decompose_tactic; normalization_trace|])) >>
   show_goal >>
   Tactics.normalise_vm_in_concl >>
   (*i Alternatives to the previous line:
@@ -1285,7 +1292,7 @@ let resolution env full_reified_goal systems_list =
    - Skip the conversion check and rely directly on the QED:
       Tacmach.convert_concl_no_check (Lazy.force coq_True) Term.VMcast >>
   i*)
-  Tactics.apply (Lazy.force coq_I)
+  Proofview.V82.of_tactic (Tactics.apply (Lazy.force coq_I))
 
 let total_reflexive_omega_tactic gl =
   Coqlib.check_required_library ["Coq";"romega";"ROmega"];
@@ -1297,7 +1304,7 @@ let total_reflexive_omega_tactic gl =
   let systems_list = destructurate_hyps full_reified_goal in
   if !debug then display_systems systems_list;
   resolution env full_reified_goal systems_list gl
-  with NO_CONTRADICTION -> Util.error "ROmega can't solve this system"
+  with NO_CONTRADICTION -> Errors.error "ROmega can't solve this system"
 
 
 (*i let tester = Tacmach.hide_atomic_tactic "TestOmega" test_tactic i*)
diff --git a/plugins/rtauto/Bintree.v b/plugins/rtauto/Bintree.v
index fbfa1bfd..267cd472 100644
--- a/plugins/rtauto/Bintree.v
+++ b/plugins/rtauto/Bintree.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -198,7 +198,7 @@ Theorem get_Full_Gt : forall S, Full S ->
 Proof.
 intros S W;induction W.
 unfold empty,index,get,contents;intros;apply Tget_Tempty.
-unfold index,get,push;simpl contents.
+unfold index,get,push. simpl @contents.
 intros i e;rewrite Tget_Tadd.
 rewrite (Gt_Psucc _ _ e).
 unfold get in IHW.
@@ -209,7 +209,7 @@ Theorem get_Full_Eq : forall S, Full S -> get (index S) S = PNone.
 intros [index0 contents0] F.
 case F.
 unfold empty,index,get,contents;intros;apply Tget_Tempty.
-unfold index,get,push;simpl contents.
+unfold push,index,get;simpl @contents.
 intros a S.
 rewrite Tget_Tadd.
 rewrite Psucc_Gt.
@@ -231,12 +231,12 @@ Proof.
 intros i a S F.
 case_eq (i ?= index S).
 intro e;rewrite (Pos.compare_eq _ _ e).
-destruct S;unfold get,push,index;simpl contents;rewrite Tget_Tadd.
+destruct S;unfold get,push,index;simpl @contents;rewrite Tget_Tadd.
 rewrite Pos.compare_refl;reflexivity.
-intros;destruct S;unfold get,push,index;simpl contents;rewrite Tget_Tadd.
-simpl index in H;rewrite H;reflexivity.
+intros;destruct S;unfold get,push,index;simpl @contents;rewrite Tget_Tadd.
+simpl @index in H;rewrite H;reflexivity.
 intro H;generalize H;clear H.
-unfold get,push;simpl index;simpl contents.
+unfold get,push;simpl.
 rewrite Tget_Tadd;intro e;rewrite e.
 change (get i S=PNone).
 apply get_Full_Gt;auto.
@@ -260,7 +260,7 @@ Qed.
 Lemma Full_index_one_empty : forall S, Full S -> index S = 1 -> S=empty.
 intros [ind cont] F one; inversion F.
 reflexivity.
-simpl index in one;assert (h:=Pos.succ_not_1 (index S)).
+simpl @index in one;assert (h:=Pos.succ_not_1 (index S)).
 congruence.
 Qed.
 
diff --git a/plugins/rtauto/Rtauto.v b/plugins/rtauto/Rtauto.v
index f823cf74..61a160b2 100644
--- a/plugins/rtauto/Rtauto.v
+++ b/plugins/rtauto/Rtauto.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/plugins/rtauto/g_rtauto.ml4 b/plugins/rtauto/g_rtauto.ml4
index 4de2638b..7fefab3e 100644
--- a/plugins/rtauto/g_rtauto.ml4
+++ b/plugins/rtauto/g_rtauto.ml4
@@ -1,14 +1,16 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i camlp4deps: "parsing/grammar.cma"  i*)
+(*i camlp4deps: "grammar/grammar.cma"  i*)
+
+DECLARE PLUGIN "rtauto_plugin"
 
 TACTIC EXTEND rtauto
-  [ "rtauto" ] -> [ Refl_tauto.rtauto_tac ]
+  [ "rtauto" ] -> [ Proofview.V82.tactic (Refl_tauto.rtauto_tac) ]
 END
 
diff --git a/plugins/rtauto/proof_search.ml b/plugins/rtauto/proof_search.ml
index 2ace38bd..23510117 100644
--- a/plugins/rtauto/proof_search.ml
+++ b/plugins/rtauto/proof_search.ml
@@ -1,12 +1,12 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Term
+open Errors
 open Util
 open Goptions
 
@@ -62,20 +62,35 @@ type form=
   | Conjunct of form * form
   | Disjunct of form * form
 
-type tag=int
-
-let decomp_form=function
-    Atom i -> Some (i,[])
-  | Arrow (f1,f2) -> Some (-1,[f1;f2])
-  | Bot -> Some (-2,[])
-  | Conjunct (f1,f2) -> Some (-3,[f1;f2])
-  | Disjunct (f1,f2) -> Some (-4,[f1;f2])
-
-module Fmap=Map.Make(struct type t=form let compare=compare end)
+module FOrd = struct
+  type t = form
+  let rec compare x y =
+    match x, y with
+    | Bot, Bot -> 0
+    | Bot, _ -> -1
+    | Atom _, Bot -> 1
+    | Atom a1, Atom a2 -> Int.compare a1 a2
+    | Atom _, _ -> -1
+    | Arrow _, (Bot | Atom _) -> 1
+    | Arrow (f1, g1), Arrow (f2, g2) ->
+        let cmp = compare f1 f2 in
+        if cmp = 0 then compare g1 g2 else cmp
+    | Arrow _, _ -> -1
+    | Conjunct _, (Bot | Atom _ | Arrow _) -> 1
+    | Conjunct (f1, g1), Conjunct (f2, g2) ->
+        let cmp = compare f1 f2 in
+        if cmp = 0 then compare g1 g2 else cmp
+    | Conjunct _, _ -> -1
+    | Disjunct _, (Bot | Atom _ | Arrow _ | Conjunct _) -> 1
+    | Disjunct (f1, g1), Disjunct (f2, g2) ->
+        let cmp = compare f1 f2 in
+        if cmp = 0 then compare g1 g2 else cmp
+end
+module Fmap = Map.Make(FOrd)
 
 type sequent =
-    {rev_hyps: form Intmap.t;
-     norev_hyps: form Intmap.t;
+    {rev_hyps: form Int.Map.t;
+     norev_hyps: form Int.Map.t;
      size:int;
      left:int Fmap.t;
      right:(int*form) list Fmap.t;
@@ -131,21 +146,21 @@ let add_step s sub =
     | SI_Or_r,[p] -> I_Or_r p
     | SE_Or i,[p1;p2] -> E_Or(i,p1,p2)
     | SD_Or i,[p] -> D_Or(i,p)
-    | _,_ -> anomaly "add_step: wrong arity"
+    | _,_ -> anomaly ~label:"add_step" (Pp.str "wrong arity")
 
 type 'a with_deps =
     {dep_it:'a;
      dep_goal:bool;
-     dep_hyps:Intset.t}
+     dep_hyps:Int.Set.t}
 
 type slice=
     {proofs_done:proof list;
      proofs_todo:sequent with_deps list;
      step:rule;
      needs_goal:bool;
-     needs_hyps:Intset.t;
+     needs_hyps:Int.Set.t;
      changes_goal:bool;
-     creates_hyps:Intset.t}
+     creates_hyps:Int.Set.t}
 
 type state =
     Complete of proof
@@ -153,7 +168,7 @@ type state =
 
 let project = function
     Complete prf -> prf
-  | Incomplete (_,_) -> anomaly "not a successful state"
+  | Incomplete (_,_) -> anomaly (Pp.str "not a successful state")
 
 let pop n prf =
   let nprf=
@@ -168,27 +183,27 @@ let rec fill stack proof =
     | slice::super ->
 	if
 	  !pruning &&
-	  slice.proofs_done=[] &&
+	  List.is_empty slice.proofs_done &&
 	  not (slice.changes_goal && proof.dep_goal) &&
-	  not (Intset.exists
-		 (fun i -> Intset.mem i proof.dep_hyps)
+	  not (Int.Set.exists
+		 (fun i -> Int.Set.mem i proof.dep_hyps)
 		 slice.creates_hyps)
 	then
 	  begin
 	    s_info.pruned_steps<-s_info.pruned_steps+1;
 	    s_info.pruned_branches<- s_info.pruned_branches +
 	    List.length slice.proofs_todo;
-	    let created_here=Intset.cardinal slice.creates_hyps in
+	    let created_here=Int.Set.cardinal slice.creates_hyps in
 	      s_info.pruned_hyps<-s_info.pruned_hyps+
 	      List.fold_left
-		(fun sum dseq -> sum + Intset.cardinal dseq.dep_hyps)
+		(fun sum dseq -> sum + Int.Set.cardinal dseq.dep_hyps)
 		created_here slice.proofs_todo;
-	    fill super (pop (Intset.cardinal slice.creates_hyps) proof)
+	    fill super (pop (Int.Set.cardinal slice.creates_hyps) proof)
 	  end
 	else
 	  let dep_hyps=
-	    Intset.union slice.needs_hyps
-	      (Intset.diff proof.dep_hyps slice.creates_hyps) in
+	    Int.Set.union slice.needs_hyps
+	      (Int.Set.diff proof.dep_hyps slice.creates_hyps) in
 	  let dep_goal=
 	    slice.needs_goal ||
 	    ((not slice.changes_goal) && proof.dep_goal) in
@@ -235,7 +250,7 @@ let append stack (step,subgoals) =
 let embed seq=
   {dep_it=seq;
    dep_goal=false;
-   dep_hyps=Intset.empty}
+   dep_hyps=Int.Set.empty}
 
 let change_goal seq gl=
     {seq with
@@ -270,7 +285,7 @@ let add_hyp seqwd f=
 	     cnx=cnx}
       | Conjunct (_,_) | Disjunct (_,_) ->
 	  {seq with
-	     rev_hyps=Intmap.add num f seq.rev_hyps;
+	     rev_hyps=Int.Map.add num f seq.rev_hyps;
 	     size=num;
 	     left=left;
 	     right=right;
@@ -285,14 +300,14 @@ let add_hyp seqwd f=
 	    match f1 with
 		Conjunct (_,_) | Disjunct (_,_) ->
 		  {seq with
-		     rev_hyps=Intmap.add num f seq.rev_hyps;
+		     rev_hyps=Int.Map.add num f seq.rev_hyps;
 		     size=num;
 		     left=left;
 		     right=nright;
 		     cnx=ncnx}
 	      | Arrow(_,_) ->
 		  {seq with
-		     norev_hyps=Intmap.add num f seq.norev_hyps;
+		     norev_hyps=Int.Map.add num f seq.norev_hyps;
 		     size=num;
 		     left=left;
 		     right=nright;
@@ -305,13 +320,13 @@ let add_hyp seqwd f=
 		     cnx=ncnx} in
     {seqwd with
        dep_it=nseq;
-       dep_hyps=Intset.add num seqwd.dep_hyps}
+       dep_hyps=Int.Set.add num seqwd.dep_hyps}
 
 exception Here_is of (int*form)
 
 let choose m=
   try
-    Intmap.iter (fun i f -> raise (Here_is (i,f))) m;
+    Int.Map.iter (fun i f -> raise (Here_is (i,f))) m;
     raise Not_found
   with
       Here_is (i,f) -> (i,f)
@@ -322,11 +337,11 @@ let search_or seq=
       Disjunct (f1,f2) ->
 	[{dep_it = SI_Or_l;
 	  dep_goal = true;
-	  dep_hyps = Intset.empty},
+	  dep_hyps = Int.Set.empty},
 	 [change_goal (embed seq) f1];
 	 {dep_it = SI_Or_r;
 	  dep_goal = true;
-	  dep_hyps = Intset.empty},
+	  dep_hyps = Int.Set.empty},
 	 [change_goal (embed seq) f2]]
     | _ -> []
 
@@ -336,19 +351,19 @@ let search_norev seq=
     match f with
 	Arrow (Arrow (f1,f2),f3) ->
 	  let nseq =
-	    {seq with norev_hyps=Intmap.remove i seq.norev_hyps} in
+	    {seq with norev_hyps=Int.Map.remove i seq.norev_hyps} in
 	    goals:=
 	      ({dep_it=SD_Arrow(i);
 		dep_goal=false;
-		dep_hyps=Intset.singleton i},
+		dep_hyps=Int.Set.singleton i},
 	       [add_hyp
 		  (add_hyp
 		     (change_goal (embed nseq) f2)
 		     (Arrow(f2,f3)))
 		  f1;
 		add_hyp (embed nseq) f3]):: !goals
-      | _ -> anomaly "search_no_rev: can't happen" in
-    Intmap.iter add_one seq.norev_hyps;
+      | _ -> anomaly ~label:"search_no_rev" (Pp.str "can't happen") in
+    Int.Map.iter add_one seq.norev_hyps;
     List.rev !goals
 
 let search_in_rev_hyps seq=
@@ -357,8 +372,8 @@ let search_in_rev_hyps seq=
     let make_step step=
       {dep_it=step;
        dep_goal=false;
-       dep_hyps=Intset.singleton i} in
-    let nseq={seq with rev_hyps=Intmap.remove i seq.rev_hyps} in
+       dep_hyps=Int.Set.singleton i} in
+    let nseq={seq with rev_hyps=Int.Map.remove i seq.rev_hyps} in
       match f with
 	  Conjunct (f1,f2) ->
 	    [make_step (SE_And(i)),
@@ -372,7 +387,7 @@ let search_in_rev_hyps seq=
 	| Arrow (Disjunct (f1,f2),f0) ->
 	    [make_step (SD_Or(i)),
 	     [add_hyp (add_hyp (embed nseq) (Arrow(f1,f0))) (Arrow (f2,f0))]]
-	| _ -> anomaly "search_in_rev_hyps: can't happen"
+	| _ -> anomaly ~label:"search_in_rev_hyps" (Pp.str "can't happen")
   with
       Not_found -> search_norev seq
 
@@ -383,27 +398,27 @@ let search_rev seq=
 	  match f1 with
 	      Conjunct (_,_) | Disjunct (_,_) ->
 		{seq with cnx=next;
-		   rev_hyps=Intmap.remove j seq.rev_hyps}
+		   rev_hyps=Int.Map.remove j seq.rev_hyps}
 	    | Arrow (_,_) ->
 		{seq with cnx=next;
-		   norev_hyps=Intmap.remove j seq.norev_hyps}
+		   norev_hyps=Int.Map.remove j seq.norev_hyps}
 	    | _ ->
 		{seq with cnx=next} in
 	  [{dep_it=SE_Arrow(i,j);
 	    dep_goal=false;
-	    dep_hyps=Intset.add i (Intset.singleton j)},
+	    dep_hyps=Int.Set.add i (Int.Set.singleton j)},
 	   [add_hyp (embed nseq) f2]]
     | [] ->
 	match seq.gl with
 	    Arrow (f1,f2) ->
 	      [{dep_it=SI_Arrow;
 		dep_goal=true;
-		dep_hyps=Intset.empty},
+		dep_hyps=Int.Set.empty},
 	       [add_hyp (change_goal (embed seq) f2) f1]]
 	  | Conjunct (f1,f2) ->
 	      [{dep_it=SI_And;
 		dep_goal=true;
-		dep_hyps=Intset.empty},[change_goal (embed seq) f1;
+		dep_hyps=Int.Set.empty},[change_goal (embed seq) f1;
 					change_goal (embed seq) f2]]
 	  | _ -> search_in_rev_hyps seq
 
@@ -412,18 +427,18 @@ let search_all seq=
       Some i ->
 	[{dep_it=SE_False (i);
 	  dep_goal=false;
-	  dep_hyps=Intset.singleton i},[]]
+	  dep_hyps=Int.Set.singleton i},[]]
     | None ->
 	try
 	  let ax = Fmap.find seq.gl seq.left in
 	    [{dep_it=SAx (ax);
 	      dep_goal=true;
-	      dep_hyps=Intset.singleton ax},[]]
+	      dep_hyps=Int.Set.singleton ax},[]]
 	with Not_found -> search_rev seq
 
 let bare_sequent = embed
-		     {rev_hyps=Intmap.empty;
-		      norev_hyps=Intmap.empty;
+		     {rev_hyps=Int.Map.empty;
+		      norev_hyps=Int.Map.empty;
 		      size=0;
 		      left=Fmap.empty;
 		      right=Fmap.empty;
@@ -442,7 +457,7 @@ let success= function
 
 let branching = function
     Incomplete (seq,stack) ->
-      check_for_interrupt ();
+      Control.check_for_interrupt ();
       let successors = search_all seq in
       let _ =
 	match successors with
@@ -450,7 +465,7 @@ let branching = function
 	  | _::next ->
 	      s_info.nd_branching<-s_info.nd_branching+List.length next in
 	List.map (append stack) successors
-  | Complete prf -> anomaly "already succeeded"
+  | Complete prf -> anomaly (Pp.str "already succeeded")
 
 open Pp
 
@@ -471,11 +486,11 @@ and pp_atom= function
   | Atom n -> int n
   | f -> str "(" ++ hv 2 (pp_form f) ++ str ")"
 
-let pr_form f = msg (pp_form f)
+let pr_form f = pp_form f
 
 let pp_intmap map =
   let pp=ref (str "") in
-   Intmap.iter (fun i obj -> pp:= (!pp ++
+   Int.Map.iter (fun i obj -> pp:= (!pp ++
 		pp_form obj ++ cut ())) map;
     str "{ " ++ v 0 (!pp) ++ str " }"
 
@@ -532,7 +547,7 @@ let pp_info () =
 	int s_info.created_branches ++ str " created" ++ fnl () ++
 	str "Hypotheses : " ++
 	int s_info.created_hyps ++ str " created" ++ fnl () in
-    msgnl
+    msg_info
       ( str "Proof-search statistics :" ++ fnl () ++
 	count_info ++
 	str "Branch ends: " ++
diff --git a/plugins/rtauto/proof_search.mli b/plugins/rtauto/proof_search.mli
index 1aaafbe6..86a2fb66 100644
--- a/plugins/rtauto/proof_search.mli
+++ b/plugins/rtauto/proof_search.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -40,7 +40,7 @@ val success: state -> bool
 
 val pp: state -> Pp.std_ppcmds
 
-val pr_form : form -> unit
+val pr_form : form -> Pp.std_ppcmds
 
 val reset_info : unit -> unit
 
diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml
index 7dedb44e..4ffc1f33 100644
--- a/plugins/rtauto/refl_tauto.ml
+++ b/plugins/rtauto/refl_tauto.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -8,10 +8,9 @@
 
 module Search = Explore.Make(Proof_search)
 
+open Errors
 open Util
 open Term
-open Names
-open Evd
 open Tacmach
 open Proof_search
 
@@ -28,13 +27,6 @@ let li_False = lazy (destInd (logic_constant "False"))
 let li_and = lazy (destInd (logic_constant "and"))
 let li_or =  lazy (destInd (logic_constant "or"))
 
-let data_constant =
-  Coqlib.gen_constant "refl_tauto" ["Init";"Datatypes"]
-
-let l_true_equals_true =
-  lazy (mkApp(logic_constant "eq_refl",
-        [|data_constant "bool";data_constant "true"|]))
-
 let pos_constant =
   Coqlib.gen_constant "refl_tauto" ["Numbers";"BinNums"]
 
@@ -103,7 +95,7 @@ let rec make_form atom_env gls term =
 	Prod(_,a,b) ->
 	  if not (Termops.dependent (mkRel 1) b) &&
 	    Retyping.get_sort_family_of
-	    (pf_env gls) (Tacmach.project gls) a = InProp
+	    (pf_env gls) (Tacmach.project gls) a == InProp
 	  then
 	    let fa=make_form atom_env gls a in
 	    let fb=make_form atom_env gls b in
@@ -112,25 +104,25 @@ let rec make_form atom_env gls term =
 	    make_atom atom_env (normalize term)
       | Cast(a,_,_) ->
 	  make_form atom_env gls a
-      | Ind ind ->
-	  if ind = Lazy.force li_False then
+      | Ind (ind, _) ->
+	  if Names.eq_ind ind (fst (Lazy.force li_False)) then
 	    Bot
 	  else
 	    make_atom atom_env (normalize term)
-      | App(hd,argv) when Array.length argv = 2 ->
+      | App(hd,argv) when Int.equal (Array.length argv) 2 ->
 	  begin
 	    try
-	      let ind = destInd hd in
-		if ind = Lazy.force li_and then
+	      let ind, _ = destInd hd in
+		if Names.eq_ind ind (fst (Lazy.force li_and)) then
 		  let fa=make_form atom_env gls argv.(0) in
 		  let fb=make_form atom_env gls argv.(1) in
 		    Conjunct (fa,fb)
-		else if ind = Lazy.force li_or then
+		else if Names.eq_ind ind (fst (Lazy.force li_or)) then
 		  let fa=make_form atom_env gls argv.(0) in
 		  let fb=make_form atom_env gls argv.(1) in
 		    Disjunct (fa,fb)
 		else make_atom atom_env (normalize term)
-	    with Invalid_argument _ -> make_atom atom_env (normalize term)
+	    with DestKO -> make_atom atom_env (normalize term)
 	  end
       | _ -> make_atom atom_env (normalize term)
 
@@ -143,7 +135,7 @@ let rec make_hyps atom_env gls lenv = function
 	make_hyps atom_env gls (typ::lenv) rest in
 	if List.exists (Termops.dependent (mkVar id)) lenv ||
 	  (Retyping.get_sort_family_of
-	     (pf_env gls) (Tacmach.project gls) typ <> InProp)
+	     (pf_env gls) (Tacmach.project gls) typ != InProp)
 	then
 	  hrec
 	else
@@ -151,7 +143,7 @@ let rec make_hyps atom_env gls lenv = function
 
 let rec build_pos n =
   if n<=1 then force node_count l_xH
-  else if n land 1 = 0 then
+  else if Int.equal (n land 1) 0 then
     mkApp (force node_count l_xO,[|build_pos (n asr 1)|])
   else
     mkApp (force node_count l_xI,[|build_pos (n asr 1)|])
@@ -269,22 +261,21 @@ let rtauto_tac gls=
   let gl=pf_concl gls in
   let _=
     if Retyping.get_sort_family_of
-      (pf_env gls) (Tacmach.project gls) gl <> InProp
+      (pf_env gls) (Tacmach.project gls) gl != InProp
     then errorlabstrm "rtauto" (Pp.str "goal should be in Prop") in
   let glf=make_form gamma gls gl in
   let hyps=make_hyps gamma gls [gl] (pf_hyps gls) in
   let formula=
     List.fold_left (fun gl (_,f)-> Arrow (f,gl)) glf hyps in
-  let search_fun =
-    if Tacinterp.get_debug()=Tactic_debug.DebugOn 0 then
-      Search.debug_depth_first
-    else
-      Search.depth_first in
+  let search_fun = match Tacinterp.get_debug() with
+  | Tactic_debug.DebugOn 0 -> Search.debug_depth_first
+  | _ -> Search.depth_first
+  in
   let _ =
     begin
       reset_info ();
       if !verbose then
-	msgnl (str "Starting proof-search ...");
+	msg_info (str "Starting proof-search ...");
     end in
   let search_start_time = System.get_time () in
   let prf =
@@ -294,10 +285,10 @@ let rtauto_tac gls=
   let search_end_time = System.get_time () in
   let _ = if !verbose then
     begin
-      msgnl (str "Proof tree found in " ++
+      msg_info (str "Proof tree found in " ++
 	     System.fmt_time_difference search_start_time search_end_time);
       pp_info ();
-      msgnl (str "Building proof term ... ")
+      msg_info (str "Building proof term ... ")
     end in
   let build_start_time=System.get_time () in
   let _ = step_count := 0; node_count := 0 in
@@ -306,11 +297,11 @@ let rtauto_tac gls=
 		      build_form formula;
 		      build_proof [] 0 prf|]) in
   let term=
-    Term.applist (main,List.rev_map (fun (id,_) -> mkVar id) hyps) in
+    applist (main,List.rev_map (fun (id,_) -> mkVar id) hyps) in
   let build_end_time=System.get_time () in
   let _ = if !verbose then
     begin
-      msgnl (str "Proof term built in " ++
+      msg_info (str "Proof term built in " ++
 	     System.fmt_time_difference build_start_time build_end_time ++
 	     fnl () ++
 	     str "Proof size : " ++ int !step_count ++
@@ -322,14 +313,14 @@ let rtauto_tac gls=
   let tac_start_time = System.get_time () in
   let result=
     if !check then
-      Tactics.exact_check term gls
+      Proofview.V82.of_tactic (Tactics.exact_check term) gls
     else
       Tactics.exact_no_check term gls in
   let tac_end_time = System.get_time () in
   let _ =
-    if !check then msgnl (str "Proof term type-checking is on");
+    if !check then msg_info (str "Proof term type-checking is on");
     if !verbose then
-      msgnl (str "Internal tactic executed in " ++
+      msg_info (str "Internal tactic executed in " ++
 	     System.fmt_time_difference tac_start_time tac_end_time) in
     result
 
diff --git a/plugins/rtauto/refl_tauto.mli b/plugins/rtauto/refl_tauto.mli
index 9f7db593..45fb50dc 100644
--- a/plugins/rtauto/refl_tauto.mli
+++ b/plugins/rtauto/refl_tauto.mli
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -18,7 +18,7 @@ val make_hyps :
     atom_env ->
     Proof_type.goal Tacmach.sigma ->
     Term.types list ->
-    (Names.identifier * Term.types option * Term.types) list ->
-    (Names.identifier * Proof_search.form) list
+    (Names.Id.t * Term.types option * Term.types) list ->
+    (Names.Id.t * Proof_search.form) list
 
 val rtauto_tac : Proof_type.tactic
diff --git a/plugins/setoid_ring/ArithRing.v b/plugins/setoid_ring/ArithRing.v
index 92e61583..e7d0cd8e 100644
--- a/plugins/setoid_ring/ArithRing.v
+++ b/plugins/setoid_ring/ArithRing.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/plugins/setoid_ring/BinList.v b/plugins/setoid_ring/BinList.v
index 22448fd7..5dd1b86d 100644
--- a/plugins/setoid_ring/BinList.v
+++ b/plugins/setoid_ring/BinList.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/plugins/setoid_ring/Cring.v b/plugins/setoid_ring/Cring.v
index f13f509a..4872c776 100644
--- a/plugins/setoid_ring/Cring.v
+++ b/plugins/setoid_ring/Cring.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -21,6 +21,7 @@ Require Export Ncring_tac.
 Class Cring {R:Type}`{Rr:Ring R} := 
  cring_mul_comm: forall x y:R, x * y == y * x.
 
+
 Ltac reify_goal lvar lexpr lterm:=
   (*idtac lvar; idtac lexpr; idtac lterm;*)
   match lexpr with
@@ -30,10 +31,10 @@ Ltac reify_goal lvar lexpr lterm:=
           |- (?op ?u1 ?u2) =>
            change (op 
              (@Ring_polynom.PEeval
-               _ zero _+_ _*_ _-_ -_ Z Ncring_initial.gen_phiZ N (fun n:N => n)
+               _ zero one _+_ _*_ _-_ -_ Z Ncring_initial.gen_phiZ N (fun n:N => n)
                (@Ring_theory.pow_N _ 1 multiplication) lvar e1)
              (@Ring_polynom.PEeval
-               _ zero _+_ _*_ _-_ -_ Z Ncring_initial.gen_phiZ N (fun n:N => n)
+               _ zero one _+_ _*_ _-_ -_ Z Ncring_initial.gen_phiZ N (fun n:N => n)
                (@Ring_theory.pow_N _ 1 multiplication) lvar e2))
         end
   end.
diff --git a/plugins/setoid_ring/Field.v b/plugins/setoid_ring/Field.v
index d2ab9e0f..4de2efe3 100644
--- a/plugins/setoid_ring/Field.v
+++ b/plugins/setoid_ring/Field.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/plugins/setoid_ring/Field_tac.v b/plugins/setoid_ring/Field_tac.v
index 34a3018b..f867c6d0 100644
--- a/plugins/setoid_ring/Field_tac.v
+++ b/plugins/setoid_ring/Field_tac.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -10,55 +10,67 @@ Require Import Ring_tac BinList Ring_polynom InitialRing.
 Require Export Field_theory.
 
  (* syntaxification *)
- Ltac mkFieldexpr C Cst CstPow radd rmul rsub ropp rdiv rinv rpow t fv :=
+ (* We do not assume that Cst recognizes the rO and rI terms as constants, as *)
+ (* the tactic could be used to discriminate occurrences of an opaque *)
+ (* constant phi, with (phi 0) not convertible to 0 for instance *)
+ Ltac mkFieldexpr C Cst CstPow rO rI radd rmul rsub ropp rdiv rinv rpow t fv :=
  let rec mkP t :=
     let f :=
     match Cst t with
     | InitialRing.NotConstant =>
         match t with
+        | rO => 
+          fun _ => constr:(@FEO C)
+        | rI => 
+          fun _ => constr:(@FEI C)
         | (radd ?t1 ?t2) =>
           fun _ =>
           let e1 := mkP t1 in
-          let e2 := mkP t2 in constr:(FEadd e1 e2)
+          let e2 := mkP t2 in constr:(@FEadd C e1 e2)
         | (rmul ?t1 ?t2) =>
           fun _ =>
           let e1 := mkP t1 in
-          let e2 := mkP t2 in constr:(FEmul e1 e2)
+          let e2 := mkP t2 in constr:(@FEmul C e1 e2)
         | (rsub ?t1 ?t2) =>
           fun _ =>
           let e1 := mkP t1 in
-          let e2 := mkP t2 in constr:(FEsub e1 e2)
+          let e2 := mkP t2 in constr:(@FEsub C e1 e2)
         | (ropp ?t1) =>
-          fun _ => let e1 := mkP t1 in constr:(FEopp e1)
+          fun _ => let e1 := mkP t1 in constr:(@FEopp C e1)
         | (rdiv ?t1 ?t2) =>
           fun _ =>
           let e1 := mkP t1 in
-          let e2 := mkP t2 in constr:(FEdiv e1 e2)
+          let e2 := mkP t2 in constr:(@FEdiv C e1 e2)
         | (rinv ?t1) =>
-          fun _ => let e1 := mkP t1 in constr:(FEinv e1)
+          fun _ => let e1 := mkP t1 in constr:(@FEinv C e1)
         | (rpow ?t1 ?n) =>
           match CstPow n with
           | InitialRing.NotConstant =>
             fun _ =>
             let p := Find_at t fv in
             constr:(@FEX C p)
-          | ?c => fun _ => let e1 := mkP t1 in constr:(FEpow e1 c)
+          | ?c => fun _ => let e1 := mkP t1 in constr:(@FEpow C e1 c)
           end
         | _ =>
           fun _ =>
           let p := Find_at t fv in
           constr:(@FEX C p)
         end
-    | ?c => fun _ => constr:(FEc c)
+    | ?c => fun _ => constr:(@FEc C c)
     end in
     f ()
  in mkP t.
 
-Ltac FFV Cst CstPow add mul sub opp div inv pow t fv :=
+ (* We do not assume that Cst recognizes the rO and rI terms as constants, as *)
+ (* the tactic could be used to discriminate occurrences of an opaque *)
+ (* constant phi, with (phi 0) not convertible to 0 for instance *)
+Ltac FFV Cst CstPow rO rI add mul sub opp div inv pow t fv :=
  let rec TFV t fv :=
   match Cst t with
   | InitialRing.NotConstant =>
       match t with
+      | rO => fv
+      | rI => fv
       | (add ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
       | (mul ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
       | (sub ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
@@ -83,60 +95,60 @@ Ltac FFV Cst CstPow add mul sub opp div inv pow t fv :=
 Ltac PackField F req Cst_tac Pow_tac L1 L2 L3 L4 cond_ok pre post :=
   let FLD :=
     match type of L1 with
-    | context [req (@FEeval ?R ?rO ?radd ?rmul ?rsub ?ropp ?rdiv ?rinv
+    | context [req (@FEeval ?R ?rO ?rI ?radd ?rmul ?rsub ?ropp ?rdiv ?rinv
                                       ?C ?phi ?Cpow ?Cp_phi ?rpow _ _) _ ] =>
         (fun proj =>
            proj Cst_tac Pow_tac pre post
-             req radd rmul rsub ropp rdiv rinv rpow C L1 L2 L3 L4 cond_ok)
+             req rO rI radd rmul rsub ropp rdiv rinv rpow C L1 L2 L3 L4 cond_ok)
     | _ => fail 1 "field anomaly: bad correctness lemma (parse)"
     end in
   F FLD.
 
 Ltac get_FldPre FLD :=
   FLD ltac:
-      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+      (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C
            L1 L2 L3 L4 cond_ok =>
        pre).
 
 Ltac get_FldPost FLD :=
   FLD ltac:
-      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+      (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C
            L1 L2 L3 L4 cond_ok =>
        post).
 
 Ltac get_L1 FLD :=
   FLD ltac:
-      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+      (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C
            L1 L2 L3 L4 cond_ok =>
        L1).
 
 Ltac get_SimplifyEqLemma FLD :=
   FLD ltac:
-      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+      (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C
            L1 L2 L3 L4 cond_ok =>
        L2).
 
 Ltac get_SimplifyLemma FLD :=
   FLD ltac:
-      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+      (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C
            L1 L2 L3 L4 cond_ok =>
        L3).
 
 Ltac get_L4 FLD :=
   FLD ltac:
-      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+      (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C
            L1 L2 L3 L4 cond_ok =>
        L4).
 
 Ltac get_CondLemma FLD :=
   FLD ltac:
-      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+      (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C
            L1 L2 L3 L4 cond_ok =>
        cond_ok).
 
 Ltac get_FldEq FLD :=
   FLD ltac:
-      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+      (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C
            L1 L2 L3 L4 cond_ok =>
        req).
 
@@ -146,33 +158,33 @@ Ltac get_FldCarrier FLD :=
 
 Ltac get_RingFV FLD :=
   FLD ltac:
-      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+      (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C
            L1 L2 L3 L4 cond_ok =>
-       FV Cst_tac Pow_tac radd rmul rsub ropp rpow).
+       FV Cst_tac Pow_tac r0 r1 radd rmul rsub ropp rpow).
 
 Ltac get_FFV FLD :=
   FLD ltac:
-      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+      (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C
            L1 L2 L3 L4 cond_ok =>
-       FFV Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow).
+       FFV Cst_tac Pow_tac r0 r1 radd rmul rsub ropp rdiv rinv rpow).
 
 Ltac get_RingMeta FLD :=
   FLD ltac:
-      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+      (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C
            L1 L2 L3 L4 cond_ok =>
-       mkPolexpr C Cst_tac Pow_tac radd rmul rsub ropp rpow).
+       mkPolexpr C Cst_tac Pow_tac r0 r1 radd rmul rsub ropp rpow).
 
 Ltac get_Meta FLD :=
   FLD ltac:
-      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+      (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C
            L1 L2 L3 L4 cond_ok =>
-       mkFieldexpr C Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow).
+       mkFieldexpr C Cst_tac Pow_tac r0 r1 radd rmul rsub ropp rdiv rinv rpow).
 
 Ltac get_Hyp_tac FLD :=
   FLD ltac:
-      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+      (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C
            L1 L2 L3 L4 cond_ok =>
-       let mkPol := mkPolexpr C Cst_tac Pow_tac radd rmul rsub ropp rpow in
+       let mkPol := mkPolexpr C Cst_tac Pow_tac r0 r1 radd rmul rsub ropp rpow in
        fun fv lH => mkHyp_tac C req ltac:(fun t => mkPol t fv) lH).
 
 Ltac get_FEeval FLD :=
@@ -180,8 +192,8 @@ Ltac get_FEeval FLD :=
   match type of L1 with
   | context
     [(@FEeval
-      ?R ?r0 ?add ?mul ?sub ?opp ?div ?inv ?C ?phi ?Cpow ?powphi ?pow _ _)] =>
-       constr:(@FEeval R r0 add mul sub opp div inv C phi Cpow powphi pow)
+      ?R ?r0 ?r1 ?add ?mul ?sub ?opp ?div ?inv ?C ?phi ?Cpow ?powphi ?pow _ _)] =>
+       constr:(@FEeval R r0 r1 add mul sub opp div inv C phi Cpow powphi pow)
   | _ => fail 1 "field anomaly: bad correctness lemma (get_FEeval)"
   end.
 
@@ -201,8 +213,7 @@ Ltac fold_field_cond req :=
 Ltac simpl_PCond FLD :=
   let req := get_FldEq FLD in
   let lemma := get_CondLemma FLD in
-  try (apply lemma; intros lock lock_def; vm_compute; rewrite lock_def; 
-       clear lock_def lock);
+  try (apply lemma; intros lock lock_def; vm_compute; rewrite lock_def; clear lock_def lock); 
   protect_fv "field_cond";
   fold_field_cond req;
   try exact I.
@@ -210,8 +221,7 @@ Ltac simpl_PCond FLD :=
 Ltac simpl_PCond_BEURK FLD :=
   let req := get_FldEq FLD in
   let lemma := get_CondLemma FLD in
-  try (apply lemma; intros lock lock_def; vm_compute; rewrite lock_def; 
-       clear lock_def lock);
+  (apply lemma; intros lock lock_def; vm_compute; rewrite lock_def; clear lock_def lock);
   protect_fv "field_cond";
   fold_field_cond req.
 
@@ -544,10 +554,9 @@ Ltac field_lemmas set ext inv_m fspec pspec sspec dspec rk :=
          let field_ok2 := constr:(field_ok1 _ _ _ pp_spec) in
          match s_spec with
          | mkhypo ?ss_spec =>
-           let field_ok3 := constr:(field_ok2 _ ss_spec) in
            match d_spec with
            | mkhypo ?dd_spec =>
-             let field_ok := constr:(field_ok3 _ dd_spec) in
+             let field_ok := constr:(field_ok2 _ dd_spec) in
              let mk_lemma lemma :=
               constr:(lemma _ _ _  _ _ _  _ _ _ _
                    set ext_r inv_m afth
@@ -563,7 +572,7 @@ Ltac field_lemmas set ext inv_m fspec pspec sspec dspec rk :=
              (fun f =>
                f afth ext_r morph field_ok field_simpl_ok field_simpl_eq_ok field_simpl_eq_in
                   cond1_ok cond2_ok)
-           | _ => fail 4 "field: bad coefficiant division specification"
+           | _ => fail 4 "field: bad coefficient division specification"
            end
          | _ => fail 3 "field: bad sign specification"
          end
diff --git a/plugins/setoid_ring/Field_theory.v b/plugins/setoid_ring/Field_theory.v
index 75d3ad86..0f5c49b0 100644
--- a/plugins/setoid_ring/Field_theory.v
+++ b/plugins/setoid_ring/Field_theory.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -9,123 +9,179 @@
 Require Ring.
 Import Ring_polynom Ring_tac Ring_theory InitialRing Setoid List Morphisms.
 Require Import ZArith_base.
-(*Require Import Omega.*)
 Set Implicit Arguments.
+(* Set Universe Polymorphism. *)
 
 Section MakeFieldPol.
 
-(* Field elements *)
- Variable R:Type.
- Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R->R).
- Variable (rdiv : R -> R ->  R) (rinv : R ->  R).
- Variable req : R -> R -> Prop.
-
- Notation "0" := rO. Notation "1" := rI.
- Notation "x + y" := (radd x y).  Notation "x * y " := (rmul x y).
- Notation "x - y " := (rsub x y). Notation "x / y" := (rdiv x y).
- Notation "- x" := (ropp x). Notation "/ x" := (rinv x).
- Notation "x == y" := (req x y) (at level 70, no associativity).
-
- (* Equality properties *)
- Variable Rsth : Equivalence req.
- Variable Reqe : ring_eq_ext radd rmul ropp req.
- Variable SRinv_ext : forall p q, p == q ->  / p == / q.
-
- (* Field properties *)
-  Record almost_field_theory : Prop := mk_afield {
-    AF_AR : almost_ring_theory rO rI radd rmul rsub ropp req;
-    AF_1_neq_0 : ~ 1 == 0;
-    AFdiv_def : forall p q, p / q == p * / q;
-    AFinv_l : forall p, ~ p == 0 ->  / p * p == 1
-  }.
+(* Field elements : R *)
+
+Variable R:Type.
+Bind Scope R_scope with R.
+Delimit Scope R_scope with ring.
+Local Open Scope R_scope.
+
+Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R->R).
+Variable (rdiv : R->R->R) (rinv : R->R).
+Variable req : R -> R -> Prop.
+
+Notation "0" := rO : R_scope.
+Notation "1" := rI : R_scope.
+Infix "+" := radd : R_scope.
+Infix "-" := rsub : R_scope.
+Infix "*" := rmul : R_scope.
+Infix "/" := rdiv : R_scope.
+Notation "- x" := (ropp x) : R_scope.
+Notation "/ x" := (rinv x) : R_scope.
+Infix "==" := req (at level 70, no associativity) : R_scope.
+
+(* Equality properties *)
+Variable Rsth : Equivalence req.
+Variable Reqe : ring_eq_ext radd rmul ropp req.
+Variable SRinv_ext : forall p q, p == q ->  / p == / q.
+
+(* Field properties *)
+Record almost_field_theory : Prop := mk_afield {
+ AF_AR : almost_ring_theory rO rI radd rmul rsub ropp req;
+ AF_1_neq_0 : ~ 1 == 0;
+ AFdiv_def : forall p q, p / q == p * / q;
+ AFinv_l : forall p, ~ p == 0 ->  / p * p == 1
+}.
 
 Section AlmostField.
 
- Variable AFth : almost_field_theory.
- Let ARth := AFth.(AF_AR).
- Let rI_neq_rO := AFth.(AF_1_neq_0).
- Let rdiv_def := AFth.(AFdiv_def).
- Let rinv_l := AFth.(AFinv_l).
+Variable AFth : almost_field_theory.
+Let ARth := AFth.(AF_AR).
+Let rI_neq_rO := AFth.(AF_1_neq_0).
+Let rdiv_def := AFth.(AFdiv_def).
+Let rinv_l := AFth.(AFinv_l).
 
- (* Coefficients *)
- Variable C: Type.
- Variable (cO cI: C) (cadd cmul csub : C->C->C) (copp : C->C).
- Variable ceqb : C->C->bool.
- Variable phi : C -> R.
+Add Morphism radd : radd_ext. Proof. exact (Radd_ext Reqe). Qed.
+Add Morphism rmul : rmul_ext. Proof. exact (Rmul_ext Reqe). Qed.
+Add Morphism ropp : ropp_ext. Proof. exact (Ropp_ext Reqe). Qed.
+Add Morphism rsub : rsub_ext. Proof. exact (ARsub_ext Rsth Reqe ARth). Qed.
+Add Morphism rinv : rinv_ext. Proof. exact SRinv_ext. Qed.
 
- Variable CRmorph : ring_morph rO rI radd rmul rsub ropp req
-                               cO cI cadd cmul csub copp ceqb phi.
+Let eq_trans := Setoid.Seq_trans _ _ Rsth.
+Let eq_sym := Setoid.Seq_sym _ _ Rsth.
+Let eq_refl := Setoid.Seq_refl _ _ Rsth.
 
-Lemma ceqb_rect : forall c1 c2 (A:Type) (x y:A) (P:A->Type),
-  (phi c1 == phi c2 -> P x) -> P y -> P (if ceqb c1 c2 then x else y).
+Let radd_0_l := ARadd_0_l ARth.
+Let radd_comm := ARadd_comm ARth.
+Let radd_assoc := ARadd_assoc ARth.
+Let rmul_1_l := ARmul_1_l ARth.
+Let rmul_0_l := ARmul_0_l ARth.
+Let rmul_comm := ARmul_comm ARth.
+Let rmul_assoc := ARmul_assoc ARth.
+Let rdistr_l := ARdistr_l ARth.
+Let ropp_mul_l := ARopp_mul_l ARth.
+Let ropp_add := ARopp_add ARth.
+Let rsub_def := ARsub_def ARth.
+
+Let radd_0_r := ARadd_0_r Rsth ARth.
+Let rmul_0_r := ARmul_0_r Rsth ARth.
+Let rmul_1_r := ARmul_1_r Rsth ARth.
+Let ropp_0 := ARopp_zero Rsth Reqe ARth.
+Let rdistr_r := ARdistr_r Rsth Reqe ARth.
+
+(* Coefficients : C *)
+
+Variable C: Type.
+Bind Scope C_scope with C.
+Delimit Scope C_scope with coef.
+
+Variable (cO cI: C) (cadd cmul csub : C->C->C) (copp : C->C).
+Variable ceqb : C->C->bool.
+Variable phi : C -> R.
+
+Variable CRmorph : ring_morph rO rI radd rmul rsub ropp req
+                              cO cI cadd cmul csub copp ceqb phi.
+
+Notation "0" := cO : C_scope.
+Notation "1" := cI : C_scope.
+Infix "+" := cadd : C_scope.
+Infix "-" := csub : C_scope.
+Infix "*" := cmul : C_scope.
+Notation "- x" := (copp x) : C_scope.
+Infix "=?" := ceqb : C_scope.
+Notation "[ x ]" := (phi x) (at level 0).
+
+Let phi_0 := CRmorph.(morph0).
+Let phi_1 := CRmorph.(morph1).
+
+Lemma ceqb_spec c c' : BoolSpec ([c] == [c']) True (c =? c')%coef.
 Proof.
-intros.
-generalize (fun h => X (morph_eq CRmorph c1 c2 h)).
-case (ceqb c1 c2); auto.
+generalize (CRmorph.(morph_eq) c c').
+destruct (c =? c')%coef; auto.
 Qed.
 
+(* Power coefficients : Cpow *)
 
- (* C notations *)
- Notation "x +! y" := (cadd x y) (at level 50).
- Notation "x *! y " := (cmul x y) (at level 40).
- Notation "x -! y " := (csub x y) (at level 50).
- Notation "-! x" := (copp x) (at level 35).
- Notation " x ?=! y" := (ceqb x y) (at level 70, no associativity).
- Notation "[ x ]" := (phi x) (at level 0).
+Variable Cpow : Type.
+Variable Cp_phi : N -> Cpow.
+Variable rpow : R -> Cpow -> R.
+Variable pow_th : power_theory rI rmul req Cp_phi rpow.
+(* sign function *)
+Variable get_sign : C -> option C.
+Variable get_sign_spec : sign_theory copp ceqb get_sign.
 
+Variable cdiv:C -> C -> C*C.
+Variable cdiv_th : div_theory req cadd cmul phi cdiv.
 
- (* Useful tactics *)
-  Add Morphism radd : radd_ext.  exact (Radd_ext Reqe). Qed.
-  Add Morphism rmul : rmul_ext.  exact (Rmul_ext Reqe). Qed.
-  Add Morphism ropp : ropp_ext.  exact (Ropp_ext Reqe). Qed.
-  Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed.
-  Add Morphism rinv : rinv_ext. exact SRinv_ext. Qed.
+Let rpow_pow := pow_th.(rpow_pow_N).
 
-Let eq_trans := Setoid.Seq_trans _ _ Rsth.
-Let eq_sym := Setoid.Seq_sym _ _ Rsth.
-Let eq_refl := Setoid.Seq_refl _ _ Rsth.
+(* Polynomial expressions : (PExpr C) *)
+
+Bind Scope PE_scope with PExpr.
+Delimit Scope PE_scope with poly.
+
+Notation NPEeval := (PEeval rO rI radd rmul rsub ropp phi Cp_phi rpow).
+Notation "P @ l" := (NPEeval l P) (at level 10, no associativity).
+
+Arguments PEc _ _%coef.
+
+Notation "0" := (PEc 0) : PE_scope.
+Notation "1" := (PEc 1) : PE_scope.
+Infix "+" := PEadd : PE_scope.
+Infix "-" := PEsub : PE_scope.
+Infix "*" := PEmul : PE_scope.
+Notation "- e" := (PEopp e) : PE_scope.
+Infix "^" := PEpow : PE_scope.
+
+Definition NPEequiv e e' := forall l, e@l == e'@l.
+Infix "===" := NPEequiv (at level 70, no associativity) : PE_scope.
 
-Hint Resolve eq_refl rdiv_def rinv_l rI_neq_rO CRmorph.(morph1) .
-Hint Resolve (Rmul_ext Reqe) (Rmul_ext Reqe) (Radd_ext Reqe)
-             (ARsub_ext Rsth Reqe ARth) (Ropp_ext Reqe) SRinv_ext.
-Hint Resolve (ARadd_0_l  ARth) (ARadd_comm  ARth) (ARadd_assoc ARth)
-             (ARmul_1_l  ARth) (ARmul_0_l  ARth)
-             (ARmul_comm  ARth) (ARmul_assoc ARth) (ARdistr_l  ARth)
-             (ARopp_mul_l ARth) (ARopp_add  ARth)
-             (ARsub_def  ARth) .
-
- (* Power coefficients *)
- Variable Cpow : Type.
- Variable Cp_phi : N -> Cpow.
- Variable rpow : R -> Cpow -> R.
- Variable pow_th : power_theory rI rmul req Cp_phi rpow.
- (* sign function *)
- Variable get_sign : C -> option C.
- Variable get_sign_spec : sign_theory copp ceqb get_sign.
-
- Variable cdiv:C -> C -> C*C.
- Variable cdiv_th : div_theory req cadd cmul phi cdiv.
-
-Notation NPEeval := (PEeval rO radd rmul rsub ropp phi Cp_phi rpow).
-Notation Nnorm:= (norm_subst cO cI cadd cmul csub copp ceqb cdiv).
-
-Notation NPphi_dev := (Pphi_dev rO rI radd rmul rsub ropp cO cI ceqb phi get_sign).
-Notation NPphi_pow := (Pphi_pow rO rI radd rmul rsub ropp cO cI ceqb phi Cp_phi rpow get_sign).
+Instance NPEequiv_eq : Equivalence NPEequiv.
+Proof.
+ split; red; unfold NPEequiv; intros; [reflexivity|symmetry|etransitivity];
+  eauto.
+Qed.
+
+Instance NPEeval_ext : Proper (eq ==> NPEequiv ==> req) NPEeval.
+Proof.
+ intros l l' <- e e' He. now rewrite (He l).
+Qed.
+
+Notation Nnorm :=
+  (norm_subst cO cI cadd cmul csub copp ceqb cdiv).
+Notation NPphi_dev :=
+  (Pphi_dev rO rI radd rmul rsub ropp cO cI ceqb phi get_sign).
+Notation NPphi_pow :=
+  (Pphi_pow rO rI radd rmul rsub ropp cO cI ceqb phi Cp_phi rpow get_sign).
 
 (* add abstract semi-ring to help with some proofs *)
 Add Ring Rring : (ARth_SRth ARth).
 
-Local Hint Extern 2 (_ == _) => f_equiv.
-
 (* additional ring properties *)
 
-Lemma rsub_0_l : forall r, 0 - r == - r.
-intros; rewrite (ARsub_def ARth);ring.
+Lemma rsub_0_l r : 0 - r == - r.
+Proof.
+rewrite rsub_def; ring.
 Qed.
 
-Lemma rsub_0_r : forall r, r - 0 == r.
-intros; rewrite (ARsub_def ARth).
-rewrite (ARopp_zero Rsth Reqe ARth);  ring.
+Lemma rsub_0_r r : r - 0 == r.
+Proof.
+rewrite rsub_def, ropp_0; ring.
 Qed.
 
 (***************************************************************************
@@ -134,452 +190,525 @@ Qed.
 
   ***************************************************************************)
 
-Theorem rdiv_simpl: forall p q, ~ q == 0 ->  q * (p / q) == p.
+Theorem rdiv_simpl p q : ~ q == 0 ->  q * (p / q) == p.
 Proof.
-intros p q H.
+intros.
 rewrite rdiv_def.
-transitivity (/ q * q * p); [  ring | idtac ].
-rewrite rinv_l; auto.
+transitivity (/ q * q * p); [ ring | ].
+now rewrite rinv_l.
 Qed.
-Hint Resolve rdiv_simpl .
 
-Instance SRdiv_ext: Proper (req ==> req ==> req) rdiv.
+Instance rdiv_ext: Proper (req ==> req ==> req) rdiv.
 Proof.
-intros p1 p2 Ep q1 q2 Eq.
-transitivity (p1 * / q1); auto.
-transitivity (p2 * / q2); auto.
+intros p1 p2 Ep q1 q2 Eq. now rewrite !rdiv_def, Ep, Eq.
 Qed.
-Hint Resolve SRdiv_ext.
 
-Lemma rmul_reg_l : forall p q1 q2,
+Lemma rmul_reg_l p q1 q2 :
   ~ p == 0 -> p * q1 == p * q2 -> q1 == q2.
 Proof.
-intros p q1 q2 H EQ.
-rewrite <- (@rdiv_simpl q1 p) by trivial.
-rewrite <- (@rdiv_simpl q2 p) by trivial.
-rewrite !rdiv_def, !(ARmul_assoc ARth).
-now rewrite EQ.
+intros H EQ.
+assert (H' : p * (q1 / p) == p * (q2 / p)).
+{ now rewrite !rdiv_def, !rmul_assoc, EQ. }
+now rewrite !rdiv_simpl in H'.
 Qed.
 
-Theorem field_is_integral_domain : forall r1 r2,
+Theorem field_is_integral_domain r1 r2 :
   ~ r1 == 0 -> ~ r2 == 0 -> ~ r1 * r2 == 0.
 Proof.
-intros r1 r2 H1 H2. contradict H2.
-transitivity (1 * r2); auto.
-transitivity (/ r1 * r1 * r2); auto.
-rewrite <- (ARmul_assoc ARth).
-rewrite H2.
-apply ARmul_0_r with (1 := Rsth) (2 := ARth).
+intros H1 H2. contradict H2.
+transitivity (/r1 * r1 * r2).
+- now rewrite rinv_l.
+- now rewrite <- rmul_assoc, H2.
 Qed.
 
-Theorem ropp_neq_0 : forall r,
+Theorem ropp_neq_0 r :
   ~ -(1) == 0 -> ~ r == 0 -> ~ -r == 0.
+Proof.
 intros.
 setoid_replace (- r) with (- (1) * r).
- apply field_is_integral_domain; trivial.
- rewrite <- (ARopp_mul_l ARth).
-   rewrite (ARmul_1_l ARth).
-   reflexivity.
+- apply field_is_integral_domain; trivial.
+- now rewrite <- ropp_mul_l, rmul_1_l.
 Qed.
 
-Theorem rdiv_r_r : forall r, ~ r == 0 -> r / r == 1.
-intros.
-rewrite (AFdiv_def AFth).
-rewrite (ARmul_comm ARth).
-apply (AFinv_l AFth).
-trivial.
+Theorem rdiv_r_r r : ~ r == 0 -> r / r == 1.
+Proof.
+intros. rewrite rdiv_def, rmul_comm. now apply rinv_l.
 Qed.
 
-Theorem rdiv1: forall r,  r == r / 1.
-intros r; transitivity (1 * (r / 1)); auto.
+Theorem rdiv1 r : r == r / 1.
+Proof.
+transitivity (1 * (r / 1)).
+- symmetry; apply rdiv_simpl. apply rI_neq_rO.
+- apply rmul_1_l.
 Qed.
 
-Theorem rdiv2:
- forall r1 r2 r3 r4,
- ~ r2 == 0 ->
- ~ r4 == 0 ->
- r1 / r2 + r3 / r4 == (r1 * r4 + r3 * r2) / (r2 * r4).
+Theorem rdiv2 a b c d :
+ ~ b == 0 ->
+ ~ d == 0 ->
+ a / b + c / d == (a * d + c * b) / (b * d).
 Proof.
-intros r1 r2 r3 r4 H H0.
-assert (~ r2 * r4 == 0) by (apply field_is_integral_domain; trivial).
-apply rmul_reg_l with (r2 * r4); trivial.
+intros H H0.
+assert (~ b * d == 0) by now apply field_is_integral_domain.
+apply rmul_reg_l with (b * d); trivial.
 rewrite rdiv_simpl; trivial.
-rewrite (ARdistr_r Rsth Reqe ARth).
-apply (Radd_ext Reqe).
-- transitivity (r2 * (r1 / r2) * r4); [  ring | auto ].
-- transitivity (r2 * (r4 * (r3 / r4))); auto.
-  transitivity (r2 * r3); auto.
+rewrite rdistr_r.
+apply radd_ext.
+- now rewrite <- rmul_assoc, (rmul_comm d), rmul_assoc, rdiv_simpl.
+- now rewrite (rmul_comm c), <- rmul_assoc, rdiv_simpl.
 Qed.
 
 
-Theorem rdiv2b:
- forall r1 r2 r3 r4 r5,
- ~ (r2*r5) == 0 ->
- ~ (r4*r5) == 0 ->
- r1 / (r2*r5) + r3 / (r4*r5) == (r1 * r4 + r3 * r2) / (r2 * (r4 * r5)).
+Theorem rdiv2b a b c d e :
+ ~ (b*e) == 0 ->
+ ~ (d*e) == 0 ->
+ a / (b*e) + c / (d*e) == (a * d + c * b) / (b * (d * e)).
 Proof.
-intros r1 r2 r3 r4 r5 H H0.
-assert (HH1: ~ r2 == 0) by (intros HH; case H; rewrite HH; ring).
-assert (HH2: ~ r5 == 0) by (intros HH; case H; rewrite HH; ring).
-assert (HH3: ~ r4 == 0) by (intros HH; case H0; rewrite HH; ring).
-assert (HH4: ~ r2 * (r4 * r5) == 0)
+intros H H0.
+assert (~ b == 0) by (contradict H; rewrite H; ring).
+assert (~ e == 0) by (contradict H; rewrite H; ring).
+assert (~ d == 0) by (contradict H0; rewrite H0; ring).
+assert (~ b * (d * e) == 0)
    by (repeat apply field_is_integral_domain; trivial).
-apply rmul_reg_l with (r2 * (r4 * r5)); trivial.
+apply rmul_reg_l with (b * (d * e)); trivial.
 rewrite rdiv_simpl; trivial.
-rewrite (ARdistr_r Rsth Reqe ARth).
-apply (Radd_ext Reqe).
- transitivity ((r2 * r5) * (r1 / (r2 * r5)) * r4); [  ring | auto ].
- transitivity ((r4 * r5) * (r3 / (r4 * r5)) * r2); [  ring | auto ].
-Qed.
-
-Theorem rdiv5: forall r1 r2,  - (r1 / r2) == - r1 / r2.
-Proof.
-intros r1 r2.
-transitivity (- (r1 * / r2)); auto.
-transitivity (- r1 * / r2); auto.
-Qed.
-Hint Resolve rdiv5 .
-
-Theorem rdiv3 r1 r2 r3 r4 :
- ~ r2 == 0 ->
- ~ r4 == 0 ->
- r1 / r2 - r3 / r4 == (r1 * r4 -  r3 * r2) / (r2 * r4).
-Proof.
-intros H2 H4.
-assert (~ r2 * r4 == 0) by (apply field_is_integral_domain; trivial).
-transitivity (r1 / r2 + - (r3 / r4)); auto.
-transitivity (r1 / r2 + - r3 / r4); auto.
-transitivity ((r1 * r4 + - r3 * r2) / (r2 * r4)).
-apply rdiv2; auto.
-f_equiv.
-transitivity (r1 * r4 + - (r3 * r2)); auto.
-Qed.
-
-
-Theorem rdiv3b:
- forall r1 r2 r3 r4 r5,
- ~ (r2 * r5) == 0 ->
- ~ (r4 * r5) == 0 ->
- r1 / (r2*r5) - r3 / (r4*r5) == (r1 * r4 - r3 * r2) / (r2 * (r4 * r5)).
-Proof.
-intros r1 r2 r3 r4 r5 H H0.
-transitivity (r1 / (r2 * r5) + - (r3 / (r4 * r5))); auto.
-transitivity (r1 / (r2 * r5) + - r3 / (r4 * r5)); auto.
-transitivity ((r1 * r4 + - r3 * r2) / (r2 * (r4 * r5))).
-apply rdiv2b; auto; try ring.
-apply (SRdiv_ext); auto.
-transitivity (r1 * r4 + - (r3 * r2)); symmetry; auto.
-Qed.
-
-Theorem rdiv6:
- forall r1 r2,
- ~ r1 == 0 -> ~ r2 == 0 ->  / (r1 / r2) == r2 / r1.
-intros r1 r2 H H0.
-assert (~ r1 / r2 == 0) as Hk.
- intros H1; case H.
-   transitivity (r2 * (r1 / r2)); auto.
-   rewrite H1;  ring.
- apply rmul_reg_l with (r1 / r2); auto.
-   transitivity (/ (r1 / r2) * (r1 / r2)); auto.
-   transitivity 1; auto.
-   repeat rewrite rdiv_def.
-   transitivity (/ r1 * r1 * (/ r2 * r2)); [ idtac |  ring ].
-   repeat rewrite rinv_l; auto.
-Qed.
-Hint Resolve rdiv6 .
-
- Theorem rdiv4:
- forall r1 r2 r3 r4,
- ~ r2 == 0 ->
- ~ r4 == 0 ->
- (r1 / r2) * (r3 / r4) == (r1 * r3) / (r2 * r4).
-Proof.
-intros r1 r2 r3 r4 H H0.
-assert (~ r2 * r4 == 0) by (apply field_is_integral_domain; trivial).
-apply rmul_reg_l with (r2 * r4); trivial.
-rewrite rdiv_simpl; trivial.
-transitivity (r2 * (r1 / r2) * (r4 * (r3 / r4))); [  ring | idtac ].
-repeat rewrite rdiv_simpl; trivial.
+rewrite rdistr_r.
+apply radd_ext.
+- transitivity ((b * e) * (a / (b * e)) * d);
+  [ ring | now rewrite rdiv_simpl ].
+- transitivity ((d * e) * (c / (d * e)) * b);
+  [ ring | now rewrite rdiv_simpl ].
 Qed.
 
- Theorem rdiv4b:
- forall r1 r2 r3 r4 r5 r6,
- ~ r2 * r5 == 0 ->
- ~ r4 * r6 == 0 ->
- ((r1 * r6) / (r2 * r5)) * ((r3 * r5) / (r4 * r6)) == (r1 * r3) / (r2 * r4).
+Theorem rdiv5 a b : - (a / b) == - a / b.
 Proof.
-intros r1 r2 r3 r4 r5 r6 H H0.
-rewrite rdiv4; auto.
-transitivity ((r5 * r6) * (r1 * r3) / ((r5 * r6) * (r2 * r4))).
-apply SRdiv_ext; ring.
-assert (HH: ~ r5*r6 == 0).
-  apply field_is_integral_domain.
-    intros H1; case H; rewrite H1; ring.
-    intros H1; case H0; rewrite H1; ring.
-rewrite <- rdiv4 ; auto.
-  rewrite rdiv_r_r; auto.
+now rewrite !rdiv_def, ropp_mul_l.
+Qed.
 
-  apply field_is_integral_domain.
-    intros H1; case H; rewrite H1; ring.
-    intros H1; case H0; rewrite H1; ring.
+Theorem rdiv3b a b c d e :
+ ~ (b * e) == 0 ->
+ ~ (d * e) == 0 ->
+ a / (b*e) - c / (d*e) == (a * d - c * b) / (b * (d * e)).
+Proof.
+intros H H0.
+rewrite !rsub_def, rdiv5, ropp_mul_l.
+now apply rdiv2b.
 Qed.
 
+Theorem rdiv6 a b :
+ ~ a == 0 -> ~ b == 0 ->  / (a / b) == b / a.
+Proof.
+intros H H0.
+assert (Hk : ~ a / b == 0).
+{ contradict H.
+  transitivity (b * (a / b)).
+  - now rewrite rdiv_simpl.
+  - rewrite H. apply rmul_0_r. }
+apply rmul_reg_l with (a / b); trivial.
+rewrite (rmul_comm (a / b)), rinv_l; trivial.
+rewrite !rdiv_def.
+transitivity (/ a * a * (/ b * b)); [ | ring ].
+now rewrite !rinv_l, rmul_1_l.
+Qed.
+
+Theorem rdiv4 a b c d :
+ ~ b == 0 ->
+ ~ d == 0 ->
+ (a / b) * (c / d) == (a * c) / (b * d).
+Proof.
+intros H H0.
+assert (~ b * d == 0) by now apply field_is_integral_domain.
+apply rmul_reg_l with (b * d); trivial.
+rewrite rdiv_simpl; trivial.
+transitivity (b * (a / b) * (d * (c / d))); [ ring | ].
+rewrite !rdiv_simpl; trivial.
+Qed.
 
-Theorem rdiv7:
- forall r1 r2 r3 r4,
- ~ r2 == 0 ->
- ~ r3 == 0 ->
- ~ r4 == 0 ->
- (r1 / r2) / (r3 / r4) == (r1 * r4) / (r2 * r3).
+Theorem rdiv4b a b c d e f :
+ ~ b * e == 0 ->
+ ~ d * f == 0 ->
+ ((a * f) / (b * e)) * ((c * e) / (d * f)) == (a * c) / (b * d).
+Proof.
+intros H H0.
+assert (~ b == 0) by (contradict H; rewrite H; ring).
+assert (~ e == 0) by (contradict H; rewrite H; ring).
+assert (~ d == 0) by (contradict H0; rewrite H0; ring).
+assert (~ f == 0) by (contradict H0; rewrite H0; ring).
+assert (~ b*d == 0) by now apply field_is_integral_domain.
+assert (~ e*f == 0) by now apply field_is_integral_domain.
+rewrite rdiv4; trivial.
+transitivity ((e * f) * (a * c) / ((e * f) * (b * d))).
+- apply rdiv_ext; ring.
+- rewrite <- rdiv4, rdiv_r_r; trivial.
+Qed.
+
+Theorem rdiv7 a b c d :
+ ~ b == 0 ->
+ ~ c == 0 ->
+ ~ d == 0 ->
+ (a / b) / (c / d) == (a * d) / (b * c).
 Proof.
 intros.
-rewrite (rdiv_def (r1 / r2)).
+rewrite (rdiv_def (a / b)).
 rewrite rdiv6; trivial.
 apply rdiv4; trivial.
 Qed.
 
-Theorem rdiv7b:
- forall r1 r2 r3 r4 r5 r6,
- ~ r2 * r6 == 0 ->
- ~ r3 * r5 == 0 ->
- ~ r4 * r6 == 0 ->
- ((r1 * r5) / (r2 * r6)) / ((r3 * r5) / (r4 * r6)) == (r1 * r4) / (r2 * r3).
+Theorem rdiv7b a b c d e f :
+ ~ b * f == 0 ->
+ ~ c * e == 0 ->
+ ~ d * f == 0 ->
+ ((a * e) / (b * f)) / ((c * e) / (d * f)) == (a * d) / (b * c).
+Proof.
+intros Hbf Hce Hdf.
+assert (~ c==0) by (contradict Hce; rewrite Hce; ring).
+assert (~ e==0) by (contradict Hce; rewrite Hce; ring).
+assert (~ b==0) by (contradict Hbf; rewrite Hbf; ring).
+assert (~ f==0) by (contradict Hbf; rewrite Hbf; ring).
+assert (~ b*c==0) by now apply field_is_integral_domain.
+assert (~ e*f==0) by now apply field_is_integral_domain.
+rewrite rdiv7; trivial.
+transitivity ((e * f) * (a * d) / ((e * f) * (b * c))).
+- apply rdiv_ext; ring.
+- now rewrite <- rdiv4, rdiv_r_r.
+Qed.
+
+Theorem rinv_nz a : ~ a == 0 -> ~ /a == 0.
+Proof.
+intros H H0. apply rI_neq_rO.
+rewrite <- (rdiv_r_r H), rdiv_def, H0. apply rmul_0_r.
+Qed.
+
+Theorem rdiv8 a b : ~ b == 0 -> a == 0 ->  a / b == 0.
+Proof.
+intros H H0.
+now rewrite rdiv_def, H0, rmul_0_l.
+Qed.
+
+Theorem cross_product_eq a b c d :
+  ~ b == 0 -> ~ d == 0 -> a * d == c * b -> a / b == c / d.
 Proof.
 intros.
-rewrite rdiv7; auto.
-transitivity ((r5 * r6) * (r1 * r4) / ((r5 * r6) * (r2 * r3))).
-apply SRdiv_ext; ring.
-assert (HH: ~ r5*r6 == 0).
-  apply field_is_integral_domain.
-    intros H2; case H0; rewrite H2; ring.
-    intros H2; case H1; rewrite H2; ring.
-rewrite <- rdiv4 ; auto.
-rewrite rdiv_r_r; auto.
-  apply field_is_integral_domain.
-    intros H2; case H; rewrite H2; ring.
-    intros H2; case H0; rewrite H2; ring.
+transitivity (a / b * (d / d)).
+- now rewrite rdiv_r_r, rmul_1_r.
+- now rewrite rdiv4, H1, (rmul_comm b d), <- rdiv4, rdiv_r_r.
 Qed.
 
+(* Results about [pow_pos] and [pow_N] *)
 
-Theorem rdiv8: forall r1 r2, ~ r2 == 0 -> r1 == 0 ->  r1 / r2 == 0.
-intros r1 r2 H H0.
-transitivity (r1 * / r2); auto.
-transitivity (0 * / r2); auto.
+Instance pow_ext : Proper (req ==> eq ==> req) (pow_pos rmul).
+Proof.
+intros x y H p p' <-.
+induction p as [p IH| p IH|];simpl; trivial; now rewrite !IH, ?H.
 Qed.
 
+Instance pow_N_ext : Proper (req ==> eq ==> req) (pow_N rI rmul).
+Proof.
+intros x y H n n' <-. destruct n; simpl; trivial. now apply pow_ext.
+Qed.
 
-Theorem cross_product_eq : forall r1 r2 r3 r4,
-  ~ r2 == 0 -> ~ r4 == 0 -> r1 * r4 == r3 * r2 -> r1 / r2 == r3 / r4.
-intros.
-transitivity (r1 / r2 * (r4 / r4)).
- rewrite rdiv_r_r; trivial.
-   symmetry .
-   apply (ARmul_1_r Rsth ARth).
- rewrite rdiv4; trivial.
-   rewrite H1.
-   rewrite (ARmul_comm ARth r2 r4).
-   rewrite <- rdiv4; trivial.
-   rewrite rdiv_r_r by trivial.
-  apply (ARmul_1_r Rsth ARth).
+Lemma pow_pos_0 p : pow_pos rmul 0 p == 0.
+Proof.
+induction p;simpl;trivial; now rewrite !IHp.
 Qed.
 
+Lemma pow_pos_1 p : pow_pos rmul 1 p == 1.
+Proof.
+induction p;simpl;trivial; ring [IHp].
+Qed.
+
+Lemma pow_pos_cst c p : pow_pos rmul [c] p == [pow_pos cmul c p].
+Proof.
+induction p;simpl;trivial; now rewrite !CRmorph.(morph_mul), !IHp.
+Qed.
+
+Lemma pow_pos_mul_l x y p :
+ pow_pos rmul (x * y) p == pow_pos rmul x p * pow_pos rmul y p.
+Proof.
+induction p;simpl;trivial; ring [IHp].
+Qed.
+
+Lemma pow_pos_add_r x p1 p2 :
+ pow_pos rmul x (p1+p2) == pow_pos rmul x p1 * pow_pos rmul x p2.
+Proof.
+ exact (Ring_theory.pow_pos_add Rsth rmul_ext rmul_assoc x p1 p2).
+Qed.
+
+Lemma pow_pos_mul_r x p1 p2 :
+  pow_pos rmul x (p1*p2) == pow_pos rmul (pow_pos rmul x p1) p2.
+Proof.
+induction p1;simpl;intros; rewrite ?pow_pos_mul_l, ?pow_pos_add_r;
+ simpl; trivial; ring [IHp1].
+Qed.
+
+Lemma pow_pos_nz x p : ~x==0 -> ~pow_pos rmul x p == 0.
+Proof.
+ intros Hx. induction p;simpl;trivial;
+  repeat (apply field_is_integral_domain; trivial).
+Qed.
+
+Lemma pow_pos_div a b p : ~ b == 0 ->
+ pow_pos rmul (a / b) p == pow_pos rmul a p / pow_pos rmul b p.
+Proof.
+ intros.
+ induction p; simpl; trivial.
+ - rewrite IHp.
+   assert (nz := pow_pos_nz p H).
+   rewrite !rdiv4; trivial.
+   apply field_is_integral_domain; trivial.
+ - rewrite IHp.
+   assert (nz := pow_pos_nz p H).
+   rewrite !rdiv4; trivial.
+Qed.
+
+(* === is a morphism *)
+
+Instance PEadd_ext : Proper (NPEequiv ==> NPEequiv ==> NPEequiv) (@PEadd C).
+Proof. intros ? ? E ? ? E' l. simpl. now rewrite E, E'. Qed.
+Instance PEsub_ext : Proper (NPEequiv ==> NPEequiv ==> NPEequiv) (@PEsub C).
+Proof. intros ? ? E ? ? E' l. simpl. now rewrite E, E'. Qed.
+Instance PEmul_ext : Proper (NPEequiv ==> NPEequiv ==> NPEequiv) (@PEmul C).
+Proof. intros ? ? E ? ? E' l. simpl. now rewrite E, E'. Qed.
+Instance PEopp_ext : Proper (NPEequiv ==> NPEequiv) (@PEopp C).
+Proof. intros ? ? E l. simpl. now rewrite E. Qed.
+Instance PEpow_ext : Proper (NPEequiv ==> eq ==> NPEequiv) (@PEpow C).
+Proof.
+ intros ? ? E ? ? <- l. simpl. rewrite !rpow_pow. apply pow_N_ext; trivial.
+Qed.
+
+Lemma PE_1_l (e : PExpr C) : (1 * e === e)%poly.
+Proof.
+ intros l. simpl. rewrite phi_1. apply rmul_1_l.
+Qed.
+
+Lemma PE_1_r (e : PExpr C) : (e * 1 === e)%poly.
+Proof.
+ intros l. simpl. rewrite phi_1. apply rmul_1_r.
+Qed.
+
+Lemma PEpow_0_r (e : PExpr C) : (e ^ 0 === 1)%poly.
+Proof.
+ intros l. simpl. now rewrite !rpow_pow.
+Qed.
+
+Lemma PEpow_1_r (e : PExpr C) : (e ^ 1 === e)%poly.
+Proof.
+ intros l. simpl. now rewrite !rpow_pow.
+Qed.
+
+Lemma PEpow_1_l n : (1 ^ n === 1)%poly.
+Proof.
+ intros l. simpl. rewrite rpow_pow. destruct n; simpl.
+ - now rewrite phi_1.
+ - now rewrite phi_1, pow_pos_1.
+Qed.
+
+Lemma PEpow_add_r (e : PExpr C) n n' :
+ (e ^ (n+n') === e ^ n * e ^ n')%poly.
+Proof.
+ intros l. simpl. rewrite !rpow_pow.
+ destruct n; simpl.
+ - rewrite rmul_1_l. trivial.
+ - destruct n'; simpl.
+   + rewrite rmul_1_r. trivial.
+   + apply pow_pos_add_r.
+Qed.
+
+Lemma PEpow_mul_l (e e' : PExpr C) n :
+ ((e * e') ^ n === e ^ n * e' ^ n)%poly.
+Proof.
+ intros l. simpl. rewrite !rpow_pow. destruct n; simpl; trivial.
+ - symmetry; apply rmul_1_l.
+ - apply pow_pos_mul_l.
+Qed.
+
+Lemma PEpow_mul_r (e : PExpr C) n n' :
+ (e ^ (n * n') === (e ^ n) ^ n')%poly.
+Proof.
+ intros l. simpl. rewrite !rpow_pow.
+ destruct n, n'; simpl; trivial.
+ - now rewrite pow_pos_1.
+ - apply pow_pos_mul_r.
+Qed.
+
+Lemma PEpow_nz l e n : ~ e @ l == 0 -> ~ (e^n) @ l == 0.
+Proof.
+ intros. simpl. rewrite rpow_pow. destruct n; simpl.
+ - apply rI_neq_rO.
+ - now apply pow_pos_nz.
+Qed.
+
+
 (***************************************************************************
 
                        Some equality test
 
   ***************************************************************************)
 
+Local Notation "a &&& b" := (if a then b else false)
+ (at level 40, left associativity).
+
 (* equality test *)
-Fixpoint PExpr_eq (e1 e2 : PExpr C) {struct e1} : bool :=
- match e1, e2 with
-   PEc c1, PEc c2 => ceqb c1 c2
-  | PEX p1, PEX p2 => Pos.eqb p1 p2
-  | PEadd e3 e5, PEadd e4 e6 => if PExpr_eq e3 e4 then PExpr_eq e5 e6 else false
-  | PEsub e3 e5, PEsub e4 e6 => if PExpr_eq e3 e4 then PExpr_eq e5 e6 else false
-  | PEmul e3 e5, PEmul e4 e6 => if PExpr_eq e3 e4 then PExpr_eq e5 e6 else false
-  | PEopp e3, PEopp e4 => PExpr_eq e3 e4
-  | PEpow e3 n3, PEpow e4 n4 => if N.eqb n3 n4 then PExpr_eq e3 e4 else false
+Fixpoint PExpr_eq (e e' : PExpr C) {struct e} : bool :=
+ match e, e' with
+  | PEc c, PEc c' => ceqb c c'
+  | PEX _ p, PEX _ p' => Pos.eqb p p'
+  | e1 + e2, e1' + e2' => PExpr_eq e1 e1' &&& PExpr_eq e2 e2'
+  | e1 - e2, e1' - e2' => PExpr_eq e1 e1' &&& PExpr_eq e2 e2'
+  | e1 * e2, e1' * e2' => PExpr_eq e1 e1' &&& PExpr_eq e2 e2'
+  | - e, - e' => PExpr_eq e e'
+  | e ^ n, e' ^ n' => N.eqb n n' &&& PExpr_eq e e'
   | _, _ => false
- end.
-
-Add Morphism (pow_pos rmul) with signature req ==> eq ==> req as pow_morph.
-intros x y H p;induction p as [p IH| p IH|];simpl;auto;ring[IH].
-Qed.
-
-Add Morphism (pow_N rI rmul) with signature req ==> eq ==> req as pow_N_morph.
-intros x y H [|p];simpl;auto. apply pow_morph;trivial.
-Qed.
-
-Theorem PExpr_eq_semi_correct:
- forall l e1 e2, PExpr_eq e1 e2 = true ->  NPEeval l e1 == NPEeval l e2.
-intros l e1; elim e1.
-intros c1; intros e2; elim e2; simpl; (try (intros; discriminate)).
-intros c2; apply (morph_eq CRmorph).
-intros p1; intros e2; elim e2; simpl; (try (intros; discriminate)).
-intros p2; case Pos.eqb_spec; intros; now subst.
-intros e3 rec1 e5 rec2 e2; case e2; simpl; (try (intros; discriminate)).
-intros e4 e6; generalize (rec1 e4); case (PExpr_eq e3 e4);
- (try (intros; discriminate)); generalize (rec2 e6); case (PExpr_eq e5 e6);
- (try (intros; discriminate)); auto.
-intros e3 rec1 e5 rec2 e2; case e2; simpl; (try (intros; discriminate)).
-intros e4 e6; generalize (rec1 e4); case (PExpr_eq e3 e4);
- (try (intros; discriminate)); generalize (rec2 e6); case (PExpr_eq e5 e6);
- (try (intros; discriminate)); auto.
-intros e3 rec1 e5 rec2 e2; case e2; simpl; (try (intros; discriminate)).
-intros e4 e6; generalize (rec1 e4); case (PExpr_eq e3 e4);
- (try (intros; discriminate)); generalize (rec2 e6); case (PExpr_eq e5 e6);
- (try (intros; discriminate)); auto.
-intros e3 rec e2; (case e2; simpl; (try (intros; discriminate))).
-intros e4; generalize (rec e4); case (PExpr_eq e3 e4);
- (try (intros; discriminate)); auto.
-intros e3 rec n3 e2;(case e2;simpl;(try (intros;discriminate))).
-intros e4 n4; case N.eqb_spec; try discriminate; intros EQ H; subst.
-repeat rewrite  pow_th.(rpow_pow_N). rewrite (rec _ H);auto.
-Qed.
-
-(* add *)
-Definition NPEadd e1 e2 :=
-  match e1, e2 with
-    PEc c1, PEc c2 => PEc (cadd c1 c2)
-  | PEc c, _ => if ceqb c cO then e2 else PEadd e1 e2
-  |  _, PEc c => if ceqb c cO then e1 else PEadd e1 e2
-    (* Peut t'on factoriser ici ??? *)
-  | _, _ => PEadd e1 e2
-  end.
+ end%poly.
 
-Theorem NPEadd_correct:
- forall l e1 e2, NPEeval l (NPEadd e1 e2) == NPEeval l (PEadd e1 e2).
+Lemma if_true (a b : bool) : a &&& b = true -> a = true /\ b = true.
 Proof.
-intros l e1 e2.
-destruct e1; destruct e2; simpl; try reflexivity; try apply ceqb_rect;
- try (intro eq_c; rewrite eq_c); simpl;try apply eq_refl;
- try (ring [(morph0 CRmorph)]).
- apply (morph_add CRmorph).
+ destruct a, b; split; trivial.
 Qed.
 
-Definition NPEpow x n :=
-  match n with
-  | N0 => PEc cI
-  | Npos p =>
-    if Pos.eqb p xH then x else
-    match x with
-    | PEc c =>
-      if ceqb c cI then PEc cI else if ceqb c cO then PEc cO else PEc (pow_pos cmul c p)
-    | _ => PEpow x n
-    end
-  end.
-
-Theorem NPEpow_correct : forall l e n,
-  NPEeval l (NPEpow e n) == NPEeval l (PEpow e n).
+Theorem PExpr_eq_semi_ok e e' :
+ PExpr_eq e e' = true ->  (e === e')%poly.
+Proof.
+revert e'; induction e; destruct e'; simpl; try discriminate.
+- intros H l. now apply (morph_eq CRmorph).
+- case Pos.eqb_spec; intros; now subst.
+- intros H; destruct (if_true _ _ H). now rewrite IHe1, IHe2.
+- intros H; destruct (if_true _ _ H). now rewrite IHe1, IHe2.
+- intros H; destruct (if_true _ _ H). now rewrite IHe1, IHe2.
+- intros H. now rewrite IHe.
+- intros H. destruct (if_true _ _ H).
+  apply N.eqb_eq in H0. now rewrite IHe, H0.
+Qed.
+
+Lemma PExpr_eq_spec e e' : BoolSpec (e === e')%poly True (PExpr_eq e e').
 Proof.
- destruct n;simpl.
- rewrite pow_th.(rpow_pow_N);simpl;auto.
- fold (p =? 1)%positive.
- case Pos.eqb_spec; intros H; (rewrite H || clear H).
- now rewrite  pow_th.(rpow_pow_N).
- destruct e;simpl;auto.
- repeat apply ceqb_rect;simpl;intros;rewrite pow_th.(rpow_pow_N);simpl.
- symmetry;induction p;simpl;trivial; ring [IHp H CRmorph.(morph1)].
- symmetry; induction p;simpl;trivial;ring [IHp CRmorph.(morph0)].
- induction p;simpl;auto;repeat rewrite CRmorph.(morph_mul);ring [IHp].
+ assert (H := PExpr_eq_semi_ok e e').
+ destruct PExpr_eq; constructor; intros; trivial. now apply H.
 Qed.
 
-(* mul *)
-Fixpoint NPEmul (x y : PExpr C) {struct x} : PExpr C :=
-  match x, y with
-    PEc c1, PEc c2 => PEc (cmul c1 c2)
-  | PEc c, _ =>
-      if ceqb c cI then y else if ceqb c cO then PEc cO else PEmul x y
-  |  _, PEc c =>
-      if ceqb c cI then x else if ceqb c cO then PEc cO else PEmul x y
-  | PEpow e1 n1, PEpow e2 n2 =>
-      if N.eqb n1 n2 then NPEpow (NPEmul e1 e2) n1 else PEmul x y
-  | _, _ => PEmul x y
-  end.
+(** Smart constructors for polynomial expression,
+    with reduction of constants *)
 
-Lemma pow_pos_mul : forall x y p, pow_pos rmul (x * y) p == pow_pos rmul x p * pow_pos rmul y p.
-induction p;simpl;auto;try ring [IHp].
-Qed.
+Definition NPEadd e1 e2 :=
+  match e1, e2 with
+  | PEc c1, PEc c2 => PEc (c1 + c2)
+  | PEc c, _ => if (c =? 0)%coef then e2 else e1 + e2
+  |  _, PEc c => if (c =? 0)%coef then e1 else e1 + e2
+    (* Peut t'on factoriser ici ??? *)
+  | _, _ => (e1 + e2)
+  end%poly.
+Infix "++" := NPEadd (at level 60, right associativity).
 
-Theorem NPEmul_correct : forall l e1 e2,
-  NPEeval l (NPEmul e1 e2) == NPEeval l (PEmul e1 e2).
-induction e1;destruct e2; simpl;try reflexivity;
- repeat apply ceqb_rect;
- try (intro eq_c; rewrite eq_c); simpl; try reflexivity;
- try ring [(morph0 CRmorph) (morph1 CRmorph)].
- apply (morph_mul CRmorph).
-case N.eqb_spec; intros H; try rewrite <- H; clear H.
-rewrite NPEpow_correct. simpl.
-repeat rewrite pow_th.(rpow_pow_N).
-rewrite IHe1; destruct n;simpl;try ring.
-apply pow_pos_mul.
-simpl;auto.
+Theorem NPEadd_ok e1 e2 : (e1 ++ e2 === e1 + e2)%poly.
+Proof.
+intros l.
+destruct e1, e2; simpl; try reflexivity; try (case ceqb_spec);
+try intro H; try rewrite H; simpl;
+try apply eq_refl; try (ring [phi_0]).
+apply (morph_add CRmorph).
 Qed.
 
-(* sub *)
 Definition NPEsub e1 e2 :=
   match e1, e2 with
-    PEc c1, PEc c2 => PEc (csub c1 c2)
-  | PEc c, _ => if ceqb c cO then PEopp e2 else PEsub e1 e2
-  |  _, PEc c => if ceqb c cO then e1 else PEsub e1 e2
+  | PEc c1, PEc c2 => PEc (c1 - c2)
+  | PEc c, _ => if (c =? 0)%coef then - e2 else e1 - e2
+  |  _, PEc c => if (c =? 0)%coef then e1 else e1 - e2
      (* Peut-on factoriser ici *)
-  | _, _ => PEsub e1 e2
-  end.
+  | _, _ => e1 - e2
+  end%poly.
+Infix "--" := NPEsub (at level 50, left associativity).
 
-Theorem NPEsub_correct:
- forall l e1 e2,  NPEeval l (NPEsub e1 e2) == NPEeval l (PEsub e1 e2).
-intros l e1 e2.
-destruct e1; destruct e2; simpl; try reflexivity; try apply ceqb_rect;
- try (intro eq_c; rewrite eq_c); simpl;
- try rewrite (morph0 CRmorph); try reflexivity;
+Theorem NPEsub_ok e1 e2: (e1 -- e2 === e1 - e2)%poly.
+Proof.
+intros l.
+destruct e1, e2; simpl; try reflexivity; try case ceqb_spec;
+ try intro H; try rewrite H; simpl;
+ try rewrite phi_0; try reflexivity;
  try (symmetry; apply rsub_0_l); try (symmetry; apply rsub_0_r).
 apply (morph_sub CRmorph).
 Qed.
 
-(* opp *)
 Definition NPEopp e1 :=
-  match e1 with PEc c1 => PEc (copp c1) | _ => PEopp e1 end.
+  match e1 with PEc c1 => PEc (- c1) | _ => - e1 end%poly.
+
+Theorem NPEopp_ok e : (NPEopp e === -e)%poly.
+Proof.
+intros l. destruct e; simpl; trivial. apply (morph_opp CRmorph).
+Qed.
+
+Definition NPEpow x n :=
+  match n with
+  | N0 => 1
+  | Npos p =>
+    if (p =? 1)%positive then x else
+    match x with
+    | PEc c =>
+      if (c =? 1)%coef then 1
+      else if (c =? 0)%coef then 0
+      else PEc (pow_pos cmul c p)
+    | _ => x ^ n
+    end
+  end%poly.
+Infix "^^" := NPEpow (at level 35, right associativity).
 
-Theorem NPEopp_correct:
- forall l e1,  NPEeval l (NPEopp e1) == NPEeval l (PEopp e1).
-intros l e1; case e1; simpl; auto.
-intros; apply (morph_opp CRmorph).
+Theorem NPEpow_ok e n : (e ^^ n === e ^ n)%poly.
+Proof.
+ intros l. unfold NPEpow; destruct n.
+ - simpl; now rewrite rpow_pow.
+ - case Pos.eqb_spec; [intro; subst | intros _].
+   + simpl. now rewrite rpow_pow.
+   + destruct e;simpl;trivial.
+     repeat case ceqb_spec; intros; rewrite ?rpow_pow, ?H; simpl.
+     * now rewrite phi_1, pow_pos_1.
+     * now rewrite phi_0, pow_pos_0.
+     * now rewrite pow_pos_cst.
+Qed.
+
+Fixpoint NPEmul (x y : PExpr C) {struct x} : PExpr C :=
+  match x, y with
+  | PEc c1, PEc c2 => PEc (c1 * c2)
+  | PEc c, _ => if (c =? 1)%coef then y else if (c =? 0)%coef then 0 else x * y
+  | _, PEc c => if (c =? 1)%coef then x else if (c =? 0)%coef then 0 else x * y
+  | e1 ^ n1, e2 ^ n2 => if (n1 =? n2)%N then (NPEmul e1 e2)^^n1 else x * y
+  | _, _ => x * y
+  end%poly.
+Infix "**" := NPEmul (at level 40, left associativity).
+
+Theorem NPEmul_ok e1 e2 : (e1 ** e2 === e1 * e2)%poly.
+Proof.
+intros l.
+revert e2; induction e1;destruct e2; simpl;try reflexivity;
+ repeat (case ceqb_spec; intro H; try rewrite H; clear H);
+ simpl; try reflexivity; try ring [phi_0 phi_1].
+ apply (morph_mul CRmorph).
+case N.eqb_spec; [intros <- | reflexivity].
+rewrite NPEpow_ok. simpl.
+rewrite !rpow_pow. rewrite IHe1.
+destruct n; simpl; [ ring | apply pow_pos_mul_l ].
 Qed.
 
 (* simplification *)
-Fixpoint PExpr_simp (e : PExpr C) : PExpr C :=
+Fixpoint PEsimp (e : PExpr C) : PExpr C :=
  match e with
-   PEadd e1 e2 => NPEadd (PExpr_simp e1) (PExpr_simp e2)
-  | PEmul e1 e2 => NPEmul (PExpr_simp e1) (PExpr_simp e2)
-  | PEsub e1 e2 => NPEsub (PExpr_simp e1) (PExpr_simp e2)
-  | PEopp e1 => NPEopp (PExpr_simp e1)
-  | PEpow e1 n1 => NPEpow (PExpr_simp e1) n1
+  | e1 + e2 => (PEsimp e1) ++ (PEsimp e2)
+  | e1 * e2 => (PEsimp e1) ** (PEsimp e2)
+  | e1 - e2 => (PEsimp e1) -- (PEsimp e2)
+  | - e1 => NPEopp (PEsimp e1)
+  | e1 ^ n1 => (PEsimp e1) ^^ n1
   | _ => e
- end.
+ end%poly.
 
-Theorem PExpr_simp_correct:
- forall l e,  NPEeval l (PExpr_simp e) == NPEeval l e.
-intros l e; elim e; simpl; auto.
-intros e1 He1 e2 He2.
-transitivity (NPEeval l (PEadd (PExpr_simp e1) (PExpr_simp e2))); auto.
-apply NPEadd_correct.
-simpl; auto.
-intros e1 He1 e2 He2.
-transitivity (NPEeval l (PEsub (PExpr_simp e1) (PExpr_simp e2))); auto.
-apply NPEsub_correct.
-simpl; auto.
-intros e1 He1 e2 He2.
-transitivity (NPEeval l (PEmul (PExpr_simp e1) (PExpr_simp e2))); auto.
-apply NPEmul_correct.
-simpl; auto.
-intros e1 He1.
-transitivity (NPEeval l (PEopp (PExpr_simp e1))); auto.
-apply NPEopp_correct.
-simpl; auto.
-intros e1 He1 n;simpl.
-rewrite NPEpow_correct;simpl.
-repeat rewrite pow_th.(rpow_pow_N).
-rewrite He1;auto.
+Theorem PEsimp_ok e : (PEsimp e === e)%poly.
+Proof.
+induction e; simpl.
+- reflexivity.
+- reflexivity.
+- intro l; trivial.
+- intro l; trivial.
+- rewrite NPEadd_ok. now f_equiv.
+- rewrite NPEsub_ok. now f_equiv.
+- rewrite NPEmul_ok. now f_equiv.
+- rewrite NPEopp_ok. now f_equiv.
+- rewrite NPEpow_ok. now f_equiv.
 Qed.
 
 
@@ -592,7 +721,9 @@ Qed.
 (* The input: syntax of a field expression *)
 
 Inductive FExpr : Type :=
-   FEc: C ->  FExpr
+ | FEO : FExpr
+ | FEI : FExpr
+ | FEc: C ->  FExpr
  | FEX: positive ->  FExpr
  | FEadd: FExpr -> FExpr ->  FExpr
  | FEsub: FExpr -> FExpr ->  FExpr
@@ -604,6 +735,8 @@ Inductive FExpr : Type :=
 
 Fixpoint FEeval (l : list R) (pe : FExpr) {struct pe} : R :=
   match pe with
+  | FEO       => rO
+  | FEI       => rI
   | FEc c     => phi c
   | FEX x     => BinList.nth 0 x l
   | FEadd x y => FEeval l x + FEeval l y
@@ -633,44 +766,46 @@ Record linear : Type := mk_linear {
 Fixpoint PCond (l : list R) (le : list (PExpr C)) {struct le} : Prop :=
   match le with
   | nil => True
-  | e1 :: nil => ~ req (NPEeval l e1) rO
-  | e1 :: l1 => ~ req (NPEeval l e1) rO /\ PCond l l1
+  | e1 :: nil => ~ req (e1 @ l) rO
+  | e1 :: l1 => ~ req (e1 @ l) rO /\ PCond l l1
   end.
 
-Theorem PCond_cons_inv_l :
-   forall l a l1, PCond l (a::l1) ->  ~ NPEeval l a == 0.
-intros l a l1 H.
-destruct l1; simpl in H |- *; trivial.
-destruct H; trivial.
+Theorem PCond_cons l a l1 :
+ PCond l (a :: l1) <-> ~ a @ l == 0 /\ PCond l l1.
+Proof.
+destruct l1.
+- simpl. split; [split|destruct 1]; trivial.
+- reflexivity.
 Qed.
 
-Theorem PCond_cons_inv_r : forall l a l1, PCond l (a :: l1) ->  PCond l l1.
-intros l a l1 H.
-destruct l1; simpl in H |- *; trivial.
-destruct H; trivial.
+Theorem PCond_cons_inv_l l a l1 : PCond l (a::l1) ->  ~ a @ l == 0.
+Proof.
+rewrite PCond_cons. now destruct 1.
 Qed.
 
-Theorem PCond_app_inv_l: forall l l1 l2, PCond l (l1 ++ l2) ->  PCond l l1.
-intros l l1 l2; elim l1; simpl app.
- simpl; auto.
- destruct l0; simpl in *.
-  destruct l2; firstorder.
-  firstorder.
+Theorem PCond_cons_inv_r l a l1 : PCond l (a :: l1) ->  PCond l l1.
+Proof.
+rewrite PCond_cons. now destruct 1.
 Qed.
 
-Theorem PCond_app_inv_r: forall l l1 l2, PCond l (l1 ++ l2) ->  PCond l l2.
-intros l l1 l2; elim l1; simpl app; auto.
-intros a l0 H H0; apply H; apply PCond_cons_inv_r with ( 1 := H0 ).
+Theorem PCond_app l l1 l2 :
+ PCond l (l1 ++ l2) <-> PCond l l1 /\ PCond l l2.
+Proof.
+induction l1.
+- simpl. split; [split|destruct 1]; trivial.
+- simpl app. rewrite !PCond_cons, IHl1. symmetry; apply and_assoc.
 Qed.
 
+
 (* An unsatisfiable condition: issued when a division by zero is detected *)
-Definition absurd_PCond := cons (PEc cO) nil.
+Definition absurd_PCond := cons 0%poly nil.
 
 Lemma absurd_PCond_bottom : forall l, ~ PCond l absurd_PCond.
+Proof.
 unfold absurd_PCond; simpl.
 red; intros.
 apply H.
-apply (morph0 CRmorph).
+apply phi_0.
 Qed.
 
 (***************************************************************************
@@ -679,167 +814,124 @@ Qed.
 
   ***************************************************************************)
 
-Fixpoint isIn (e1:PExpr C)  (p1:positive)
-                      (e2:PExpr C)  (p2:positive) {struct e2}: option (N * PExpr C) :=
+Definition default_isIn e1 p1 e2 p2 :=
+  if PExpr_eq e1 e2 then
+    match Z.pos_sub p1 p2 with
+     | Zpos p => Some (Npos p, 1%poly)
+     | Z0 => Some (N0, 1%poly)
+     | Zneg p => Some (N0, e2 ^^ Npos p)
+    end
+  else None.
+
+Fixpoint isIn e1 p1 e2 p2 {struct e2}: option (N * PExpr C) :=
   match e2 with
-  | PEmul e3 e4 =>
+  | e3 * e4 =>
        match isIn e1 p1 e3 p2 with
-       | Some (N0, e5) => Some (N0, NPEmul e5 (NPEpow e4 (Npos p2)))
+       | Some (N0, e5) => Some (N0, e5 ** (e4 ^^ Npos p2))
        | Some (Npos p, e5) =>
           match isIn e1 p e4 p2 with
-          | Some (n, e6) => Some (n, NPEmul e5 e6)
-          | None => Some (Npos p, NPEmul e5 (NPEpow e4 (Npos p2)))
+          | Some (n, e6) => Some (n, e5 ** e6)
+          | None => Some (Npos p, e5 ** (e4 ^^ Npos p2))
           end
        | None =>
          match isIn e1 p1 e4 p2 with
-         | Some (n, e5) => Some (n,NPEmul (NPEpow e3 (Npos p2)) e5)
+         | Some (n, e5) => Some (n, (e3 ^^ Npos p2) ** e5)
          | None => None
          end
        end
-  | PEpow e3 N0 => None
-  | PEpow e3 (Npos p3) => isIn e1 p1 e3 (Pos.mul p3 p2)
-  | _ =>
-     if  PExpr_eq e1 e2 then
-         match Z.pos_sub p1 p2 with
-          | Zpos p => Some (Npos p, PEc cI)
-          | Z0 => Some (N0, PEc cI)
-          | Zneg p => Some (N0, NPEpow e2 (Npos p))
-          end
-     else None
-   end.
+  | e3 ^ N0 => None
+  | e3 ^ Npos p3 => isIn e1 p1 e3 (Pos.mul p3 p2)
+  | _ => default_isIn e1 p1 e2 p2
+   end%poly.
 
  Definition ZtoN z := match z with Zpos p => Npos p | _ => N0 end.
  Definition NtoZ n := match n with Npos p => Zpos p | _ => Z0 end.
 
- Notation pow_pos_add :=
-   (Ring_theory.pow_pos_add Rsth Reqe.(Rmul_ext) ARth.(ARmul_assoc)).
-
  Lemma Z_pos_sub_gt p q : (p > q)%positive ->
   Z.pos_sub p q = Zpos (p - q).
  Proof. intros; now apply Z.pos_sub_gt, Pos.gt_lt. Qed.
 
  Ltac simpl_pos_sub := rewrite ?Z_pos_sub_gt in * by assumption.
 
- Lemma isIn_correct_aux : forall l e1 e2 p1 p2,
-  match
-      (if  PExpr_eq e1 e2 then
-         match Z.sub (Zpos p1) (Zpos p2) with
-          | Zpos p => Some (Npos p, PEc cI)
-          | Z0 => Some (N0, PEc cI)
-          | Zneg p => Some (N0, NPEpow e2 (Npos p))
-          end
-     else None)
-   with
+ Lemma default_isIn_ok e1 e2 p1 p2 :
+  match default_isIn e1 p1 e2 p2 with
    | Some(n, e3) =>
-       NPEeval l (PEpow e2 (Npos p2)) ==
-       NPEeval l (PEmul (PEpow e1 (ZtoN (Zpos p1 - NtoZ n))) e3) /\
-       (Zpos p1 > NtoZ n)%Z
-   |  _ => True
+       let n' := ZtoN (Zpos p1 - NtoZ n) in
+       (e2 ^ N.pos p2 === e1 ^ n' * e3)%poly
+       /\ (Zpos p1 > NtoZ n)%Z
+   | _ => True
   end.
 Proof.
-  intros l e1 e2 p1 p2; generalize (PExpr_eq_semi_correct l e1 e2);
-   case (PExpr_eq e1 e2); simpl; auto; intros H.
+  unfold default_isIn.
+  case PExpr_eq_spec; trivial. intros EQ.
   rewrite Z.pos_sub_spec.
-  case Pos.compare_spec;intros;simpl.
-  - repeat rewrite pow_th.(rpow_pow_N);simpl. split. 2:reflexivity.
-    subst. rewrite H by trivial. ring [ (morph1 CRmorph)].
-  - fold (p2 - p1 =? 1)%positive.
-    fold (NPEpow e2 (Npos (p2 - p1))).
-    rewrite NPEpow_correct;simpl.
-    repeat rewrite pow_th.(rpow_pow_N);simpl.
-    rewrite H;trivial. split. 2:reflexivity.
-    rewrite <- pow_pos_add. now rewrite Pos.add_comm, Pos.sub_add.
-  - repeat rewrite pow_th.(rpow_pow_N);simpl.
-    rewrite H;trivial.
-    rewrite Z.pos_sub_gt by now apply Pos.sub_decr.
-    replace (p1 - (p1 - p2))%positive with p2;
-    [| rewrite Pos.sub_sub_distr, Pos.add_comm;
-       auto using Pos.add_sub, Pos.sub_decr ].
-    split.
-    simpl. ring [ (morph1 CRmorph)].
-    now apply Z.lt_gt, Pos.sub_decr.
-Qed.
-
-Lemma pow_pos_pow_pos : forall x p1 p2, pow_pos rmul (pow_pos rmul x p1) p2 == pow_pos rmul x (p1*p2).
-induction p1;simpl;intros;repeat rewrite pow_pos_mul;repeat rewrite pow_pos_add;simpl.
-ring [(IHp1 p2)]. ring [(IHp1 p2)]. auto.
-Qed.
-
-
-Theorem isIn_correct: forall l e1 p1 e2 p2,
+  case Pos.compare_spec;intros H; split; try reflexivity.
+  - simpl. now rewrite PE_1_r, H, EQ.
+  - rewrite NPEpow_ok, EQ, <- PEpow_add_r. f_equiv.
+    simpl. f_equiv. now rewrite Pos.add_comm, Pos.sub_add.
+  - simpl. rewrite PE_1_r, EQ. f_equiv.
+    rewrite Z.pos_sub_gt by now apply Pos.sub_decr. simpl. f_equiv.
+    rewrite Pos.sub_sub_distr, Pos.add_comm; trivial.
+    rewrite Pos.add_sub; trivial.
+    apply Pos.sub_decr; trivial.
+  - simpl. now apply Z.lt_gt, Pos.sub_decr.
+Qed.
+
+Ltac npe_simpl := rewrite ?NPEmul_ok, ?NPEpow_ok, ?PEpow_mul_l.
+Ltac npe_ring := intro l; simpl; ring.
+
+Theorem isIn_ok e1 p1 e2 p2 :
   match isIn e1 p1 e2 p2 with
    | Some(n, e3) =>
-       NPEeval l (PEpow e2 (Npos p2)) ==
-       NPEeval l (PEmul (PEpow e1 (ZtoN (Zpos p1 - NtoZ n))) e3) /\
-        (Zpos p1 > NtoZ n)%Z
+       let n' := ZtoN (Zpos p1 - NtoZ n) in
+       (e2 ^ N.pos p2 === e1 ^ n' * e3)%poly
+       /\ (Zpos p1 > NtoZ n)%Z
    |  _ => True
   end.
 Proof.
 Opaque NPEpow.
-intros l e1 p1 e2; generalize p1;clear p1;elim e2; intros;
-  try (refine (isIn_correct_aux l e1 _ p1 p2);fail);simpl isIn.
-generalize (H p1 p2);clear H;destruct (isIn e1 p1 p p2). destruct p3.
-destruct n.
-  simpl. rewrite NPEmul_correct. simpl; rewrite NPEpow_correct;simpl.
-  repeat rewrite pow_th.(rpow_pow_N);simpl.
-  rewrite pow_pos_mul;intros (H,H1);split;[ring[H]|trivial].
-  generalize (H0 p4 p2);clear H0;destruct (isIn e1 p4 p0 p2). destruct p5.
-  destruct n;simpl.
-    rewrite NPEmul_correct;repeat rewrite pow_th.(rpow_pow_N);simpl.
-    intros (H1,H2) (H3,H4).
-    simpl_pos_sub. simpl in H3.
-    rewrite pow_pos_mul. rewrite H1;rewrite H3.
-    assert (pow_pos rmul (NPEeval l e1) (p1 - p4) * NPEeval l p3 *
-        (pow_pos rmul (NPEeval l e1) p4 * NPEeval l p5) ==
-        pow_pos rmul (NPEeval l e1) p4 * pow_pos rmul (NPEeval l e1) (p1 - p4) *
-        NPEeval l p3 *NPEeval l p5) by ring. rewrite H;clear H.
-   rewrite <- pow_pos_add.
-   rewrite Pos.add_comm, Pos.sub_add by (now apply Z.gt_lt in H4).
-   split. symmetry;apply ARth.(ARmul_assoc). reflexivity.
-   repeat rewrite pow_th.(rpow_pow_N);simpl.
-   intros (H1,H2) (H3,H4).
-   simpl_pos_sub. simpl in H1, H3.
-   assert (Zpos p1 > Zpos p6)%Z.
-     apply Zgt_trans with (Zpos p4). exact H4. exact H2.
-  simpl_pos_sub.
-  split. 2:exact H.
-  rewrite pow_pos_mul. simpl;rewrite H1;rewrite H3.
-  assert (pow_pos rmul (NPEeval l e1) (p1 - p4) * NPEeval l p3 *
-                (pow_pos rmul (NPEeval l e1) (p4 - p6) * NPEeval l p5) ==
-             pow_pos rmul (NPEeval l e1) (p1 - p4) * pow_pos rmul (NPEeval l e1) (p4 - p6) *
-                NPEeval l p3 * NPEeval l p5) by ring. rewrite H0;clear H0.
-  rewrite <- pow_pos_add.
-  replace (p1 - p4 + (p4 - p6))%positive with (p1 - p6)%positive.
- rewrite NPEmul_correct. simpl;ring.
-  assert
-     (Zpos p1 - Zpos p6 = Zpos p1 - Zpos p4 + (Zpos p4 - Zpos p6))%Z.
- change  ((Zpos p1 - Zpos p6)%Z = (Zpos p1 + (- Zpos p4) + (Zpos p4 +(- Zpos p6)))%Z).
- rewrite <- Z.add_assoc. rewrite (Z.add_assoc  (- Zpos p4)).
- simpl. rewrite Z.pos_sub_diag. simpl. reflexivity.
- unfold Z.sub, Z.opp in H0. simpl in H0.
-  simpl_pos_sub. inversion H0; trivial.
- simpl. repeat rewrite pow_th.(rpow_pow_N).
- intros H1 (H2,H3). simpl_pos_sub.
- rewrite NPEmul_correct;simpl;rewrite NPEpow_correct;simpl.
- simpl in H2. rewrite pow_th.(rpow_pow_N);simpl.
- rewrite pow_pos_mul. split. ring [H2]. exact H3.
- generalize (H0 p1 p2);clear H0;destruct (isIn e1 p1 p0 p2). destruct p3.
- destruct n;simpl. rewrite NPEmul_correct;simpl;rewrite NPEpow_correct;simpl.
- repeat rewrite pow_th.(rpow_pow_N);simpl.
- intros (H1,H2);split;trivial. rewrite pow_pos_mul;ring [H1].
- rewrite NPEmul_correct;simpl;rewrite NPEpow_correct;simpl.
- repeat rewrite pow_th.(rpow_pow_N);simpl. rewrite pow_pos_mul.
- intros (H1, H2);rewrite H1;split.
-   simpl_pos_sub. simpl in H1;ring [H1]. trivial.
- trivial.
- destruct n. trivial.
- generalize (H p1 (p0*p2)%positive);clear H;destruct (isIn e1 p1 p (p0*p2)). destruct p3.
- destruct n;simpl. repeat rewrite pow_th.(rpow_pow_N). simpl.
- intros (H1,H2);split. rewrite pow_pos_pow_pos. trivial. trivial.
- repeat rewrite pow_th.(rpow_pow_N). simpl.
- intros (H1,H2);split;trivial.
- rewrite pow_pos_pow_pos;trivial.
- trivial.
+revert p1 p2.
+induction e2; intros p1 p2;
+ try refine (default_isIn_ok e1 _ p1 p2); simpl isIn.
+- specialize (IHe2_1 p1 p2).
+  destruct isIn as [([|p],e)|].
+  + split; [|reflexivity].
+    clear IHe2_2.
+    destruct IHe2_1 as (IH,_).
+    npe_simpl. rewrite IH. npe_ring.
+  + specialize (IHe2_2 p p2).
+    destruct isIn as [([|p'],e')|].
+    * destruct IHe2_1 as (IH1,GT1).
+      destruct IHe2_2 as (IH2,GT2).
+      split; [|simpl; apply Zgt_trans with (Z.pos p); trivial].
+      npe_simpl. rewrite IH1, IH2. simpl. simpl_pos_sub. simpl.
+      replace (N.pos p1) with (N.pos p + N.pos (p1 - p))%N.
+      rewrite PEpow_add_r; npe_ring.
+      { simpl. f_equal. rewrite Pos.add_comm, Pos.sub_add. trivial.
+        now apply Pos.gt_lt. }
+    * destruct IHe2_1 as (IH1,GT1).
+      destruct IHe2_2 as (IH2,GT2).
+      assert (Z.pos p1 > Z.pos p')%Z by (now apply Zgt_trans with (Zpos p)).
+      split; [|simpl; trivial].
+      npe_simpl. rewrite IH1, IH2. simpl. simpl_pos_sub. simpl.
+      replace (N.pos (p1 - p')) with (N.pos (p1 - p) + N.pos (p - p'))%N.
+      rewrite PEpow_add_r; npe_ring.
+      { simpl. f_equal. rewrite Pos.add_sub_assoc, Pos.sub_add; trivial.
+        now apply Pos.gt_lt.
+        now apply Pos.gt_lt. }
+    * destruct IHe2_1 as (IH,GT). split; trivial.
+      npe_simpl. rewrite IH. npe_ring.
+  + specialize (IHe2_2 p1 p2).
+    destruct isIn as [(n,e)|]; trivial.
+    destruct IHe2_2 as (IH,GT). split; trivial.
+    set (d := ZtoN (Z.pos p1 - NtoZ n)) in *; clearbody d.
+    npe_simpl. rewrite IH. npe_ring.
+- destruct n; trivial.
+  specialize (IHe2 p1 (p * p2)%positive).
+  destruct isIn as [(n,e)|]; trivial.
+  destruct IHe2 as (IH,GT). split; trivial.
+  set (d := ZtoN (Z.pos p1 - NtoZ n)) in *; clearbody d.
+  now rewrite <- PEpow_mul_r.
 Qed.
 
 Record rsplit : Type := mk_rsplit {
@@ -852,121 +944,122 @@ Notation left := rsplit_left.
 Notation right := rsplit_right.
 Notation common := rsplit_common.
 
-Fixpoint split_aux (e1: PExpr C) (p:positive) (e2:PExpr C) {struct e1}: rsplit :=
+Fixpoint split_aux e1 p e2 {struct e1}: rsplit :=
   match e1 with
-  | PEmul e3 e4 =>
+  | e3 * e4 =>
       let r1 := split_aux e3 p e2 in
       let r2 := split_aux e4 p (right r1) in
-          mk_rsplit (NPEmul (left r1) (left r2))
-                    (NPEmul (common r1) (common r2))
-                    (right r2)
-  | PEpow e3 N0 => mk_rsplit (PEc cI) (PEc cI) e2
-  | PEpow e3 (Npos p3) => split_aux e3 (Pos.mul p3 p) e2
+      mk_rsplit (left r1 ** left r2)
+                (common r1 ** common r2)
+                (right r2)
+  | e3 ^ N0 => mk_rsplit 1 1 e2
+  | e3 ^ Npos p3 => split_aux e3 (Pos.mul p3 p) e2
   | _ =>
-       match isIn e1 p e2 xH with
-       | Some (N0,e3) => mk_rsplit (PEc cI) (NPEpow e1 (Npos p)) e3
-       | Some (Npos q, e3) => mk_rsplit (NPEpow e1 (Npos q)) (NPEpow e1 (Npos (p - q))) e3
-       | None => mk_rsplit (NPEpow e1 (Npos p)) (PEc cI) e2
+       match isIn e1 p e2 1 with
+       | Some (N0,e3) => mk_rsplit 1 (e1 ^^ Npos p) e3
+       | Some (Npos q, e3) => mk_rsplit (e1 ^^ Npos q) (e1 ^^ Npos (p - q)) e3
+       | None => mk_rsplit (e1 ^^ Npos p) 1 e2
        end
-  end.
+  end%poly.
 
-Lemma split_aux_correct_1 : forall l e1 p e2,
-  let res :=  match isIn e1 p e2 xH with
-       | Some (N0,e3) => mk_rsplit (PEc cI) (NPEpow e1 (Npos p)) e3
-       | Some (Npos q, e3) => mk_rsplit (NPEpow e1 (Npos q)) (NPEpow e1 (Npos (p - q))) e3
-       | None => mk_rsplit (NPEpow e1  (Npos p)) (PEc cI) e2
-       end in
-       NPEeval l (PEpow e1 (Npos p)) == NPEeval l (NPEmul (left res) (common res))
-   /\
-       NPEeval l e2 == NPEeval l (NPEmul (right res) (common res)).
-Proof.
- intros. unfold res;clear res; generalize (isIn_correct l e1 p e2 xH).
- destruct (isIn e1 p e2 1). destruct p0.
+Lemma split_aux_ok1 e1 p e2 :
+  (let res := match isIn e1 p e2 1 with
+       | Some (N0,e3) => mk_rsplit 1 (e1 ^^ Npos p) e3
+       | Some (Npos q, e3) => mk_rsplit (e1 ^^ Npos q) (e1 ^^ Npos (p - q)) e3
+       | None => mk_rsplit (e1 ^^ Npos p) 1 e2
+       end
+  in
+  e1 ^ Npos p === left res * common res
+  /\ e2 === right res * common res)%poly.
+Proof.
  Opaque NPEpow NPEmul.
-  destruct n;simpl;
-    (repeat rewrite NPEmul_correct;simpl;
-     repeat rewrite NPEpow_correct;simpl;
-     repeat rewrite pow_th.(rpow_pow_N);simpl).
-  intros (H, Hgt);split;try ring [H CRmorph.(morph1)].
-  intros (H, Hgt). simpl_pos_sub. simpl in H;split;try ring [H].
-  apply Z.gt_lt in Hgt.
-  now rewrite <- pow_pos_add, Pos.add_comm, Pos.sub_add.
-  simpl;intros. repeat rewrite NPEmul_correct;simpl.
-  rewrite NPEpow_correct;simpl. split;ring [CRmorph.(morph1)].
-Qed.
-
-Theorem split_aux_correct: forall l e1 p e2,
-  NPEeval l (PEpow e1 (Npos p)) ==
-       NPEeval l (NPEmul (left (split_aux e1 p e2)) (common (split_aux e1 p e2)))
-/\
-  NPEeval l  e2 == NPEeval l (NPEmul (right (split_aux e1 p e2))
-                                   (common (split_aux e1 p e2))).
-Proof.
-intros l; induction e1;intros k e2; try refine (split_aux_correct_1 l _ k e2);simpl.
-generalize (IHe1_1 k e2); clear IHe1_1.
-generalize (IHe1_2 k (rsplit_right (split_aux e1_1 k e2))); clear IHe1_2.
-simpl. repeat (rewrite NPEmul_correct;simpl).
-repeat rewrite pow_th.(rpow_pow_N);simpl.
-intros (H1,H2) (H3,H4);split.
-rewrite pow_pos_mul. rewrite H1;rewrite H3. ring.
-rewrite H4;rewrite H2;ring.
-destruct n;simpl.
-split. repeat rewrite pow_th.(rpow_pow_N);simpl.
-rewrite NPEmul_correct. simpl.
- induction k;simpl;try ring [CRmorph.(morph1)]; ring [IHk CRmorph.(morph1)].
- rewrite NPEmul_correct;simpl. ring [CRmorph.(morph1)].
-generalize (IHe1 (p*k)%positive e2);clear IHe1;simpl.
-repeat rewrite NPEmul_correct;simpl.
-repeat rewrite pow_th.(rpow_pow_N);simpl.
-rewrite pow_pos_pow_pos. intros [H1 H2];split;ring [H1 H2].
+ intros. unfold res;clear res; generalize (isIn_ok e1 p e2 xH).
+ destruct (isIn e1 p e2 1) as [([|p'],e')|]; simpl.
+ - intros (H1,H2); split; npe_simpl.
+   + now rewrite PE_1_l.
+   + rewrite PEpow_1_r in H1. rewrite H1. npe_ring.
+ - intros (H1,H2); split; npe_simpl.
+   + rewrite <- PEpow_add_r. f_equiv. simpl. f_equal.
+     rewrite Pos.add_comm, Pos.sub_add; trivial.
+     now apply Z.gt_lt in H2.
+   + rewrite PEpow_1_r in H1. rewrite H1. simpl_pos_sub. simpl. npe_ring.
+ - intros _; split; npe_simpl; now rewrite PE_1_r.
+Qed.
+
+Theorem split_aux_ok: forall e1 p e2,
+  (e1 ^ Npos p === left (split_aux e1 p e2) * common (split_aux e1 p e2)
+  /\ e2 === right (split_aux e1 p e2) * common (split_aux e1 p e2))%poly.
+Proof.
+induction e1;intros k e2; try refine (split_aux_ok1 _ k e2);simpl.
+destruct (IHe1_1 k e2) as (H1,H2).
+destruct (IHe1_2 k (right (split_aux e1_1 k e2))) as (H3,H4).
+clear IHe1_1 IHe1_2.
+- npe_simpl; split.
+  * rewrite H1, H3. npe_ring.
+  * rewrite H2 at 1. rewrite H4 at 1. npe_ring.
+- destruct n; simpl.
+  + rewrite PEpow_0_r, PEpow_1_l, !PE_1_r. now split.
+  + rewrite <- PEpow_mul_r. simpl. apply IHe1.
 Qed.
 
 Definition split e1 e2 := split_aux e1 xH e2.
 
-Theorem split_correct_l: forall l e1 e2,
-  NPEeval l e1 == NPEeval l (NPEmul (left (split e1 e2))
-                                   (common (split e1 e2))).
+Theorem split_ok_l e1 e2 :
+  (e1 === left (split e1 e2) * common (split e1 e2))%poly.
+Proof.
+destruct (split_aux_ok e1 xH e2) as (H,_). now rewrite <- H, PEpow_1_r.
+Qed.
+
+Theorem split_ok_r e1 e2 :
+  (e2 === right (split e1 e2) * common (split e1 e2))%poly.
 Proof.
-intros l e1 e2; case (split_aux_correct l e1 xH e2);simpl.
-rewrite pow_th.(rpow_pow_N);simpl;auto.
+destruct (split_aux_ok e1 xH e2) as (_,H). trivial.
 Qed.
 
-Theorem split_correct_r: forall l e1 e2,
-  NPEeval l e2 == NPEeval l (NPEmul (right (split e1 e2))
-                                   (common (split e1 e2))).
+Lemma split_nz_l l e1 e2 :
+ ~ e1 @ l == 0 -> ~ left (split e1 e2) @ l == 0.
 Proof.
-intros l e1 e2; case (split_aux_correct l e1 xH e2);simpl;auto.
+ intros H. contradict H. rewrite (split_ok_l e1 e2); simpl.
+ now rewrite H, rmul_0_l.
+Qed.
+
+Lemma split_nz_r l e1 e2 :
+ ~ e2 @ l == 0 -> ~ right (split e1 e2) @ l == 0.
+Proof.
+ intros H. contradict H. rewrite (split_ok_r e1 e2); simpl.
+ now rewrite H, rmul_0_l.
 Qed.
 
 Fixpoint Fnorm (e : FExpr) : linear :=
   match e with
-  | FEc c => mk_linear (PEc c) (PEc cI) nil
-  | FEX x => mk_linear (PEX C x) (PEc cI) nil
+  | FEO => mk_linear 0 1 nil
+  | FEI => mk_linear 1 1 nil
+  | FEc c => mk_linear (PEc c) 1 nil
+  | FEX x => mk_linear (PEX C x) 1 nil
   | FEadd e1 e2 =>
       let x := Fnorm e1 in
       let y := Fnorm e2 in
       let s := split (denum x) (denum y) in
       mk_linear
-        (NPEadd (NPEmul (num x) (right s)) (NPEmul (num y) (left s)))
-        (NPEmul (left s) (NPEmul (right s) (common s)))
-        (condition x ++ condition y)
-
+        ((num x ** right s) ++ (num y ** left s))
+        (left s ** (right s ** common s))
+        (condition x ++ condition y)%list
   | FEsub e1 e2 =>
       let x := Fnorm e1 in
       let y := Fnorm e2 in
       let s := split (denum x) (denum y) in
       mk_linear
-        (NPEsub (NPEmul (num x) (right s)) (NPEmul (num y) (left s)))
-        (NPEmul (left s) (NPEmul (right s) (common s)))
-        (condition x ++ condition y)
+        ((num x ** right s) -- (num y ** left s))
+        (left s ** (right s ** common s))
+        (condition x ++ condition y)%list
   | FEmul e1 e2 =>
       let x := Fnorm e1 in
       let y := Fnorm e2 in
       let s1 := split (num x) (denum y) in
       let s2 := split (num y) (denum x) in
-      mk_linear (NPEmul (left s1) (left s2))
-        (NPEmul (right s2) (right s1))
-        (condition x ++ condition y)
+      mk_linear (left s1 ** left s2)
+        (right s2 ** right s1)
+        (condition x ++ condition y)%list
   | FEopp e1 =>
       let x := Fnorm e1 in
       mk_linear (NPEopp (num x)) (denum x) (condition x)
@@ -978,15 +1071,14 @@ Fixpoint Fnorm (e : FExpr) : linear :=
       let y := Fnorm e2 in
       let s1 := split (num x) (num y) in
       let s2 := split (denum x) (denum y) in
-      mk_linear (NPEmul (left s1) (right s2))
-        (NPEmul (left s2) (right s1))
-        (num y :: condition x ++ condition y)
+      mk_linear (left s1 ** right s2)
+        (left s2 ** right s1)
+        (num y :: condition x ++ condition y)%list
   | FEpow e1 n =>
       let x := Fnorm e1 in
-      mk_linear (NPEpow (num x) n) (NPEpow (denum x) n) (condition x)
+      mk_linear ((num x)^^n) ((denum x)^^n) (condition x)
   end.
 
-
 (* Example *)
 (*
 Eval compute
@@ -996,93 +1088,31 @@ Eval compute
           (FEadd (FEinv (FEX xH%positive)) (FEinv (FEX (xO xH)%positive))))).
 *)
 
- Lemma pow_pos_not_0 : forall x, ~x==0 -> forall p, ~pow_pos rmul x p == 0.
+Theorem Pcond_Fnorm l e :
+ PCond l (condition (Fnorm e)) ->  ~ (denum (Fnorm e))@l == 0.
 Proof.
- induction p;simpl.
-  intro Hp;assert (H1 := @rmul_reg_l _ (pow_pos rmul x p * pow_pos rmul x p) 0 H).
-  apply IHp.
-  rewrite (@rmul_reg_l _ (pow_pos rmul x p)  0 IHp).
-  reflexivity.
-  rewrite H1. ring. rewrite Hp;ring.
-  intro Hp;apply IHp. rewrite (@rmul_reg_l _ (pow_pos rmul x p)  0 IHp).
-  reflexivity. rewrite Hp;ring. trivial.
-Qed.
-
-Theorem Pcond_Fnorm:
- forall l e,
- PCond l (condition (Fnorm e)) ->  ~ NPEeval l (denum (Fnorm e)) == 0.
-intros l e; elim e.
- simpl; intros _ _; rewrite (morph1 CRmorph); exact rI_neq_rO.
- simpl; intros _ _; rewrite (morph1 CRmorph); exact rI_neq_rO.
- intros e1 Hrec1 e2 Hrec2 Hcond.
-   simpl condition in Hcond.
-   simpl denum.
-   rewrite NPEmul_correct.
-   simpl.
-   apply field_is_integral_domain.
-   intros HH; case Hrec1; auto.
-     apply PCond_app_inv_l with (1 := Hcond).
-   rewrite (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))).
-   rewrite NPEmul_correct; simpl; rewrite HH; ring.
-   intros HH; case Hrec2; auto.
-     apply PCond_app_inv_r with (1 := Hcond).
-   rewrite (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))); auto.
- intros e1 Hrec1 e2 Hrec2 Hcond.
-   simpl condition in Hcond.
-   simpl denum.
-   rewrite NPEmul_correct.
-   simpl.
-   apply field_is_integral_domain.
-   intros HH; case Hrec1; auto.
-     apply PCond_app_inv_l with (1 := Hcond).
-   rewrite (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))).
-   rewrite NPEmul_correct; simpl; rewrite HH; ring.
-   intros HH; case Hrec2; auto.
-     apply PCond_app_inv_r with (1 := Hcond).
-   rewrite (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))); auto.
- intros e1 Hrec1 e2 Hrec2 Hcond.
-   simpl condition in Hcond.
-   simpl denum.
-   rewrite NPEmul_correct.
-   simpl.
-   apply field_is_integral_domain.
-  intros HH; apply Hrec1.
-    apply PCond_app_inv_l with (1 := Hcond).
-    rewrite (split_correct_r l (num (Fnorm e2)) (denum (Fnorm e1))).
-    rewrite NPEmul_correct; simpl; rewrite HH; ring.
-  intros HH; apply Hrec2.
-    apply PCond_app_inv_r with (1 := Hcond).
-    rewrite (split_correct_r l (num (Fnorm e1)) (denum (Fnorm e2))).
-    rewrite NPEmul_correct; simpl; rewrite HH; ring.
- intros e1 Hrec1 Hcond.
-   simpl condition in Hcond.
-   simpl denum.
-   auto.
- intros e1 Hrec1 Hcond.
-   simpl condition in Hcond.
-   simpl denum.
-   apply PCond_cons_inv_l with (1:=Hcond).
- intros e1 Hrec1 e2 Hrec2 Hcond.
-   simpl condition in Hcond.
-   simpl denum.
-   rewrite NPEmul_correct.
-   simpl.
-   apply field_is_integral_domain.
-    intros HH; apply Hrec1.
-    specialize PCond_cons_inv_r with (1:=Hcond); intro Hcond1.
-    apply PCond_app_inv_l with (1 := Hcond1).
-    rewrite (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))).
-    rewrite NPEmul_correct; simpl; rewrite HH; ring.
-    intros HH; apply PCond_cons_inv_l with (1:=Hcond).
-    rewrite (split_correct_r l (num (Fnorm e1)) (num (Fnorm e2))).
-    rewrite NPEmul_correct; simpl; rewrite HH; ring.
- simpl;intros e1 Hrec1 n Hcond.
-  rewrite NPEpow_correct.
-  simpl;rewrite pow_th.(rpow_pow_N).
-  destruct n;simpl;intros.
-  apply AFth.(AF_1_neq_0). apply pow_pos_not_0;auto.
-Qed.
-Hint Resolve Pcond_Fnorm.
+induction e; simpl condition; rewrite ?PCond_cons, ?PCond_app;
+ simpl denum; intros (Hc1,Hc2) || intros Hc; rewrite ?NPEmul_ok.
+- simpl. rewrite phi_1; exact rI_neq_rO.
+- simpl. rewrite phi_1; exact rI_neq_rO.
+- simpl; intros. rewrite phi_1; exact rI_neq_rO.
+- simpl; intros. rewrite phi_1; exact rI_neq_rO.
+- rewrite <- split_ok_r. simpl. apply field_is_integral_domain.
+  + apply split_nz_l, IHe1, Hc1.
+  + apply IHe2, Hc2.
+- rewrite <- split_ok_r. simpl. apply field_is_integral_domain.
+  + apply split_nz_l, IHe1, Hc1.
+  + apply IHe2, Hc2.
+- simpl. apply field_is_integral_domain.
+  + apply split_nz_r, IHe1, Hc1.
+  + apply split_nz_r, IHe2, Hc2.
+- now apply IHe.
+- trivial.
+- destruct Hc2 as (Hc2,_). simpl. apply field_is_integral_domain.
+  + apply split_nz_l, IHe1, Hc2.
+  + apply split_nz_r, Hc1.
+- rewrite NPEpow_ok. apply PEpow_nz, IHe, Hc.
+Qed.
 
 
 (***************************************************************************
@@ -1091,154 +1121,106 @@ Hint Resolve Pcond_Fnorm.
 
   ***************************************************************************)
 
-Theorem Fnorm_FEeval_PEeval:
- forall l fe,
+Ltac uneval :=
+ repeat match goal with
+  | |- context [ ?x @ ?l * ?y @ ?l ] => change (x@l * y@l) with ((x*y)@l)
+  | |- context [ ?x @ ?l + ?y @ ?l ] => change (x@l + y@l) with ((x+y)@l)
+ end.
+
+Theorem Fnorm_FEeval_PEeval l fe:
  PCond l (condition (Fnorm fe)) ->
- FEeval l fe == NPEeval l (num (Fnorm fe)) / NPEeval l (denum (Fnorm fe)).
-Proof.
-intros l fe; elim fe; simpl.
-intros c H; rewrite CRmorph.(morph1); apply rdiv1.
-intros p H; rewrite CRmorph.(morph1); apply rdiv1.
-intros e1 He1 e2 He2 HH.
-assert (HH1: PCond l (condition (Fnorm e1))).
-apply PCond_app_inv_l with ( 1 := HH ).
-assert (HH2: PCond l (condition (Fnorm e2))).
-apply PCond_app_inv_r with ( 1 := HH ).
-rewrite (He1 HH1); rewrite (He2 HH2).
-rewrite NPEadd_correct; simpl.
-repeat rewrite NPEmul_correct; simpl.
-generalize (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2)))
-   (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))).
-repeat rewrite NPEmul_correct; simpl.
-intros U1 U2; rewrite U1; rewrite U2.
-apply rdiv2b; auto.
-  rewrite <- U1; auto.
-  rewrite <- U2; auto.
-
-intros e1 He1 e2 He2 HH.
-assert (HH1: PCond l (condition (Fnorm e1))).
-apply PCond_app_inv_l with ( 1 := HH ).
-assert (HH2: PCond l (condition (Fnorm e2))).
-apply PCond_app_inv_r with ( 1 := HH ).
-rewrite (He1 HH1); rewrite (He2 HH2).
-rewrite NPEsub_correct; simpl.
-repeat rewrite NPEmul_correct; simpl.
-generalize (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2)))
-   (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))).
-repeat rewrite NPEmul_correct; simpl.
-intros U1 U2; rewrite U1; rewrite U2.
-apply rdiv3b; auto.
-  rewrite <- U1; auto.
-  rewrite <- U2; auto.
-
-intros e1 He1 e2 He2 HH.
-assert (HH1: PCond l (condition (Fnorm e1))).
-apply PCond_app_inv_l with ( 1 := HH ).
-assert (HH2: PCond l (condition (Fnorm e2))).
-apply PCond_app_inv_r with ( 1 := HH ).
-rewrite (He1 HH1); rewrite (He2 HH2).
-repeat rewrite NPEmul_correct; simpl.
-generalize (split_correct_l l (num (Fnorm e1)) (denum (Fnorm e2)))
-   (split_correct_r l (num (Fnorm e1)) (denum (Fnorm e2)))
-   (split_correct_l l (num (Fnorm e2)) (denum (Fnorm e1)))
-   (split_correct_r l (num (Fnorm e2)) (denum (Fnorm e1))).
-repeat rewrite NPEmul_correct; simpl.
-intros U1 U2 U3 U4; rewrite U1; rewrite U2; rewrite U3;
-  rewrite U4; simpl.
-apply rdiv4b; auto.
-  rewrite <- U4; auto.
-  rewrite <- U2; auto.
-
-intros e1 He1 HH.
-rewrite NPEopp_correct; simpl; rewrite (He1 HH); apply rdiv5; auto.
-
-intros e1 He1 HH.
-assert (HH1: PCond l (condition (Fnorm e1))).
-apply PCond_cons_inv_r with ( 1 := HH ).
-rewrite (He1 HH1); apply rdiv6; auto.
-apply PCond_cons_inv_l with ( 1 := HH ).
-
-intros e1 He1 e2 He2 HH.
-assert (HH1: PCond l (condition (Fnorm e1))).
-apply PCond_app_inv_l with (condition (Fnorm e2)).
-apply PCond_cons_inv_r with ( 1 := HH ).
-assert (HH2: PCond l (condition (Fnorm e2))).
-apply PCond_app_inv_r with (condition (Fnorm e1)).
-apply PCond_cons_inv_r with ( 1 := HH ).
-rewrite (He1 HH1); rewrite (He2 HH2).
-repeat rewrite NPEmul_correct;simpl.
-generalize (split_correct_l l (num (Fnorm e1)) (num (Fnorm e2)))
-   (split_correct_r l (num (Fnorm e1)) (num (Fnorm e2)))
-   (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2)))
-   (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))).
-repeat rewrite NPEmul_correct; simpl.
-intros U1 U2 U3 U4; rewrite U1; rewrite U2; rewrite U3;
-  rewrite U4; simpl.
-apply rdiv7b; auto.
-  rewrite <- U3; auto.
-  rewrite <- U2; auto.
-apply PCond_cons_inv_l with ( 1 := HH ).
-  rewrite <- U4; auto.
-
-intros e1 He1 n Hcond;assert (He1' := He1 Hcond);clear He1.
-repeat rewrite NPEpow_correct;simpl;repeat rewrite pow_th.(rpow_pow_N).
-rewrite He1';clear He1'.
-destruct n;simpl. apply rdiv1.
-generalize (NPEeval l (num (Fnorm e1))) (NPEeval l (denum (Fnorm e1)))
-  (Pcond_Fnorm _ _ Hcond).
-intros r r0 Hdiff;induction p;simpl.
-repeat (rewrite <- rdiv4;trivial).
-rewrite IHp. reflexivity.
-apply pow_pos_not_0;trivial.
-apply pow_pos_not_0;trivial.
-intro Hp. apply (pow_pos_not_0 Hdiff  p).
-rewrite  (@rmul_reg_l (pow_pos rmul r0 p) (pow_pos rmul r0 p)  0).
- reflexivity. apply pow_pos_not_0;trivial. ring [Hp].
-rewrite <- rdiv4;trivial.
-rewrite IHp;reflexivity.
-apply pow_pos_not_0;trivial. apply pow_pos_not_0;trivial.
-reflexivity.
-Qed.
-
-Theorem Fnorm_crossproduct:
- forall l fe1 fe2,
+ FEeval l fe == (num (Fnorm fe)) @ l / (denum (Fnorm fe)) @ l.
+Proof.
+induction fe; simpl condition; rewrite ?PCond_cons, ?PCond_app; simpl;
+ intros (Hc1,Hc2) || intros Hc;
+ try (specialize (IHfe1 Hc1);apply Pcond_Fnorm in Hc1);
+ try (specialize (IHfe2 Hc2);apply Pcond_Fnorm in Hc2);
+ try set (F1 := Fnorm fe1) in *; try set (F2 := Fnorm fe2) in *.
+
+- now rewrite phi_1, phi_0, rdiv_def.
+- now rewrite phi_1; apply rdiv1.
+- rewrite phi_1; apply rdiv1.
+- rewrite phi_1; apply rdiv1.
+- rewrite NPEadd_ok, !NPEmul_ok. simpl.
+  rewrite <- rdiv2b; uneval; rewrite <- ?split_ok_l, <- ?split_ok_r; trivial.
+  now f_equiv.
+
+- rewrite NPEsub_ok, !NPEmul_ok. simpl.
+  rewrite <- rdiv3b; uneval; rewrite <- ?split_ok_l, <- ?split_ok_r; trivial.
+  now f_equiv.
+
+- rewrite !NPEmul_ok. simpl.
+  rewrite IHfe1, IHfe2.
+  rewrite (split_ok_l (num F1) (denum F2) l),
+          (split_ok_r (num F1) (denum F2) l),
+          (split_ok_l (num F2) (denum F1) l),
+          (split_ok_r (num F2) (denum F1) l) in *.
+  apply rdiv4b; trivial.
+
+- rewrite NPEopp_ok; simpl; rewrite (IHfe Hc); apply rdiv5.
+
+- rewrite (IHfe Hc2); apply rdiv6; trivial;
+   apply Pcond_Fnorm; trivial.
+
+- destruct Hc2 as (Hc2,Hc3).
+  rewrite !NPEmul_ok. simpl.
+  assert (U1 := split_ok_l (num F1) (num F2) l).
+  assert (U2 := split_ok_r (num F1) (num F2) l).
+  assert (U3 := split_ok_l (denum F1) (denum F2) l).
+  assert (U4 := split_ok_r (denum F1) (denum F2) l).
+  rewrite (IHfe1 Hc2), (IHfe2 Hc3), U1, U2, U3, U4.
+  simpl in U2, U3, U4. apply rdiv7b;
+   rewrite <- ?U2, <- ?U3, <- ?U4; try apply Pcond_Fnorm; trivial.
+
+- rewrite !NPEpow_ok. simpl. rewrite !rpow_pow, (IHfe Hc).
+  destruct n; simpl.
+  + apply rdiv1.
+  + apply pow_pos_div. apply Pcond_Fnorm; trivial.
+Qed.
+
+Theorem Fnorm_crossproduct l fe1 fe2 :
  let nfe1 := Fnorm fe1 in
  let nfe2 := Fnorm fe2 in
- NPEeval l (PEmul (num nfe1) (denum nfe2)) ==
- NPEeval l (PEmul (num nfe2) (denum nfe1)) ->
+ (num nfe1 * denum nfe2) @ l == (num nfe2 * denum nfe1) @ l ->
  PCond l (condition nfe1 ++ condition nfe2) ->
  FEeval l fe1 == FEeval l fe2.
-intros l fe1 fe2 nfe1 nfe2 Hcrossprod Hcond; subst nfe1 nfe2.
-rewrite Fnorm_FEeval_PEeval by
- apply PCond_app_inv_l with (1 := Hcond).
- rewrite Fnorm_FEeval_PEeval by
-  apply PCond_app_inv_r with (1 := Hcond).
-  apply cross_product_eq; trivial.
-   apply Pcond_Fnorm.
-     apply PCond_app_inv_l with (1 := Hcond).
-   apply Pcond_Fnorm.
-     apply PCond_app_inv_r with (1 := Hcond).
+Proof.
+simpl. rewrite PCond_app. intros Hcrossprod (Hc1,Hc2).
+rewrite !Fnorm_FEeval_PEeval; trivial.
+apply cross_product_eq; trivial;
+ apply Pcond_Fnorm; trivial.
 Qed.
 
 (* Correctness lemmas of reflexive tactics *)
-Notation Ninterp_PElist := (interp_PElist rO radd rmul rsub ropp req phi Cp_phi rpow).
-Notation Nmk_monpol_list := (mk_monpol_list cO cI cadd cmul csub copp ceqb cdiv).
+Notation Ninterp_PElist :=
+  (interp_PElist rO rI radd rmul rsub ropp req phi Cp_phi rpow).
+Notation Nmk_monpol_list :=
+  (mk_monpol_list cO cI cadd cmul csub copp ceqb cdiv).
 
-Theorem Fnorm_correct:
+Theorem Fnorm_ok:
  forall n l lpe fe,
   Ninterp_PElist l lpe ->
   Peq ceqb (Nnorm n (Nmk_monpol_list lpe) (num (Fnorm fe))) (Pc cO) = true ->
   PCond l (condition (Fnorm fe)) ->  FEeval l fe == 0.
-intros n l lpe fe Hlpe H H1;
- apply eq_trans with (1 := Fnorm_FEeval_PEeval l fe H1).
-apply rdiv8; auto.
-transitivity (NPEeval l (PEc cO)); auto.
-rewrite (norm_subst_ok Rsth Reqe ARth CRmorph pow_th cdiv_th n l lpe);auto.
-change (NPEeval l (PEc cO)) with (Pphi 0 radd rmul phi l (Pc cO)).
-apply (Peq_ok Rsth Reqe CRmorph);auto.
-simpl. apply (morph0 CRmorph); auto.
+Proof.
+intros n l lpe fe Hlpe H H1.
+rewrite (Fnorm_FEeval_PEeval l fe H1).
+apply rdiv8. apply Pcond_Fnorm; trivial.
+transitivity (0@l); trivial.
+rewrite (norm_subst_ok Rsth Reqe ARth CRmorph pow_th cdiv_th n l lpe); trivial.
+change (0 @ l) with (Pphi 0 radd rmul phi l (Pc cO)).
+apply (Peq_ok Rsth Reqe CRmorph); trivial.
 Qed.
 
+Notation ring_rw_correct :=
+ (ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec).
+
+Notation ring_rw_pow_correct :=
+ (ring_rw_pow_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec).
+
+Notation ring_correct :=
+ (ring_correct Rsth Reqe ARth CRmorph pow_th cdiv_th).
+
 (* simplify a field expression into a fraction *)
 (* TODO: simplify when den is constant... *)
 Definition display_linear l num den :=
@@ -1247,71 +1229,54 @@ Definition display_linear l num den :=
 Definition display_pow_linear l num den :=
   NPphi_pow l num / NPphi_pow l den.
 
-Theorem Field_rw_correct :
- forall n lpe l,
+Theorem Field_rw_correct n lpe l :
    Ninterp_PElist l lpe ->
    forall lmp, Nmk_monpol_list lpe = lmp ->
    forall fe nfe, Fnorm fe = nfe ->
    PCond l (condition nfe) ->
-   FEeval l fe == display_linear l (Nnorm n lmp (num nfe)) (Nnorm n lmp (denum nfe)).
+   FEeval l fe ==
+     display_linear l (Nnorm n lmp (num nfe)) (Nnorm n lmp (denum nfe)).
 Proof.
-  intros n lpe l Hlpe lmp lmp_eq fe nfe eq_nfe H; subst nfe lmp.
-  apply eq_trans with (1 := Fnorm_FEeval_PEeval _ _ H).
-  unfold display_linear; apply SRdiv_ext;
-  eapply (ring_rw_correct Rsth Reqe ARth CRmorph);eauto.
+  intros Hlpe lmp lmp_eq fe nfe eq_nfe H; subst nfe lmp.
+  rewrite (Fnorm_FEeval_PEeval _ _ H).
+  unfold display_linear; apply rdiv_ext;
+  eapply ring_rw_correct; eauto.
 Qed.
 
-Theorem Field_rw_pow_correct :
- forall n lpe l,
+Theorem Field_rw_pow_correct n lpe l :
    Ninterp_PElist l lpe ->
    forall lmp, Nmk_monpol_list lpe = lmp ->
    forall fe nfe, Fnorm fe = nfe ->
    PCond l (condition nfe) ->
-   FEeval l fe == display_pow_linear l (Nnorm n lmp (num nfe)) (Nnorm n lmp (denum nfe)).
+   FEeval l fe ==
+     display_pow_linear l (Nnorm n lmp (num nfe)) (Nnorm n lmp (denum nfe)).
 Proof.
-  intros n lpe l Hlpe lmp lmp_eq fe nfe eq_nfe H; subst nfe lmp.
-  apply eq_trans with (1 := Fnorm_FEeval_PEeval _ _ H).
-  unfold display_pow_linear; apply SRdiv_ext;
-  eapply (ring_rw_pow_correct Rsth Reqe ARth CRmorph);eauto.
+  intros Hlpe lmp lmp_eq fe nfe eq_nfe H; subst nfe lmp.
+  rewrite (Fnorm_FEeval_PEeval _ _ H).
+  unfold display_pow_linear; apply rdiv_ext;
+  eapply ring_rw_pow_correct;eauto.
 Qed.
 
-Theorem Field_correct :
- forall n l lpe fe1 fe2, Ninterp_PElist l lpe ->
+Theorem Field_correct n l lpe fe1 fe2 :
+ Ninterp_PElist l lpe ->
  forall lmp, Nmk_monpol_list lpe = lmp ->
  forall nfe1, Fnorm fe1 = nfe1 ->
  forall nfe2, Fnorm fe2 = nfe2 ->
- Peq ceqb (Nnorm n lmp (PEmul (num nfe1) (denum nfe2)))
-          (Nnorm n lmp (PEmul (num nfe2) (denum nfe1))) = true ->
+ Peq ceqb (Nnorm n lmp (num nfe1 * denum nfe2))
+          (Nnorm n lmp (num nfe2 * denum nfe1)) = true ->
  PCond l (condition nfe1 ++ condition nfe2) ->
  FEeval l fe1 == FEeval l fe2.
 Proof.
-intros n l lpe fe1 fe2 Hlpe lmp eq_lmp nfe1 eq1 nfe2 eq2 Hnorm Hcond; subst nfe1 nfe2 lmp.
+intros Hlpe lmp eq_lmp nfe1 eq1 nfe2 eq2 Hnorm Hcond; subst nfe1 nfe2 lmp.
 apply Fnorm_crossproduct; trivial.
-eapply (ring_correct Rsth Reqe ARth CRmorph); eauto.
+eapply ring_correct; eauto.
 Qed.
 
 (* simplify a field equation : generate the crossproduct and simplify
    polynomials *)
-Theorem Field_simplify_eq_old_correct :
- forall l fe1 fe2 nfe1 nfe2,
- Fnorm fe1 = nfe1 ->
- Fnorm fe2 = nfe2 ->
- NPphi_dev l (Nnorm O nil (PEmul (num nfe1) (denum nfe2))) ==
- NPphi_dev l (Nnorm O nil (PEmul (num nfe2) (denum nfe1))) ->
- PCond l (condition nfe1 ++ condition nfe2) ->
- FEeval l fe1 == FEeval l fe2.
-Proof.
-intros l fe1 fe2 nfe1 nfe2 eq1 eq2 Hcrossprod Hcond;  subst nfe1 nfe2.
-apply Fnorm_crossproduct; trivial.
-match goal with
- [ |- NPEeval l ?x == NPEeval l ?y] =>
-    rewrite (ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec
-       O nil l I Logic.eq_refl x Logic.eq_refl);
-    rewrite (ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec
-       O nil l I Logic.eq_refl y Logic.eq_refl)
- end.
-trivial.
-Qed.
+
+(** This allows rewriting modulo the simplification of PEeval on PMul *)
+Declare Equivalent Keys PEeval rmul.
 
 Theorem Field_simplify_eq_correct :
  forall n l lpe fe1 fe2,
@@ -1320,37 +1285,23 @@ Theorem Field_simplify_eq_correct :
  forall nfe1, Fnorm fe1 = nfe1 ->
  forall nfe2, Fnorm fe2 = nfe2 ->
  forall den, split (denum nfe1) (denum nfe2) = den ->
- NPphi_dev l (Nnorm n lmp (PEmul (num nfe1) (right den))) ==
- NPphi_dev l (Nnorm n lmp (PEmul (num nfe2) (left den))) ->
+ NPphi_dev l (Nnorm n lmp (num nfe1 * right den)) ==
+ NPphi_dev l (Nnorm n lmp (num nfe2 * left den)) ->
  PCond l (condition nfe1 ++ condition nfe2) ->
  FEeval l fe1 == FEeval l fe2.
 Proof.
-intros n l lpe fe1 fe2 Hlpe lmp Hlmp nfe1 eq1 nfe2 eq2 den eq3 Hcrossprod Hcond;
-  subst nfe1 nfe2 den lmp.
-apply Fnorm_crossproduct; trivial.
+intros n l lpe fe1 fe2 Hlpe lmp Hlmp nfe1 eq1 nfe2 eq2 den eq3 Hcrossprod Hcond.
+apply Fnorm_crossproduct; rewrite ?eq1, ?eq2; trivial.
 simpl.
-rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))).
-rewrite (split_correct_r l (denum (Fnorm fe1)) (denum (Fnorm fe2))).
-rewrite NPEmul_correct.
-rewrite NPEmul_correct.
+rewrite (split_ok_l (denum nfe1) (denum nfe2) l), eq3.
+rewrite (split_ok_r (denum nfe1) (denum nfe2) l), eq3.
 simpl.
-repeat rewrite (ARmul_assoc ARth).
-rewrite <-(
-  let x := PEmul (num (Fnorm fe1))
-                     (rsplit_right (split (denum (Fnorm fe1)) (denum (Fnorm fe2)))) in
-ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l
-        Hlpe Logic.eq_refl
-        x Logic.eq_refl) in Hcrossprod.
-rewrite <-(
-  let x := (PEmul (num (Fnorm fe2))
-                     (rsplit_left
-                        (split (denum (Fnorm fe1)) (denum (Fnorm fe2))))) in
-    ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l
-        Hlpe Logic.eq_refl
-        x Logic.eq_refl) in Hcrossprod.
-simpl in Hcrossprod.
-rewrite Hcrossprod.
-reflexivity.
+rewrite !rmul_assoc.
+apply rmul_ext; trivial.
+rewrite (ring_rw_correct n lpe l Hlpe Logic.eq_refl (num nfe1 * right den) Logic.eq_refl),
+ (ring_rw_correct n lpe l Hlpe Logic.eq_refl (num nfe2 * left den) Logic.eq_refl).
+rewrite Hlmp.
+apply Hcrossprod.
 Qed.
 
 Theorem Field_simplify_eq_pow_correct :
@@ -1360,37 +1311,55 @@ Theorem Field_simplify_eq_pow_correct :
  forall nfe1, Fnorm fe1 = nfe1 ->
  forall nfe2, Fnorm fe2 = nfe2 ->
  forall den, split (denum nfe1) (denum nfe2) = den ->
- NPphi_pow l (Nnorm n lmp (PEmul (num nfe1) (right den))) ==
- NPphi_pow l (Nnorm n lmp (PEmul (num nfe2) (left den))) ->
+ NPphi_pow l (Nnorm n lmp (num nfe1 * right den)) ==
+ NPphi_pow l (Nnorm n lmp (num nfe2 * left den)) ->
  PCond l (condition nfe1 ++ condition nfe2) ->
  FEeval l fe1 == FEeval l fe2.
 Proof.
-intros n l lpe fe1 fe2 Hlpe lmp Hlmp nfe1 eq1 nfe2 eq2 den eq3 Hcrossprod Hcond;
-  subst nfe1 nfe2 den lmp.
-apply Fnorm_crossproduct; trivial.
+intros n l lpe fe1 fe2 Hlpe lmp Hlmp nfe1 eq1 nfe2 eq2 den eq3 Hcrossprod Hcond.
+apply Fnorm_crossproduct; rewrite ?eq1, ?eq2; trivial.
 simpl.
-rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))).
-rewrite (split_correct_r l (denum (Fnorm fe1)) (denum (Fnorm fe2))).
-rewrite NPEmul_correct.
-rewrite NPEmul_correct.
+rewrite (split_ok_l (denum nfe1) (denum nfe2) l), eq3.
+rewrite (split_ok_r (denum nfe1) (denum nfe2) l), eq3.
 simpl.
-repeat rewrite (ARmul_assoc ARth).
-rewrite <-(
-  let x := PEmul (num (Fnorm fe1))
-                     (rsplit_right (split (denum (Fnorm fe1)) (denum (Fnorm fe2)))) in
-ring_rw_pow_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l
-        Hlpe Logic.eq_refl
-        x Logic.eq_refl) in Hcrossprod.
-rewrite <-(
-  let x := (PEmul (num (Fnorm fe2))
-                     (rsplit_left
-                        (split (denum (Fnorm fe1)) (denum (Fnorm fe2))))) in
-    ring_rw_pow_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l
-        Hlpe Logic.eq_refl
-        x Logic.eq_refl) in Hcrossprod.
-simpl in Hcrossprod.
-rewrite Hcrossprod.
-reflexivity.
+rewrite !rmul_assoc.
+apply rmul_ext; trivial.
+rewrite
+ (ring_rw_pow_correct n lpe l Hlpe Logic.eq_refl (num nfe1 * right den) Logic.eq_refl),
+ (ring_rw_pow_correct n lpe l Hlpe Logic.eq_refl (num nfe2 * left den) Logic.eq_refl).
+rewrite Hlmp.
+apply Hcrossprod.
+Qed.
+
+Theorem Field_simplify_aux_ok l fe1 fe2 den :
+ FEeval l fe1 == FEeval l fe2 ->
+ split (denum (Fnorm fe1)) (denum (Fnorm fe2)) = den ->
+ PCond l (condition (Fnorm fe1) ++ condition (Fnorm fe2)) ->
+ (num (Fnorm fe1) * right den) @ l == (num (Fnorm fe2) * left den) @ l.
+Proof.
+ rewrite PCond_app; intros Hfe Hden (Hc1,Hc2); simpl.
+ assert (Hc1' := Pcond_Fnorm _ _ Hc1).
+ assert (Hc2' := Pcond_Fnorm _ _ Hc2).
+ set (N1 := num (Fnorm fe1)) in *. set (N2 := num (Fnorm fe2)) in *.
+ set (D1 := denum (Fnorm fe1)) in *. set (D2 := denum (Fnorm fe2)) in *.
+ assert (~ (common den) @ l == 0).
+ { intro H. apply Hc1'.
+   rewrite (split_ok_l D1 D2 l).
+   rewrite Hden. simpl. ring [H]. }
+ apply (@rmul_reg_l ((common den) @ l)); trivial.
+ rewrite !(rmul_comm ((common den) @ l)), <- !rmul_assoc.
+ change
+  (N1@l * (right den * common den) @ l ==
+   N2@l * (left den * common den) @ l).
+ rewrite <- Hden, <- split_ok_l, <- split_ok_r.
+ apply (@rmul_reg_l (/ D2@l)). { apply rinv_nz; trivial. }
+ rewrite (rmul_comm (/ D2 @ l)), <- !rmul_assoc.
+ rewrite <- rdiv_def, rdiv_r_r, rmul_1_r by trivial.
+ apply (@rmul_reg_l (/ (D1@l))). { apply rinv_nz; trivial. }
+ rewrite !(rmul_comm  (/ D1@l)), <- !rmul_assoc.
+ rewrite <- !rdiv_def, rdiv_r_r, rmul_1_r by trivial.
+ rewrite (rmul_comm (/ D2@l)), <- rdiv_def.
+ unfold N1,N2,D1,D2; rewrite <- !Fnorm_FEeval_PEeval; trivial.
 Qed.
 
 Theorem Field_simplify_eq_pow_in_correct :
@@ -1400,47 +1369,17 @@ Theorem Field_simplify_eq_pow_in_correct :
  forall nfe1, Fnorm fe1 = nfe1 ->
  forall nfe2, Fnorm fe2 = nfe2 ->
  forall den, split (denum nfe1) (denum nfe2) = den ->
- forall np1, Nnorm n lmp (PEmul (num nfe1) (right den)) = np1 ->
- forall np2, Nnorm n lmp (PEmul (num nfe2) (left den)) = np2 ->
+ forall np1, Nnorm n lmp (num nfe1 * right den) = np1 ->
+ forall np2, Nnorm n lmp (num nfe2 * left den) = np2 ->
  FEeval l fe1 == FEeval l fe2 ->
-  PCond l (condition nfe1 ++ condition nfe2) ->
+ PCond l (condition nfe1 ++ condition nfe2) ->
  NPphi_pow l np1 ==
  NPphi_pow l np2.
 Proof.
  intros. subst nfe1 nfe2 lmp np1 np2.
- repeat rewrite (Pphi_pow_ok Rsth Reqe ARth CRmorph pow_th get_sign_spec).
- repeat (rewrite <- (norm_subst_ok Rsth Reqe ARth CRmorph pow_th);trivial). simpl.
- assert (N1 := Pcond_Fnorm _ _ (PCond_app_inv_l _ _ _ H7)).
- assert (N2 := Pcond_Fnorm _ _ (PCond_app_inv_r _ _ _ H7)).
- apply (@rmul_reg_l (NPEeval l (rsplit_common den))).
- intro Heq;apply N1.
- rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))).
- rewrite H3. rewrite NPEmul_correct. simpl. ring [Heq].
- repeat rewrite (ARth.(ARmul_comm) (NPEeval l (rsplit_common den))).
- repeat rewrite <- ARth.(ARmul_assoc).
- change (NPEeval l (rsplit_right den) * NPEeval l (rsplit_common den)) with
-      (NPEeval l (PEmul (rsplit_right den) (rsplit_common den))).
- change (NPEeval l (rsplit_left den) * NPEeval l (rsplit_common den)) with
-      (NPEeval l (PEmul (rsplit_left den) (rsplit_common den))).
- repeat rewrite <- NPEmul_correct. rewrite <- H3. rewrite <- split_correct_l.
- rewrite <- split_correct_r.
- apply (@rmul_reg_l (/NPEeval l (denum (Fnorm fe2)))).
- intro Heq; apply AFth.(AF_1_neq_0).
- rewrite <- (@AFinv_l AFth (NPEeval l (denum (Fnorm fe2))));trivial.
- ring [Heq]. rewrite (ARth.(ARmul_comm)  (/ NPEeval l (denum (Fnorm fe2)))).
- repeat rewrite <- (ARth.(ARmul_assoc)).
- rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r by trivial.
- apply (@rmul_reg_l (/NPEeval l (denum (Fnorm fe1)))).
- intro Heq; apply AFth.(AF_1_neq_0).
- rewrite <- (@AFinv_l AFth (NPEeval l (denum (Fnorm fe1))));trivial.
- ring [Heq]. repeat rewrite (ARth.(ARmul_comm)  (/ NPEeval l (denum (Fnorm fe1)))).
- repeat rewrite <- (ARth.(ARmul_assoc)).
- repeat rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r by trivial.
- rewrite (AFth.(AFdiv_def)). ring_simplify. unfold SRopp.
- rewrite  (ARth.(ARmul_comm) (/ NPEeval l (denum (Fnorm fe2)))).
- repeat rewrite <- (AFth.(AFdiv_def)).
- repeat rewrite <- Fnorm_FEeval_PEeval ; trivial.
- apply (PCond_app_inv_r _ _ _ H7). apply (PCond_app_inv_l _ _ _ H7).
+ rewrite !(Pphi_pow_ok Rsth Reqe ARth CRmorph pow_th get_sign_spec).
+ repeat (rewrite <- (norm_subst_ok Rsth Reqe ARth CRmorph pow_th);trivial).
+ simpl. apply Field_simplify_aux_ok; trivial.
 Qed.
 
 Theorem Field_simplify_eq_in_correct :
@@ -1450,47 +1389,16 @@ forall n l lpe fe1 fe2,
  forall nfe1, Fnorm fe1 = nfe1 ->
  forall nfe2, Fnorm fe2 = nfe2 ->
  forall den, split (denum nfe1) (denum nfe2) = den ->
- forall np1, Nnorm n lmp (PEmul (num nfe1) (right den)) = np1 ->
- forall np2, Nnorm n lmp (PEmul (num nfe2) (left den)) = np2 ->
+ forall np1, Nnorm n lmp (num nfe1 * right den) = np1 ->
+ forall np2, Nnorm n lmp (num nfe2 * left den) = np2 ->
  FEeval l fe1 == FEeval l fe2 ->
-  PCond l (condition nfe1 ++ condition nfe2) ->
- NPphi_dev l np1 ==
- NPphi_dev l np2.
+ PCond l (condition nfe1 ++ condition nfe2) ->
+ NPphi_dev l np1 == NPphi_dev l np2.
 Proof.
  intros. subst nfe1 nfe2 lmp np1 np2.
- repeat rewrite (Pphi_dev_ok Rsth Reqe ARth CRmorph  get_sign_spec).
- repeat (rewrite <- (norm_subst_ok Rsth Reqe ARth CRmorph pow_th);trivial). simpl.
- assert (N1 := Pcond_Fnorm _ _ (PCond_app_inv_l _ _ _ H7)).
- assert (N2 := Pcond_Fnorm _ _ (PCond_app_inv_r _ _ _ H7)).
- apply (@rmul_reg_l (NPEeval l (rsplit_common den))).
- intro Heq;apply N1.
- rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))).
- rewrite H3. rewrite NPEmul_correct. simpl. ring [Heq].
- repeat rewrite (ARth.(ARmul_comm) (NPEeval l (rsplit_common den))).
- repeat rewrite <- ARth.(ARmul_assoc).
- change (NPEeval l (rsplit_right den) * NPEeval l (rsplit_common den)) with
-      (NPEeval l (PEmul (rsplit_right den) (rsplit_common den))).
- change (NPEeval l (rsplit_left den) * NPEeval l (rsplit_common den)) with
-      (NPEeval l (PEmul (rsplit_left den) (rsplit_common den))).
- repeat rewrite <- NPEmul_correct;rewrite <- H3. rewrite <- split_correct_l.
- rewrite <- split_correct_r.
- apply (@rmul_reg_l (/NPEeval l (denum (Fnorm fe2)))).
- intro Heq; apply AFth.(AF_1_neq_0).
- rewrite <- (@AFinv_l AFth (NPEeval l (denum (Fnorm fe2))));trivial.
- ring [Heq]. rewrite (ARth.(ARmul_comm)  (/ NPEeval l (denum (Fnorm fe2)))).
- repeat rewrite <- (ARth.(ARmul_assoc)).
- rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r by trivial.
- apply (@rmul_reg_l (/NPEeval l (denum (Fnorm fe1)))).
- intro Heq; apply AFth.(AF_1_neq_0).
- rewrite <- (@AFinv_l AFth (NPEeval l (denum (Fnorm fe1))));trivial.
- ring [Heq]. repeat rewrite (ARth.(ARmul_comm)  (/ NPEeval l (denum (Fnorm fe1)))).
- repeat rewrite <- (ARth.(ARmul_assoc)).
- repeat rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r by trivial.
- rewrite (AFth.(AFdiv_def)). ring_simplify. unfold SRopp.
- rewrite  (ARth.(ARmul_comm) (/ NPEeval l (denum (Fnorm fe2)))).
- repeat rewrite <- (AFth.(AFdiv_def)).
- repeat rewrite <- Fnorm_FEeval_PEeval;trivial.
- apply (PCond_app_inv_r _ _ _ H7). apply (PCond_app_inv_l _ _ _ H7).
+ rewrite !(Pphi_dev_ok Rsth Reqe ARth CRmorph  get_sign_spec).
+ repeat (rewrite <- (norm_subst_ok Rsth Reqe ARth CRmorph pow_th);trivial).
+ apply Field_simplify_aux_ok; trivial.
 Qed.
 
 
@@ -1499,7 +1407,7 @@ Section Fcons_impl.
 Variable Fcons : PExpr C -> list (PExpr C) -> list (PExpr C).
 
 Hypothesis PCond_fcons_inv : forall l a l1,
-  PCond l (Fcons a l1) ->  ~ NPEeval l a == 0 /\ PCond l l1.
+  PCond l (Fcons a l1) ->  ~ a @ l == 0 /\ PCond l l1.
 
 Fixpoint Fapp (l m:list (PExpr C)) {struct l} : list (PExpr C) :=
   match l with
@@ -1507,15 +1415,15 @@ Fixpoint Fapp (l m:list (PExpr C)) {struct l} : list (PExpr C) :=
   | cons a l1 => Fcons a (Fapp l1 m)
   end.
 
- Lemma fcons_correct : forall l l1,
+Lemma fcons_ok : forall l l1,
   (forall lock, lock = PCond l -> lock (Fapp l1 nil)) -> PCond l l1.
- Proof.
- intros l l1 h1; assert (H := h1 (PCond l) (refl_equal _));clear h1.
- induction l1; simpl; intros.
-  trivial.
-  elim PCond_fcons_inv with (1 := H); intros.
-  destruct l1; trivial. split; trivial. apply IHl1; trivial.
- Qed.
+Proof.
+intros l l1 h1; assert (H := h1 (PCond l) (refl_equal _));clear h1.
+induction l1; simpl; intros.
+ trivial.
+ elim PCond_fcons_inv with (1 := H); intros.
+ destruct l1; trivial. split; trivial. apply IHl1; trivial.
+Qed.
 
 End Fcons_impl.
 
@@ -1531,21 +1439,15 @@ Fixpoint Fcons (e:PExpr C) (l:list (PExpr C)) {struct l} : list (PExpr C) :=
  end.
 
 Theorem PFcons_fcons_inv:
- forall l a l1, PCond l (Fcons a l1) ->  ~ NPEeval l a == 0 /\ PCond l l1.
-intros l a l1; elim l1; simpl Fcons; auto.
-simpl; auto.
-intros a0 l0.
-generalize (PExpr_eq_semi_correct l a a0); case (PExpr_eq a a0).
-intros H H0 H1; split; auto.
-rewrite H; auto.
-generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto.
-intros H H0 H1;
- assert (Hp: ~ NPEeval l a0 == 0 /\ (~ NPEeval l a == 0 /\ PCond l l0)).
-split.
-generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto.
-apply H0.
-generalize (PCond_cons_inv_r _ _ _ H1); simpl; auto.
-generalize Hp; case l0; simpl; intuition.
+ forall l a l1, PCond l (Fcons a l1) ->  ~ a @ l == 0 /\ PCond l l1.
+Proof.
+induction l1 as [|e l1]; simpl Fcons.
+- simpl; now split.
+- case PExpr_eq_spec; intros H; rewrite !PCond_cons; intros (H1,H2);
+   repeat split; trivial.
+  + now rewrite H.
+  + now apply IHl1.
+  + now apply IHl1.
 Qed.
 
 (* equality of normal forms rather than syntactic equality *)
@@ -1558,23 +1460,16 @@ Fixpoint Fcons0 (e:PExpr C) (l:list (PExpr C)) {struct l} : list (PExpr C) :=
  end.
 
 Theorem PFcons0_fcons_inv:
- forall l a l1, PCond l (Fcons0 a l1) ->  ~ NPEeval l a == 0 /\ PCond l l1.
-intros l a l1; elim l1; simpl Fcons0; auto.
-simpl; auto.
-intros a0 l0.
-generalize (ring_correct Rsth Reqe ARth CRmorph pow_th cdiv_th O l nil a a0). simpl.
-  case (Peq ceqb (Nnorm O nil a) (Nnorm O nil a0)).
-intros H H0 H1; split; auto.
-rewrite H; auto.
-generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto.
-intros H H0 H1;
- assert (Hp: ~ NPEeval l a0 == 0 /\ (~ NPEeval l a == 0 /\ PCond l l0)).
-split.
-generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto.
-apply H0.
-generalize (PCond_cons_inv_r _ _ _ H1); simpl; auto.
-clear get_sign get_sign_spec.
-generalize Hp; case l0; simpl; intuition.
+ forall l a l1, PCond l (Fcons0 a l1) ->  ~ a @ l == 0 /\ PCond l l1.
+Proof.
+induction l1 as [|e l1]; simpl Fcons0.
+- simpl; now split.
+- generalize (ring_correct O l nil a e). lazy zeta; simpl Peq.
+  case Peq; intros H; rewrite !PCond_cons; intros (H1,H2);
+   repeat split; trivial.
+  + now rewrite H.
+  + now apply IHl1.
+  + now apply IHl1.
 Qed.
 
 (* split factorized denominators *)
@@ -1586,95 +1481,83 @@ Fixpoint Fcons00 (e:PExpr C) (l:list (PExpr C)) {struct e} : list (PExpr C) :=
  end.
 
 Theorem PFcons00_fcons_inv:
-  forall l a l1, PCond l (Fcons00 a l1) -> ~ NPEeval l a == 0 /\ PCond l l1.
-intros l a; elim a; try (intros; apply PFcons0_fcons_inv; auto; fail).
- intros p H p0 H0 l1 H1.
-   simpl in H1.
-   case (H _ H1); intros H2 H3.
-   case (H0 _ H3); intros H4 H5; split; auto.
-   simpl.
-   apply field_is_integral_domain; trivial.
-   simpl;intros. rewrite pow_th.(rpow_pow_N).
-   destruct (H _ H0);split;auto.
-   destruct n;simpl. apply AFth.(AF_1_neq_0).
-   apply pow_pos_not_0;trivial.
+  forall l a l1, PCond l (Fcons00 a l1) -> ~ a @ l == 0 /\ PCond l l1.
+Proof.
+intros l a; elim a; try (intros; apply PFcons0_fcons_inv; trivial; fail).
+- intros p H p0 H0 l1 H1.
+  simpl in H1.
+  destruct (H _ H1) as (H2,H3).
+  destruct (H0 _ H3) as (H4,H5). split; trivial.
+  simpl.
+  apply field_is_integral_domain; trivial.
+- intros. destruct (H _ H0). split; trivial.
+  apply PEpow_nz; trivial.
 Qed.
 
 Definition Pcond_simpl_gen :=
-  fcons_correct _ PFcons00_fcons_inv.
+  fcons_ok _ PFcons00_fcons_inv.
 
 
 (* Specific case when the equality test of coefs is complete w.r.t. the
    field equality: non-zero coefs can be eliminated, and opposite can
    be simplified (if -1 <> 0) *)
 
-Hypothesis ceqb_complete : forall c1 c2, phi c1 == phi c2 -> ceqb c1 c2 = true.
+Hypothesis ceqb_complete : forall c1 c2, [c1] == [c2] -> ceqb c1 c2 = true.
 
-Lemma ceqb_rect_complete : forall c1 c2 (A:Type) (x y:A) (P:A->Type),
-  (phi c1 == phi c2 -> P x) ->
-  (~ phi c1 == phi c2 -> P y) ->
-  P (if ceqb c1 c2 then x else y).
+Lemma ceqb_spec' c1 c2 : Bool.reflect ([c1] == [c2]) (ceqb c1 c2).
 Proof.
-intros.
-generalize (fun h => X (morph_eq CRmorph c1 c2 h)).
-generalize (@ceqb_complete c1 c2).
-case (c1 ?=! c2); auto; intros.
-apply X0.
-red; intro.
-absurd (false = true); auto;  discriminate.
+assert (H := morph_eq CRmorph c1 c2).
+assert (H' := @ceqb_complete c1 c2).
+destruct (ceqb c1 c2); constructor.
+- now apply H.
+- intro E. specialize (H' E). discriminate.
 Qed.
 
 Fixpoint Fcons1 (e:PExpr C) (l:list (PExpr C)) {struct e} : list (PExpr C) :=
  match e with
-   PEmul e1 e2 => Fcons1 e1 (Fcons1 e2 l)
+ | PEmul e1 e2 => Fcons1 e1 (Fcons1 e2 l)
  | PEpow e _ => Fcons1 e l
- | PEopp e => if ceqb (copp cI) cO then absurd_PCond else Fcons1 e l
- | PEc c => if ceqb c cO then absurd_PCond else l
+ | PEopp e => if (-(1) =? 0)%coef then absurd_PCond else Fcons1 e l
+ | PEc c => if (c =? 0)%coef then absurd_PCond else l
  | _ => Fcons0 e l
  end.
 
 Theorem PFcons1_fcons_inv:
-  forall l a l1, PCond l (Fcons1 a l1) -> ~ NPEeval l a == 0 /\ PCond l l1.
-intros l a; elim a; try (intros; apply PFcons0_fcons_inv; auto; fail).
- simpl; intros c l1.
-   apply ceqb_rect_complete; intros.
-  elim (@absurd_PCond_bottom l H0).
-  split; trivial.
-    rewrite <- (morph0 CRmorph); trivial.
- intros p H p0 H0 l1 H1.
-   simpl in H1.
-   case (H _ H1); intros H2 H3.
-   case (H0 _ H3); intros H4 H5; split; auto.
-   simpl.
-   apply field_is_integral_domain; trivial.
- simpl; intros p H l1.
-   apply ceqb_rect_complete; intros.
-  elim (@absurd_PCond_bottom l H1).
-  destruct (H _ H1).
+  forall l a l1, PCond l (Fcons1 a l1) -> ~ a @ l == 0 /\ PCond l l1.
+Proof.
+intros l a; elim a; try (intros; apply PFcons0_fcons_inv; trivial; fail).
+- simpl; intros c l1.
+  case ceqb_spec'; intros H H0.
+  + elim (@absurd_PCond_bottom l H0).
+  + split; trivial. rewrite <- phi_0; trivial.
+- intros p H p0 H0 l1 H1. simpl in H1.
+  destruct (H _ H1) as (H2,H3).
+  destruct (H0 _ H3) as (H4,H5).
+  split; trivial. simpl. apply field_is_integral_domain; trivial.
+- simpl; intros p H l1.
+  case ceqb_spec'; intros H0 H1.
+  + elim (@absurd_PCond_bottom l H1).
+  + destruct (H _ H1).
     split; trivial.
     apply ropp_neq_0; trivial.
-    rewrite (morph_opp CRmorph) in H0.
-    rewrite (morph1 CRmorph) in H0.
-    rewrite (morph0 CRmorph) in H0.
-    trivial.
- intros;simpl. destruct (H _ H0);split;trivial.
- rewrite pow_th.(rpow_pow_N). destruct n;simpl.
- apply AFth.(AF_1_neq_0). apply pow_pos_not_0;trivial.
+    rewrite (morph_opp CRmorph), phi_0, phi_1 in H0. trivial.
+- intros. destruct (H _ H0);split;trivial. apply PEpow_nz; trivial.
 Qed.
 
-Definition Fcons2 e l := Fcons1 (PExpr_simp e) l.
+Definition Fcons2 e l := Fcons1 (PEsimp e) l.
 
 Theorem PFcons2_fcons_inv:
- forall l a l1, PCond l (Fcons2 a l1) -> ~ NPEeval l a == 0 /\ PCond l l1.
+ forall l a l1, PCond l (Fcons2 a l1) -> ~ a @ l == 0 /\ PCond l l1.
+Proof.
 unfold Fcons2; intros l a l1 H; split;
- case (PFcons1_fcons_inv l (PExpr_simp a) l1); auto.
+ case (PFcons1_fcons_inv l (PEsimp a) l1); trivial.
 intros H1 H2 H3; case H1.
-transitivity (NPEeval l a); trivial.
-apply PExpr_simp_correct.
+transitivity (a@l); trivial.
+apply PEsimp_ok.
 Qed.
 
 Definition Pcond_simpl_complete :=
-  fcons_correct _ PFcons2_fcons_inv.
+  fcons_ok _ PFcons2_fcons_inv.
 
 End Fcons_simpl.
 
@@ -1742,22 +1625,22 @@ Hypothesis S_inj : forall x y, 1+x==1+y -> x==y.
 
 Hypothesis gen_phiPOS_not_0 : forall p, ~ gen_phiPOS1 rI radd rmul p == 0.
 
-Lemma add_inj_r : forall p x y,
+Lemma add_inj_r p x y :
    gen_phiPOS1 rI radd rmul p + x == gen_phiPOS1 rI radd rmul p + y -> x==y.
-intros p x y.
+Proof.
 elim p using Pos.peano_ind; simpl; intros.
  apply S_inj; trivial.
  apply H.
    apply S_inj.
-   repeat rewrite (ARadd_assoc ARth).
+   rewrite !(ARadd_assoc ARth).
    rewrite <- (ARgen_phiPOS_Psucc Rsth Reqe ARth); trivial.
 Qed.
 
-Lemma gen_phiPOS_inj : forall x y,
+Lemma gen_phiPOS_inj x y :
   gen_phiPOS rI radd rmul x == gen_phiPOS rI radd rmul y ->
   x = y.
-intros x y.
-repeat rewrite <- (same_gen Rsth Reqe ARth).
+Proof.
+rewrite <- !(same_gen Rsth Reqe ARth).
 case (Pos.compare_spec x y).
  intros.
    trivial.
@@ -1777,9 +1660,10 @@ case (Pos.compare_spec x y).
 Qed.
 
 
-Lemma gen_phiN_inj : forall x y,
+Lemma gen_phiN_inj x y :
   gen_phiN rO rI radd rmul x == gen_phiN rO rI radd rmul y ->
   x = y.
+Proof.
 destruct x; destruct y; simpl; intros; trivial.
  elim gen_phiPOS_not_0 with p.
    symmetry .
@@ -1789,7 +1673,7 @@ destruct x; destruct y; simpl; intros; trivial.
  rewrite gen_phiPOS_inj with (1 := H); trivial.
 Qed.
 
-Lemma gen_phiN_complete : forall x y,
+Lemma gen_phiN_complete x y :
   gen_phiN rO rI radd rmul x == gen_phiN rO rI radd rmul y ->
   N.eqb x y = true.
 Proof.
@@ -1808,31 +1692,22 @@ Section Field.
  Let AFth := F2AF Rsth Reqe Fth.
  Let ARth := Rth_ARth Rsth Reqe Rth.
 
-Lemma ring_S_inj : forall x y, 1+x==1+y -> x==y.
+Lemma ring_S_inj x y : 1+x==1+y -> x==y.
+Proof.
 intros.
-transitivity (x + (1 + - (1))).
- rewrite (Ropp_def Rth).
-   symmetry .
-   apply (ARadd_0_r Rsth ARth).
- transitivity (y + (1 + - (1))).
-  repeat rewrite <- (ARplus_assoc ARth).
-    repeat rewrite (ARadd_assoc ARth).
-    apply (Radd_ext Reqe).
-   repeat rewrite <- (ARadd_comm ARth 1).
-     trivial.
-   reflexivity.
-  rewrite (Ropp_def Rth).
-    apply (ARadd_0_r Rsth ARth).
+rewrite <- (ARadd_0_l ARth x), <- (ARadd_0_l ARth y).
+rewrite <- (Ropp_def Rth 1), (ARadd_comm ARth 1).
+rewrite <- !(ARadd_assoc ARth). now apply (Radd_ext Reqe).
 Qed.
 
-
- Hypothesis gen_phiPOS_not_0 : forall p, ~ gen_phiPOS1 rI radd rmul p == 0.
+Hypothesis gen_phiPOS_not_0 : forall p, ~ gen_phiPOS1 rI radd rmul p == 0.
 
 Let gen_phiPOS_inject :=
    gen_phiPOS_inj AFth ring_S_inj gen_phiPOS_not_0.
 
-Lemma gen_phiPOS_discr_sgn : forall x y,
+Lemma gen_phiPOS_discr_sgn x y :
   ~ gen_phiPOS rI radd rmul x == - gen_phiPOS rI radd rmul y.
+Proof.
 red; intros.
 apply gen_phiPOS_not_0 with (y + x)%positive.
 rewrite (ARgen_phiPOS_add Rsth Reqe ARth).
@@ -1845,9 +1720,10 @@ transitivity (gen_phiPOS1 1 radd rmul y + - gen_phiPOS1 1 radd rmul y).
  apply (Ropp_def Rth).
 Qed.
 
-Lemma gen_phiZ_inj : forall x y,
+Lemma gen_phiZ_inj x y :
   gen_phiZ rO rI radd rmul ropp x == gen_phiZ rO rI radd rmul ropp y ->
   x = y.
+Proof.
 destruct x; destruct y; simpl; intros.
  trivial.
  elim gen_phiPOS_not_0 with p.
@@ -1878,9 +1754,10 @@ destruct x; destruct y; simpl; intros.
    reflexivity.
 Qed.
 
-Lemma gen_phiZ_complete : forall x y,
+Lemma gen_phiZ_complete x y :
   gen_phiZ rO rI radd rmul ropp x == gen_phiZ rO rI radd rmul ropp y ->
   Zeq_bool x y = true.
+Proof.
 intros.
  replace y with x.
  unfold Zeq_bool.
@@ -1891,3 +1768,6 @@ Qed.
 End Field.
 
 End Complete.
+
+Arguments FEO [C].
+Arguments FEI [C].
diff --git a/plugins/setoid_ring/InitialRing.v b/plugins/setoid_ring/InitialRing.v
index e106d5b5..b92b847b 100644
--- a/plugins/setoid_ring/InitialRing.v
+++ b/plugins/setoid_ring/InitialRing.v
@@ -1,13 +1,12 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-Require Import ZArith_base.
-Require Import Zpow_def.
+Require Import Zbool.
 Require Import BinInt.
 Require Import BinNat.
 Require Import Setoid.
@@ -16,6 +15,7 @@ Require Import Ring_polynom.
 Import List.
 
 Set Implicit Arguments.
+(* Set Universe Polymorphism. *)
 
 Import RingSyntax.
 
@@ -815,7 +815,7 @@ Ltac ring_elements set ext rspec pspec sspec dspec rk :=
                   fun f => f arth ext_r morph lemma1 lemma2
                 | _ => fail 4 "ring: bad sign specification"
                 end
-             | _ => fail 3 "ring: bad coefficiant division specification"
+             | _ => fail 3 "ring: bad coefficient division specification"
              end
           | _ => fail 2 "ring: bad power specification"
           end
diff --git a/plugins/setoid_ring/NArithRing.v b/plugins/setoid_ring/NArithRing.v
index cfd00521..a10eeecc 100644
--- a/plugins/setoid_ring/NArithRing.v
+++ b/plugins/setoid_ring/NArithRing.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/plugins/setoid_ring/Ncring.v b/plugins/setoid_ring/Ncring.v
index 95d7deee..2dc3197d 100644
--- a/plugins/setoid_ring/Ncring.v
+++ b/plugins/setoid_ring/Ncring.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/plugins/setoid_ring/Ncring_initial.v b/plugins/setoid_ring/Ncring_initial.v
index 516a993e..c40e0ffb 100644
--- a/plugins/setoid_ring/Ncring_initial.v
+++ b/plugins/setoid_ring/Ncring_initial.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -192,6 +192,7 @@ Lemma gen_phiZ_opp : forall x, [- x] == - [x].
  Lemma gen_phiZ_ext : forall x y : Z, x = y -> [x] == [y].
  Proof. intros;subst;reflexivity. Qed.
 
+Declare Equivalent Keys bracket gen_phiZ.
 (*proof that [.] satisfies morphism specifications*)
 Global Instance gen_phiZ_morph :
 (@Ring_morphism (Z:Type) R _ _ _ _ _ _ _ Zops Zr _ _ _ _ _ _ _ _ _ gen_phiZ) . (* beurk!*)
diff --git a/plugins/setoid_ring/Ncring_polynom.v b/plugins/setoid_ring/Ncring_polynom.v
index eefc9428..5845b629 100644
--- a/plugins/setoid_ring/Ncring_polynom.v
+++ b/plugins/setoid_ring/Ncring_polynom.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -103,7 +103,7 @@ Variable P:Pol.
 
 (* Xi^n * P + Q
 les variables de tete de Q ne sont pas forcement < i 
-mais Q est normalisé : variables de tete decroissantes *)
+mais Q est normalisé : variables de tete decroissantes *)
 
 Fixpoint PaddX (i n:positive)(Q:Pol){struct Q}:=
   match Q with
@@ -216,8 +216,8 @@ Definition Psub(P P':Pol):= P ++ (--P').
   intros l P i n Q;unfold mkPX.
   destruct P;try (simpl;reflexivity).
   assert (Hh := ring_morphism_eq  c 0). 
-simpl; case_eq (Ceqb c 0);simpl;try reflexivity.
-intros.
+  simpl; case_eq (Ceqb c 0);simpl;try reflexivity.
+  intros.
   rewrite Hh. rewrite ring_morphism0.
   rsimpl. apply Ceqb_eq. trivial.
   destruct (Pos.compare_spec i p).
@@ -416,10 +416,13 @@ Qed.
  Variable pow_th : power_theory Cp_phi rpow.
 
  (** evaluation of polynomial expressions towards R *)
+
  Fixpoint PEeval (l:list R) (pe:PExpr C) {struct pe} : R :=
    match pe with
+   | PEO => 0
+   | PEI => 1
    | PEc c => [c]
-   | PEX j => nth 0 j l
+   | PEX _ j => nth 0 j l
    | PEadd pe1 pe2 => (PEeval l pe1) + (PEeval l pe2)
    | PEsub pe1 pe2 => (PEeval l pe1) - (PEeval l pe2)
    | PEmul pe1 pe2 => (PEeval l pe1) * (PEeval l pe2)
@@ -500,8 +503,10 @@ Definition pow_N_gen (R:Type)(x1:R)(m:R->R->R)(x:R) (p:N) :=
 
   Fixpoint norm_aux (pe:PExpr C) : Pol :=
    match pe with
+   | PEO => Pc cO
+   | PEI => Pc cI
    | PEc c => Pc c
-   | PEX j => mk_X j
+   | PEX _ j => mk_X j
    | PEadd pe1 (PEopp pe2) =>
      Psub (norm_aux pe1) (norm_aux pe2)
    | PEadd pe1 pe2 => Padd (norm_aux  pe1) (norm_aux pe2)
@@ -520,28 +525,30 @@ Definition pow_N_gen (R:Type)(x1:R)(m:R->R->R)(x:R) (p:N) :=
   Proof.
    intros.
    induction pe.
-Esimpl3. Esimpl3. simpl.
- rewrite IHpe1;rewrite IHpe2.
- destruct pe2; Esimpl3. 
-unfold Psub.
-destruct pe1; destruct pe2; rewrite Padd_ok; rewrite Popp_ok; reflexivity.
-simpl. unfold Psub. rewrite IHpe1;rewrite IHpe2.
-destruct pe1. destruct pe2; rewrite Padd_ok; rewrite Popp_ok; try reflexivity.
-Esimpl3. Esimpl3. Esimpl3. Esimpl3. Esimpl3. Esimpl3.
- Esimpl3. Esimpl3. Esimpl3. Esimpl3. Esimpl3. Esimpl3. Esimpl3.
-simpl. rewrite IHpe1;rewrite IHpe2. rewrite Pmul_ok. reflexivity.
-simpl. rewrite IHpe; Esimpl3. 
-simpl.
-   rewrite Ppow_N_ok; (intros;try reflexivity). 
-   rewrite rpow_pow_N.  Esimpl3.
-   induction n;simpl. Esimpl3. induction p; simpl.
-  try rewrite IHp;try rewrite IHpe;
- repeat rewrite Pms_ok;
-      repeat rewrite Pmul_ok;reflexivity.
-rewrite Pmul_ok. try rewrite IHp;try rewrite IHpe;
- repeat rewrite Pms_ok;
-      repeat rewrite Pmul_ok;reflexivity. trivial.
-exact pow_th.
+   - now simpl; rewrite <- ring_morphism0.
+   - now simpl; rewrite <- ring_morphism1.
+   - Esimpl3. 
+   - Esimpl3. 
+   - simpl.
+     rewrite IHpe1;rewrite IHpe2.
+     destruct pe2; Esimpl3. 
+     unfold Psub.
+     destruct pe1; destruct pe2; rewrite Padd_ok; rewrite Popp_ok; reflexivity.
+   - simpl. unfold Psub. rewrite IHpe1;rewrite IHpe2.
+     now destruct pe1; 
+       [destruct pe2; rewrite Padd_ok; rewrite Popp_ok; Esimpl3 | Esimpl3..]. 
+   - simpl. rewrite IHpe1;rewrite IHpe2. rewrite Pmul_ok. reflexivity.
+   - now simpl; rewrite IHpe; Esimpl3. 
+   - simpl.
+     rewrite Ppow_N_ok; (intros;try reflexivity). 
+     rewrite rpow_pow_N; [| now apply pow_th]. 
+     induction n;simpl; [now Esimpl3|]. 
+     induction p; simpl; trivial.
+     + try rewrite IHp;try rewrite IHpe;
+         repeat rewrite Pms_ok; repeat rewrite Pmul_ok;reflexivity.
+     + rewrite Pmul_ok. 
+       try rewrite IHp;try rewrite IHpe; repeat rewrite Pms_ok;
+         repeat rewrite Pmul_ok;reflexivity. 
   Qed.
 
  Lemma norm_subst_spec :
diff --git a/plugins/setoid_ring/Ncring_tac.v b/plugins/setoid_ring/Ncring_tac.v
index 4fb02909..31c9e54d 100644
--- a/plugins/setoid_ring/Ncring_tac.v
+++ b/plugins/setoid_ring/Ncring_tac.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -76,11 +76,11 @@ Instance  reify_mul (R:Type)
  : reify (mul:=op) (PEmul e1 e2) lvar (op t1 t2)|10.
 
 Instance  reify_mul_ext (R:Type) `{Ring R}
-  lvar z e2 t2 
+  lvar (z:Z) e2 t2 
  `{Ring (T:=R)}
  {_:reify e2 lvar t2}
  : reify (PEmul (PEc z) e2) lvar
-      (@multiplication Z _ _  z t2)|9.
+      (@multiplication Z _ _ z t2)|9.
 
 Instance  reify_sub (R:Type)
  e1 lvar t1 e2 t2 op
@@ -127,7 +127,6 @@ Definition list_reifyl (R:Type) lexpr lvar lterm
 
 Unset Implicit Arguments.
 
-
 Ltac lterm_goal g :=
   match g with
   | ?t1 == ?t2 => constr:(t1::t2::nil)
@@ -138,6 +137,7 @@ Ltac lterm_goal g :=
 Lemma Zeqb_ok: forall x y : Z, Zeq_bool x y = true -> x == y.
  intros x y H. rewrite (Zeq_bool_eq x y H). reflexivity. Qed. 
 
+
 Ltac reify_goal lvar lexpr lterm:=
   (*idtac lvar; idtac lexpr; idtac lterm;*)
   match lexpr with
diff --git a/plugins/setoid_ring/Ring.v b/plugins/setoid_ring/Ring.v
index 98150d35..b2417db6 100644
--- a/plugins/setoid_ring/Ring.v
+++ b/plugins/setoid_ring/Ring.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/plugins/setoid_ring/Ring_base.v b/plugins/setoid_ring/Ring_base.v
index b64023ea..9508b8e7 100644
--- a/plugins/setoid_ring/Ring_base.v
+++ b/plugins/setoid_ring/Ring_base.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/plugins/setoid_ring/Ring_equiv.v b/plugins/setoid_ring/Ring_equiv.v
deleted file mode 100644
index 945f6c68..00000000
--- a/plugins/setoid_ring/Ring_equiv.v
+++ /dev/null
@@ -1,74 +0,0 @@
-Require Import Setoid_ring_theory.
-Require Import LegacyRing_theory.
-Require Import Ring_theory.
-
-Set Implicit Arguments.
-
-Section Old2New.
-
-Variable A : Type.
-
-Variable Aplus : A -> A -> A.
-Variable Amult : A -> A -> A.
-Variable Aone : A.
-Variable Azero : A.
-Variable Aopp : A -> A.
-Variable Aeq : A -> A -> bool.
-Variable R : Ring_Theory Aplus Amult Aone Azero Aopp Aeq.
-
-Let Aminus := fun x y => Aplus x (Aopp y).
-
-Lemma ring_equiv1 :
-  ring_theory Azero Aone Aplus Amult Aminus Aopp (eq (A:=A)).
-Proof.
-destruct R.
-split;  eauto.
-Qed.
-
-End Old2New.
-
-Section New2OldRing.
- Variable R : Type.
- Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R).
- Variable Rth : ring_theory rO rI radd rmul rsub ropp (eq (A:=R)).
-
- Variable reqb : R -> R -> bool.
- Variable reqb_ok : forall x y, reqb x y = true -> x = y.
-
- Lemma ring_equiv2 :
-   Ring_Theory radd  rmul rI rO ropp reqb.
-Proof.
-elim Rth; intros; constructor;  eauto.
-intros.
-apply reqb_ok.
-destruct (reqb x y); trivial; intros.
-elim H.
-Qed.
-
- Definition default_eqb : R -> R -> bool := fun x y => false.
- Lemma default_eqb_ok : forall x y, default_eqb x y = true -> x = y.
-Proof.
-discriminate 1.
-Qed.
-
-End New2OldRing.
-
-Section New2OldSemiRing.
- Variable R : Type.
- Variable (rO rI : R) (radd rmul: R->R->R).
- Variable SRth : semi_ring_theory rO rI radd rmul (eq (A:=R)).
-
- Variable reqb : R -> R -> bool.
- Variable reqb_ok : forall x y, reqb x y = true -> x = y.
-
- Lemma sring_equiv2 :
-   Semi_Ring_Theory radd rmul rI rO reqb.
-Proof.
-elim SRth; intros; constructor;  eauto.
-intros.
-apply reqb_ok.
-destruct (reqb x y); trivial; intros.
-elim H.
-Qed.
-
-End New2OldSemiRing.
diff --git a/plugins/setoid_ring/Ring_polynom.v b/plugins/setoid_ring/Ring_polynom.v
index 21d3099c..2d2756b1 100644
--- a/plugins/setoid_ring/Ring_polynom.v
+++ b/plugins/setoid_ring/Ring_polynom.v
@@ -1,17 +1,19 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+
 Set Implicit Arguments.
-Require Import Setoid Morphisms BinList BinPos BinNat BinInt.
+Require Import Setoid Morphisms. 
+Require Import BinList BinPos BinNat BinInt.
 Require Export Ring_theory.
-
 Local Open Scope positive_scope.
 Import RingSyntax.
+(* Set Universe Polymorphism. *)
 
 Section MakeRingPol.
 
@@ -372,17 +374,6 @@ Section MakeRingPol.
 
  Infix "**" := Pmul.
 
- Fixpoint Psquare (P:Pol) : Pol :=
-   match P with
-   | Pc c => Pc (c *! c)
-   | Pinj j Q => Pinj j (Psquare Q)
-   | PX P i Q =>
-     let twoPQ := Pmul P (mkPinj xH (PmulC Q (cI +! cI))) in
-     let Q2 := Psquare Q in
-     let P2 := Psquare P in
-     mkPX (mkPX P2 i P0 ++ twoPQ) i Q2
-   end.
-
  (** Monomial **)
 
  (** A monomial is X1^k1...Xi^ki. Its representation
@@ -511,6 +502,29 @@ Section MakeRingPol.
  Reserved Notation "P @ l " (at level 10, no associativity).
  Notation "P @ l " := (Pphi l P).
 
+ Definition Pequiv (P Q : Pol) := forall l, P@l == Q@l.
+ Infix "===" := Pequiv (at level 70, no associativity).
+
+ Instance Pequiv_eq : Equivalence Pequiv.
+ Proof.
+  unfold Pequiv; split; red; intros; [reflexivity|now symmetry|now etransitivity].
+ Qed.
+
+ Instance Pphi_ext : Proper (eq ==> Pequiv ==> req) Pphi.
+ Proof.
+  now intros l l' <- P Q H.
+ Qed.
+
+ Instance Pinj_ext : Proper (eq ==> Pequiv ==> Pequiv) Pinj.
+ Proof.
+  intros i j <- P P' HP l. simpl. now rewrite HP.
+ Qed.
+
+ Instance PX_ext : Proper (Pequiv ==> eq ==> Pequiv ==> Pequiv) PX.
+ Proof.
+  intros P P' HP p p' <- Q Q' HQ l. simpl. now rewrite HP, HQ.
+ Qed.
+
  (** Evaluation of a monomial towards R *)
 
  Fixpoint Mphi(l:list R) (M: Mon) : R :=
@@ -532,8 +546,9 @@ Section MakeRingPol.
  Lemma jump_add' i j (l:list R) : jump (i + j) l = jump j (jump i l).
  Proof. rewrite Pos.add_comm. apply jump_add. Qed.
 
- Lemma Peq_ok P P' : (P ?== P') = true -> forall l, P@l == P'@ l.
+ Lemma Peq_ok P P' : (P ?== P') = true -> P === P'.
  Proof.
+  unfold Pequiv.
   revert P';induction P;destruct P';simpl; intros H l; try easy.
   - now apply (morph_eq CRmorph).
   - destruct (Pos.compare_spec p p0); [ subst | easy | easy ].
@@ -545,8 +560,7 @@ Section MakeRingPol.
     now rewrite IHP1, IHP2.
  Qed.
 
- Lemma Peq_spec P P' :
-   BoolSpec (forall l, P@l == P'@l) True (P ?== P').
+ Lemma Peq_spec P P' : BoolSpec (P === P') True (P ?== P').
  Proof.
   generalize (Peq_ok P P'). destruct (P ?== P'); auto.
  Qed.
@@ -567,6 +581,11 @@ Section MakeRingPol.
   now rewrite jump_add'.
  Qed.
 
+ Instance mkPinj_ext : Proper (eq ==> Pequiv ==> Pequiv) mkPinj.
+ Proof.
+  intros i j <- P Q H l. now rewrite !mkPinj_ok.
+ Qed.
+
  Lemma pow_pos_add x i j : x^(j + i) == x^i * x^j.
  Proof.
   rewrite Pos.add_comm.
@@ -590,6 +609,11 @@ Section MakeRingPol.
     rewrite H, Pphi0, Pos.add_comm, pow_pos_add; rsimpl.
  Qed.
 
+ Instance mkPX_ext : Proper (Pequiv ==> eq ==> Pequiv ==> Pequiv) mkPX.
+ Proof.
+  intros P P' HP i i' <- Q Q' HQ l. now rewrite !mkPX_ok, HP, HQ.
+ Qed.
+
  Hint Rewrite
   Pphi0
   Pphi1
@@ -656,7 +680,7 @@ Section MakeRingPol.
   - add_permut.
   - destruct p; simpl;
     rewrite ?jump_pred_double; add_permut.
-  - destr_pos_sub; intros ->;Esimpl.
+  - destr_pos_sub; intros ->; Esimpl.
     + rewrite IHP';rsimpl. add_permut.
     + rewrite IHP', pow_pos_add;simpl;Esimpl. add_permut.
     + rewrite IHP1, pow_pos_add;rsimpl. add_permut.
@@ -689,47 +713,23 @@ Section MakeRingPol.
         rewrite IHP'2, pow_pos_add; rsimpl. add_permut.
  Qed.
 
- Lemma PsubX_ok P' P k l :
-  (forall P l, (P--P')@l == P@l - P'@l) ->
-  (PsubX Psub P' k P) @ l == P@l - P'@l * (hd l)^k.
+ Lemma Psub_opp P' P : P -- P' === P ++ (--P').
  Proof.
-  intros IHP'.
-  revert k l. induction P;simpl;intros.
-  - rewrite Popp_ok;rsimpl; add_permut.
-  - destruct p; simpl;
-    rewrite Popp_ok;rsimpl;
-    rewrite ?jump_pred_double; add_permut.
-  - destr_pos_sub; intros ->; Esimpl.
-    + rewrite IHP';rsimpl. add_permut.
-    + rewrite IHP', pow_pos_add;simpl;Esimpl. add_permut.
-    + rewrite IHP1, pow_pos_add;rsimpl. add_permut.
+  revert P; induction P'; simpl; intros.
+  - intro l; Esimpl.
+  - revert p; induction P; simpl; intros; try reflexivity.
+    + destr_pos_sub; intros ->; now apply mkPinj_ext.
+    + destruct p0; now apply PX_ext.
+  - destruct P; simpl; try reflexivity.
+    + destruct p0; now apply PX_ext.
+    + destr_pos_sub; intros ->; apply mkPX_ext; auto.
+      revert p1. induction P2; simpl; intros; try reflexivity.
+      destr_pos_sub; intros ->; now apply mkPX_ext.
  Qed.
 
  Lemma Psub_ok P' P l : (P -- P')@l == P@l - P'@l.
  Proof.
-  revert P l; induction P';simpl;intros;Esimpl.
-  - revert p l; induction P;simpl;intros.
-    + Esimpl; add_permut.
-    + destr_pos_sub; intros ->;Esimpl.
-      * rewrite IHP';rsimpl.
-      * rewrite IHP';Esimpl. now rewrite jump_add'.
-      * rewrite IHP. now rewrite jump_add'.
-    + destruct p0;simpl.
-      * rewrite IHP2;simpl. rsimpl.
-      * rewrite IHP2;simpl. rewrite jump_pred_double. rsimpl.
-      * rewrite IHP'. rsimpl.
-  - destruct P;simpl.
-    + Esimpl; add_permut.
-    + destruct p0;simpl;Esimpl; rewrite IHP'2; simpl.
-      * rsimpl. add_permut.
-      * rewrite jump_pred_double. rsimpl. add_permut.
-      * rsimpl. add_permut.
-    + destr_pos_sub; intros ->; Esimpl.
-      * rewrite IHP'1, IHP'2;rsimpl. add_permut.
-      * rewrite IHP'1, IHP'2;simpl;Esimpl.
-        rewrite pow_pos_add;rsimpl. add_permut.
-      * rewrite PsubX_ok by trivial;rsimpl.
-        rewrite IHP'2, pow_pos_add;rsimpl. add_permut.
+  rewrite Psub_opp, Padd_ok, Popp_ok. rsimpl.
  Qed.
 
  Lemma PmulI_ok P' :
@@ -764,15 +764,6 @@ Section MakeRingPol.
       add_permut; f_equiv; mul_permut.
  Qed.
 
- Lemma Psquare_ok P l : (Psquare P)@l == P@l * P@l.
- Proof.
-  revert l;induction P;simpl;intros;Esimpl.
-  - apply IHP.
-  - rewrite Padd_ok, Pmul_ok;Esimpl.
-    rewrite IHP1, IHP2.
-    mul_push ((hd l)^p). now mul_push (P2@l).
- Qed.
-
  Lemma mkZmon_ok M j l :
    (mkZmon j M) @@ l == (zmon j M) @@ l.
  Proof.
@@ -807,9 +798,9 @@ Section MakeRingPol.
      P@l == Q@l + [c] * R@l.
  Proof.
  revert l.
- induction P as [c0 | j P IH | P1 IH1 i P2 IH2]; intros l; Esimpl.
- - assert (H := div_th.(div_eucl_th) c0 c).
-   destruct cdiv as (q,r). rewrite H; Esimpl. add_permut.
+ induction P as [c0 | j P IH | P1 IH1 i P2 IH2]; intros l; Esimpl. 
+ - assert (H := div_th.(div_eucl_th) c0 c). 
+   destruct cdiv as (q,r). rewrite H; Esimpl. add_permut. 
  - destr_factor. Esimpl.
  - destr_factor. Esimpl. add_permut.
  Qed.
@@ -818,11 +809,12 @@ Section MakeRingPol.
    let (c,M) := cM in
    let (Q,R) := MFactor P c M in
      P@l == Q@l + [c] * M@@l * R@l.
- Proof.
+ Proof. 
  destruct cM as (c,M). revert M l.
- induction P; destruct M; intros l; simpl; auto;
+ induction P; destruct M; intros l; simpl; auto; 
  try (case ceqb_spec; intro He);
-  try (case Pos.compare_spec; intros He); rewrite ?He;
+  try (case Pos.compare_spec; intros He);
+  rewrite ?He;
    destr_factor; simpl; Esimpl.
  - assert (H := div_th.(div_eucl_th) c0 c).
    destruct cdiv as (q,r). rewrite H; Esimpl. add_permut.
@@ -880,9 +872,9 @@ Section MakeRingPol.
  Lemma PSubstL1_ok n LM1 P1 l :
    MPcond LM1 l -> P1@l == (PSubstL1 P1 LM1 n)@l.
  Proof.
- revert P1; induction LM1 as [|(M2,P2) LM2 IH]; simpl; intros.
- - reflexivity.
- - rewrite <- IH by intuition. now apply PNSubst1_ok.
+ revert P1; induction LM1 as [|(M2,P2) LM2 IH]; simpl; intros. 
+ - reflexivity. 
+ - rewrite <- IH by intuition; now apply PNSubst1_ok.
  Qed.
 
  Lemma PSubstL_ok n LM1 P1 P2 l :
@@ -907,6 +899,8 @@ Section MakeRingPol.
  (** Definition of polynomial expressions *)
 
  Inductive PExpr : Type :=
+  | PEO : PExpr
+  | PEI : PExpr            
   | PEc : C -> PExpr
   | PEX : positive -> PExpr
   | PEadd : PExpr -> PExpr -> PExpr
@@ -915,6 +909,7 @@ Section MakeRingPol.
   | PEopp : PExpr -> PExpr
   | PEpow : PExpr -> N -> PExpr.
 
+
  (** evaluation of polynomial expressions towards R *)
  Definition mk_X j := mkPinj_pred j mkX.
 
@@ -922,6 +917,8 @@ Section MakeRingPol.
 
  Fixpoint PEeval (l:list R) (pe:PExpr) {struct pe} : R :=
    match pe with
+   | PEO => rO
+   | PEI => rI
    | PEc c => phi c
    | PEX j => nth 0 j l
    | PEadd pe1 pe2 => (PEeval l pe1) + (PEeval l pe2)
@@ -985,11 +982,13 @@ Section POWER.
   Variable n : nat.
   Variable lmp:list (C*Mon*Pol).
   Let subst_l P := PNSubstL P lmp n n.
-  Let Pmul_subst P1 P2 := subst_l (Pmul P1 P2).
+  Let Pmul_subst P1 P2 := subst_l (P1 ** P2).
   Let Ppow_subst := Ppow_N subst_l.
 
   Fixpoint norm_aux (pe:PExpr) : Pol :=
    match pe with
+   | PEO => Pc cO
+   | PEI => Pc cI
    | PEc c => Pc c
    | PEX j => mk_X j
    | PEadd (PEopp pe1) pe2 => (norm_aux pe2) -- (norm_aux pe1)
@@ -1021,7 +1020,7 @@ Section POWER.
     end.
   Proof.
   simpl (norm_aux (PEadd _ _)).
-  destruct pe1; [ | | | | | reflexivity | ];
+  destruct pe1; [ | | | | | | | reflexivity | ];
    destruct pe2; simpl get_PEopp; reflexivity.
   Qed.
 
@@ -1034,22 +1033,26 @@ Section POWER.
   now destruct pe.
   Qed.
 
+  Arguments norm_aux !pe : simpl nomatch.
+
   Lemma norm_aux_spec l pe :
     PEeval l pe == (norm_aux pe)@l.
   Proof.
    intros.
-   induction pe.
+   induction pe; cbn.
+   - now rewrite (morph0 CRmorph). 
+   - now rewrite (morph1 CRmorph).
    - reflexivity.
    - apply mkX_ok.
-   - simpl PEeval. rewrite IHpe1, IHpe2.
+   - rewrite IHpe1, IHpe2.
      assert (H1 := norm_aux_PEopp pe1).
      assert (H2 := norm_aux_PEopp pe2).
      rewrite norm_aux_PEadd.
      do 2 destruct get_PEopp; rewrite ?H1, ?H2; Esimpl; add_permut.
-   - simpl. rewrite IHpe1, IHpe2. Esimpl.
-   - simpl. rewrite IHpe1, IHpe2. now rewrite Pmul_ok.
-   - simpl. rewrite IHpe. Esimpl.
-   - simpl. rewrite Ppow_N_ok by reflexivity.
+   - rewrite IHpe1, IHpe2. Esimpl.
+   - rewrite IHpe1, IHpe2. now rewrite Pmul_ok.
+   - rewrite IHpe. Esimpl.
+   - rewrite Ppow_N_ok by reflexivity.
      rewrite pow_th.(rpow_pow_N). destruct n0; simpl; Esimpl.
      induction p;simpl; now rewrite ?IHp, ?IHpe, ?Pms_ok, ?Pmul_ok.
   Qed.
@@ -1483,3 +1486,6 @@ Qed.
  Qed.
 
 End MakeRingPol.
+
+Arguments PEO [C].
+Arguments PEI [C].
diff --git a/plugins/setoid_ring/Ring_tac.v b/plugins/setoid_ring/Ring_tac.v
index 7a7ffcfd..77863edc 100644
--- a/plugins/setoid_ring/Ring_tac.v
+++ b/plugins/setoid_ring/Ring_tac.v
@@ -196,12 +196,17 @@ Ltac get_MonPol lemma :=
 (********************************************************)
 
 (* Building the atom list of a ring expression *)
-Ltac FV Cst CstPow add mul sub opp pow t fv :=
+(* We do not assume that Cst recognizes the rO and rI terms as constants, as *)
+(* the tactic could be used to discriminate occurrences of an opaque *)
+(* constant phi, with (phi 0) not convertible to 0 for instance *)
+Ltac FV Cst CstPow rO rI add mul sub opp pow t fv :=
  let rec TFV t fv :=
   let f :=
   match Cst t with
   | NotConstant =>
       match t with
+      | rO =>  fun _ => fv
+      | rI =>  fun _ => fv
       | (add ?t1 ?t2) => fun _ => TFV t2 ltac:(TFV t1 fv)
       | (mul ?t1 ?t2) => fun _ => TFV t2 ltac:(TFV t1 fv)
       | (sub ?t1 ?t2) => fun _ => TFV t2 ltac:(TFV t1 fv)
@@ -219,32 +224,39 @@ Ltac FV Cst CstPow add mul sub opp pow t fv :=
  in TFV t fv.
 
  (* syntaxification of ring expressions *)
-Ltac mkPolexpr C Cst CstPow radd rmul rsub ropp rpow t fv :=
+ (* We do not assume that Cst recognizes the rO and rI terms as constants, as *)
+ (* the tactic could be used to discriminate occurrences of an opaque *)
+ (* constant phi, with (phi 0) not convertible to 0 for instance *)
+Ltac mkPolexpr C Cst CstPow rO rI radd rmul rsub ropp rpow t fv :=
  let rec mkP t :=
     let f :=
     match Cst t with
     | InitialRing.NotConstant =>
         match t with
+        | rO => 
+          fun _ => constr:(@PEO C)
+        | rI => 
+          fun _ => constr:(@PEI C)
         | (radd ?t1 ?t2) =>
           fun _ =>
           let e1 := mkP t1 in
-          let e2 := mkP t2 in constr:(PEadd e1 e2)
+          let e2 := mkP t2 in constr:(@PEadd C e1 e2)
         | (rmul ?t1 ?t2) =>
           fun _ =>
           let e1 := mkP t1 in
-          let e2 := mkP t2 in constr:(PEmul e1 e2)
+          let e2 := mkP t2 in constr:(@PEmul C e1 e2)
         | (rsub ?t1 ?t2) =>
           fun _ =>
           let e1 := mkP t1 in
-          let e2 := mkP t2 in constr:(PEsub e1 e2)
+          let e2 := mkP t2 in constr:(@PEsub C e1 e2)
         | (ropp ?t1) =>
           fun _ =>
-          let e1 := mkP t1 in constr:(PEopp e1)
+          let e1 := mkP t1 in constr:(@PEopp C e1)
         | (rpow ?t1 ?n) =>
           match CstPow n with
           | InitialRing.NotConstant =>
             fun _ => let p := Find_at t fv in constr:(PEX C p)
-          | ?c => fun _ => let e1 := mkP t1 in constr:(PEpow e1 c)
+          | ?c => fun _ => let e1 := mkP t1 in constr:(@PEpow C e1 c)
           end
         | _ =>
           fun _ => let p := Find_at t fv in constr:(PEX C p)
@@ -260,58 +272,58 @@ Ltac PackRing F req sth ext morph arth cst_tac pow_tac lemma1 lemma2 pre post :=
   let RNG :=
     match type of lemma1 with
     | context
-       [@PEeval ?R ?rO ?add ?mul ?sub ?opp ?C ?phi ?Cpow ?powphi ?pow _ _] =>
+       [@PEeval ?R ?r0 ?r1 ?add ?mul ?sub ?opp ?C ?phi ?Cpow ?powphi ?pow _ _] =>
         (fun proj => proj
              cst_tac pow_tac pre post
-             R req add mul sub opp C Cpow powphi pow lemma1 lemma2)
+             R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2)
     | _ => fail 1 "field anomaly: bad correctness lemma (parse)"
     end in
   F RNG.
 
 Ltac get_Carrier RNG :=
   RNG ltac:(fun cst_tac pow_tac pre post
-             R req add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
+             R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
             R).
 
 Ltac get_Eq RNG :=
   RNG ltac:(fun cst_tac pow_tac pre post
-             R req add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
+             R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
             req).
 
 Ltac get_Pre RNG :=
   RNG ltac:(fun cst_tac pow_tac pre post
-             R req add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
+             R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
             pre).
 
 Ltac get_Post RNG :=
   RNG ltac:(fun cst_tac pow_tac pre post
-             R req add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
+             R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
             post).
 
 Ltac get_NormLemma RNG :=
   RNG ltac:(fun cst_tac pow_tac pre post
-             R req add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
+             R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
             lemma1).
 
 Ltac get_SimplifyLemma RNG :=
   RNG ltac:(fun cst_tac pow_tac pre post
-             R req add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
+             R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
             lemma2).
 
 Ltac get_RingFV RNG :=
   RNG ltac:(fun cst_tac pow_tac pre post
-             R req add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
-            FV cst_tac pow_tac add mul sub opp pow).
+             R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
+            FV cst_tac pow_tac r0 r1 add mul sub opp pow).
 
 Ltac get_RingMeta RNG :=
   RNG ltac:(fun cst_tac pow_tac pre post
-             R req add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
-            mkPolexpr C cst_tac pow_tac add mul sub opp pow).
+             R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
+            mkPolexpr C cst_tac pow_tac r0 r1 add mul sub opp pow).
 
 Ltac get_RingHypTac RNG :=
   RNG ltac:(fun cst_tac pow_tac pre post
-             R req add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
-       let mkPol := mkPolexpr C cst_tac pow_tac add mul sub opp pow in
+             R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
+       let mkPol := mkPolexpr C cst_tac pow_tac r0 r1 add mul sub opp pow in
        fun fv lH => mkHyp_tac C req ltac:(fun t => mkPol t fv) lH).
 
 (* ring tactics *)
@@ -338,8 +350,8 @@ Ltac Ring RNG lemma lH :=
     (apply (lemma vfv vlpe pe1 pe2)
       || fail "typing error while applying ring");
     [ ((let prh := proofHyp_tac lH in exact prh)
-        || idtac "can not automatically proof hypothesis :";
-           idtac " maybe a left member of a hypothesis is not a monomial")
+        || idtac "can not automatically prove hypothesis :";
+           [> idtac " maybe a left member of a hypothesis is not a monomial"..])
     | vm_compute;
       (exact (eq_refl true) || fail "not a valid ring equation")]).
 
diff --git a/plugins/setoid_ring/Ring_theory.v b/plugins/setoid_ring/Ring_theory.v
index af43b0ab..4f05f0d4 100644
--- a/plugins/setoid_ring/Ring_theory.v
+++ b/plugins/setoid_ring/Ring_theory.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -28,6 +28,8 @@ Reserved Notation "x == y" (at level 70, no associativity).
 End RingSyntax.
 Import RingSyntax.
 
+(* Set Universe Polymorphism. *)
+
 Section Power.
  Variable R:Type.
  Variable rI : R.
@@ -252,6 +254,7 @@ Section ALMOST_RING.
 
  Section SEMI_RING.
  Variable SReqe : sring_eq_ext radd rmul req.
+
    Add Morphism radd : radd_ext1.  exact (SRadd_ext SReqe). Qed.
    Add Morphism rmul : rmul_ext1.  exact (SRmul_ext SReqe). Qed.
  Variable SRth : semi_ring_theory 0 1 radd rmul req.
@@ -503,7 +506,6 @@ Qed.
 
 End ALMOST_RING.
 
-
 Section AddRing.
 
 (* Variable R : Type.
@@ -528,7 +530,6 @@ Inductive ring_kind : Type :=
     (_ : ring_morph rO rI radd rmul rsub ropp req
                     cO cI cadd cmul csub copp ceqb phi).
 
-
 End AddRing.
 
 
diff --git a/plugins/setoid_ring/Rings_Z.v b/plugins/setoid_ring/Rings_Z.v
index 58a4d7ea..605a23a9 100644
--- a/plugins/setoid_ring/Rings_Z.v
+++ b/plugins/setoid_ring/Rings_Z.v
@@ -1,6 +1,7 @@
 Require Export Cring.
 Require Export Integral_domain.
 Require Export Ncring_initial.
+Require Export Omega.
 
 Instance Zcri: (Cring (Rr:=Zr)).
 red. exact Z.mul_comm. Defined.
diff --git a/plugins/setoid_ring/ZArithRing.v b/plugins/setoid_ring/ZArithRing.v
index 1177688d..848e06a7 100644
--- a/plugins/setoid_ring/ZArithRing.v
+++ b/plugins/setoid_ring/ZArithRing.v
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -48,8 +48,8 @@ Ltac Zpower_neg :=
 Add Ring Zr : Zth
   (decidable Zeq_bool_eq, constants [Zcst], preprocess [Zpower_neg;unfold Z.succ],
    power_tac Zpower_theory [Zpow_tac],
-    (* The two following option are not needed, it is the default chose when the set of
-        coefficiant is usual ring Z *)
+    (* The following two options are not needed; they are the default choice
+       when the set of coefficient is the usual ring Z *)
     div (InitialRing.Ztriv_div_th (@Eqsth Z) (@IDphi Z)),
    sign get_signZ_th).
 
diff --git a/plugins/setoid_ring/newring.ml4 b/plugins/setoid_ring/newring.ml4
index d1a5c0ab..2f9e8509 100644
--- a/plugins/setoid_ring/newring.ml4
+++ b/plugins/setoid_ring/newring.ml4
@@ -1,30 +1,27 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(*i camlp4deps: "parsing/grammar.cma" i*)
+(*i camlp4deps: "grammar/grammar.cma" i*)
 
 open Pp
+open Errors
 open Util
 open Names
 open Term
+open Vars
 open Closure
 open Environ
 open Libnames
-open Tactics
+open Globnames
 open Glob_term
 open Tacticals
 open Tacexpr
-open Pcoq
-open Tactic
-open Constr
-open Proof_type
 open Coqlib
-open Tacmach
 open Mod_subst
 open Tacinterp
 open Libobject
@@ -32,14 +29,20 @@ open Printer
 open Declare
 open Decl_kinds
 open Entries
+open Misctypes
+
+DECLARE PLUGIN "newring_plugin"
 
 (****************************************************************************)
 (* controlled reduction *)
 
-let mark_arg i c = mkEvar(i,[|c|])
+(** ppedrot: something dubious here, we're obviously using evars the wrong
+    way. FIXME! *)
+
+let mark_arg i c = mkEvar(Evar.unsafe_of_int i,[|c|])
 let unmark_arg f c =
   match destEvar c with
-    | (i,[|c|]) -> f i c
+    | (i,[|c|]) -> f (Evar.repr i) c
     | _ -> assert false
 
 type protect_flag = Eval|Prot|Rec
@@ -48,10 +51,19 @@ let tag_arg tag_rec map subs i c =
   match map i with
       Eval -> mk_clos subs c
     | Prot -> mk_atom c
-    | Rec -> if i = -1 then mk_clos subs c else tag_rec c
+    | Rec -> if Int.equal i (-1) then mk_clos subs c else tag_rec c
+
+let global_head_of_constr c = 
+  let f, args = decompose_app c in
+    try global_of_constr f
+    with Not_found -> anomaly (str "global_head_of_constr")
+
+let global_of_constr_nofail c = 
+  try global_of_constr c
+  with Not_found -> VarRef (Id.of_string "dummy")
 
 let rec mk_clos_but f_map subs t =
-  match f_map t with
+  match f_map (global_of_constr_nofail t) with
     | Some map -> tag_arg (mk_clos_but f_map subs) map subs (-1) t
     | None ->
         (match kind_of_term t with
@@ -62,9 +74,9 @@ let rec mk_clos_but f_map subs t =
 and mk_clos_app_but f_map subs f args n =
   if n >= Array.length args then mk_atom(mkApp(f, args))
   else
-    let fargs, args' = array_chop n args in
+    let fargs, args' = Array.chop n args in
     let f' = mkApp(f,fargs) in
-    match f_map f' with
+    match f_map (global_of_constr_nofail f') with
         Some map ->
           mk_clos_deep
             (fun s' -> unmark_arg (tag_arg (mk_clos_but f_map s') map s'))
@@ -72,24 +84,13 @@ and mk_clos_app_but f_map subs f args n =
             (mkApp (mark_arg (-1) f', Array.mapi mark_arg args'))
       | None -> mk_clos_app_but f_map subs f args (n+1)
 
-
-let interp_map l c =
-  try
-    let (im,am) = List.assoc c l in
-    Some(fun i ->
-      if List.mem i im then Eval
-      else if List.mem i am then Prot
-      else if i = -1 then Eval
-      else Rec)
-  with Not_found -> None
-
 let interp_map l t =
-  try Some(list_assoc_f eq_constr t l) with Not_found -> None
+  try Some(List.assoc_f eq_gr t l) with Not_found -> None
 
-let protect_maps = ref Stringmap.empty
-let add_map s m = protect_maps := Stringmap.add s m !protect_maps
+let protect_maps = ref String.Map.empty
+let add_map s m = protect_maps := String.Map.add s m !protect_maps
 let lookup_map map =
-  try Stringmap.find map !protect_maps
+  try String.Map.find map !protect_maps
   with Not_found ->
     errorlabstrm"lookup_map"(str"map "++qs map++str"not found")
 
@@ -101,112 +102,120 @@ let protect_tac map =
   Tactics.reduct_option (protect_red map,DEFAULTcast) None ;;
 
 let protect_tac_in map id =
-  Tactics.reduct_option (protect_red map,DEFAULTcast) (Some(id, Termops.InHyp));;
+  Tactics.reduct_option (protect_red map,DEFAULTcast) (Some(id, Locus.InHyp));;
 
 
 TACTIC EXTEND protect_fv
   [ "protect_fv" string(map) "in" ident(id) ] ->
-    [ protect_tac_in map id ]
+    [ Proofview.V82.tactic (protect_tac_in map id) ]
 | [ "protect_fv" string(map) ] ->
-    [ protect_tac map ]
+    [ Proofview.V82.tactic (protect_tac map) ]
 END;;
 
 (****************************************************************************)
 
 let closed_term t l =
-  let l = List.map constr_of_global l in
+  let l = List.map Universes.constr_of_global l in
   let cs = List.fold_right Quote.ConstrSet.add l Quote.ConstrSet.empty in
   if Quote.closed_under cs t then tclIDTAC else tclFAIL 0 (mt())
 ;;
 
 TACTIC EXTEND closed_term
   [ "closed_term" constr(t) "[" ne_reference_list(l) "]" ] ->
-    [ closed_term t l ]
+    [ Proofview.V82.tactic (closed_term t l) ]
 END
 ;;
 
-TACTIC EXTEND echo
+(* TACTIC EXTEND echo
 | [ "echo" constr(t) ] ->
   [ Pp.msg (Termops.print_constr t);  Tacinterp.eval_tactic (TacId []) ]
-END;;
+END;;*)
 
 (*
 let closed_term_ast l =
-  TacFun([Some(id_of_string"t")],
-  TacAtom(dummy_loc,TacExtend(dummy_loc,"closed_term",
-  [Genarg.in_gen Genarg.wit_constr (mkVar(id_of_string"t"));
-   Genarg.in_gen (Genarg.wit_list1 Genarg.wit_ref) l])))
+  TacFun([Some(Id.of_string"t")],
+  TacAtom(Loc.ghost,TacExtend(Loc.ghost,"closed_term",
+  [Genarg.in_gen Constrarg.wit_constr (mkVar(Id.of_string"t"));
+   Genarg.in_gen (Genarg.wit_list Constrarg.wit_ref) l])))
 *)
 let closed_term_ast l =
-  let l = List.map (fun gr -> ArgArg(dummy_loc,gr)) l in
-  TacFun([Some(id_of_string"t")],
-  TacAtom(dummy_loc,TacExtend(dummy_loc,"closed_term",
-  [Genarg.in_gen Genarg.globwit_constr (GVar(dummy_loc,id_of_string"t"),None);
-   Genarg.in_gen (Genarg.wit_list1 Genarg.globwit_ref) l])))
+  let tacname = {
+    mltac_plugin = "newring_plugin";
+    mltac_tactic = "closed_term";
+  } in
+  let l = List.map (fun gr -> ArgArg(Loc.ghost,gr)) l in
+  TacFun([Some(Id.of_string"t")],
+  TacML(Loc.ghost,tacname,
+  [Genarg.in_gen (Genarg.glbwit Constrarg.wit_constr) (GVar(Loc.ghost,Id.of_string"t"),None);
+   Genarg.in_gen (Genarg.glbwit (Genarg.wit_list Constrarg.wit_ref)) l]))
 (*
-let _ = add_tacdef false ((dummy_loc,id_of_string"ring_closed_term"
+let _ = add_tacdef false ((Loc.ghost,Id.of_string"ring_closed_term"
 *)
 
 (****************************************************************************)
 
 let ic c =
   let env = Global.env() and sigma = Evd.empty in
-  Constrintern.interp_constr sigma env c
+  Constrintern.interp_open_constr env sigma c
+
+let ic_unsafe c = (*FIXME remove *)
+  let env = Global.env() and sigma = Evd.empty in
+    fst (Constrintern.interp_constr env sigma c)
 
 let ty c = Typing.type_of (Global.env()) Evd.empty c
 
-let decl_constant na c =
-  mkConst(declare_constant (id_of_string na) (DefinitionEntry
-    { const_entry_body = c;
-      const_entry_secctx = None;
-      const_entry_type = None;
-      const_entry_opaque = true },
-    IsProof Lemma))
+let decl_constant na ctx c =
+  let vars = Universes.universes_of_constr c in
+  let ctx = Universes.restrict_universe_context (Univ.ContextSet.of_context ctx) vars in
+  mkConst(declare_constant (Id.of_string na) 
+	    (DefinitionEntry (definition_entry ~opaque:true
+				~univs:(Univ.ContextSet.to_context ctx) c),
+	     IsProof Lemma))
 
 (* Calling a global tactic *)
 let ltac_call tac (args:glob_tactic_arg list) =
-  TacArg(dummy_loc,TacCall(dummy_loc, ArgArg(dummy_loc, Lazy.force tac),args))
+  TacArg(Loc.ghost,TacCall(Loc.ghost, ArgArg(Loc.ghost, Lazy.force tac),args))
 
 (* Calling a locally bound tactic *)
 let ltac_lcall tac args =
-  TacArg(dummy_loc,TacCall(dummy_loc, ArgVar(dummy_loc, id_of_string tac),args))
+  TacArg(Loc.ghost,TacCall(Loc.ghost, ArgVar(Loc.ghost, Id.of_string tac),args))
 
 let ltac_letin (x, e1) e2 =
-  TacLetIn(false,[(dummy_loc,id_of_string x),e1],e2)
+  TacLetIn(false,[(Loc.ghost,Id.of_string x),e1],e2)
 
 let ltac_apply (f:glob_tactic_expr) (args:glob_tactic_arg list) =
   Tacinterp.eval_tactic
     (ltac_letin ("F", Tacexp f) (ltac_lcall "F" args))
 
 let ltac_record flds =
-  TacFun([Some(id_of_string"proj")], ltac_lcall "proj" flds)
+  TacFun([Some(Id.of_string"proj")], ltac_lcall "proj" flds)
 
 
-let carg c = TacDynamic(dummy_loc,Pretyping.constr_in c)
+let carg c = TacDynamic(Loc.ghost,Pretyping.constr_in c)
 
-let dummy_goal env =
+let dummy_goal env sigma =
   let (gl,_,sigma) = 
-    Goal.V82.mk_goal Evd.empty (named_context_val env) mkProp Store.empty in
-  {Evd.it = gl;
-   Evd.sigma = sigma}
+    Goal.V82.mk_goal sigma (named_context_val env) mkProp Evd.Store.empty in
+  {Evd.it = gl; Evd.sigma = sigma}
 
-let exec_tactic env n f args =
-  let lid = list_tabulate(fun i -> id_of_string("x"^string_of_int i)) n in
+let constr_of v = match Value.to_constr v with
+  | Some c -> c
+  | None -> failwith "Ring.exec_tactic: anomaly"
+
+let exec_tactic env evd n f args =
+  let lid = List.init n (fun i -> Id.of_string("x"^string_of_int i)) in
   let res = ref [||] in
   let get_res ist =
-    let l = List.map (fun id ->  List.assoc id ist.lfun) lid in
+    let l = List.map (fun id ->  Id.Map.find id ist.lfun) lid in
     res := Array.of_list l;
     TacId[] in
   let getter =
     Tacexp(TacFun(List.map(fun id -> Some id) lid,
-                  glob_tactic(tacticIn get_res))) in
-  let _ =
-    Tacinterp.eval_tactic(ltac_call f (args@[getter])) (dummy_goal env) in
-  !res
-
-let constr_of = function
-  | VConstr ([],c) -> c
-  | _ -> failwith "Ring.exec_tactic: anomaly"
+                  Tacintern.glob_tactic(tacticIn get_res))) in
+  let gl = dummy_goal env evd in
+  let gls = Proofview.V82.of_tactic (Tacinterp.eval_tactic(ltac_call f (args@[getter]))) gl in
+  let evd, nf = Evarutil.nf_evars_and_universes (Refiner.project gls) in
+    Array.map (fun x -> nf (constr_of x)) !res, Evd.universe_context evd
 
 let stdlib_modules =
   [["Coq";"Setoids";"Setoid"];
@@ -217,16 +226,23 @@ let stdlib_modules =
 
 let coq_constant c =
   lazy (Coqlib.gen_constant_in_modules "Ring" stdlib_modules c)
+let coq_reference c =
+  lazy (Coqlib.gen_reference_in_modules "Ring" stdlib_modules c)
 
 let coq_mk_Setoid = coq_constant "Build_Setoid_Theory"
-let coq_cons = coq_constant "cons"
-let coq_nil = coq_constant "nil"
-let coq_None = coq_constant "None"
-let coq_Some = coq_constant "Some"
+let coq_None = coq_reference "None"
+let coq_Some = coq_reference "Some"
 let coq_eq = coq_constant "eq"
 
+let coq_cons = coq_reference "cons"
+let coq_nil = coq_reference "nil"
+
 let lapp f args = mkApp(Lazy.force f,args)
 
+let plapp evd f args = 
+  let fc = Evarutil.e_new_global evd (Lazy.force f) in
+    mkApp(fc,args)
+
 let dest_rel0 t =
   match kind_of_term t with
   | App(f,args) when Array.length args >= 2 ->
@@ -255,17 +271,19 @@ let plugin_modules =
 
 let my_constant c =
   lazy (Coqlib.gen_constant_in_modules "Ring" plugin_modules c)
+let my_reference c =
+  lazy (Coqlib.gen_reference_in_modules "Ring" plugin_modules c)
 
 let new_ring_path =
-  make_dirpath (List.map id_of_string ["Ring_tac";plugin_dir;"Coq"])
+  DirPath.make (List.map Id.of_string ["Ring_tac";plugin_dir;"Coq"])
 let ltac s =
-  lazy(make_kn (MPfile new_ring_path) (make_dirpath []) (mk_label s))
+  lazy(make_kn (MPfile new_ring_path) DirPath.empty (Label.make s))
 let znew_ring_path =
-  make_dirpath (List.map id_of_string ["InitialRing";plugin_dir;"Coq"])
+  DirPath.make (List.map Id.of_string ["InitialRing";plugin_dir;"Coq"])
 let zltac s =
-  lazy(make_kn (MPfile znew_ring_path) (make_dirpath []) (mk_label s))
+  lazy(make_kn (MPfile znew_ring_path) DirPath.empty (Label.make s))
 
-let mk_cst l s = lazy (Coqlib.gen_constant "newring" l s);;
+let mk_cst l s = lazy (Coqlib.gen_reference "newring" l s);;
 let pol_cst s = mk_cst [plugin_dir;"Ring_polynom"] s ;;
 
 (* Ring theory *)
@@ -274,9 +292,9 @@ let pol_cst s = mk_cst [plugin_dir;"Ring_polynom"] s ;;
 let coq_almost_ring_theory = my_constant "almost_ring_theory"
 
 (* setoid and morphism utilities *)
-let coq_eq_setoid = my_constant "Eqsth"
-let coq_eq_morph = my_constant "Eq_ext"
-let coq_eq_smorph = my_constant "Eq_s_ext"
+let coq_eq_setoid = my_reference "Eqsth"
+let coq_eq_morph = my_reference "Eq_ext"
+let coq_eq_smorph = my_reference "Eq_s_ext"
 
 (* ring -> almost_ring utilities *)
 let coq_ring_theory = my_constant "ring_theory"
@@ -303,16 +321,19 @@ let ltac_inv_morph_nothing = zltac"inv_morph_nothing"
 let coq_pow_N_pow_N = my_constant "pow_N_pow_N"
 
 (* hypothesis *)
-let coq_mkhypo = my_constant "mkhypo"
-let coq_hypo = my_constant "hypo"
+let coq_mkhypo = my_reference "mkhypo"
+let coq_hypo = my_reference "hypo"
 
 (* Equality: do not evaluate but make recursive call on both sides *)
 let map_with_eq arg_map c =
   let (req,_,_) = dest_rel c in
   interp_map
-    ((req,(function -1->Prot|_->Rec))::
+    ((global_head_of_constr req,(function -1->Prot|_->Rec))::
     List.map (fun (c,map) -> (Lazy.force c,map)) arg_map)
 
+let map_without_eq arg_map _ =
+  interp_map (List.map (fun (c,map) -> (Lazy.force c,map)) arg_map)
+
 let _ = add_map "ring"
   (map_with_eq
     [coq_cons,(function -1->Eval|2->Rec|_->Prot);
@@ -343,15 +364,12 @@ type ring_info =
       ring_pre_tac : glob_tactic_expr;
       ring_post_tac : glob_tactic_expr }
 
-module Cmap = Map.Make(struct type t = constr let compare = constr_ord end)
+module Cmap = Map.Make(Constr)
 
-let from_carrier = ref Cmap.empty
-let from_relation = ref Cmap.empty
-let from_name = ref Spmap.empty
+let from_carrier = Summary.ref Cmap.empty ~name:"ring-tac-carrier-table"
+let from_name = Summary.ref Spmap.empty ~name:"ring-tac-name-table"
 
 let ring_for_carrier r = Cmap.find r !from_carrier
-let ring_for_relation rel = Cmap.find rel !from_relation
-
 
 let find_ring_structure env sigma l =
   match l with
@@ -370,32 +388,9 @@ let find_ring_structure env sigma l =
             (str"cannot find a declared ring structure over"++
              spc()++str"\""++pr_constr ty++str"\""))
     | [] -> assert false
-(*
-        let (req,_,_) = dest_rel cl in
-        (try ring_for_relation req
-        with Not_found ->
-          errorlabstrm "ring"
-            (str"cannot find a declared ring structure for equality"++
-             spc()++str"\""++pr_constr req++str"\"")) *)
-
-let _ =
-  Summary.declare_summary "tactic-new-ring-table"
-    { Summary.freeze_function =
-        (fun () -> !from_carrier,!from_relation,!from_name);
-      Summary.unfreeze_function =
-        (fun (ct,rt,nt) ->
-          from_carrier := ct; from_relation := rt; from_name := nt);
-      Summary.init_function =
-        (fun () ->
-          from_carrier := Cmap.empty; from_relation := Cmap.empty;
-          from_name := Spmap.empty) }
 
 let add_entry (sp,_kn) e =
-(*  let _ = ty e.ring_lemma1 in
-  let _ = ty e.ring_lemma2 in
-*)
   from_carrier := Cmap.add e.ring_carrier e !from_carrier;
-  from_relation := Cmap.add e.ring_req e !from_relation;
   from_name := Spmap.add sp e !from_name
 
 
@@ -408,10 +403,10 @@ let subst_th (subst,th) =
   let th' = subst_mps subst th.ring_th in
   let thm1' = subst_mps subst th.ring_lemma1 in
   let thm2' = subst_mps subst th.ring_lemma2 in
-  let tac'= subst_tactic subst th.ring_cst_tac in
-  let pow_tac'= subst_tactic subst th.ring_pow_tac in
-  let pretac'= subst_tactic subst th.ring_pre_tac in
-  let posttac'= subst_tactic subst th.ring_post_tac in
+  let tac'= Tacsubst.subst_tactic subst th.ring_cst_tac in
+  let pow_tac'= Tacsubst.subst_tactic subst th.ring_pow_tac in
+  let pretac'= Tacsubst.subst_tactic subst th.ring_pre_tac in
+  let posttac'= Tacsubst.subst_tactic subst th.ring_post_tac in
   if c' == th.ring_carrier &&
      eq' == th.ring_req &&
      eq_constr set' th.ring_setoid &&
@@ -443,20 +438,20 @@ let theory_to_obj : ring_info -> obj =
   let cache_th (name,th) = add_entry name th in
   declare_object
     {(default_object "tactic-new-ring-theory") with
-      open_function = (fun i o -> if i=1 then cache_th o);
+      open_function = (fun i o -> if Int.equal i 1 then cache_th o);
       cache_function = cache_th;
       subst_function = subst_th;
       classify_function = (fun x -> Substitute x)}
 
 
-let setoid_of_relation env a r =
-  let evm = Evd.empty in
+let setoid_of_relation env evd a r =
   try
-    lapp coq_mk_Setoid
-      [|a ; r ;
-	Rewrite.get_reflexive_proof env evm a r ;
-	Rewrite.get_symmetric_proof env evm a r ;
-	Rewrite.get_transitive_proof env evm a r |]
+    let evm = !evd in
+    let evm, refl = Rewrite.get_reflexive_proof env evm a r in
+    let evm, sym = Rewrite.get_symmetric_proof env evm a r in
+    let evm, trans = Rewrite.get_transitive_proof env evm a r in
+      evd := evm;
+      lapp coq_mk_Setoid [|a ; r ; refl; sym; trans |]
   with Not_found ->
     error "cannot find setoid relation"
 
@@ -469,7 +464,7 @@ let op_smorph r add mul req m1 m2 =
 (* let default_ring_equality (r,add,mul,opp,req) = *)
 (*   let is_setoid = function *)
 (*       {rel_refl=Some _; rel_sym=Some _;rel_trans=Some _;rel_aeq=rel} -> *)
-(*         eq_constr req rel (\* Qu: use conversion ? *\) *)
+(*         eq_constr_nounivs req rel (\* Qu: use conversion ? *\) *)
 (*     | _ -> false in *)
 (*   match default_relation_for_carrier ~filter:is_setoid r with *)
 (*       Leibniz _ -> *)
@@ -484,7 +479,7 @@ let op_smorph r add mul req m1 m2 =
 (*         let is_endomorphism = function *)
 (*             { args=args } -> List.for_all *)
 (*                 (function (var,Relation rel) -> *)
-(*                   var=None && eq_constr req rel *)
+(*                   var=None && eq_constr_nounivs req rel *)
 (*                   | _ -> false) args in *)
 (*         let add_m = *)
 (*           try default_morphism ~filter:is_endomorphism add *)
@@ -519,17 +514,19 @@ let op_smorph r add mul req m1 m2 =
 (*             op_smorph r add mul req add_m.lem mul_m.lem) in *)
 (*         (setoid,op_morph) *)
 
-let ring_equality (r,add,mul,opp,req) =
+let ring_equality env evd (r,add,mul,opp,req) =
   match kind_of_term req with
-    | App (f, [| _ |]) when eq_constr f (Lazy.force coq_eq) ->
-	let setoid = lapp coq_eq_setoid [|r|] in
+    | App (f, [| _ |]) when eq_constr_nounivs f (Lazy.force coq_eq) ->
+	let setoid = plapp evd coq_eq_setoid [|r|] in
 	let op_morph =
 	  match opp with
-              Some opp -> lapp coq_eq_morph [|r;add;mul;opp|]
-            | None -> lapp coq_eq_smorph [|r;add;mul|] in
+              Some opp -> plapp evd coq_eq_morph [|r;add;mul;opp|]
+            | None -> plapp evd coq_eq_smorph [|r;add;mul|] in
+	let setoid = Typing.solve_evars env evd setoid in
+	let op_morph = Typing.solve_evars env evd op_morph in
 	  (setoid,op_morph)
     | _ ->
-	let setoid = setoid_of_relation (Global.env ()) r req in
+	let setoid = setoid_of_relation (Global.env ()) evd r req in
 	let signature = [Some (r,Some req);Some (r,Some req)],Some(r,Some req) in
 	let add_m, add_m_lem =
 	  try Rewrite.default_morphism signature add
@@ -549,7 +546,7 @@ let ring_equality (r,add,mul,opp,req) =
 		let op_morph =
 		  op_morph r add mul opp req add_m_lem mul_m_lem opp_m_lem in
 		  Flags.if_verbose
-		    msgnl
+		    msg_info
 		    (str"Using setoid \""++pr_constr req++str"\""++spc()++
 			str"and morphisms \""++pr_constr add_m_lem ++
 			str"\","++spc()++ str"\""++pr_constr mul_m_lem++
@@ -558,7 +555,7 @@ let ring_equality (r,add,mul,opp,req) =
 		  op_morph)
             | None ->
 		(Flags.if_verbose
-		    msgnl
+		    msg_info
 		    (str"Using setoid \""++pr_constr req ++str"\"" ++ spc() ++
 			str"and morphisms \""++pr_constr add_m_lem ++
 			str"\""++spc()++str"and \""++
@@ -566,22 +563,22 @@ let ring_equality (r,add,mul,opp,req) =
 		 op_smorph r add mul req add_m_lem mul_m_lem) in
           (setoid,op_morph)
 
-let build_setoid_params r add mul opp req eqth =
+let build_setoid_params env evd r add mul opp req eqth =
   match eqth with
       Some th -> th
-    | None -> ring_equality (r,add,mul,opp,req)
+    | None -> ring_equality env evd (r,add,mul,opp,req)
 
 let dest_ring env sigma th_spec =
   let th_typ = Retyping.get_type_of env sigma th_spec in
   match kind_of_term th_typ with
       App(f,[|r;zero;one;add;mul;sub;opp;req|])
-        when eq_constr f (Lazy.force coq_almost_ring_theory) ->
+        when eq_constr_nounivs f (Lazy.force coq_almost_ring_theory) ->
           (None,r,zero,one,add,mul,Some sub,Some opp,req)
     | App(f,[|r;zero;one;add;mul;req|])
-        when eq_constr f (Lazy.force coq_semi_ring_theory) ->
+        when eq_constr_nounivs f (Lazy.force coq_semi_ring_theory) ->
         (Some true,r,zero,one,add,mul,None,None,req)
     | App(f,[|r;zero;one;add;mul;sub;opp;req|])
-        when eq_constr f (Lazy.force coq_ring_theory) ->
+        when eq_constr_nounivs f (Lazy.force coq_ring_theory) ->
         (Some false,r,zero,one,add,mul,Some sub,Some opp,req)
     | _ -> error "bad ring structure"
 
@@ -591,18 +588,18 @@ let dest_morph env sigma m_spec =
   match kind_of_term m_typ with
       App(f,[|r;zero;one;add;mul;sub;opp;req;
               c;czero;cone;cadd;cmul;csub;copp;ceqb;phi|])
-        when eq_constr f (Lazy.force coq_ring_morph) ->
+        when eq_constr_nounivs f (Lazy.force coq_ring_morph) ->
           (c,czero,cone,cadd,cmul,Some csub,Some copp,ceqb,phi)
     | App(f,[|r;zero;one;add;mul;req;c;czero;cone;cadd;cmul;ceqb;phi|])
-        when eq_constr f (Lazy.force coq_semi_morph) ->
+        when eq_constr_nounivs f (Lazy.force coq_semi_morph) ->
         (c,czero,cone,cadd,cmul,None,None,ceqb,phi)
     | _ -> error "bad morphism structure"
 
 
-type coeff_spec =
-    Computational of constr (* equality test *)
+type 'constr coeff_spec =
+    Computational of 'constr (* equality test *)
   | Abstract (* coeffs = Z *)
-  | Morphism of constr (* general morphism *)
+  | Morphism of 'constr (* general morphism *)
 
 
 let reflect_coeff rkind =
@@ -618,101 +615,89 @@ type cst_tac_spec =
 
 let interp_cst_tac env sigma rk kind (zero,one,add,mul,opp) cst_tac =
   match cst_tac with
-      Some (CstTac t) -> Tacinterp.glob_tactic t
+      Some (CstTac t) -> Tacintern.glob_tactic t
     | Some (Closed lc) ->
         closed_term_ast (List.map Smartlocate.global_with_alias lc)
     | None ->
-        (match rk, opp, kind with
-            Abstract, None, _ ->
-              let t = ArgArg(dummy_loc,Lazy.force ltac_inv_morphN) in
-              TacArg(dummy_loc,TacCall(dummy_loc,t,List.map carg [zero;one;add;mul]))
-          | Abstract, Some opp, Some _ ->
-              let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morphZ) in
-              TacArg(dummy_loc,TacCall(dummy_loc,t,List.map carg [zero;one;add;mul;opp]))
-          | Abstract, Some opp, None ->
-              let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morphNword) in
-              TacArg
-                (dummy_loc,TacCall(dummy_loc,t,List.map carg [zero;one;add;mul;opp]))
-          | Computational _,_,_ ->
-              let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morph_gen) in
-              TacArg
-                (dummy_loc,TacCall(dummy_loc,t,List.map carg [zero;one;zero;one]))
-          | Morphism mth,_,_ ->
-              let (_,czero,cone,_,_,_,_,_,_) = dest_morph env sigma mth in
-              let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morph_gen) in
-              TacArg
-                (dummy_loc,TacCall(dummy_loc,t,List.map carg [zero;one;czero;cone])))
-
-let make_hyp env c =
-  let t = Retyping.get_type_of env Evd.empty c in
-  lapp coq_mkhypo [|t;c|]
-
-let make_hyp_list env lH =
-  let carrier = Lazy.force coq_hypo in
-  List.fold_right
-    (fun c l -> lapp coq_cons [|carrier; (make_hyp env c); l|]) lH
-    (lapp coq_nil [|carrier|])
-
-let interp_power env pow =
-  let carrier = Lazy.force coq_hypo in
+        let t = ArgArg(Loc.ghost,Lazy.force ltac_inv_morph_nothing) in
+              TacArg(Loc.ghost,TacCall(Loc.ghost,t,[]))
+
+let make_hyp env evd c =
+  let t = Retyping.get_type_of env !evd c in
+   plapp evd coq_mkhypo [|t;c|]
+
+let make_hyp_list env evd lH =
+  let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in
+  let l = 
+    List.fold_right
+      (fun c l -> plapp evd coq_cons [|carrier; (make_hyp env evd c); l|]) lH
+      (plapp evd coq_nil [|carrier|])
+  in 
+  let l' = Typing.solve_evars env evd l in
+    Evarutil.nf_evars_universes !evd l'
+
+let interp_power env evd pow =
+  let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in
   match pow with
   | None ->
-      let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morph_nothing) in
-      (TacArg(dummy_loc,TacCall(dummy_loc,t,[])), lapp coq_None [|carrier|])
+      let t = ArgArg(Loc.ghost, Lazy.force ltac_inv_morph_nothing) in
+      (TacArg(Loc.ghost,TacCall(Loc.ghost,t,[])), plapp evd coq_None [|carrier|])
   | Some (tac, spec) ->
       let tac =
         match tac with
-        | CstTac t -> Tacinterp.glob_tactic t
+        | CstTac t -> Tacintern.glob_tactic t
         | Closed lc ->
             closed_term_ast (List.map Smartlocate.global_with_alias lc) in
-      let spec = make_hyp env (ic spec) in
-      (tac, lapp coq_Some [|carrier; spec|])
+      let spec = make_hyp env evd (ic_unsafe spec) in
+      (tac, plapp evd coq_Some [|carrier; spec|])
 
-let interp_sign env sign =
-  let carrier = Lazy.force coq_hypo in
+let interp_sign env evd sign =
+  let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in
   match sign with
-  | None -> lapp coq_None [|carrier|]
+  | None -> plapp evd coq_None [|carrier|]
   | Some spec ->
-      let spec = make_hyp env (ic spec) in
-      lapp coq_Some [|carrier;spec|]
+      let spec = make_hyp env evd (ic_unsafe spec) in
+      plapp evd coq_Some [|carrier;spec|]
        (* Same remark on ill-typed terms ... *)
 
-let interp_div env div =
-  let carrier = Lazy.force coq_hypo in
+let interp_div env evd div =
+  let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in
   match div with
-  | None -> lapp coq_None [|carrier|]
+  | None -> plapp evd coq_None [|carrier|]
   | Some spec ->
-      let spec = make_hyp env (ic spec) in
-      lapp coq_Some [|carrier;spec|]
+      let spec = make_hyp env evd (ic_unsafe spec) in
+      plapp evd coq_Some [|carrier;spec|]
        (* Same remark on ill-typed terms ... *)
 
-let add_theory name rth eqth morphth cst_tac (pre,post) power sign div =
+let add_theory name (sigma,rth) eqth morphth cst_tac (pre,post) power sign div =
   check_required_library (cdir@["Ring_base"]);
   let env = Global.env() in
-  let sigma = Evd.empty in
   let (kind,r,zero,one,add,mul,sub,opp,req) = dest_ring env sigma rth in
-  let (sth,ext) = build_setoid_params r add mul opp req eqth in
-  let (pow_tac, pspec) = interp_power env power in
-  let sspec = interp_sign env sign in
-  let dspec = interp_div env div in
+  let evd = ref sigma in
+  let (sth,ext) = build_setoid_params env evd r add mul opp req eqth in
+  let (pow_tac, pspec) = interp_power env evd power in
+  let sspec = interp_sign env evd sign in
+  let dspec = interp_div env evd div in
   let rk = reflect_coeff morphth in
-  let params =
-    exec_tactic env 5 (zltac "ring_lemmas")
+  let params,ctx =
+    exec_tactic env !evd 5 (zltac "ring_lemmas")
       (List.map carg[sth;ext;rth;pspec;sspec;dspec;rk]) in
-  let lemma1 = constr_of params.(3) in
-  let lemma2 = constr_of params.(4) in
+  let lemma1 = params.(3) in
+  let lemma2 = params.(4) in
 
-  let lemma1 = decl_constant (string_of_id name^"_ring_lemma1") lemma1 in
-  let lemma2 = decl_constant (string_of_id name^"_ring_lemma2") lemma2 in
+  let lemma1 =
+    decl_constant (Id.to_string name^"_ring_lemma1") ctx lemma1 in
+  let lemma2 =
+    decl_constant (Id.to_string name^"_ring_lemma2") ctx lemma2 in
   let cst_tac =
     interp_cst_tac env sigma morphth kind (zero,one,add,mul,opp) cst_tac in
   let pretac =
     match pre with
-        Some t -> Tacinterp.glob_tactic t
+        Some t -> Tacintern.glob_tactic t
       | _ -> TacId [] in
   let posttac =
     match post with
-        Some t -> Tacinterp.glob_tactic t
+        Some t -> Tacintern.glob_tactic t
       | _ -> TacId [] in
   let _ =
     Lib.add_leaf name
@@ -720,9 +705,9 @@ let add_theory name rth eqth morphth cst_tac (pre,post) power sign div =
         { ring_carrier = r;
           ring_req = req;
           ring_setoid = sth;
-          ring_ext = constr_of params.(1);
-          ring_morph = constr_of params.(2);
-          ring_th = constr_of params.(0);
+          ring_ext = params.(1);
+          ring_morph = params.(2);
+          ring_th = params.(0);
           ring_cst_tac = cst_tac;
 	  ring_pow_tac = pow_tac;
           ring_lemma1 = lemma1;
@@ -731,22 +716,28 @@ let add_theory name rth eqth morphth cst_tac (pre,post) power sign div =
           ring_post_tac = posttac }) in
   ()
 
-type ring_mod =
-    Ring_kind of coeff_spec
+type 'constr ring_mod =
+    Ring_kind of 'constr coeff_spec
   | Const_tac of cst_tac_spec
   | Pre_tac of raw_tactic_expr
   | Post_tac of raw_tactic_expr
-  | Setoid of Topconstr.constr_expr * Topconstr.constr_expr
-  | Pow_spec of cst_tac_spec * Topconstr.constr_expr
+  | Setoid of Constrexpr.constr_expr * Constrexpr.constr_expr
+  | Pow_spec of cst_tac_spec * Constrexpr.constr_expr
            (* Syntaxification tactic , correctness lemma *)
-  | Sign_spec of Topconstr.constr_expr
-  | Div_spec of Topconstr.constr_expr
+  | Sign_spec of Constrexpr.constr_expr
+  | Div_spec of Constrexpr.constr_expr
+
+
+let ic_coeff_spec = function
+  | Computational t -> Computational (ic_unsafe t)
+  | Morphism t -> Morphism (ic_unsafe t)
+  | Abstract -> Abstract
 
 
 VERNAC ARGUMENT EXTEND ring_mod
-  | [ "decidable" constr(eq_test) ] -> [ Ring_kind(Computational (ic eq_test)) ]
+  | [ "decidable" constr(eq_test) ] -> [ Ring_kind(Computational eq_test) ]
   | [ "abstract" ] -> [ Ring_kind Abstract ]
-  | [ "morphism" constr(morph) ] -> [ Ring_kind(Morphism (ic morph)) ]
+  | [ "morphism" constr(morph) ] -> [ Ring_kind(Morphism morph) ]
   | [ "constants" "[" tactic(cst_tac) "]" ] -> [ Const_tac(CstTac cst_tac) ]
   | [ "closed" "[" ne_global_list(l) "]" ] -> [ Const_tac(Closed l) ]
   | [ "preprocess" "[" tactic(pre) "]" ] -> [ Pre_tac pre ]
@@ -761,7 +752,7 @@ VERNAC ARGUMENT EXTEND ring_mod
 END
 
 let set_once s r v =
-  if !r = None then r := Some v else error (s^" cannot be set twice")
+  if Option.is_empty !r then r := Some v else error (s^" cannot be set twice")
 
 let process_ring_mods l =
   let kind = ref None in
@@ -773,21 +764,29 @@ let process_ring_mods l =
   let power = ref None in
   let div = ref None in
   List.iter(function
-      Ring_kind k -> set_once "ring kind" kind k
+      Ring_kind k -> set_once "ring kind" kind (ic_coeff_spec k)
     | Const_tac t -> set_once "tactic recognizing constants" cst_tac t
     | Pre_tac t -> set_once "preprocess tactic" pre t
     | Post_tac t -> set_once "postprocess tactic" post t
-    | Setoid(sth,ext) -> set_once "setoid" set (ic sth,ic ext)
+    | Setoid(sth,ext) -> set_once "setoid" set (ic_unsafe sth,ic_unsafe ext)
     | Pow_spec(t,spec) -> set_once "power" power (t,spec)
     | Sign_spec t -> set_once "sign" sign t
     | Div_spec t -> set_once "div" div t) l;
   let k = match !kind with Some k -> k | None -> Abstract in
   (k, !set, !cst_tac, !pre, !post, !power, !sign, !div)
 
-VERNAC COMMAND EXTEND AddSetoidRing
+VERNAC COMMAND EXTEND AddSetoidRing CLASSIFIED AS SIDEFF
   | [ "Add" "Ring" ident(id) ":" constr(t) ring_mods(l) ] ->
     [ let (k,set,cst,pre,post,power,sign, div) = process_ring_mods l in
       add_theory id (ic t) set k cst (pre,post) power sign div]
+  | [ "Print" "Rings" ] => [Vernac_classifier.classify_as_query] -> [
+    msg_notice (strbrk "The following ring structures have been declared:");
+    Spmap.iter (fun fn fi ->
+      msg_notice (hov 2
+        (Ppconstr.pr_id (Libnames.basename fn)++spc()++
+          str"with carrier "++ pr_constr fi.ring_carrier++spc()++
+          str"and equivalence relation "++ pr_constr fi.ring_req))
+    ) !from_name ]
 END
 
 (*****************************************************************************)
@@ -799,10 +798,11 @@ let make_args_list rl t =
   | [] -> let (_,t1,t2) = dest_rel0 t in [t1;t2]
   | _ -> rl
 
-let make_term_list carrier rl =
-  List.fold_right
-    (fun x l -> lapp coq_cons [|carrier;x;l|]) rl
-    (lapp coq_nil [|carrier|])
+let make_term_list env evd carrier rl =
+  let l = List.fold_right
+    (fun x l -> plapp evd coq_cons [|carrier;x;l|]) rl
+    (plapp evd coq_nil [|carrier|])
+  in Typing.solve_evars env evd l
 
 let ltac_ring_structure e =
   let req = carg e.ring_req in
@@ -819,19 +819,24 @@ let ltac_ring_structure e =
   [req;sth;ext;morph;th;cst_tac;pow_tac;
    lemma1;lemma2;pretac;posttac]
 
-let ring_lookup (f:glob_tactic_expr) lH rl t gl =
-  let env = pf_env gl in
-  let sigma = project gl in
-  let rl = make_args_list rl t in
-  let e = find_ring_structure env sigma rl in
-  let rl = carg (make_term_list e.ring_carrier rl) in
-  let lH = carg (make_hyp_list env lH) in
-  let ring = ltac_ring_structure e in
-  ltac_apply f (ring@[lH;rl]) gl
+let ring_lookup (f:glob_tactic_expr) lH rl t =
+  Proofview.Goal.enter begin fun gl ->
+    let sigma = Proofview.Goal.sigma gl in
+    let env = Proofview.Goal.env gl in
+    try (* find_ring_strucure can raise an exception *)
+      let evdref = ref sigma in
+      let rl = make_args_list rl t in
+      let e = find_ring_structure env sigma rl in
+      let rl = carg (make_term_list env evdref e.ring_carrier rl) in
+      let lH = carg (make_hyp_list env evdref lH) in
+      let ring = ltac_ring_structure e in
+      Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (ltac_apply f (ring@[lH;rl]))
+    with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e
+  end
 
 TACTIC EXTEND ring_lookup
 | [ "ring_lookup" tactic0(f) "[" constr_list(lH) "]" ne_constr_list(lrt) ] ->
-    [ let (t,lr) = list_sep_last lrt in ring_lookup f lH lr t]
+    [ let (t,lr) = List.sep_last lrt in ring_lookup f lH lr t]
 END
 
 
@@ -839,10 +844,10 @@ END
 (***********************************************************************)
 
 let new_field_path =
-  make_dirpath (List.map id_of_string ["Field_tac";plugin_dir;"Coq"])
+  DirPath.make (List.map Id.of_string ["Field_tac";plugin_dir;"Coq"])
 
 let field_ltac s =
-  lazy(make_kn (MPfile new_field_path) (make_dirpath []) (mk_label s))
+  lazy(make_kn (MPfile new_field_path) DirPath.empty (Label.make s))
 
 
 let _ = add_map "field"
@@ -851,9 +856,9 @@ let _ = add_map "field"
     coq_nil, (function -1->Eval|_ -> Prot);
     (* display_linear: evaluate polynomials and coef operations, protect
        field operations and make recursive call on the var map *)
-    my_constant "display_linear",
+    my_reference "display_linear",
       (function -1|9|10|11|12|13|15|16->Eval|14->Rec|_->Prot);
-    my_constant "display_pow_linear",
+    my_reference "display_pow_linear",
      (function -1|9|10|11|12|13|14|16|18|19->Eval|17->Rec|_->Prot);
    (* Pphi_dev: evaluate polynomial and coef operations, protect
        ring operations and make recursive call on the var map *)
@@ -865,16 +870,16 @@ let _ = add_map "field"
     pol_cst "PEeval", (function -1|7|9|12->Eval|11->Rec|_->Prot);
     (* FEeval: evaluate morphism, protect field
        operations and make recursive call on the var map *)
-    my_constant "FEeval", (function -1|8|9|10|11|14->Eval|13->Rec|_->Prot)]);;
+    my_reference "FEeval", (function -1|8|9|10|11|14->Eval|13->Rec|_->Prot)]);;
 
 let _ = add_map "field_cond"
-  (map_with_eq
+  (map_without_eq
     [coq_cons,(function -1->Eval|2->Rec|_->Prot);
      coq_nil, (function -1->Eval|_ -> Prot);
     (* PCond: evaluate morphism and denum list, protect ring
        operations and make recursive call on the var map *)
-     my_constant "PCond", (function -1|8|10|13->Eval|12->Rec|_->Prot)]);;
-(*                       (function -1|8|10->Eval|9->Rec|_->Prot)]);;*)
+     my_reference "PCond", (function -1|9|11|14->Eval|13->Rec|_->Prot)]);;
+(*                       (function -1|9|11->Eval|10->Rec|_->Prot)]);;*)
 
 
 let _ = Redexpr.declare_reduction "simpl_field_expr"
@@ -882,29 +887,29 @@ let _ = Redexpr.declare_reduction "simpl_field_expr"
 
 
 
-let afield_theory = my_constant "almost_field_theory"
-let field_theory = my_constant "field_theory"
-let sfield_theory = my_constant "semi_field_theory"
-let af_ar = my_constant"AF_AR"
-let f_r = my_constant"F_R"
-let sf_sr = my_constant"SF_SR"
-let dest_field env sigma th_spec =
-  let th_typ = Retyping.get_type_of env sigma th_spec in
+let afield_theory = my_reference "almost_field_theory"
+let field_theory = my_reference "field_theory"
+let sfield_theory = my_reference "semi_field_theory"
+let af_ar = my_reference"AF_AR"
+let f_r = my_reference"F_R"
+let sf_sr = my_reference"SF_SR"
+let dest_field env evd th_spec =
+  let th_typ = Retyping.get_type_of env !evd th_spec in
   match kind_of_term th_typ with
     | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|])
-        when eq_constr f (Lazy.force afield_theory) ->
-        let rth = lapp af_ar
+        when is_global (Lazy.force afield_theory) f ->
+        let rth = plapp evd af_ar
           [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in
         (None,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth)
     | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|])
-        when eq_constr f (Lazy.force field_theory) ->
+        when is_global (Lazy.force field_theory) f ->
         let rth =
-          lapp f_r
+          plapp evd f_r
             [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in
         (Some false,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth)
     | App(f,[|r;zero;one;add;mul;div;inv;req|])
-        when eq_constr f (Lazy.force sfield_theory) ->
-        let rth = lapp sf_sr
+        when is_global (Lazy.force sfield_theory) f ->
+        let rth = plapp evd sf_sr
           [|r;zero;one;add;mul;div;inv;req;th_spec|] in
         (Some true,r,zero,one,add,mul,None,None,div,inv,req,rth)
     | _ -> error "bad field structure"
@@ -922,13 +927,10 @@ type field_info =
       field_pre_tac : glob_tactic_expr;
       field_post_tac : glob_tactic_expr }
 
-let field_from_carrier = ref Cmap.empty
-let field_from_relation = ref Cmap.empty
-let field_from_name = ref Spmap.empty
-
+let field_from_carrier = Summary.ref Cmap.empty ~name:"field-tac-carrier-table"
+let field_from_name = Summary.ref Spmap.empty ~name:"field-tac-name-table"
 
 let field_for_carrier r = Cmap.find r !field_from_carrier
-let field_for_relation rel = Cmap.find rel !field_from_relation
 
 let find_field_structure env sigma l =
   check_required_library (cdir@["Field_tac"]);
@@ -948,35 +950,9 @@ let find_field_structure env sigma l =
             (str"cannot find a declared field structure over"++
              spc()++str"\""++pr_constr ty++str"\""))
     | [] -> assert false
-(*        let (req,_,_) = dest_rel cl in
-        (try field_for_relation req
-        with Not_found ->
-          errorlabstrm "field"
-            (str"cannot find a declared field structure for equality"++
-             spc()++str"\""++pr_constr req++str"\"")) *)
-
-let _ =
-  Summary.declare_summary "tactic-new-field-table"
-    { Summary.freeze_function =
-        (fun () -> !field_from_carrier,!field_from_relation,!field_from_name);
-      Summary.unfreeze_function =
-        (fun (ct,rt,nt) ->
-          field_from_carrier := ct; field_from_relation := rt;
-          field_from_name := nt);
-      Summary.init_function =
-        (fun () ->
-          field_from_carrier := Cmap.empty; field_from_relation := Cmap.empty;
-          field_from_name := Spmap.empty) }
 
 let add_field_entry (sp,_kn) e =
-(*
-  let _ = ty e.field_ok in
-  let _ = ty e.field_simpl_eq_ok in
-  let _ = ty e.field_simpl_ok in
-  let _ = ty e.field_cond in
-*)
   field_from_carrier := Cmap.add e.field_carrier e !field_from_carrier;
-  field_from_relation := Cmap.add e.field_req e !field_from_relation;
   field_from_name := Spmap.add sp e !field_from_name
 
 let subst_th (subst,th) =
@@ -987,10 +963,10 @@ let subst_th (subst,th) =
   let thm3' = subst_mps subst th.field_simpl_ok in
   let thm4' = subst_mps subst th.field_simpl_eq_in_ok in
   let thm5' = subst_mps subst th.field_cond in
-  let tac'= subst_tactic subst th.field_cst_tac in
-  let pow_tac' = subst_tactic subst th.field_pow_tac in
-  let pretac'= subst_tactic subst th.field_pre_tac in
-  let posttac'= subst_tactic subst th.field_post_tac in
+  let tac'= Tacsubst.subst_tactic subst th.field_cst_tac in
+  let pow_tac' = Tacsubst.subst_tactic subst th.field_pow_tac in
+  let pretac'= Tacsubst.subst_tactic subst th.field_pre_tac in
+  let posttac'= Tacsubst.subst_tactic subst th.field_post_tac in
   if c' == th.field_carrier &&
      eq' == th.field_req &&
      thm1' == th.field_ok &&
@@ -1019,17 +995,17 @@ let ftheory_to_obj : field_info -> obj =
   let cache_th (name,th) = add_field_entry name th in
   declare_object
     {(default_object "tactic-new-field-theory") with
-      open_function = (fun i o -> if i=1 then cache_th o);
+      open_function = (fun i o -> if Int.equal i 1 then cache_th o);
       cache_function = cache_th;
       subst_function = subst_th;
       classify_function = (fun x -> Substitute x) }
 
-let field_equality r inv req =
+let field_equality evd r inv req =
   match kind_of_term req with
-    | App (f, [| _ |]) when eq_constr f (Lazy.force coq_eq) ->
-        mkApp((Coqlib.build_coq_eq_data()).congr,[|r;r;inv|])
+    | App (f, [| _ |]) when eq_constr_nounivs f (Lazy.force coq_eq) ->
+        mkApp(Universes.constr_of_global (Coqlib.build_coq_eq_data()).congr,[|r;r;inv|])
     | _ ->
-	let _setoid = setoid_of_relation (Global.env ()) r req in
+	let _setoid = setoid_of_relation (Global.env ()) evd r req in
 	let signature = [Some (r,Some req)],Some(r,Some req) in
 	let inv_m, inv_m_lem =
 	  try Rewrite.default_morphism signature inv
@@ -1037,45 +1013,50 @@ let field_equality r inv req =
             error "field inverse should be declared as a morphism" in
 	  inv_m_lem
 
-let add_field_theory name fth eqth morphth cst_tac inj (pre,post) power sign odiv =
+let add_field_theory name (sigma,fth) eqth morphth cst_tac inj (pre,post) power sign odiv =
   check_required_library (cdir@["Field_tac"]);
   let env = Global.env() in
-  let sigma = Evd.empty in
+  let evd = ref sigma in
   let (kind,r,zero,one,add,mul,sub,opp,div,inv,req,rth) =
-    dest_field env sigma fth in
-  let (sth,ext) = build_setoid_params r add mul opp req eqth in
+    dest_field env evd fth in
+  let (sth,ext) = build_setoid_params env evd r add mul opp req eqth in
   let eqth = Some(sth,ext) in
-  let _ = add_theory name rth eqth morphth cst_tac (None,None) power sign odiv in
-  let (pow_tac, pspec) = interp_power env power in
-  let sspec = interp_sign env sign in
-  let dspec = interp_div env odiv in
-  let inv_m = field_equality r inv req in
+  let _ = add_theory name (!evd,rth) eqth morphth cst_tac (None,None) power sign odiv in
+  let (pow_tac, pspec) = interp_power env evd power in
+  let sspec = interp_sign env evd sign in
+  let dspec = interp_div env evd odiv in
+  let inv_m = field_equality evd r inv req in
   let rk = reflect_coeff morphth in
-  let params =
-    exec_tactic env 9 (field_ltac"field_lemmas")
+  let params,ctx =
+    exec_tactic env !evd 9 (field_ltac"field_lemmas")
       (List.map carg[sth;ext;inv_m;fth;pspec;sspec;dspec;rk]) in
-  let lemma1 = constr_of params.(3) in
-  let lemma2 = constr_of params.(4) in
-  let lemma3 = constr_of params.(5) in
-  let lemma4 = constr_of params.(6) in
+  let lemma1 = params.(3) in
+  let lemma2 = params.(4) in
+  let lemma3 = params.(5) in
+  let lemma4 = params.(6) in
   let cond_lemma =
     match inj with
-      | Some thm -> mkApp(constr_of params.(8),[|thm|])
-      | None -> constr_of params.(7) in
-  let lemma1 = decl_constant (string_of_id name^"_field_lemma1") lemma1 in
-  let lemma2 = decl_constant (string_of_id name^"_field_lemma2") lemma2 in
-  let lemma3 = decl_constant (string_of_id name^"_field_lemma3") lemma3 in
-  let lemma4 = decl_constant (string_of_id name^"_field_lemma4") lemma4 in
-  let cond_lemma = decl_constant (string_of_id name^"_lemma5") cond_lemma in
+      | Some thm -> mkApp(params.(8),[|thm|])
+      | None -> params.(7) in
+  let lemma1 = decl_constant (Id.to_string name^"_field_lemma1")
+    ctx lemma1 in
+  let lemma2 = decl_constant (Id.to_string name^"_field_lemma2") 
+    ctx lemma2 in
+  let lemma3 = decl_constant (Id.to_string name^"_field_lemma3") 
+    ctx lemma3 in
+  let lemma4 = decl_constant (Id.to_string name^"_field_lemma4") 
+    ctx lemma4 in
+  let cond_lemma = decl_constant (Id.to_string name^"_lemma5") 
+    ctx cond_lemma in
   let cst_tac =
     interp_cst_tac env sigma morphth kind (zero,one,add,mul,opp) cst_tac in
   let pretac =
     match pre with
-        Some t -> Tacinterp.glob_tactic t
+        Some t -> Tacintern.glob_tactic t
       | _ -> TacId [] in
   let posttac =
     match post with
-        Some t -> Tacinterp.glob_tactic t
+        Some t -> Tacintern.glob_tactic t
       | _ -> TacId [] in
   let _ =
     Lib.add_leaf name
@@ -1092,9 +1073,9 @@ let add_field_theory name fth eqth morphth cst_tac inj (pre,post) power sign odi
           field_pre_tac = pretac;
           field_post_tac = posttac }) in  ()
 
-type field_mod =
-    Ring_mod of ring_mod
-  | Inject of Topconstr.constr_expr
+type 'constr field_mod =
+    Ring_mod of 'constr ring_mod
+  | Inject of Constrexpr.constr_expr
 
 VERNAC ARGUMENT EXTEND field_mod
   | [ ring_mod(m) ] -> [ Ring_mod m ]
@@ -1112,23 +1093,31 @@ let process_field_mods l =
   let power = ref None in
   let div = ref None in
   List.iter(function
-      Ring_mod(Ring_kind k) -> set_once "field kind" kind k
+      Ring_mod(Ring_kind k) -> set_once "field kind" kind (ic_coeff_spec k)
     | Ring_mod(Const_tac t) ->
         set_once "tactic recognizing constants" cst_tac t
     | Ring_mod(Pre_tac t) -> set_once "preprocess tactic" pre t
     | Ring_mod(Post_tac t) -> set_once "postprocess tactic" post t
-    | Ring_mod(Setoid(sth,ext)) -> set_once "setoid" set (ic sth,ic ext)
+    | Ring_mod(Setoid(sth,ext)) -> set_once "setoid" set (ic_unsafe sth,ic_unsafe ext)
     | Ring_mod(Pow_spec(t,spec)) -> set_once "power" power (t,spec)
     | Ring_mod(Sign_spec t) -> set_once "sign" sign t
     | Ring_mod(Div_spec t) -> set_once "div" div t
-    | Inject i -> set_once "infinite property" inj (ic i)) l;
+    | Inject i -> set_once "infinite property" inj (ic_unsafe i)) l;
   let k = match !kind with Some k -> k | None -> Abstract in
   (k, !set, !inj, !cst_tac, !pre, !post, !power, !sign, !div)
 
-VERNAC COMMAND EXTEND AddSetoidField
+VERNAC COMMAND EXTEND AddSetoidField CLASSIFIED AS SIDEFF
 | [ "Add" "Field" ident(id) ":" constr(t) field_mods(l) ] ->
   [ let (k,set,inj,cst_tac,pre,post,power,sign,div) = process_field_mods l in
     add_field_theory id (ic t) set k cst_tac inj (pre,post) power sign div]
+| [ "Print" "Fields" ] => [Vernac_classifier.classify_as_query] -> [
+    msg_notice (strbrk "The following field structures have been declared:");
+    Spmap.iter (fun fn fi ->
+      msg_notice (hov 2
+        (Ppconstr.pr_id (Libnames.basename fn)++spc()++
+          str"with carrier "++ pr_constr fi.field_carrier++spc()++
+          str"and equivalence relation "++ pr_constr fi.field_req))
+    ) !field_from_name ]
 END
 
 
@@ -1146,18 +1135,23 @@ let ltac_field_structure e =
   [req;cst_tac;pow_tac;field_ok;field_simpl_ok;field_simpl_eq_ok;
    field_simpl_eq_in_ok;cond_ok;pretac;posttac]
 
-let field_lookup (f:glob_tactic_expr) lH rl t gl =
-  let env = pf_env gl in
-  let sigma = project gl in
-  let rl = make_args_list rl t in
-  let e = find_field_structure env sigma rl in
-  let rl = carg (make_term_list e.field_carrier rl) in
-  let lH = carg (make_hyp_list env lH) in
-  let field = ltac_field_structure e in
-  ltac_apply f (field@[lH;rl]) gl
+let field_lookup (f:glob_tactic_expr) lH rl t =
+  Proofview.Goal.enter begin fun gl ->
+    let sigma = Proofview.Goal.sigma gl in
+    let env = Proofview.Goal.env gl in
+    try
+      let evdref = ref sigma in
+      let rl = make_args_list rl t in
+      let e = find_field_structure env sigma rl in
+      let rl = carg (make_term_list env evdref e.field_carrier rl) in
+      let lH = carg (make_hyp_list env evdref lH) in
+      let field = ltac_field_structure e in
+      Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (ltac_apply f (field@[lH;rl]))
+    with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e
+  end
 
 
 TACTIC EXTEND field_lookup
 | [ "field_lookup" tactic(f) "[" constr_list(lH) "]" ne_constr_list(lt) ] ->
-      [ let (t,l) = list_sep_last lt in field_lookup f lH l t ]
+      [ let (t,l) = List.sep_last lt in field_lookup f lH l t ]
 END
diff --git a/plugins/setoid_ring/vo.itarget b/plugins/setoid_ring/vo.itarget
index 580df9b5..595ba55e 100644
--- a/plugins/setoid_ring/vo.itarget
+++ b/plugins/setoid_ring/vo.itarget
@@ -7,7 +7,6 @@ InitialRing.vo
 NArithRing.vo
 RealField.vo
 Ring_base.vo
-Ring_equiv.vo
 Ring_polynom.vo
 Ring_tac.vo
 Ring_theory.vo
diff --git a/plugins/subtac/eterm.ml b/plugins/subtac/eterm.ml
deleted file mode 100644
index f4d8b769..00000000
--- a/plugins/subtac/eterm.ml
+++ /dev/null
@@ -1,259 +0,0 @@
-(**
-   - Get types of existentials ;
-   - Flatten dependency tree (prefix order) ;
-   - Replace existentials by De Bruijn indices in term, applied to the right arguments ;
-   - Apply term prefixed by quantification on "existentials".
-*)
-
-open Term
-open Sign
-open Names
-open Evd
-open List
-open Pp
-open Util
-open Subtac_utils
-open Proof_type
-
-let trace s =
-  if !Flags.debug then (msgnl s; msgerr s)
-  else ()
-
-let succfix (depth, fixrels) =
-  (succ depth, List.map succ fixrels)
-
-type oblinfo =
-  { ev_name: int * identifier;
-    ev_hyps: named_context;
-    ev_status: obligation_definition_status;
-    ev_chop: int option;
-    ev_src: hole_kind located;
-    ev_typ: types;
-    ev_tac: tactic option;
-    ev_deps: Intset.t }
-
-(* spiwack: Store field for internalizing ev_tac in evar_infos' evar_extra. *)
-open Store.Field
-let evar_tactic = Store.field ()
-
-(** Substitute evar references in t using De Bruijn indices,
-  where n binders were passed through. *)
-
-let subst_evar_constr evs n idf t = 
-  let seen = ref Intset.empty in
-  let transparent = ref Idset.empty in
-  let evar_info id = List.assoc id evs in
-  let rec substrec (depth, fixrels) c = match kind_of_term c with
-    | Evar (k, args) ->
-	let { ev_name = (id, idstr) ;
-	      ev_hyps = hyps ; ev_chop = chop } =
-	  try evar_info k
-	  with Not_found ->
-	    anomaly ("eterm: existential variable " ^ string_of_int k ^ " not found")
-	in
-        seen := Intset.add id !seen;
-	  (* Evar arguments are created in inverse order,
-	     and we must not apply to defined ones (i.e. LetIn's)
-	  *)
-	let args =
-	  let n = match chop with None -> 0 | Some c -> c in
-	  let (l, r) = list_chop n (List.rev (Array.to_list args)) in
-	    List.rev r
-	in
-	let args =
-	  let rec aux hyps args acc =
-	     match hyps, args with
-		 ((_, None, _) :: tlh), (c :: tla) ->
-		   aux tlh tla ((substrec (depth, fixrels) c) :: acc)
-	       | ((_, Some _, _) :: tlh), (_ :: tla) ->
-		   aux tlh tla acc
-	       | [], [] -> acc
-	       | _, _ -> acc (*failwith "subst_evars: invalid argument"*)
-	  in aux hyps args []
-	in
-	  if List.exists (fun x -> match kind_of_term x with Rel n -> List.mem n fixrels | _ -> false) args then
-	    transparent := Idset.add idstr !transparent;
-	  mkApp (idf idstr, Array.of_list args)
-    | Fix _ ->
-	map_constr_with_binders succfix substrec (depth, 1 :: fixrels) c
-    | _ -> map_constr_with_binders succfix substrec (depth, fixrels) c
-  in
-  let t' = substrec (0, []) t in
-    t', !seen, !transparent
-
-
-(** Substitute variable references in t using De Bruijn indices,
-  where n binders were passed through. *)
-let subst_vars acc n t =
-  let var_index id = Util.list_index id acc in
-  let rec substrec depth c = match kind_of_term c with
-    | Var v -> (try mkRel (depth + (var_index v)) with Not_found -> c)
-    | _ -> map_constr_with_binders succ substrec depth c
-  in
-    substrec 0 t
-
-(** Rewrite type of an evar ([ H1 : t1, ... Hn : tn |- concl ])
-    to a product : forall H1 : t1, ..., forall Hn : tn, concl.
-    Changes evars and hypothesis references to variable references.
-*)
-let etype_of_evar evs hyps concl =
-  let rec aux acc n = function
-      (id, copt, t) :: tl ->
-	let t', s, trans = subst_evar_constr evs n mkVar t in
-	let t'' = subst_vars acc 0 t' in
-	let rest, s', trans' = aux (id :: acc) (succ n) tl in
-	let s' = Intset.union s s' in
-	let trans' = Idset.union trans trans' in
-	  (match copt with
-	      Some c -> 
-		let c', s'', trans'' = subst_evar_constr evs n mkVar c in
-		let c' = subst_vars acc 0 c' in
-		  mkNamedProd_or_LetIn (id, Some c', t'') rest,
-		Intset.union s'' s',
-		Idset.union trans'' trans'
-	    | None ->
-		mkNamedProd_or_LetIn (id, None, t'') rest, s', trans')
-    | [] ->
-	let t', s, trans = subst_evar_constr evs n mkVar concl in
-	  subst_vars acc 0 t', s, trans
-  in aux [] 0 (rev hyps)
-
-
-open Tacticals
-
-let trunc_named_context n ctx =
-  let len = List.length ctx in
-    list_firstn (len - n) ctx
-
-let rec chop_product n t =
-  if n = 0 then Some t
-  else
-    match kind_of_term t with
-      | Prod (_, _, b) ->  if noccurn 1 b then chop_product (pred n) (Termops.pop b) else None
-      | _ -> None
-
-let evars_of_evar_info evi =
-  Intset.union (Evarutil.evars_of_term evi.evar_concl)
-    (Intset.union
-	(match evi.evar_body with
-	| Evar_empty -> Intset.empty
-	| Evar_defined b -> Evarutil.evars_of_term b)
-	(Evarutil.evars_of_named_context (evar_filtered_context evi)))
-
-let evar_dependencies evm oev =
-  let one_step deps =
-    Intset.fold (fun ev s ->
-      let evi = Evd.find evm ev in
-      let deps' = evars_of_evar_info evi in
-	if Intset.mem oev deps' then
-	  raise (Invalid_argument ("Ill-formed evar map: cycle detected for evar " ^ string_of_int oev))
-	else Intset.union deps' s)
-      deps deps
-  in
-  let rec aux deps =
-    let deps' = one_step deps in
-      if Intset.equal deps deps' then deps
-      else aux deps'
-  in aux (Intset.singleton oev)
-      
-let move_after (id, ev, deps as obl) l = 
-  let rec aux restdeps = function
-    | (id', _, _) as obl' :: tl -> 
-	let restdeps' = Intset.remove id' restdeps in
-	  if Intset.is_empty restdeps' then
-	    obl' :: obl :: tl
-	  else obl' :: aux restdeps' tl
-    | [] -> [obl]
-  in aux (Intset.remove id deps) l
-    
-let sort_dependencies evl =
-  let rec aux l found list =
-    match l with
-    | (id, ev, deps) as obl :: tl ->
-	let found' = Intset.union found (Intset.singleton id) in
-	  if Intset.subset deps found' then
-	    aux tl found' (obl :: list)
-	  else aux (move_after obl tl) found list
-    | [] -> List.rev list
-  in aux evl Intset.empty []
-
-let map_evar_body f = function
-  | Evar_empty -> Evar_empty
-  | Evar_defined c -> Evar_defined (f c)
-
-open Environ
-      
-let map_evar_info f evi =
-  { evi with evar_hyps = val_of_named_context (map_named_context f (named_context_of_val evi.evar_hyps));
-    evar_concl = f evi.evar_concl;
-    evar_body = map_evar_body f evi.evar_body }
-    
-let eterm_obligations env name isevars evm fs ?status t ty = 
-  (* 'Serialize' the evars *)
-  let nc = Environ.named_context env in
-  let nc_len = Sign.named_context_length nc in
-  let evl = List.rev (to_list evm) in
-  let evl = List.map (fun (id, ev) -> (id, ev, evar_dependencies evm id)) evl in
-  let sevl = sort_dependencies evl in
-  let evl = List.map (fun (id, ev, _) -> id, ev) sevl in
-  let evn =
-    let i = ref (-1) in
-      List.rev_map (fun (id, ev) -> incr i;
-		      (id, (!i, id_of_string
-			      (string_of_id name ^ "_obligation_" ^ string_of_int (succ !i))),
-		       ev)) evl
-  in
-  let evts =
-    (* Remove existential variables in types and build the corresponding products *)
-    fold_right
-      (fun (id, (n, nstr), ev) l ->
-	 let hyps = Evd.evar_filtered_context ev in
-	 let hyps = trunc_named_context nc_len hyps in
-	 let evtyp, deps, transp = etype_of_evar l hyps ev.evar_concl in
-	 let evtyp, hyps, chop =
-	   match chop_product fs evtyp with
-	   | Some t -> t, trunc_named_context fs hyps, fs
-	   | None -> evtyp, hyps, 0
-	 in
-	 let loc, k = evar_source id isevars in
-	 let status = match k with QuestionMark o -> Some o | _ -> status in
-	 let status, chop = match status with
-	   | Some (Define true as stat) ->
-	       if chop <> fs then Define false, None
-	       else stat, Some chop
-	   | Some s -> s, None
-	   | None -> Define true, None
-	 in
-	 let tac = match evar_tactic.get ev.evar_extra with
-	   | Some t ->
-	       if Dyn.tag t = "tactic" then
-		 Some (Tacinterp.interp 
-			  (Tacinterp.globTacticIn (Tacinterp.tactic_out t)))
-	       else None
-	   | None -> None
-	 in
-	 let info = { ev_name = (n, nstr);
-		      ev_hyps = hyps; ev_status = status; ev_chop = chop;
-		      ev_src = loc, k; ev_typ = evtyp ; ev_deps = deps; ev_tac = tac }
-	 in (id, info) :: l)
-      evn []
-  in
-  let t', _, transparent = (* Substitute evar refs in the term by variables *)
-    subst_evar_constr evts 0 mkVar t 
-  in
-  let ty, _, _ = subst_evar_constr evts 0 mkVar ty in
-  let evars = 
-    List.map (fun (ev, info) ->
-      let { ev_name = (_, name); ev_status = status;
-	    ev_src = src; ev_typ = typ; ev_deps = deps; ev_tac = tac } = info
-      in
-      let status = match status with
-	| Define true when Idset.mem name transparent -> Define false
-	| _ -> status
-      in name, typ, src, status, deps, tac) evts
-  in
-  let evnames = List.map (fun (ev, info) -> ev, snd info.ev_name) evts in
-  let evmap f c = pi1 (subst_evar_constr evts 0 f c) in
-    Array.of_list (List.rev evars), (evnames, evmap), t', ty
-
-let mkMetas n = list_tabulate (fun _ -> Evarutil.mk_new_meta ()) n
diff --git a/plugins/subtac/eterm.mli b/plugins/subtac/eterm.mli
deleted file mode 100644
index 35744b71..00000000
--- a/plugins/subtac/eterm.mli
+++ /dev/null
@@ -1,33 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Environ
-open Tacmach
-open Term
-open Evd
-open Names
-open Util
-open Tacinterp
-
-val mkMetas : int -> constr list
-
-val evar_dependencies : evar_map -> int -> Intset.t
-val sort_dependencies : (int * evar_info * Intset.t) list -> (int * evar_info * Intset.t) list
-
-(* env, id, evars, number of function prototypes to try to clear from
-   evars contexts, object and type *)
-val eterm_obligations : env -> identifier -> evar_map -> evar_map -> int ->
-  ?status:obligation_definition_status -> constr -> types -> 
-  (identifier * types * hole_kind located * obligation_definition_status * Intset.t * 
-      tactic option) array
-    (* Existential key, obl. name, type as product, location of the original evar, associated tactic,
-       status and dependencies as indexes into the array *)
-  * ((existential_key * identifier) list * ((identifier -> constr) -> constr -> constr)) * constr * types
-    (* Translations from existential identifiers to obligation identifiers 
-       and for terms with existentials to closed terms, given a 
-       translation from obligation identifiers to constrs, new term, new type *)
diff --git a/plugins/subtac/g_subtac.ml4 b/plugins/subtac/g_subtac.ml4
deleted file mode 100644
index c89d135f..00000000
--- a/plugins/subtac/g_subtac.ml4
+++ /dev/null
@@ -1,167 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(*i camlp4deps: "parsing/grammar.cma" i*)
-
-(*
-  Syntax for the subtac terms and types.
-  Elaborated from correctness/psyntax.ml4 by Jean-Christophe Filliâtre *)
-
-
-open Flags
-open Util
-open Names
-open Nameops
-open Vernacentries
-open Reduction
-open Term
-open Libnames
-open Topconstr
-
-(* We define new entries for programs, with the use of this module
- * Subtac. These entries are named Subtac.<foo>
- *)
-
-module Gram = Pcoq.Gram
-module Vernac = Pcoq.Vernac_
-module Tactic = Pcoq.Tactic
-
-module SubtacGram =
-struct
-  let gec s = Gram.entry_create ("Subtac."^s)
-		(* types *)
-  let subtac_gallina_loc : Vernacexpr.vernac_expr located Gram.entry = gec "subtac_gallina_loc"
-
-  let subtac_withtac : Tacexpr.raw_tactic_expr option Gram.entry = gec "subtac_withtac"
-end
-
-open Glob_term
-open SubtacGram
-open Util
-open Pcoq
-open Prim
-open Constr
-let sigref = mkRefC (Qualid (dummy_loc, Libnames.qualid_of_string "Coq.Init.Specif.sig"))
-
-GEXTEND Gram
-  GLOBAL: subtac_gallina_loc typeclass_constraint subtac_withtac;
-
-  subtac_gallina_loc:
-    [ [ g = Vernac.gallina -> loc, g
-    | g = Vernac.gallina_ext -> loc, g ] ]
-    ;
-
-  subtac_withtac:
-    [ [ "with"; t = Tactic.tactic -> Some t
-      | -> None ] ]
-  ;
-
-  Constr.closed_binder:
-    [[ "("; id=Prim.name; ":"; t=Constr.lconstr; "|"; c=Constr.lconstr; ")" ->
-	  let typ = mkAppC (sigref, [mkLambdaC ([id], default_binder_kind, t, c)]) in
-          [LocalRawAssum ([id], default_binder_kind, typ)]
-    ] ];
-
-  END
-
-
-type 'a gallina_loc_argtype = (Vernacexpr.vernac_expr located, 'a) Genarg.abstract_argument_type
-
-let (wit_subtac_gallina_loc : Genarg.tlevel gallina_loc_argtype),
-  (globwit_subtac_gallina_loc : Genarg.glevel gallina_loc_argtype),
-  (rawwit_subtac_gallina_loc : Genarg.rlevel gallina_loc_argtype) =
-  Genarg.create_arg None "subtac_gallina_loc"
-
-type 'a withtac_argtype = (Tacexpr.raw_tactic_expr option, 'a) Genarg.abstract_argument_type
-
-let (wit_subtac_withtac : Genarg.tlevel withtac_argtype),
-  (globwit_subtac_withtac : Genarg.glevel withtac_argtype),
-  (rawwit_subtac_withtac : Genarg.rlevel withtac_argtype) =
-  Genarg.create_arg None "subtac_withtac"
-
-VERNAC COMMAND EXTEND Subtac
-[ "Program" subtac_gallina_loc(g) ] -> [ Subtac.subtac g ]
-  END
-
-let try_catch_exn f e =
-  try f e
-  with exn when Errors.noncritical exn ->
-    errorlabstrm "Program" (Errors.print exn)
-
-let subtac_obligation e = try_catch_exn Subtac_obligations.subtac_obligation e
-let next_obligation e = try_catch_exn Subtac_obligations.next_obligation e
-let try_solve_obligation e = try_catch_exn Subtac_obligations.try_solve_obligation e
-let try_solve_obligations e = try_catch_exn Subtac_obligations.try_solve_obligations e
-let solve_all_obligations e = try_catch_exn Subtac_obligations.solve_all_obligations e
-let admit_obligations e = try_catch_exn Subtac_obligations.admit_obligations e
-
-VERNAC COMMAND EXTEND Subtac_Obligations
-| [ "Obligation" integer(num) "of" ident(name) ":" lconstr(t) subtac_withtac(tac) ] -> 
-    [ subtac_obligation (num, Some name, Some t) tac ]
-| [ "Obligation" integer(num) "of" ident(name) subtac_withtac(tac) ] -> 
-    [ subtac_obligation (num, Some name, None) tac ]
-| [ "Obligation" integer(num) ":" lconstr(t) subtac_withtac(tac) ] -> 
-    [ subtac_obligation (num, None, Some t) tac ]
-| [ "Obligation" integer(num) subtac_withtac(tac) ] -> 
-    [ subtac_obligation (num, None, None) tac ]
-| [ "Next" "Obligation" "of" ident(name) subtac_withtac(tac) ] -> 
-    [ next_obligation (Some name) tac ]
-| [ "Next" "Obligation" subtac_withtac(tac) ] -> [ next_obligation None tac ]
-END
-
-VERNAC COMMAND EXTEND Subtac_Solve_Obligation
-| [ "Solve" "Obligation" integer(num) "of" ident(name) "using" tactic(t) ] ->
-    [ try_solve_obligation num (Some name) (Some (Tacinterp.interp t)) ]
-| [ "Solve" "Obligation" integer(num) "using" tactic(t) ] ->
-    [ try_solve_obligation num None (Some (Tacinterp.interp t)) ]
-      END
-
-VERNAC COMMAND EXTEND Subtac_Solve_Obligations
-| [ "Solve" "Obligations" "of" ident(name) "using" tactic(t) ] ->
-    [ try_solve_obligations (Some name) (Some (Tacinterp.interp t)) ]
-| [ "Solve" "Obligations" "using" tactic(t) ] ->
-    [ try_solve_obligations None (Some (Tacinterp.interp t)) ]
-| [ "Solve" "Obligations" ] ->
-    [ try_solve_obligations None None ]
-      END
-
-VERNAC COMMAND EXTEND Subtac_Solve_All_Obligations
-| [ "Solve" "All" "Obligations" "using" tactic(t) ] ->
-    [ solve_all_obligations (Some (Tacinterp.interp t)) ]
-| [ "Solve" "All" "Obligations" ] ->
-    [ solve_all_obligations None ]
-      END
-
-VERNAC COMMAND EXTEND Subtac_Admit_Obligations
-| [ "Admit" "Obligations" "of" ident(name) ] -> [ admit_obligations (Some name) ]
-| [ "Admit" "Obligations" ] -> [ admit_obligations None ]
-    END
-
-VERNAC COMMAND EXTEND Subtac_Set_Solver
-| [ "Obligation" "Tactic" ":=" tactic(t) ] -> [
-    Subtac_obligations.set_default_tactic 
-      (Vernacexpr.use_section_locality ())
-      (Tacinterp.glob_tactic t) ]
-END
-
-open Pp
-
-VERNAC COMMAND EXTEND Subtac_Show_Solver
-| [ "Show" "Obligation" "Tactic" ] -> [
-    msgnl (str"Program obligation tactic is " ++ Subtac_obligations.print_default_tactic ()) ]
-END
-
-VERNAC COMMAND EXTEND Subtac_Show_Obligations
-| [ "Obligations" "of" ident(name) ] -> [ Subtac_obligations.show_obligations (Some name) ]
-| [ "Obligations" ] -> [ Subtac_obligations.show_obligations None ]
-END
-
-VERNAC COMMAND EXTEND Subtac_Show_Preterm
-| [ "Preterm" "of" ident(name) ] -> [ Subtac_obligations.show_term (Some name) ]
-| [ "Preterm" ] -> [ Subtac_obligations.show_term None ]
-END
diff --git a/plugins/subtac/subtac.ml b/plugins/subtac/subtac.ml
deleted file mode 100644
index 89d9050c..00000000
--- a/plugins/subtac/subtac.ml
+++ /dev/null
@@ -1,226 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Compat
-open Global
-open Pp
-open Util
-open Names
-open Sign
-open Evd
-open Term
-open Termops
-open Namegen
-open Reductionops
-open Environ
-open Type_errors
-open Typeops
-open Libnames
-open Classops
-open List
-open Recordops
-open Evarutil
-open Pretype_errors
-open Glob_term
-open Evarconv
-open Pattern
-open Vernacexpr
-
-open Subtac_coercion
-open Subtac_utils
-open Coqlib
-open Printer
-open Subtac_errors
-open Eterm
-
-let require_library dirpath =
-  let qualid = (dummy_loc, qualid_of_dirpath (dirpath_of_string dirpath)) in
-    Library.require_library [qualid] None
-
-open Pp
-open Ppconstr
-open Decl_kinds
-open Tacinterp
-open Tacexpr
-
-let solve_tccs_in_type env id isevars evm c typ =
-  if not (Evd.is_empty evm) then
-    let stmt_id = Nameops.add_suffix id "_stmt" in
-    let obls, _, c', t' = eterm_obligations env stmt_id !isevars evm 0 ~status:Expand c typ in
-      match Subtac_obligations.add_definition stmt_id ~term:c' typ obls with
-      | Subtac_obligations.Defined cst -> constant_value (Global.env()) 
-	  (match cst with ConstRef kn -> kn | _ -> assert false)
-      | _ ->
-	  errorlabstrm "start_proof"
-	    (str "The statement obligations could not be resolved automatically, " ++ spc () ++
-		str "write a statement definition first.")
-  else
-    let _ = Typeops.infer_type env c in c
-
-
-let start_proof_com env isevars sopt kind (bl,t) hook =
-  let id = match sopt with
-    | Some (loc,id) ->
-        (* We check existence here: it's a bit late at Qed time *)
-        if Nametab.exists_cci (Lib.make_path id) or is_section_variable id then
-          user_err_loc (loc,"start_proof",pr_id id ++ str " already exists");
-        id
-    | None ->
-	next_global_ident_away (id_of_string "Unnamed_thm")
- 	  (Pfedit.get_all_proof_names ())
-  in
-  let evm, c, typ, imps =
-    Subtac_pretyping.subtac_process ~is_type:true env isevars id [] (Topconstr.prod_constr_expr t bl) None
-  in
-  let c = solve_tccs_in_type env id isevars evm c typ in
-    Lemmas.start_proof id kind c (fun loc gr ->
-      Impargs.declare_manual_implicits (loc = Local) gr ~enriching:true [imps];
-      hook loc gr)
-
-let start_proof_and_print env isevars idopt k t hook =
-  start_proof_com env isevars idopt k t hook;
-  Vernacentries.print_subgoals ()
-
-let _ = Detyping.set_detype_anonymous (fun loc n -> GVar (loc, id_of_string ("Anonymous_REL_" ^ string_of_int n)))
-
-let assumption_message id =
-  Flags.if_verbose message ((string_of_id id) ^ " is assumed")
-
-let declare_assumptions env isevars idl is_coe k bl c nl =
-  if not (Pfedit.refining ()) then
-    let id = snd (List.hd idl) in
-    let evm, c, typ, imps =
-      Subtac_pretyping.subtac_process env isevars id [] (Topconstr.prod_constr_expr c bl) None
-    in
-    let c = solve_tccs_in_type env id isevars evm c typ in
-      List.iter (Command.declare_assumption is_coe k c imps false nl) idl
-  else
-    errorlabstrm "Command.Assumption"
-	(str "Cannot declare an assumption while in proof editing mode.")
-
-let dump_constraint ty ((loc, n), _, _) =
-  match n with
-    | Name id -> Dumpglob.dump_definition (loc, id) false ty
-    | Anonymous -> ()
-
-let dump_variable lid = ()
-
-let vernac_assumption env isevars kind l nl =
-  let global = fst kind = Global in
-    List.iter (fun (is_coe,(idl,c)) ->
-      if Dumpglob.dump () then
-	List.iter (fun lid ->
-	  if global then Dumpglob.dump_definition lid (not global) "ax"
-	  else dump_variable lid) idl;
-      declare_assumptions env isevars idl is_coe kind [] c nl) l
-
-let check_fresh (loc,id) =
-  if Nametab.exists_cci (Lib.make_path id) or is_section_variable id then
-    user_err_loc (loc,"",pr_id id ++ str " already exists")
-
-let subtac (loc, command) =
-  check_required_library ["Coq";"Init";"Datatypes"];
-  check_required_library ["Coq";"Init";"Specif"];
-  let env = Global.env () in
-  let isevars = ref (create_evar_defs Evd.empty) in
-  try
-  match command with
-  | VernacDefinition (defkind, (_, id as lid), expr, hook) ->
-      check_fresh lid;
-      Dumpglob.dump_definition lid false "def";
-      (match expr with
-      | ProveBody (bl, t) ->
-	  start_proof_and_print env isevars (Some lid) (Global, DefinitionBody Definition) (bl,t)
-	    (fun _ _ -> ())
-      | DefineBody (bl, _, c, tycon) ->
-	  ignore(Subtac_pretyping.subtac_proof defkind hook env isevars id bl c tycon))
-  | VernacFixpoint l ->
-      List.iter (fun ((lid, _, _, _, _), _) ->
-	check_fresh lid;
-	Dumpglob.dump_definition lid false "fix") l;
-      let _ = trace (str "Building fixpoint") in
-	ignore(Subtac_command.build_recursive l)
-
-  | VernacStartTheoremProof (thkind, [Some id, (bl,t,guard)], lettop, hook) ->
-      if guard <> None then 
-        error "Do not support building theorems as a fixpoint.";
-      Dumpglob.dump_definition id false "prf";
-      if not(Pfedit.refining ()) then
-	if lettop then
-	  errorlabstrm "Subtac_command.StartProof"
-	    (str "Let declarations can only be used in proof editing mode");
-      if Lib.is_modtype () then
-	errorlabstrm "Subtac_command.StartProof"
-	  (str "Proof editing mode not supported in module types");
-      check_fresh id;
-      start_proof_and_print env isevars (Some id) (Global, Proof thkind) (bl,t) hook
-
-  | VernacAssumption (stre,nl,l) ->
-      vernac_assumption env isevars stre l nl
-
-  | VernacInstance (abst, glob, sup, is, props, pri) ->
-      dump_constraint "inst" is;
-      if abst then
-	error "Declare Instance not supported here.";
-      ignore(Subtac_classes.new_instance ~global:glob sup is props pri)
-
-  | VernacCoFixpoint l ->
-      if Dumpglob.dump () then
-	List.iter (fun ((lid, _, _, _), _) -> Dumpglob.dump_definition lid false "cofix") l;
-      ignore(Subtac_command.build_corecursive l)
-
-  (*| VernacEndProof e ->
-    subtac_end_proof e*)
-
-  | _ -> user_err_loc (loc,"", str ("Invalid Program command"))
-  with
-  | Typing_error e ->
-      msg_warning (str "Type error in Program tactic:");
-      let cmds =
-	(match e with
-	| NonFunctionalApp (loc, x, mux, e) ->
-	    str "non functional application of term " ++
-	      e ++ str " to function " ++ x ++ str " of (mu) type " ++ mux
-	| NonSigma (loc, t) ->
-	    str "Term is not of Sigma type: " ++ t
-	| NonConvertible (loc, x, y) ->
-	    str "Unconvertible terms:" ++ spc () ++
-	      x ++ spc () ++ str "and" ++ spc () ++ y
-	| IllSorted (loc, t) ->
-	    str "Term is ill-sorted:" ++ spc () ++ t
-	)
-      in msg_warning cmds
-
-  | Subtyping_error e ->
-      msg_warning (str "(Program tactic) Subtyping error:");
-      let cmds =
-	match e with
-	| UncoercibleInferType (loc, x, y) ->
-	    str "Uncoercible terms:" ++ spc ()
-	    ++ x ++ spc () ++ str "and" ++ spc () ++ y
-	| UncoercibleInferTerm (loc, x, y, tx, ty) ->
-	    str "Uncoercible terms:" ++ spc ()
-	    ++ tx ++ spc () ++ str "of" ++ spc () ++ str "type" ++ spc () ++ x
-	    ++ str "and" ++ spc() ++ ty ++ spc () ++ str "of" ++ spc () ++ str "type" ++ spc () ++ y
-	| UncoercibleRewrite (x, y) ->
-	    str "Uncoercible terms:" ++ spc ()
-	    ++ x ++ spc () ++ str "and" ++ spc () ++ y
-      in msg_warning cmds
-
-  | Cases.PatternMatchingError (env, exn) as e -> raise e
-
-  | Type_errors.TypeError (env, exn) as e -> raise e
-
-  | Pretype_errors.PretypeError (env, _, exn) as e -> raise e
-
-  | (Loc.Exc_located (loc, Proof_type.LtacLocated (_,e')) |
-     Loc.Exc_located (loc, e') as e) -> raise e
-
-  | reraise ->
-      (*       msg_warning (str "Uncaught exception: " ++ Errors.print e); *)
-      raise reraise
diff --git a/plugins/subtac/subtac.mli b/plugins/subtac/subtac.mli
deleted file mode 100644
index b51150aa..00000000
--- a/plugins/subtac/subtac.mli
+++ /dev/null
@@ -1,2 +0,0 @@
-val require_library : string -> unit
-val subtac : Util.loc * Vernacexpr.vernac_expr -> unit
diff --git a/plugins/subtac/subtac_cases.ml b/plugins/subtac/subtac_cases.ml
deleted file mode 100644
index 9ff8ba50..00000000
--- a/plugins/subtac/subtac_cases.ml
+++ /dev/null
@@ -1,2023 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Cases
-open Util
-open Names
-open Nameops
-open Term
-open Termops
-open Namegen
-open Declarations
-open Inductiveops
-open Environ
-open Sign
-open Reductionops
-open Typeops
-open Type_errors
-open Glob_term
-open Retyping
-open Pretype_errors
-open Evarutil
-open Evarconv
-open Subtac_utils
-
-(************************************************************************)
-(*            Pattern-matching compilation (Cases)                      *)
-(************************************************************************)
-
-(************************************************************************)
-(* Configuration, errors and warnings *)
-
-open Pp
-
-let mssg_may_need_inversion () =
-  str "Found a matching with no clauses on a term unknown to have an empty inductive type"
-
-(* Utils *)
-let make_anonymous_patvars =
-  list_tabulate (fun _ -> PatVar (dummy_loc,Anonymous))
-
-(* Environment management *)
-let push_rels vars env = List.fold_right push_rel vars env
-
-(* We have x1:t1...xn:tn,xi':ti,y1..yk |- c and re-generalize
-   over xi:ti to get x1:t1...xn:tn,xi':ti,y1..yk |- c[xi:=xi'] *)
-
-let regeneralize_rel i k j = if j = i+k then k else if j < i+k then j else j
-
-let rec regeneralize_index i k t = match kind_of_term t with
-  | Rel j when j = i+k -> mkRel (k+1)
-  | Rel j when j < i+k -> t
-  | Rel j when j > i+k -> t
-  | _ -> map_constr_with_binders succ (regeneralize_index i) k t
-
-type alias_constr =
-  | DepAlias
-  | NonDepAlias
-
-let mkSpecialLetInJudge j (na,(deppat,nondeppat,d,t)) =
-  { uj_val =
-      (match d with
-	| DepAlias -> mkLetIn (na,deppat,t,j.uj_val)
-	| NonDepAlias ->
-	    if (not (dependent (mkRel 1) j.uj_type))
-	      or (* A leaf: *) isRel deppat
-	    then
-	      (* The body of pat is not needed to type j - see *)
-	      (* insert_aliases - and both deppat and nondeppat have the *)
-	      (* same type, then one can freely substitute one by the other *)
-	      subst1 nondeppat j.uj_val
-	    else
-	      (* The body of pat is not needed to type j but its value *)
-	      (* is dependent in the type of j; our choice is to *)
-	      (* enforce this dependency *)
-	      mkLetIn (na,deppat,t,j.uj_val));
-    uj_type = subst1 deppat j.uj_type }
-
-(**********************************************************************)
-(* Structures used in compiling pattern-matching *)
-
-type rhs =
-    { rhs_env    : env;
-      avoid_ids  : identifier list;
-      it         : glob_constr;
-    }
-
-type equation =
-    { patterns     : cases_pattern list;
-      rhs          : rhs;
-      alias_stack  : name list;
-      eqn_loc      : loc;
-      used         : bool ref }
-
-type matrix = equation list
-
-(* 1st argument of IsInd is the original ind before extracting the summary *)
-type tomatch_type =
-  | IsInd of types * inductive_type
-  | NotInd of constr option * types
-
-type tomatch_status =
-  | Pushed of ((constr * tomatch_type) * int list)
-  | Alias of (constr * constr * alias_constr * constr)
-  | Abstract of rel_declaration
-
-type tomatch_stack = tomatch_status list
-
-(* The type [predicate_signature] types the terms to match and the rhs:
-
-   - [PrLetIn (names,dep,pred)] types a pushed term ([Pushed]),
-     if dep<>Anonymous, the term is dependent, let n=|names|, if
-     n<>0 then the type of the pushed term is necessarily an
-     inductive with n real arguments. Otherwise, it may be
-     non inductive, or inductive without real arguments, or inductive
-     originating from a subterm in which case real args are not dependent;
-     it accounts for n+1 binders if dep or n binders if not dep
-   - [PrProd] types abstracted term ([Abstract]); it accounts for one binder
-   - [PrCcl] types the right-hand side
-   - Aliases [Alias] have no trace in [predicate_signature]
-*)
-
-type predicate_signature =
-  | PrLetIn of (name list * name) * predicate_signature
-  | PrProd of predicate_signature
-  | PrCcl of constr
-
-(* We keep a constr for aliases and a cases_pattern for error message *)
-
-type alias_builder =
-  | AliasLeaf
-  | AliasConstructor of constructor
-
-type pattern_history =
-  | Top
-  | MakeAlias of alias_builder * pattern_continuation
-
-and pattern_continuation =
-  | Continuation of int * cases_pattern list * pattern_history
-  | Result of cases_pattern list
-
-let start_history n = Continuation (n, [], Top)
-
-let feed_history arg = function
-  | Continuation (n, l, h) when n>=1 ->
-      Continuation (n-1, arg :: l, h)
-  | Continuation (n, _, _) ->
-      anomaly ("Bad number of expected remaining patterns: "^(string_of_int n))
-  | Result _ ->
-      anomaly "Exhausted pattern history"
-
-(* This is for non exhaustive error message *)
-
-let rec glob_pattern_of_partial_history args2 = function
-  | Continuation (n, args1, h) ->
-      let args3 = make_anonymous_patvars (n - (List.length args2)) in
-      build_glob_pattern (List.rev_append args1 (args2@args3)) h
-  | Result pl -> pl
-
-and build_glob_pattern args = function
-  | Top -> args
-  | MakeAlias (AliasLeaf, rh) ->
-      assert (args = []);
-      glob_pattern_of_partial_history [PatVar (dummy_loc, Anonymous)] rh
-  | MakeAlias (AliasConstructor pci, rh) ->
-      glob_pattern_of_partial_history
-	[PatCstr (dummy_loc, pci, args, Anonymous)] rh
-
-let complete_history = glob_pattern_of_partial_history []
-
-(* This is to build glued pattern-matching history and alias bodies *)
-
-let rec simplify_history = function
-  | Continuation (0, l, Top) -> Result (List.rev l)
-  | Continuation (0, l, MakeAlias (f, rh)) ->
-      let pargs = List.rev l in
-      let pat = match f with
-	| AliasConstructor pci ->
-	    PatCstr (dummy_loc,pci,pargs,Anonymous)
-	| AliasLeaf ->
-	    assert (l = []);
-	    PatVar (dummy_loc, Anonymous) in
-      feed_history pat rh
-  | h -> h
-
-(* Builds a continuation expecting [n] arguments and building [ci] applied
-   to this [n] arguments *)
-
-let push_history_pattern n current cont =
-  Continuation (n, [], MakeAlias (current, cont))
-
-(* A pattern-matching problem has the following form:
-
-   env, isevars |- <pred> Cases tomatch of mat end
-
-  where tomatch is some sequence of "instructions" (t1  ... tn)
-
-  and mat is some matrix
-   (p11 ... p1n -> rhs1)
-   (    ...            )
-   (pm1 ... pmn -> rhsm)
-
-  Terms to match: there are 3 kinds of instructions
-
-  - "Pushed" terms to match are typed in [env]; these are usually just
-    Rel(n) except for the initial terms given by user and typed in [env]
-  - "Abstract" instructions means an abstraction has to be inserted in the
-    current branch to build (this means a pattern has been detected dependent
-    in another one and generalisation is necessary to ensure well-typing)
-  - "Alias" instructions means an alias has to be inserted (this alias
-    is usually removed at the end, except when its type is not the
-    same as the type of the matched term from which it comes -
-    typically because the inductive types are "real" parameters)
-
-  Right-hand-sides:
-
-  They consist of a raw term to type in an environment specific to the
-  clause they belong to: the names of declarations are those of the
-  variables present in the patterns. Therefore, they come with their
-  own [rhs_env] (actually it is the same as [env] except for the names
-  of variables).
-
-*)
-type pattern_matching_problem =
-    { env      : env;
-      isevars  : Evd.evar_map ref;
-      pred     : predicate_signature option;
-      tomatch  : tomatch_stack;
-      history  : pattern_continuation;
-      mat      : matrix;
-      caseloc  : loc;
-      casestyle: case_style;
-      typing_function: type_constraint -> env -> glob_constr -> unsafe_judgment }
-
-(*--------------------------------------------------------------------------*
- * A few functions to infer the inductive type from the patterns instead of *
- * checking that the patterns correspond to the ind. type of the            *
- * destructurated object. Allows type inference of examples like            *
- *  match n with O => true | _ => false end                                 *
- *  match x in I with C => true | _ => false end                            *
- *--------------------------------------------------------------------------*)
-
-(* Computing the inductive type from the matrix of patterns *)
-
-(* We use the "in I" clause to coerce the terms to match and otherwise
-   use the constructor to know in which type is the matching problem
-
-   Note that insertion of coercions inside nested patterns is done
-   each time the matrix is expanded *)
-
-let rec find_row_ind = function
-    [] -> None
-  | PatVar _ :: l -> find_row_ind l
-  | PatCstr(loc,c,_,_) :: _ -> Some (loc,c)
-
-let inductive_template isevars env tmloc ind =
-  let arsign = get_full_arity_sign env ind in
-  let hole_source = match tmloc with
-    | Some loc -> fun i -> (loc, Evd.TomatchTypeParameter (ind,i))
-    | None -> fun _ -> (dummy_loc, Evd.InternalHole) in
-   let (_,evarl,_) =
-    List.fold_right
-      (fun (na,b,ty) (subst,evarl,n) ->
-	match b with
-        | None ->
-	    let ty' = substl subst ty in
-	    let e = e_new_evar isevars env ~src:(hole_source n) ty' in
-	    (e::subst,e::evarl,n+1)
-	| Some b ->
-	    (b::subst,evarl,n+1))
-      arsign ([],[],1) in
-   applist (mkInd ind,List.rev evarl)
-
-
-(************************************************************************)
-(* Utils *)
-
-let mkExistential env ?(src=(dummy_loc,Evd.InternalHole)) isevars =
-  e_new_evar isevars env ~src:src (new_Type ())
-
-let evd_comb2 f isevars x y =
-  let (evd',y) = f !isevars x y in
-  isevars := evd';
-  y
-
-let context_of_arsign l =
-  let (x, _) = List.fold_right
-    (fun c (x, n) ->
-      (lift_rel_context n c @ x, List.length c + n))
-    l ([], 0)
-  in x
-
-(* We put the tycon inside the arity signature, possibly discovering dependencies. *)
-
-let prepare_predicate_from_arsign_tycon loc env evm tomatchs arsign c =
-  let nar = List.fold_left (fun n sign -> List.length sign + n) 0 arsign in
-  let subst, len =
-    List.fold_left2 (fun (subst, len) (tm, tmtype) sign ->
-      let signlen = List.length sign in
-	match kind_of_term tm with
-	  | Rel n when dependent tm c
-		&& signlen = 1 (* The term to match is not of a dependent type itself *) ->
-	      ((n, len) :: subst, len - signlen)
-	  | Rel n when signlen > 1 (* The term is of a dependent type,
-				      maybe some variable in its type appears in the tycon. *) ->
-	      (match tmtype with
-	      | NotInd _ -> (* len - signlen, subst*) assert false (* signlen > 1 *)
-	      | IsInd (_, IndType(indf,realargs)) ->
-		  let subst =
-		    if dependent tm c && List.for_all isRel realargs
-		    then (n, 1) :: subst else subst
-		  in
-		    List.fold_left
-		      (fun (subst, len) arg ->
-			match kind_of_term arg with
-			| Rel n when dependent arg c ->
-			    ((n, len) :: subst, pred len)
-			| _ -> (subst, pred len))
-		      (subst, len) realargs)
-	  | _ -> (subst, len - signlen))
-      ([], nar) tomatchs arsign
-  in
-  let rec predicate lift c =
-    match kind_of_term c with
-      | Rel n when n > lift ->
-	  (try
-	      (* Make the predicate dependent on the matched variable *)
-	      let idx = List.assoc (n - lift) subst in
-		mkRel (idx + lift)
-	    with Not_found ->
-	      (* A variable that is not matched, lift over the arsign. *)
-	      mkRel (n + nar))
-      | _ ->
-	  map_constr_with_binders succ predicate lift c
-  in
-    try
-      (* The tycon may be ill-typed after abstraction. *)
-      let pred = predicate 0 c in
-      let env' = push_rel_context (context_of_arsign arsign) env in
-	ignore(Typing.sort_of env' evm pred); pred
-    with e when Errors.noncritical e -> lift nar c
-
-module Cases_F(Coercion : Coercion.S) : S = struct
-
-let inh_coerce_to_ind isevars env ty tyi =
-  let expected_typ = inductive_template isevars env None tyi in
-     (* devrait être indifférent d'exiger leq ou pas puisque pour
-        un inductif cela doit être égal *)
-  let _ = e_cumul env isevars expected_typ ty in ()
-
-let unify_tomatch_with_patterns isevars env loc typ pats =
-  match find_row_ind pats with
-    | None -> NotInd (None,typ)
-    | Some (_,(ind,_)) ->
-	inh_coerce_to_ind isevars env typ ind;
-	try IsInd (typ,find_rectype env ( !isevars) typ)
-	with Not_found -> NotInd (None,typ)
-
-let find_tomatch_tycon isevars env loc = function
-  (* Try if some 'in I ...' is present and can be used as a constraint *)
-  | Some (_,ind,_,_) -> mk_tycon (inductive_template isevars env loc ind)
-  | None -> empty_tycon
-
-let coerce_row typing_fun isevars env pats (tomatch,(_,indopt)) =
-  let loc = Some (loc_of_glob_constr tomatch) in
-  let tycon = find_tomatch_tycon isevars env loc indopt in
-  let j = typing_fun tycon env tomatch in
-  let evd, j = Coercion.inh_coerce_to_base (loc_of_glob_constr tomatch) env !isevars j in
-  isevars := evd;
-  let typ = nf_evar ( !isevars) j.uj_type in
-  let t =
-    try IsInd (typ,find_rectype env ( !isevars) typ)
-    with Not_found ->
-      unify_tomatch_with_patterns isevars env loc typ pats in
-  (j.uj_val,t)
-
-let coerce_to_indtype typing_fun isevars env matx tomatchl =
-  let pats = List.map (fun r ->  r.patterns) matx in
-  let matx' = match matrix_transpose pats with
-    | [] -> List.map (fun _ -> []) tomatchl (* no patterns at all *)
-    | m -> m in
-  List.map2 (coerce_row typing_fun isevars env) matx' tomatchl
-
-
-
-let adjust_tomatch_to_pattern pb ((current,typ),deps) =
-  (* Ideally, we could find a common inductive type to which both the
-     term to match and the patterns coerce *)
-  (* In practice, we coerce the term to match if it is not already an
-     inductive type and it is not dependent; moreover, we use only
-     the first pattern type and forget about the others *)
-  let typ = match typ with IsInd (t,_) -> t | NotInd (_,t) -> t in
-  let typ =
-    try IsInd (typ,find_rectype pb.env ( !(pb.isevars)) typ)
-    with Not_found -> NotInd (None,typ) in
-  let tomatch = ((current,typ),deps) in
-  match typ with
-  | NotInd (None,typ) ->
-      let tm1 = List.map (fun eqn -> List.hd eqn.patterns) pb.mat in
-      (match find_row_ind tm1 with
-	| None -> tomatch
-	| Some (_,(ind,_)) ->
-	    let indt = inductive_template pb.isevars pb.env None ind in
-	    let current =
-	      if deps = [] & isEvar typ then
-	      (* Don't insert coercions if dependent; only solve evars *)
-		let _ = e_cumul pb.env pb.isevars indt typ in
-		current
-	      else
-		(evd_comb2 (Coercion.inh_conv_coerce_to true dummy_loc pb.env)
-		  pb.isevars (make_judge current typ) (mk_tycon_type indt)).uj_val in
-	    let sigma =  !(pb.isevars) in
-	    let typ = IsInd (indt,find_rectype pb.env sigma indt) in
-	    ((current,typ),deps))
-  | _ -> tomatch
-
-   (* extract some ind from [t], possibly coercing from constructors in [tm] *)
-let to_mutind env isevars tm c t =
-(*  match c with
-    | Some body -> *) NotInd (c,t)
-(*    | None -> unify_tomatch_with_patterns isevars env t tm*)
-
-let type_of_tomatch = function
-  | IsInd (t,_) -> t
-  | NotInd (_,t) -> t
-
-let mkDeclTomatch na = function
-  | IsInd (t,_) -> (na,None,t)
-  | NotInd (c,t) -> (na,c,t)
-
-let map_tomatch_type f = function
-  | IsInd (t,ind) -> IsInd (f t,map_inductive_type f ind)
-  | NotInd (c,t) -> NotInd (Option.map f c, f t)
-
-let liftn_tomatch_type n depth = map_tomatch_type (liftn n depth)
-let lift_tomatch_type n = liftn_tomatch_type n 1
-
-(**********************************************************************)
-(* Utilities on patterns *)
-
-let current_pattern eqn =
-  match eqn.patterns with
-    | pat::_ -> pat
-    | [] -> anomaly "Empty list of patterns"
-
-let alias_of_pat = function
-  | PatVar (_,name) -> name
-  | PatCstr(_,_,_,name) -> name
-
-let remove_current_pattern eqn =
-  match eqn.patterns with
-    | pat::pats ->
-	{ eqn with
-	    patterns = pats;
-	    alias_stack = alias_of_pat pat :: eqn.alias_stack }
-    | [] -> anomaly "Empty list of patterns"
-
-let prepend_pattern tms eqn = {eqn with patterns = tms@eqn.patterns }
-
-(**********************************************************************)
-(* Well-formedness tests *)
-(* Partial check on patterns *)
-
-exception NotAdjustable
-
-let rec adjust_local_defs loc = function
-  | (pat :: pats, (_,None,_) :: decls) ->
-      pat :: adjust_local_defs loc (pats,decls)
-  | (pats, (_,Some _,_) :: decls) ->
-      PatVar (loc, Anonymous) :: adjust_local_defs loc (pats,decls)
-  | [], [] -> []
-  | _ -> raise NotAdjustable
-
-let check_and_adjust_constructor env ind cstrs = function
-  | PatVar _ as pat -> pat
-  | PatCstr (loc,((_,i) as cstr),args,alias) as pat ->
-      (* Check it is constructor of the right type *)
-      let ind' = inductive_of_constructor cstr in
-      if Names.eq_ind ind' ind then
-	(* Check the constructor has the right number of args *)
-	let ci = cstrs.(i-1) in
-	let nb_args_constr = ci.cs_nargs in
-	if List.length args = nb_args_constr then pat
-	else
-	  try
-	    let args' = adjust_local_defs loc (args, List.rev ci.cs_args)
-	    in PatCstr (loc, cstr, args', alias)
-	  with NotAdjustable ->
-	    error_wrong_numarg_constructor_loc loc (Global.env())
-	      cstr nb_args_constr
-      else
-	(* Try to insert a coercion *)
-	try
-	  Coercion.inh_pattern_coerce_to loc pat ind' ind
-	with Not_found ->
-	  error_bad_constructor_loc loc cstr ind
-
-let check_all_variables typ mat =
-  List.iter
-    (fun eqn -> match current_pattern eqn with
-       | PatVar (_,id) -> ()
-       | PatCstr (loc,cstr_sp,_,_) ->
-	   error_bad_pattern_loc loc cstr_sp typ)
-    mat
-
-let check_unused_pattern env eqn =
-  if not !(eqn.used) then
-    raise_pattern_matching_error
-      (eqn.eqn_loc, env, UnusedClause eqn.patterns)
-
-let set_used_pattern eqn = eqn.used := true
-
-let extract_rhs pb =
-  match pb.mat with
-    | [] -> errorlabstrm "build_leaf" (mssg_may_need_inversion())
-    | eqn::_ ->
-	set_used_pattern eqn;
-	eqn.rhs
-
-(**********************************************************************)
-(* Functions to deal with matrix factorization *)
-
-let occur_in_rhs na rhs =
-  match na with
-    | Anonymous -> false
-    | Name id -> occur_glob_constr id rhs.it
-
-let is_dep_patt eqn = function
-  | PatVar (_,name) -> occur_in_rhs name eqn.rhs
-  | PatCstr _ -> true
-
-let dependencies_in_rhs nargs eqns =
-  if eqns = [] then list_tabulate (fun _ -> false) nargs (* Only "_" patts *)
-  else
-  let deps = List.map (fun (tms,eqn) -> List.map (is_dep_patt eqn) tms) eqns in
-  let columns = matrix_transpose deps in
-  List.map (List.exists ((=) true)) columns
-
-let dependent_decl a = function
-  | (na,None,t) -> dependent a t
-  | (na,Some c,t) -> dependent a t || dependent a c
-
-(* Computing the matrix of dependencies *)
-
-(* We are in context d1...dn |- and [find_dependencies k 1 nextlist]
-   computes for declaration [k+1] in which of declarations in
-   [nextlist] (which corresponds to d(k+2)...dn) it depends;
-   declarations are expressed by index, e.g. in dependency list
-   [n-2;1], [1] points to [dn] and [n-2] to [d3] *)
-
-let rec find_dependency_list k n = function
-  | [] -> []
-  | (used,tdeps,d)::rest ->
-      let deps = find_dependency_list k (n+1) rest in
-      if used && dependent_decl (mkRel n) d
-      then list_add_set (List.length rest + 1) (list_union deps tdeps)
-      else deps
-
-let find_dependencies is_dep_or_cstr_in_rhs d (k,nextlist) =
-  let deps = find_dependency_list k 1 nextlist in
-  if is_dep_or_cstr_in_rhs || deps <> []
-  then (k-1,(true ,deps,d)::nextlist)
-  else (k-1,(false,[]  ,d)::nextlist)
-
-let find_dependencies_signature deps_in_rhs typs =
-  let k = List.length deps_in_rhs in
-  let _,l = List.fold_right2 find_dependencies deps_in_rhs typs (k,[]) in
-  List.map (fun (_,deps,_) -> deps) l
-
-(******)
-
-(* A Pushed term to match has just been substituted by some
-   constructor t = (ci x1...xn) and the terms x1 ... xn have been added to
-   match
-
-   - all terms to match and to push (dependent on t by definition)
-     must have (Rel depth) substituted by t and Rel's>depth lifted by n
-   - all pushed terms to match (non dependent on t by definition) must
-     be lifted by n
-
-  We start with depth=1
-*)
-
-let regeneralize_index_tomatch n =
-  let rec genrec depth = function
-  | [] -> []
-  | Pushed ((c,tm),l)::rest ->
-      let c = regeneralize_index n depth c in
-      let tm = map_tomatch_type (regeneralize_index n depth) tm in
-      let l = List.map (regeneralize_rel n depth) l in
-      Pushed ((c,tm),l)::(genrec depth rest)
-  | Alias (c1,c2,d,t)::rest ->
-      Alias (regeneralize_index n depth c1,c2,d,t)::(genrec depth rest)
-  | Abstract d::rest ->
-      Abstract (map_rel_declaration (regeneralize_index n depth) d)
-      ::(genrec (depth+1) rest) in
-  genrec 0
-
-let rec replace_term n c k t =
-  if isRel t && destRel t = n+k then lift k c
-  else map_constr_with_binders succ (replace_term n c) k t
-
-let replace_tomatch n c =
-  let rec replrec depth = function
-  | [] -> []
-  | Pushed ((b,tm),l)::rest ->
-      let b = replace_term n c depth b in
-      let tm = map_tomatch_type (replace_term n c depth) tm in
-      List.iter (fun i -> if i=n+depth then anomaly "replace_tomatch") l;
-      Pushed ((b,tm),l)::(replrec depth rest)
-  | Alias (c1,c2,d,t)::rest ->
-      Alias (replace_term n c depth c1,c2,d,t)::(replrec depth rest)
-  | Abstract d::rest ->
-      Abstract (map_rel_declaration (replace_term n c depth) d)
-      ::(replrec (depth+1) rest) in
-  replrec 0
-
-let rec liftn_tomatch_stack n depth = function
-  | [] -> []
-  | Pushed ((c,tm),l)::rest ->
-      let c = liftn n depth c in
-      let tm = liftn_tomatch_type n depth tm in
-      let l = List.map (fun i -> if i<depth then i else i+n) l in
-      Pushed ((c,tm),l)::(liftn_tomatch_stack n depth rest)
-  | Alias (c1,c2,d,t)::rest ->
-      Alias (liftn n depth c1,liftn n depth c2,d,liftn n depth t)
-      ::(liftn_tomatch_stack n depth rest)
-  | Abstract d::rest ->
-      Abstract (map_rel_declaration (liftn n depth) d)
-      ::(liftn_tomatch_stack n (depth+1) rest)
-
-
-let lift_tomatch_stack n = liftn_tomatch_stack n 1
-
-(* if [current] has type [I(p1...pn u1...um)] and we consider the case
-   of constructor [ci] of type [I(p1...pn u'1...u'm)], then the
-   default variable [name] is expected to have which type?
-   Rem: [current] is [(Rel i)] except perhaps for initial terms to match *)
-
-(************************************************************************)
-(* Some heuristics to get names for variables pushed in pb environment *)
-(* Typical requirement:
-
-   [match y with (S (S x)) => x | x => x end] should be compiled into
-   [match y with O => y | (S n) => match n with O => y | (S x) => x end end]
-
-   and [match y with (S (S n)) => n | n => n end] into
-   [match y with O => y | (S n0) => match n0 with O => y | (S n) => n end end]
-
-  i.e. user names should be preserved and created names should not
-  interfere with user names *)
-
-let merge_name get_name obj = function
-  | Anonymous -> get_name obj
-  | na -> na
-
-let merge_names get_name = List.map2 (merge_name get_name)
-
-let get_names env sign eqns =
-  let names1 = list_tabulate (fun _ -> Anonymous) (List.length sign) in
-  (* If any, we prefer names used in pats, from top to bottom *)
-  let names2 =
-    List.fold_right
-      (fun (pats,eqn) names -> merge_names alias_of_pat pats names)
-      eqns names1 in
-  (* Otherwise, we take names from the parameters of the constructor but
-     avoiding conflicts with user ids *)
-  let allvars =
-    List.fold_left (fun l (_,eqn) -> list_union l eqn.rhs.avoid_ids) [] eqns in
-  let names4,_ =
-    List.fold_left2
-      (fun (l,avoid) d na ->
-	 let na =
-	   merge_name
-	     (fun (na,_,t) -> Name (next_name_away (named_hd env t na) avoid))
-	     d na
-	 in
-         (na::l,(out_name na)::avoid))
-      ([],allvars) (List.rev sign) names2 in
-  names4
-
-(************************************************************************)
-(* Recovering names for variables pushed to the rhs' environment *)
-
-let recover_alias_names get_name = List.map2 (fun x (_,c,t) ->(get_name x,c,t))
-
-let all_name sign = List.map (fun (n, b, t) -> let n = match n with Name _ -> n | Anonymous -> Name (id_of_string "Anonymous") in
-				(n, b, t)) sign
-
-let push_rels_eqn sign eqn =
-  let sign = all_name sign in
-    {eqn with rhs = {eqn.rhs with rhs_env = push_rels sign eqn.rhs.rhs_env; } }
-
-let push_rels_eqn_with_names sign eqn =
-  let pats = List.rev (list_firstn (List.length sign) eqn.patterns) in
-  let sign = recover_alias_names alias_of_pat pats sign in
-  push_rels_eqn sign eqn
-
-let build_aliases_context env sigma names allpats pats =
-  (* pats is the list of bodies to push as an alias *)
-  (* They all are defined in env and we turn them into a sign *)
-  (* cuts in sign need to be done in allpats *)
-  let rec insert env sign1 sign2 n newallpats oldallpats = function
-    | (deppat,_,_,_)::pats, Anonymous::names when not (isRel deppat) ->
-        (* Anonymous leaves must be considered named and treated in the *)
-        (* next clause because they may occur in implicit arguments *)
-	insert env sign1 sign2
-	  n newallpats (List.map List.tl oldallpats) (pats,names)
-    | (deppat,nondeppat,d,t)::pats, na::names ->
-	let nondeppat = lift n nondeppat in
-	let deppat = lift n deppat in
-	let newallpats =
-	  List.map2 (fun l1 l2 -> List.hd l2::l1) newallpats oldallpats in
-	let oldallpats = List.map List.tl oldallpats in
-	let decl = (na,Some deppat,t) in
-	let a = (deppat,nondeppat,d,t) in
-	insert (push_rel decl env) (decl::sign1) ((na,a)::sign2) (n+1)
-	  newallpats oldallpats (pats,names)
-    | [], [] -> newallpats, sign1, sign2, env
-    | _ -> anomaly "Inconsistent alias and name lists" in
-  let allpats = List.map (fun x -> [x]) allpats
-  in insert env [] [] 0 (List.map (fun _ -> []) allpats) allpats (pats, names)
-
-let insert_aliases_eqn sign eqnnames alias_rest eqn =
-  let thissign = List.map2 (fun na (_,c,t) -> (na,c,t)) eqnnames sign in
-    push_rels_eqn thissign { eqn with  alias_stack = alias_rest; }
-
-
-let insert_aliases env sigma alias eqns =
-  (* Là, y a une faiblesse, si un alias est utilisé dans un cas par *)
-  (* défaut présent mais inutile, ce qui est le cas général, l'alias *)
-  (* est introduit même s'il n'est pas utilisé dans les cas réguliers *)
-  let eqnsnames = List.map (fun eqn -> List.hd eqn.alias_stack) eqns in
-  let alias_rests = List.map (fun eqn -> List.tl eqn.alias_stack) eqns in
-  (* names2 takes the meet of all needed aliases *)
-  let names2 =
-    List.fold_right (merge_name (fun x -> x)) eqnsnames Anonymous in
-  (* Only needed aliases are kept by build_aliases_context *)
-  let eqnsnames, sign1, sign2, env =
-    build_aliases_context env sigma [names2] eqnsnames [alias] in
-  let eqns = list_map3 (insert_aliases_eqn sign1) eqnsnames alias_rests eqns in
-  sign2, env, eqns
-
-(**********************************************************************)
-(* Functions to deal with elimination predicate *)
-
-exception Occur
-let noccur_between_without_evar n m term =
-  let rec occur_rec n c = match kind_of_term c with
-    | Rel p       -> if n<=p && p<n+m then raise Occur
-    | Evar (_,cl) -> ()
-    | _             -> iter_constr_with_binders succ occur_rec n c
-  in
-  try occur_rec n term; true with Occur -> false
-
-(* Inferring the predicate *)
-let prepare_unif_pb typ cs =
-  let n = List.length (assums_of_rel_context cs.cs_args) in
-
-  (* We may need to invert ci if its parameters occur in typ *)
-  let typ' =
-    if noccur_between_without_evar 1 n typ then lift (-n) typ
-    else (* TODO4-1 *)
-      error "Unable to infer return clause of this pattern-matching problem" in
-  let args = extended_rel_list (-n) cs.cs_args in
-  let ci = applist (mkConstruct cs.cs_cstr, cs.cs_params@args) in
-
-  (* This is the problem: finding P s.t. cs_args |- (P realargs ci) = typ' *)
-  (Array.map (lift (-n)) cs.cs_concl_realargs, ci, typ')
-
-
-(* Infering the predicate *)
-(*
-The problem to solve is the following:
-
-We match Gamma |- t : I(u01..u0q) against the following constructors:
-
-  Gamma, x11...x1p1 |- C1(x11..x1p1) : I(u11..u1q)
-   ...
-  Gamma, xn1...xnpn |- Cn(xn1..xnp1) : I(un1..unq)
-
-Assume the types in the branches are the following
-
-  Gamma, x11...x1p1 |- branch1 : T1
-   ...
-  Gamma, xn1...xnpn |- branchn : Tn
-
-Assume the type of the global case expression is Gamma |- T
-
-The predicate has the form phi = [y1..yq][z:I(y1..yq)]? and must satisfy
-the following n+1 equations:
-
-  Gamma, x11...x1p1 |- (phi u11..u1q (C1 x11..x1p1))  =  T1
-   ...
-  Gamma, xn1...xnpn |- (phi un1..unq (Cn xn1..xnpn))  =  Tn
-  Gamma             |- (phi u01..u0q t)               =  T
-
-Some hints:
-
-- Clearly, if xij occurs in Ti, then, a "match z with (Ci xi1..xipi) => ..."
-  should be inserted somewhere in Ti.
-
-- If T is undefined, an easy solution is to insert a "match z with (Ci
-  xi1..xipi) => ..." in front of each Ti
-
-- Otherwise, T1..Tn and T must be step by step unified, if some of them
-  diverge, then try to replace the diverging subterm by one of y1..yq or z.
-
-- The main problem is what to do when an existential variables is encountered
-
-let prepare_unif_pb typ cs =
-  let n = cs.cs_nargs in
-  let _,p = decompose_prod_n n typ in
-  let ci = build_dependent_constructor cs in
-  (* This is the problem: finding P s.t. cs_args |- (P realargs ci) = p *)
-  (n, cs.cs_concl_realargs, ci, p)
-
-let eq_operator_lift k (n,n') = function
-  | OpRel p, OpRel p' when p > k & p' > k ->
-      if p < k+n or p' < k+n' then false else p - n = p' - n'
-  | op, op' -> op = op'
-
-let rec transpose_args n =
-  if n=0 then []
-  else
-    (Array.map (fun l -> List.hd l) lv)::
-    (transpose_args (m-1) (Array.init (fun l -> List.tl l)))
-
-let shift_operator k = function OpLambda _ | OpProd _ -> k+1 | _ -> k
-
-let reloc_operator (k,n) = function OpRel p when p > k ->
-let rec unify_clauses k pv =
-  let pv'= Array.map (fun (n,sign,_,p) -> n,splay_constr (whd_betaiotaevar (push_rels (List.rev sign) env) ( isevars)) p) pv in
-  let n1,op1 = let (n1,(op1,args1)) = pv'.(0) in n1,op1 in
-  if Array.for_all (fun (ni,(opi,_)) -> eq_operator_lift k (n1,ni) (op1,opi)) pv'
-  then
-    let argvl = transpose_args (List.length args1) pv' in
-    let k' = shift_operator k op1 in
-    let argl = List.map (unify_clauses k') argvl in
-    gather_constr (reloc_operator (k,n1) op1) argl
-*)
-
-let abstract_conclusion typ cs =
-  let n = List.length (assums_of_rel_context cs.cs_args) in
-  let (sign,p) = decompose_prod_n n typ in
-  it_mkLambda p sign
-
-let infer_predicate loc env isevars typs cstrs indf =
-  (* Il faudra substituer les isevars a un certain moment *)
-  if Array.length cstrs = 0 then (* "TODO4-3" *)
-    error "Inference of annotation for empty inductive types not implemented"
-  else
-    (* Empiric normalization: p may depend in a irrelevant way on args of the*)
-    (* cstr as in [c:{_:Alpha & Beta}] match c with (existS a b)=>(a,b) end *)
-    let typs =
-      Array.map (local_strong whd_beta ( !isevars)) typs
-    in
-    let eqns = array_map2 prepare_unif_pb typs cstrs in
-    (* First strategy: no dependencies at all *)
-(*
-    let (mis,_) = dest_ind_family indf in
-    let (cclargs,_,typn) = eqns.(mis_nconstr mis -1) in
-*)
-    let (sign,_) = get_arity env indf in
-    let mtyp =
-      if array_exists is_Type typs then
-	(* Heuristic to avoid comparison between non-variables algebric univs*)
-	new_Type ()
-      else
-	mkExistential env ~src:(loc, Evd.CasesType) isevars
-    in
-    if array_for_all (fun (_,_,typ) -> e_cumul env isevars typ mtyp) eqns
-    then
-      (* Non dependent case -> turn it into a (dummy) dependent one *)
-      let sign = (Anonymous,None,build_dependent_inductive env indf)::sign in
-      let pred = it_mkLambda_or_LetIn (lift (List.length sign) mtyp) sign in
-      (true,pred) (* true = dependent -- par défaut *)
-    else
-(*
-      let s = get_sort_of env ( isevars) typs.(0) in
-      let predpred = it_mkLambda_or_LetIn (mkSort s) sign in
-      let caseinfo = make_default_case_info mis in
-      let brs = array_map2 abstract_conclusion typs cstrs in
-      let predbody = mkCase (caseinfo, (nf_betaiota predpred), mkRel 1, brs) in
-      let pred = it_mkLambda_or_LetIn (lift (List.length sign) mtyp) sign in
-*)
-      (* "TODO4-2" *)
-      (* We skip parameters *)
-      let cis =
-	Array.map
-	  (fun cs ->
-	     applist (mkConstruct cs.cs_cstr, extended_rel_list 0 cs.cs_args))
-	  cstrs in
-      let ct = array_map2 (fun ci (_,_,t) -> (ci,t)) cis eqns in
-      raise_pattern_matching_error (loc,env, CannotInferPredicate ct)
-(*
-      (true,pred)
-*)
-
-(* Propagation of user-provided predicate through compilation steps *)
-
-let rec map_predicate f k = function
-  | PrCcl ccl -> PrCcl (f k ccl)
-  | PrProd pred ->
-      PrProd (map_predicate f (k+1) pred)
-  | PrLetIn ((names,dep as tm),pred) ->
-      let k' = List.length names + (if dep<>Anonymous then 1 else 0) in
-      PrLetIn (tm, map_predicate f (k+k') pred)
-
-let rec noccurn_predicate k = function
-  | PrCcl ccl -> noccurn k ccl
-  | PrProd pred -> noccurn_predicate (k+1) pred
-  | PrLetIn ((names,dep),pred) ->
-      let k' = List.length names + (if dep<>Anonymous then 1 else 0) in
-      noccurn_predicate (k+k') pred
-
-let liftn_predicate n = map_predicate (liftn n)
-
-let lift_predicate n = liftn_predicate n 1
-
-let regeneralize_index_predicate n = map_predicate (regeneralize_index n) 0
-
-let substnl_predicate sigma = map_predicate (substnl sigma)
-
-(* This is parallel bindings *)
-let subst_predicate (args,copt) pred =
-  let sigma = match copt with
-    | None -> List.rev args
-    | Some c -> c::(List.rev args) in
-  substnl_predicate sigma 0 pred
-
-let specialize_predicate_var (cur,typ) = function
-  | PrProd _ | PrCcl _ ->
-     anomaly "specialize_predicate_var: a pattern-variable must be pushed"
-  | PrLetIn (([],dep),pred) ->
-      subst_predicate ([],if dep<>Anonymous then Some cur else None) pred
-  | PrLetIn ((_,dep),pred) ->
-      (match typ with
-        | IsInd (_,IndType (_,realargs)) ->
-           subst_predicate (realargs,if dep<>Anonymous then Some cur else None) pred
-        | _ -> anomaly "specialize_predicate_var")
-
-let ungeneralize_predicate = function
-  | PrLetIn _ | PrCcl _ -> anomaly "ungeneralize_predicate: expects a product"
-  | PrProd pred -> pred
-
-(*****************************************************************************)
-(* We have pred = [X:=realargs;x:=c]P typed in Gamma1, x:I(realargs), Gamma2 *)
-(* and we want to abstract P over y:t(x) typed in the same context to get    *)
-(*                                                                           *)
-(*    pred' = [X:=realargs;x':=c](y':t(x'))P[y:=y']                          *)
-(*                                                                           *)
-(* We first need to lift t(x) s.t. it is typed in Gamma, X:=rargs, x'        *)
-(* then we have to replace x by x' in t(x) and y by y' in P                  *)
-(*****************************************************************************)
-let generalize_predicate ny d = function
-  | PrLetIn ((names,dep as tm),pred) ->
-      if dep=Anonymous then anomaly "Undetected dependency";
-      let p = List.length names + 1 in
-      let pred = lift_predicate 1 pred in
-      let pred = regeneralize_index_predicate (ny+p+1) pred in
-      PrLetIn (tm, PrProd pred)
-  | PrProd _ | PrCcl _ ->
-      anomaly "generalize_predicate: expects a non trivial pattern"
-
-let rec extract_predicate l = function
-  | pred, Alias (deppat,nondeppat,_,_)::tms ->
-      let tms' = match kind_of_term nondeppat with
-        | Rel i -> replace_tomatch i deppat tms
-        | _ -> (* initial terms are not dependent *) tms in
-      extract_predicate l (pred,tms')
-  | PrProd pred, Abstract d'::tms ->
-      let d' = map_rel_declaration (lift (List.length l)) d' in
-      substl l (mkProd_or_LetIn d' (extract_predicate [] (pred,tms)))
-  | PrLetIn (([],dep),pred), Pushed ((cur,_),_)::tms ->
-      extract_predicate (if dep<>Anonymous then cur::l else l) (pred,tms)
-  | PrLetIn ((_,dep),pred), Pushed ((cur,IsInd (_,(IndType(_,realargs)))),_)::tms ->
-      let l = List.rev realargs@l in
-      extract_predicate (if dep<>Anonymous then cur::l else l) (pred,tms)
-  | PrCcl ccl, [] ->
-      substl l ccl
-  | _ -> anomaly"extract_predicate: predicate inconsistent with terms to match"
-
-let abstract_predicate env sigma indf cur tms = function
-  | (PrProd _ | PrCcl _) -> anomaly "abstract_predicate: must be some LetIn"
-  | PrLetIn ((names,dep),pred) ->
-      let sign = make_arity_signature env true indf in
-      (* n is the number of real args + 1 *)
-      let n = List.length sign in
-      let tms = lift_tomatch_stack n tms in
-      let tms =
-        match kind_of_term cur with
-          | Rel i -> regeneralize_index_tomatch (i+n) tms
-          | _ -> (* Initial case *) tms in
-      (* Depending on whether the predicate is dependent or not, and has real
-         args or not, we lift it to make room for [sign] *)
-      (* Even if not intrinsically dep, we move the predicate into a dep one *)
-      let sign,k =
-        if names = [] & n <> 1 then
-          (* Real args were not considered *)
-          (if dep<>Anonymous then
-            ((let (_,c,t) = List.hd sign in (dep,c,t)::List.tl sign),n-1)
-          else
-            (sign,n))
-        else
-          (* Real args are OK *)
-          (List.map2 (fun na (_,c,t) -> (na,c,t)) (dep::names) sign,
-           if dep<>Anonymous then 0 else 1) in
-      let pred = lift_predicate k pred in
-      let pred = extract_predicate [] (pred,tms) in
-      (true, it_mkLambda_or_LetIn_name env pred sign)
-
-let rec known_dependent = function
-  | None -> false
-  | Some (PrLetIn ((_,dep),_)) -> dep<>Anonymous
-  | Some (PrCcl _) -> false
-  | Some (PrProd _) ->
-      anomaly "known_dependent: can only be used when patterns remain"
-
-(* [expand_arg] is used by [specialize_predicate]
-   it replaces gamma, x1...xn, x1...xk |- pred
-   by gamma, x1...xn, x1...xk-1 |- [X=realargs,xk=xk]pred (if dep) or
-   by gamma, x1...xn, x1...xk-1 |- [X=realargs]pred (if not dep) *)
-
-let expand_arg n alreadydep (na,t) deps (k,pred) =
-  (* current can occur in pred even if the original problem is not dependent *)
-  let dep =
-    if alreadydep<>Anonymous then alreadydep
-    else if deps = [] && noccurn_predicate 1 pred then Anonymous
-    else Name (id_of_string "x") in
-  let pred = if dep<>Anonymous then pred else lift_predicate (-1) pred in
-  (* There is no dependency in realargs for subpattern *)
-  (k-1, PrLetIn (([],dep), pred))
-
-
-(*****************************************************************************)
-(* pred = [X:=realargs;x:=c]P types the following problem:                   *)
-(*                                                                           *)
-(*  Gamma |- match Pushed(c:I(realargs)) rest with...end: pred               *)
-(*                                                                           *)
-(* where the branch with constructor Ci:(x1:T1)...(xn:Tn)->I(realargsi)      *)
-(* is considered. Assume each Ti is some Ii(argsi).                          *)
-(* We let e=Ci(x1,...,xn) and replace pred by                                *)
-(*                                                                           *)
-(* pred' = [X1:=rargs1,x1:=x1']...[Xn:=rargsn,xn:=xn'](P[X:=realargsi;x:=e]) *)
-(*                                                                           *)
-(* s.t Gamma,x1'..xn' |- match Pushed(x1')..Pushed(xn') rest with..end :pred'*)
-(*                                                                           *)
-(*****************************************************************************)
-let specialize_predicate tomatchs deps cs = function
-  | (PrProd _ | PrCcl _) ->
-      anomaly "specialize_predicate: a matched pattern must be pushed"
-  | PrLetIn ((names,isdep),pred) ->
-      (* Assume some gamma st: gamma, (X,x:=realargs,copt) |- pred *)
-      let nrealargs = List.length names in
-      let k = nrealargs + (if isdep<>Anonymous then 1 else 0) in
-      (* We adjust pred st: gamma, x1..xn, (X,x:=realargs,copt) |- pred' *)
-      let n = cs.cs_nargs in
-      let pred' = liftn_predicate n (k+1) pred in
-      let argsi = if nrealargs <> 0 then Array.to_list cs.cs_concl_realargs else [] in
-      let copti = if isdep<>Anonymous then Some (build_dependent_constructor cs) else None in
-      (* The substituends argsi, copti are all defined in gamma, x1...xn *)
-      (* We need _parallel_ bindings to get gamma, x1...xn |- pred'' *)
-      let pred'' = subst_predicate (argsi, copti) pred' in
-      (* We adjust pred st: gamma, x1..xn, x1..xn |- pred'' *)
-      let pred''' = liftn_predicate n (n+1) pred'' in
-      (* We finally get gamma,x1..xn |- [X1,x1:=R1,x1]..[Xn,xn:=Rn,xn]pred'''*)
-      snd (List.fold_right2 (expand_arg n isdep) tomatchs deps (n,pred'''))
-
-let find_predicate loc env isevars p typs cstrs current
-  (IndType (indf,realargs)) tms =
-  let (dep,pred) =
-    match p with
-      | Some p -> abstract_predicate env ( !isevars) indf current tms p
-      | None -> infer_predicate loc env isevars typs cstrs indf in
-  let typ = whd_beta ( !isevars) (applist (pred, realargs)) in
-  if dep then
-    (pred, whd_beta ( !isevars) (applist (typ, [current])),
-     new_Type ())
-  else
-    (pred, typ, new_Type ())
-
-(************************************************************************)
-(* Sorting equations by constructor *)
-
-type inversion_problem =
-  (* the discriminating arg in some Ind and its order in Ind *)
-  | Incompatible of int * (int * int)
-  | Constraints of (int * constr) list
-
-let solve_constraints constr_info indt =
-  (* TODO *)
-  Constraints []
-
-let rec irrefutable env = function
-  | PatVar (_,name) -> true
-  | PatCstr (_,cstr,args,_) ->
-      let ind = inductive_of_constructor cstr in
-      let (_,mip) = Inductive.lookup_mind_specif env ind in
-      let one_constr = Array.length mip.mind_user_lc = 1 in
-      one_constr & List.for_all (irrefutable env) args
-
-let first_clause_irrefutable env = function
-  | eqn::mat -> List.for_all (irrefutable env) eqn.patterns
-  | _ -> false
-
-let group_equations pb ind current cstrs mat =
-  let mat =
-    if first_clause_irrefutable pb.env mat then [List.hd mat] else mat in
-  let brs = Array.create (Array.length cstrs) [] in
-  let only_default = ref true in
-  let _ =
-    List.fold_right (* To be sure it's from bottom to top *)
-      (fun eqn () ->
-	 let rest = remove_current_pattern eqn in
-	 let pat = current_pattern eqn in
-	 match check_and_adjust_constructor pb.env ind cstrs pat with
-	   | PatVar (_,name) ->
-	       (* This is a default clause that we expand *)
-	       for i=1 to Array.length cstrs do
-		 let n = cstrs.(i-1).cs_nargs in
-		 let args = make_anonymous_patvars n in
-		 brs.(i-1) <- (args, rest) :: brs.(i-1)
-	       done
-	   | PatCstr (loc,((_,i)),args,_) ->
-	       (* This is a regular clause *)
-	       only_default := false;
-	       brs.(i-1) <- (args,rest) :: brs.(i-1)) mat () in
-  (brs,!only_default)
-
-(************************************************************************)
-(* Here starts the pattern-matching compilation algorithm *)
-
-(* Abstracting over dependent subterms to match *)
-let rec generalize_problem pb = function
-  | [] -> pb
-  | i::l ->
-      let d = map_rel_declaration (lift i) (Environ.lookup_rel i pb.env) in
-      let pb' = generalize_problem pb l in
-      let tomatch = lift_tomatch_stack 1 pb'.tomatch in
-      let tomatch = regeneralize_index_tomatch (i+1) tomatch in
-      { pb with
-	  tomatch = Abstract d :: tomatch;
-          pred = Option.map (generalize_predicate i d) pb'.pred }
-
-(* No more patterns: typing the right-hand side of equations *)
-let build_leaf pb =
-  let rhs = extract_rhs pb in
-  let tycon = match pb.pred with
-    | None -> anomaly "Predicate not found"
-    | Some (PrCcl typ) -> mk_tycon typ
-    | Some _ -> anomaly "not all parameters of pred have been consumed" in
-    pb.typing_function tycon rhs.rhs_env rhs.it
-
-(* Building the sub-problem when all patterns are variables *)
-let shift_problem (current,t) pb =
-  {pb with
-     tomatch = Alias (current,current,NonDepAlias,type_of_tomatch t)::pb.tomatch;
-     pred = Option.map (specialize_predicate_var (current,t)) pb.pred;
-     history = push_history_pattern 0 AliasLeaf pb.history;
-     mat = List.map remove_current_pattern pb.mat }
-
-(* Building the sub-pattern-matching problem for a given branch *)
-let build_branch current deps pb eqns const_info =
-  (* We remember that we descend through a constructor *)
-  let alias_type =
-    if Array.length const_info.cs_concl_realargs = 0
-      & not (known_dependent pb.pred) & deps = []
-    then
-      NonDepAlias
-    else
-      DepAlias
-  in
-  let history =
-    push_history_pattern const_info.cs_nargs
-      (AliasConstructor const_info.cs_cstr)
-      pb.history in
-
-  (* We find matching clauses *)
-  let cs_args = (*assums_of_rel_context*) const_info.cs_args in
-  let names = get_names pb.env cs_args eqns in
-  let submat = List.map (fun (tms,eqn) -> prepend_pattern tms eqn) eqns in
-  if submat = [] then
-    raise_pattern_matching_error
-      (dummy_loc, pb.env, NonExhaustive (complete_history history));
-  let typs = List.map2 (fun (_,c,t) na -> (na,c,t)) cs_args names in
-  let _,typs',_ =
-    List.fold_right
-      (fun (na,c,t as d) (env,typs,tms) ->
-	 let tm1 = List.map List.hd tms in
-	 let tms = List.map List.tl tms in
- 	 (push_rel d env, (na,to_mutind env pb.isevars tm1 c t)::typs,tms))
-      typs (pb.env,[],List.map fst eqns) in
-
-  let dep_sign =
-    find_dependencies_signature
-      (dependencies_in_rhs const_info.cs_nargs eqns) (List.rev typs) in
-
-  (* The dependent term to subst in the types of the remaining UnPushed
-     terms is relative to the current context enriched by topushs *)
-  let ci = build_dependent_constructor const_info in
-
-  (* We replace [(mkRel 1)] by its expansion [ci] *)
-  (* and context "Gamma = Gamma1, current, Gamma2" by "Gamma;typs;curalias" *)
-  (* This is done in two steps : first from "Gamma |- tms" *)
-  (* into  "Gamma; typs; curalias |- tms" *)
-  let tomatch = lift_tomatch_stack const_info.cs_nargs pb.tomatch in
-
-  let currents =
-    list_map2_i
-      (fun i (na,t) deps -> Pushed ((mkRel i, lift_tomatch_type i t), deps))
-      1 typs' (List.rev dep_sign) in
-
-  let sign = List.map (fun (na,t) -> mkDeclTomatch na t) typs' in
-  let ind =
-    appvect (
-      applist (mkInd (inductive_of_constructor const_info.cs_cstr),
-      List.map (lift const_info.cs_nargs) const_info.cs_params),
-      const_info.cs_concl_realargs) in
-
-  let cur_alias = lift (List.length sign) current in
-  let currents = Alias (ci,cur_alias,alias_type,ind) :: currents in
-  let env' = push_rels sign pb.env in
-  let pred' = Option.map (specialize_predicate (List.rev typs') dep_sign const_info) pb.pred in
-    sign,
-  { pb with
-      env = env';
-      tomatch = List.rev_append currents tomatch;
-      pred = pred';
-      history = history;
-      mat = List.map (push_rels_eqn_with_names sign) submat }
-
-(**********************************************************************
- INVARIANT:
-
-  pb = { env, subst, tomatch, mat, ...}
-  tomatch = list of Pushed (c:T) or Abstract (na:T) or Alias (c:T)
-
-  "Pushed" terms and types are relative to env
-  "Abstract" types are relative to env enriched by the previous terms to match
-
-*)
-
-(**********************************************************************)
-(* Main compiling descent *)
-let rec compile pb =
-  match pb.tomatch with
-    | (Pushed cur)::rest -> match_current { pb with tomatch = rest } cur
-    | (Alias x)::rest -> compile_alias pb x rest
-    | (Abstract d)::rest -> compile_generalization pb d rest
-    | [] -> build_leaf pb
-
-and match_current pb tomatch =
-  let ((current,typ as ct),deps) = adjust_tomatch_to_pattern pb tomatch in
-  match typ with
-    | NotInd (_,typ) ->
-	check_all_variables typ pb.mat;
-	compile (shift_problem ct pb)
-    | IsInd (_,(IndType(indf,realargs) as indt)) ->
-	let mind,_ = dest_ind_family indf in
-	let cstrs = get_constructors pb.env indf in
-	let eqns,onlydflt = group_equations pb mind current cstrs pb.mat in
-	if (Array.length cstrs <> 0 or pb.mat <> []) & onlydflt  then
-	  compile (shift_problem ct pb)
-	else
-          let _constraints = Array.map (solve_constraints indt) cstrs in
-
-	  (* We generalize over terms depending on current term to match *)
-	  let pb = generalize_problem pb deps in
-
-	  (* We compile branches *)
-	  let brs = array_map2 (compile_branch current deps pb) eqns cstrs in
-
-	  (* We build the (elementary) case analysis *)
-	  let brvals = Array.map (fun (v,_) -> v) brs in
-	  let brtyps = Array.map (fun (_,t) -> t) brs in
-	  let (pred,typ,s) =
-	    find_predicate pb.caseloc pb.env pb.isevars
-	      pb.pred brtyps cstrs current indt pb.tomatch in
-	  let ci = make_case_info pb.env mind pb.casestyle in
-	  let case = mkCase (ci,nf_betaiota Evd.empty pred,current,brvals) in
-	  let inst = List.map mkRel deps in
-	  { uj_val = applist (case, inst);
-	    uj_type = substl inst typ }
-
-and compile_branch current deps pb eqn cstr =
-  let sign, pb = build_branch current deps pb eqn cstr in
-  let j = compile pb in
-  (it_mkLambda_or_LetIn j.uj_val sign, j.uj_type)
-
-and compile_generalization pb d rest =
-  let pb =
-    { pb with
-       env = push_rel d pb.env;
-       tomatch = rest;
-       pred = Option.map ungeneralize_predicate pb.pred;
-       mat = List.map (push_rels_eqn [d]) pb.mat } in
-  let j = compile pb in
-  { uj_val = mkLambda_or_LetIn d j.uj_val;
-    uj_type = mkProd_or_LetIn d j.uj_type }
-
-and compile_alias pb (deppat,nondeppat,d,t) rest =
-  let history = simplify_history pb.history in
-  let sign, newenv, mat =
-    insert_aliases pb.env ( !(pb.isevars)) (deppat,nondeppat,d,t) pb.mat in
-  let n = List.length sign in
-
-  (* We had Gamma1; x:current; Gamma2 |- tomatch(x) and we rebind x to get *)
-  (* Gamma1; x:current; Gamma2; typs; x':=curalias |- tomatch(x') *)
-  let tomatch = lift_tomatch_stack n rest in
-  let tomatch = match kind_of_term nondeppat with
-    | Rel i ->
-	if n = 1 then regeneralize_index_tomatch (i+n) tomatch
-	else replace_tomatch i deppat tomatch
-    | _ -> (* initial terms are not dependent *) tomatch in
-
-  let pb =
-    {pb with
-       env = newenv;
-       tomatch = tomatch;
-       pred = Option.map (lift_predicate n) pb.pred;
-       history = history;
-       mat = mat } in
-  let j = compile pb in
-  List.fold_left mkSpecialLetInJudge j sign
-
-(* pour les alias des initiaux, enrichir les env de ce qu'il faut et
-substituer après par les initiaux *)
-
-(**************************************************************************)
-(* Preparation of the pattern-matching problem                            *)
-
-(* builds the matrix of equations testing that each eqn has n patterns
- * and linearizing the _ patterns.
- * Syntactic correctness has already been done in astterm *)
-let matx_of_eqns env eqns =
-  let build_eqn (loc,ids,lpat,rhs) =
-    let rhs =
-      { rhs_env = env;
-	avoid_ids = ids@(ids_of_named_context (named_context env));
-	it = rhs;
-      } in
-    { patterns = lpat;
-      alias_stack = [];
-      eqn_loc = loc;
-      used = ref false;
-      rhs = rhs }
-  in List.map build_eqn eqns
-
-(************************************************************************)
-(* preparing the elimination predicate if any                          *)
-
-let oldprepare_predicate_from_tycon loc dep env isevars tomatchs sign c =
-  let cook (n, l, env, signs) = function
-    | c,IsInd (_,IndType(indf,realargs)) ->
-	let indf' = lift_inductive_family n indf in
-	let sign = make_arity_signature env dep indf' in
-	let p = List.length realargs in
-	if dep then
-	  (n + p + 1, c::(List.rev realargs)@l, push_rels sign env,sign::signs)
-	else
-	  (n + p, (List.rev realargs)@l, push_rels sign env,sign::signs)
-    | c,NotInd _ ->
-	(n, l, env, []::signs) in
-  let n, allargs, env, signs = List.fold_left cook (0, [], env, []) tomatchs in
-  let names = List.rev (List.map (List.map pi1) signs) in
-  let allargs =
-    List.map (fun c -> lift n (nf_betadeltaiota env ( !isevars) c)) allargs in
-  let rec build_skeleton env c =
-    (* Don't put into normal form, it has effects on the synthesis of evars *)
- (* let c = whd_betadeltaiota env ( isevars) c in *)
-    (* We turn all subterms possibly dependent into an evar with maximum ctxt*)
-    if isEvar c or List.exists (eq_constr c) allargs then
-      e_new_evar isevars env  ~src:(loc, Evd.CasesType)
-        (Retyping.get_type_of env ( !isevars) c)
-    else
-      map_constr_with_full_binders push_rel build_skeleton env c
-  in
-    names, build_skeleton env (lift n c)
-
-(* Here, [pred] is assumed to be in the context built from all *)
-(* realargs and terms to match *)
-let build_initial_predicate isdep allnames pred =
-  let nar = List.fold_left (fun n names -> List.length names + n) 0 allnames in
-  let rec buildrec n pred = function
-    | [] -> PrCcl pred
-    | names::lnames ->
-        let names' = if isdep then List.tl names else names in
-        let n' = n + List.length names' in
-        let pred, p, user_p =
-          if isdep then
-            if dependent (mkRel (nar-n')) pred then pred, 1, 1
-            else liftn (-1) (nar-n') pred, 0, 1
-          else pred, 0, 0 in
-        let na =
-          if p=1 then
-            let na = List.hd names in
-            if na = Anonymous then
-              (* peut arriver en raison des evars *)
-              Name (id_of_string "x") (*Hum*)
-            else na
-          else Anonymous in
-        PrLetIn ((names',na), buildrec (n'+user_p) pred lnames)
-  in buildrec 0 pred allnames
-
-let extract_arity_signature env0 tomatchl tmsign =
-  let get_one_sign n tm (na,t) =
-    match tm with
-      | NotInd (bo,typ) ->
-	  (match t with
-	    | None -> [na,Option.map (lift n) bo,lift n typ]
-	    | Some (loc,_,_,_) ->
- 	    user_err_loc (loc,"",
-	    str "Unexpected type annotation for a term of non inductive type"))
-      | IsInd (_,IndType(indf,realargs)) ->
-          let indf' = lift_inductive_family n indf in
-	  let (ind,params) = dest_ind_family indf' in
-	  let nrealargs = List.length realargs in
-	  let realnal =
-	    match t with
-	      | Some (loc,ind',nparams,realnal) ->
-		  if ind <> ind' then
-		    user_err_loc (loc,"",str "Wrong inductive type");
-		  if List.length params <> nparams
-		    or nrealargs <> List.length realnal then
-		      anomaly "Ill-formed 'in' clause in cases";
-		  List.rev realnal
-	      | None -> list_tabulate (fun _ -> Anonymous) nrealargs in
-	  let arsign = fst (get_arity env0 indf') in
-	  (na,None,build_dependent_inductive env0 indf')
-	  ::(List.map2 (fun x (_,c,t) ->(x,c,t)) realnal arsign) in
-  let rec buildrec n = function
-    | [],[] -> []
-    | (_,tm)::ltm, x::tmsign ->
-	let l = get_one_sign n tm x in
-	l :: buildrec (n + List.length l) (ltm,tmsign)
-    | _ -> assert false
-  in List.rev (buildrec 0 (tomatchl,tmsign))
-
-let extract_arity_signatures env0 tomatchl tmsign =
-  let get_one_sign tm (na,t) =
-    match tm with
-      | NotInd (bo,typ) ->
-	  (match t with
-	    | None -> [na,bo,typ]
-	    | Some (loc,_,_,_) ->
- 	    user_err_loc (loc,"",
-	    str "Unexpected type annotation for a term of non inductive type"))
-      | IsInd (_,IndType(indf,realargs)) ->
-	  let (ind,params) = dest_ind_family indf in
-	  let nrealargs = List.length realargs in
-	  let realnal =
-	    match t with
-	      | Some (loc,ind',nparams,realnal) ->
-		  if ind <> ind' then
-		    user_err_loc (loc,"",str "Wrong inductive type");
-		  if List.length params <> nparams
-		    or nrealargs <> List.length realnal then
-		      anomaly "Ill-formed 'in' clause in cases";
-		  List.rev realnal
-	      | None -> list_tabulate (fun _ -> Anonymous) nrealargs in
-	  let arsign = fst (get_arity env0 indf) in
-	    (na,None,build_dependent_inductive env0 indf)
-	    ::(try List.map2 (fun x (_,c,t) ->(x,c,t)) realnal arsign
-              with e when Errors.noncritical e -> assert false) in
-  let rec buildrec = function
-    | [],[] -> []
-    | (_,tm)::ltm, x::tmsign ->
-	let l = get_one_sign tm x in
-	  l :: buildrec (ltm,tmsign)
-    | _ -> assert false
-  in List.rev (buildrec (tomatchl,tmsign))
-
-let inh_conv_coerce_to_tycon loc env isevars j tycon =
-  match tycon with
-    | Some p ->
-	let (evd',j) = Coercion.inh_conv_coerce_to true loc env !isevars j p in
-          isevars := evd';
-          j
-    | None -> j
-
-let out_ind = function IsInd (_, IndType(x, y)) -> (x, y) | _ -> assert(false)
-
-let string_of_name name =
-  match name with
-    | Anonymous -> "anonymous"
-    | Name n -> string_of_id n
-
-let id_of_name n = id_of_string (string_of_name n)
-
-let make_prime_id name =
-  let str = string_of_name name in
-    id_of_string str, id_of_string (str ^ "'")
-
-let prime avoid name =
-  let previd, id = make_prime_id name in
-    previd, next_ident_away id avoid
-
-let make_prime avoid prevname =
-  let previd, id = prime !avoid prevname in
-    avoid := id :: !avoid;
-    previd, id
-
-let eq_id avoid id =
-  let hid = id_of_string ("Heq_" ^ string_of_id id) in
-  let hid' = next_ident_away hid avoid in
-    hid'
-
-let mk_eq typ x y = mkApp (delayed_force eq_ind, [| typ; x ; y |])
-let mk_eq_refl typ x = mkApp (delayed_force eq_refl, [| typ; x |])
-let mk_JMeq typ x typ' y =
-  mkApp (delayed_force Subtac_utils.jmeq_ind, [| typ; x ; typ'; y |])
-let mk_JMeq_refl typ x = mkApp (delayed_force Subtac_utils.jmeq_refl, [| typ; x |])
-
-let hole = GHole (dummy_loc, Evd.QuestionMark (Evd.Define true))
-
-let constr_of_pat env isevars arsign pat avoid =
-  let rec typ env (ty, realargs) pat avoid =
-    match pat with
-    | PatVar (l,name) ->
-	let name, avoid = match name with
-	    Name n -> name, avoid
-	  | Anonymous ->
-	      let previd, id = prime avoid (Name (id_of_string "wildcard")) in
-		Name id, id :: avoid
-	in
-	  PatVar (l, name), [name, None, ty] @ realargs, mkRel 1, ty, (List.map (fun x -> mkRel 1) realargs), 1, avoid
-    | PatCstr (l,((_, i) as cstr),args,alias) ->
-	let cind = inductive_of_constructor cstr in
-	let IndType (indf, _) = 
-	  try find_rectype env ( !isevars) (lift (-(List.length realargs)) ty)
-	  with Not_found -> error_case_not_inductive env 
-	    {uj_val = ty; uj_type = Typing.type_of env !isevars ty}
-	in
-	let ind, params = dest_ind_family indf in
-	if ind <> cind then error_bad_constructor_loc l cstr ind;
-	let cstrs = get_constructors env indf in
-	let ci = cstrs.(i-1) in
-	let nb_args_constr = ci.cs_nargs in
-	assert(nb_args_constr = List.length args);
-	let patargs, args, sign, env, n, m, avoid =
-	  List.fold_right2
-	    (fun (na, c, t) ua (patargs, args, sign, env, n, m, avoid)  ->
-	       let pat', sign', arg', typ', argtypargs, n', avoid =
-		 typ env (substl args (liftn (List.length sign) (succ (List.length args)) t), []) ua avoid
-	       in
-	       let args' = arg' :: List.map (lift n') args in
-	       let env' = push_rels sign' env in
-		 (pat' :: patargs, args', sign' @ sign, env', n' + n, succ m, avoid))
-	    ci.cs_args (List.rev args) ([], [], [], env, 0, 0, avoid)
-	in
-	let args = List.rev args in
-	let patargs = List.rev patargs in
-	let pat' = PatCstr (l, cstr, patargs, alias) in
-	let cstr = mkConstruct ci.cs_cstr in
-	let app = applistc cstr (List.map (lift (List.length sign)) params) in
-	let app = applistc app args in
-	let apptype = Retyping.get_type_of env ( !isevars) app in
-	let IndType (indf, realargs) = find_rectype env ( !isevars) apptype in
-	  match alias with
-	      Anonymous ->
-		pat', sign, app, apptype, realargs, n, avoid
-	    | Name id ->
-		let sign = (alias, None, lift m ty) :: sign in
-		let avoid = id :: avoid in
-		let sign, i, avoid =
-		  try
-		    let env = push_rels sign env in
-		    isevars := the_conv_x_leq (push_rels sign env) (lift (succ m) ty) (lift 1 apptype) !isevars;
-		    let eq_t = mk_eq (lift (succ m) ty)
-		      (mkRel 1) (* alias *)
-		      (lift 1 app) (* aliased term *)
-		    in
-		    let neq = eq_id avoid id in
-		      (Name neq, Some (mkRel 0), eq_t) :: sign, 2, neq :: avoid
-		  with Reduction.NotConvertible -> sign, 1, avoid
-		in
-		  (* Mark the equality as a hole *)
-		  pat', sign, lift i app, lift i apptype, realargs, n + i, avoid
-  in
-  let pat', sign, patc, patty, args, z, avoid = typ env (pi3 (List.hd arsign), List.tl arsign) pat avoid in
-    pat', (sign, patc, (pi3 (List.hd arsign), args), pat'), avoid
-
-
-(* shadows functional version *)
-let eq_id avoid id =
-  let hid = id_of_string ("Heq_" ^ string_of_id id) in
-  let hid' = next_ident_away hid !avoid in
-    avoid := hid' :: !avoid;
-    hid'
-
-let rels_of_patsign =
-  List.map (fun ((na, b, t) as x) ->
-    match b with
-      | Some t' when kind_of_term t' = Rel 0 -> (na, None, t)
-      | _ -> x)
-
-let vars_of_ctx ctx =
-  let _, y =
-    List.fold_right (fun (na, b, t)  (prev, vars) ->
-      match b with
-	| Some t' when kind_of_term t' = Rel 0 ->
-	    prev,
-	    (GApp (dummy_loc,
-		(GRef (dummy_loc, delayed_force refl_ref)), [hole; GVar (dummy_loc, prev)])) :: vars
-	| _ ->
-	    match na with
-		Anonymous -> raise (Invalid_argument "vars_of_ctx")
-	      | Name n -> n, GVar (dummy_loc, n) :: vars)
-      ctx (id_of_string "vars_of_ctx_error", [])
-  in List.rev y
-
-let rec is_included x y =
-  match x, y with
-    | PatVar _, _ -> true
-    | _, PatVar _ -> true
-    | PatCstr (l, (_, i), args, alias), PatCstr (l', (_, i'), args', alias')  ->
-	if i = i' then List.for_all2 is_included args args'
-	else false
-
-(* liftsign is the current pattern's complete signature length. Hence pats is already typed in its
-   full signature. However prevpatterns are in the original one signature per pattern form.
- *)
-let build_ineqs prevpatterns pats liftsign =
-  let _tomatchs = List.length pats in
-  let diffs =
-    List.fold_left
-      (fun c eqnpats ->
-	  let acc = List.fold_left2
-	    (* ppat is the pattern we are discriminating against, curpat is the current one. *)
-	    (fun acc (ppat_sign, ppat_c, (ppat_ty, ppat_tyargs), ppat)
-	      (curpat_sign, curpat_c, (curpat_ty, curpat_tyargs), curpat) ->
-	      match acc with
-		  None -> None
-		| Some (sign, len, n, c) -> (* FixMe: do not work with ppat_args *)
-		    if is_included curpat ppat then
-		      (* Length of previous pattern's signature *)
-		      let lens = List.length ppat_sign in
-		      (* Accumulated length of previous pattern's signatures *)
-		      let len' = lens + len in
-		      let acc =
-			((* Jump over previous prevpat signs *)
-			  lift_rel_context len ppat_sign @ sign,
-			  len',
-			  succ n, (* nth pattern *)
-			  mkApp (delayed_force eq_ind,
-				[| lift (len' + liftsign) curpat_ty;
-				   liftn (len + liftsign) (succ lens) ppat_c ;
-				   lift len' curpat_c |]) ::
-			    List.map (lift lens (* Jump over this prevpat signature *)) c)
-		      in Some acc
-		    else None)
-	   (Some ([], 0, 0, [])) eqnpats pats
-	 in match acc with
-	     None -> c
-	   | Some (sign, len, _, c') ->
-	       let conj = it_mkProd_or_LetIn (mk_not (mk_conj c'))
-		 (lift_rel_context liftsign sign)
-	       in
-		 conj :: c)
-      [] prevpatterns
-  in match diffs with [] -> None
-    | _ -> Some (mk_conj diffs)
-
-let subst_rel_context k ctx subst =
-  let (_, ctx') =
-    List.fold_right
-      (fun (n, b, t) (k, acc) ->
-	 (succ k, (n, Option.map (substnl subst k) b, substnl subst k t) :: acc))
-      ctx (k, [])
-  in ctx'
-
-let lift_rel_contextn n k sign =
-  let rec liftrec k = function
-    | (na,c,t)::sign ->
-	(na,Option.map (liftn n k) c,liftn n k t)::(liftrec (k-1) sign)
-    | [] -> []
-  in
-  liftrec (rel_context_length sign + k) sign
-
-let constrs_of_pats typing_fun env isevars eqns tomatchs sign neqs arity =
-  let i = ref 0 in
-  let (x, y, z) =
-    List.fold_left
-      (fun (branches, eqns, prevpatterns) eqn ->
-	 let _, newpatterns, pats =
-	   List.fold_left2
-	     (fun (idents, newpatterns, pats) pat arsign ->
-		let pat', cpat, idents = constr_of_pat env isevars arsign pat idents in
-		  (idents, pat' :: newpatterns, cpat :: pats))
-	      ([], [], []) eqn.patterns sign
-	 in
-	 let newpatterns = List.rev newpatterns and opats = List.rev pats in
-	 let rhs_rels, pats, signlen =
-	   List.fold_left
-	     (fun (renv, pats, n) (sign,c, (s, args), p) ->
-	       (* Recombine signatures and terms of all of the row's patterns *)
-	       let sign' = lift_rel_context n sign in
-	       let len = List.length sign' in
-		 (sign' @ renv,
-		 (* lift to get outside of previous pattern's signatures. *)
-		 (sign', liftn n (succ len) c, (s, List.map (liftn n (succ len)) args), p) :: pats,
-		 len + n))
-	     ([], [], 0) opats in
-	 let pats, _ = List.fold_left
-	   (* lift to get outside of past patterns to get terms in the combined environment. *)
-	   (fun (pats, n) (sign, c, (s, args), p) ->
-	     let len = List.length sign in
-	       ((rels_of_patsign sign, lift n c, (s, List.map (lift n) args), p) :: pats, len + n))
-	   ([], 0) pats
-	 in
-	 let ineqs = build_ineqs prevpatterns pats signlen in
-	 let rhs_rels' = rels_of_patsign rhs_rels in
-	 let _signenv = push_rel_context rhs_rels' env in
-	 let arity =
-	   let args, nargs =
-	     List.fold_right (fun (sign, c, (_, args), _) (allargs,n) ->
-	       (args @ c :: allargs, List.length args + succ n))
-	       pats ([], 0)
-	   in
-	   let args = List.rev args in
-	     substl args (liftn signlen (succ nargs) arity)
-	 in
-	 let rhs_rels', tycon =
-	   let neqs_rels, arity =
-	     match ineqs with
-	     | None -> [], arity
-	     | Some ineqs ->
-		 [Anonymous, None, ineqs], lift 1 arity
-	   in
-	   let eqs_rels, arity = decompose_prod_n_assum neqs arity in
-	     eqs_rels @ neqs_rels @ rhs_rels', arity
-	 in
-	 let rhs_env = push_rels rhs_rels' env in
-	 let j = typing_fun (mk_tycon tycon) rhs_env eqn.rhs.it in
-	 let bbody = it_mkLambda_or_LetIn j.uj_val rhs_rels'
-	 and btype = it_mkProd_or_LetIn j.uj_type rhs_rels' in
-	 let branch_name = id_of_string ("program_branch_" ^ (string_of_int !i)) in
-	 let branch_decl = (Name branch_name, Some (lift !i bbody), (lift !i btype)) in
-	 let branch =
-	   let bref = GVar (dummy_loc, branch_name) in
-	     match vars_of_ctx rhs_rels with
-		 [] -> bref
-	       | l -> GApp (dummy_loc, bref, l)
-	 in
-	 let branch = match ineqs with
-	     Some _ -> GApp (dummy_loc, branch, [ hole ])
-	   | None -> branch
-	 in
-	 incr i;
-	 let rhs = { eqn.rhs with it = branch } in
-	   (branch_decl :: branches,
-	   { eqn with patterns = newpatterns; rhs = rhs } :: eqns,
-	   opats :: prevpatterns))
-      ([], [], []) eqns
-  in x, y
-
-(* Builds the predicate. If the predicate is dependent, its context is
- * made of 1+nrealargs assumptions for each matched term in an inductive
- * type and 1 assumption for each term not _syntactically_ in an
- * inductive type.
-
- * Each matched terms are independently considered dependent or not.
-
- * A type constraint but no annotation case: it is assumed non dependent.
- *)
-
-let lift_ctx n ctx =
-  let ctx', _ =
-    List.fold_right (fun (c, t) (ctx, n') -> (liftn n n' c, liftn_tomatch_type n n' t) :: ctx, succ n') ctx ([], 0)
-  in ctx'
-
-(* Turn matched terms into variables. *)
-let abstract_tomatch env tomatchs tycon =
-  let prev, ctx, names, tycon =
-    List.fold_left
-      (fun (prev, ctx, names, tycon) (c, t) ->
-	 let lenctx =  List.length ctx in
-	 match kind_of_term c with
-	     Rel n -> (lift lenctx c, lift_tomatch_type lenctx t) :: prev, ctx, names, tycon
-	   | _ ->
-	       let tycon = Option.map
-		 (fun t -> subst_term (lift 1 c) (lift 1 t)) tycon in
-	       let name = next_ident_away (id_of_string "filtered_var") names in
-		 (mkRel 1, lift_tomatch_type (succ lenctx) t) :: lift_ctx 1 prev,
-	       (Name name, Some (lift lenctx c), lift lenctx $ type_of_tomatch t) :: ctx,
-	       name :: names, tycon)
-      ([], [], [], tycon) tomatchs
-  in List.rev prev, ctx, tycon
-
-let is_dependent_ind = function
-    IsInd (_, IndType (indf, args)) when List.length args > 0 -> true
-  | _ -> false
-
-let build_dependent_signature env evars avoid tomatchs arsign =
-  let avoid = ref avoid in
-  let arsign = List.rev arsign in
-  let allnames = List.rev (List.map (List.map pi1) arsign) in
-  let nar = List.fold_left (fun n names -> List.length names + n) 0 allnames in
-  let eqs, neqs, refls, slift, arsign' =
-    List.fold_left2
-      (fun (eqs, neqs, refl_args, slift, arsigns) (tm, ty) arsign ->
-	 (* The accumulator:
-	    previous eqs,
-	    number of previous eqs,
-	    lift to get outside eqs and in the introduced variables ('as' and 'in'),
-	    new arity signatures
-	 *)
-	 match ty with
-	     IsInd (ty, IndType (indf, args)) when List.length args > 0 ->
-	       (* Build the arity signature following the names in matched terms as much as possible *)
-	       let argsign = List.tl arsign in (* arguments in inverse application order *)
-	       let (appn, appb, appt) as _appsign = List.hd arsign in (* The matched argument *)
-	       let argsign = List.rev argsign in (* arguments in application order *)
-	       let env', nargeqs, argeqs, refl_args, slift, argsign' =
-		 List.fold_left2
-		   (fun (env, nargeqs, argeqs, refl_args, slift, argsign') arg (name, b, t) ->
-		      let argt = Retyping.get_type_of env evars arg in
-		      let eq, refl_arg =
-			if Reductionops.is_conv env evars argt t then
-			  (mk_eq (lift (nargeqs + slift) argt)
-			     (mkRel (nargeqs + slift))
-			     (lift (nargeqs + nar) arg),
-			   mk_eq_refl argt arg)
-			else
-			  (mk_JMeq (lift (nargeqs + slift) t)
-			     (mkRel (nargeqs + slift))
-			     (lift (nargeqs + nar) argt)
-			     (lift (nargeqs + nar) arg),
-			   mk_JMeq_refl argt arg)
-		      in
-		      let previd, id =
-			let name =
-			  match kind_of_term arg with
-			      Rel n -> pi1 (lookup_rel n env)
-			    | _ -> name
-			in
-			  make_prime avoid name
-		      in
-			(env, succ nargeqs,
-			 (Name (eq_id avoid previd), None, eq) :: argeqs,
-			 refl_arg :: refl_args,
-			 pred slift,
-			 (Name id, b, t) :: argsign'))
-		   (env, neqs, [], [], slift, []) args argsign
-	       in
-	       let eq = mk_JMeq
-		 (lift (nargeqs + slift) appt)
-		 (mkRel (nargeqs + slift))
-		 (lift (nargeqs + nar) ty)
-		 (lift (nargeqs + nar) tm)
-	       in
-	       let refl_eq = mk_JMeq_refl ty tm in
-	       let previd, id = make_prime avoid appn in
-		 (((Name (eq_id avoid previd), None, eq) :: argeqs) :: eqs,
-		 succ nargeqs,
-		 refl_eq :: refl_args,
-		 pred slift,
-		 (((Name id, appb, appt) :: argsign') :: arsigns))
-
-	   | _ ->
-	       (* Non dependent inductive or not inductive, just use a regular equality *)
-	       let (name, b, typ) = match arsign with [x] -> x | _ -> assert(false) in
-	       let previd, id = make_prime avoid name in
-	       let arsign' = (Name id, b, typ) in
-	       let tomatch_ty = type_of_tomatch ty in
-	       let eq =
-		 mk_eq (lift nar tomatch_ty)
-		   (mkRel slift) (lift nar tm)
-	       in
-		 ([(Name (eq_id avoid previd), None, eq)] :: eqs, succ neqs,
-		  (mk_eq_refl tomatch_ty tm) :: refl_args,
-		  pred slift, (arsign' :: []) :: arsigns))
-      ([], 0, [], nar, []) tomatchs arsign
-  in
-  let arsign'' = List.rev arsign' in
-    assert(slift = 0); (* we must have folded over all elements of the arity signature *)
-    arsign'', allnames, nar, eqs, neqs, refls
-
-(**************************************************************************)
-(* Main entry of the matching compilation                                 *)
-
-let liftn_rel_context n k sign =
-  let rec liftrec k = function
-    | (na,c,t)::sign ->
-	(na,Option.map (liftn n k) c,liftn n k t)::(liftrec (k-1) sign)
-    | [] -> []
-  in
-    liftrec (k + rel_context_length sign) sign
-
-let nf_evars_env sigma (env : env) : env =
-  let nf t = nf_evar sigma t in
-  let env0 : env = reset_context env in
-  let f e (na, b, t) e' : env =
-    Environ.push_named (na, Option.map nf b, nf t) e'
-  in
-  let env' = Environ.fold_named_context f ~init:env0 env in
-    Environ.fold_rel_context (fun e (na, b, t) e' -> Environ.push_rel (na, Option.map nf b, nf t) e')
-     ~init:env' env
-
-
-let prepare_predicate_from_rettyp loc typing_fun isevars env tomatchs sign tycon rtntyp =
-  (* We extract the signature of the arity *)
-  let arsign = extract_arity_signature env tomatchs sign in
-  let newenv = List.fold_right push_rels arsign env in
-  let allnames = List.rev (List.map (List.map pi1) arsign) in
-    match rtntyp with
-      | Some rtntyp ->
-	  let predcclj = typing_fun (mk_tycon (new_Type ())) newenv rtntyp in
-	  let predccl = (j_nf_evar !isevars predcclj).uj_val in
-	    Some (build_initial_predicate true allnames predccl)
-      | None ->
-	  match valcon_of_tycon tycon with
-	    | Some ty ->
-		let pred =
-		  prepare_predicate_from_arsign_tycon loc env !isevars tomatchs arsign ty
-		in Some (build_initial_predicate true allnames pred)
-	    | None -> None
-
-let compile_cases loc style (typing_fun, isevars) (tycon : Evarutil.type_constraint) env (predopt, tomatchl, eqns) =
-
-  let typing_fun tycon env = typing_fun tycon env isevars in
-
-  (* We build the matrix of patterns and right-hand side *)
-  let matx = matx_of_eqns env eqns in
-
-  (* We build the vector of terms to match consistently with the *)
-  (* constructors found in patterns *)
-  let tomatchs = coerce_to_indtype typing_fun isevars env matx tomatchl in
-  let _isdep = List.exists (fun (x, y) -> is_dependent_ind y) tomatchs in
-    if predopt = None then
-      let tycon = valcon_of_tycon tycon in
-      let tomatchs, tomatchs_lets, tycon' = abstract_tomatch env tomatchs tycon in
-      let env = push_rel_context tomatchs_lets env in
-      let len = List.length eqns in
-      let sign, allnames, signlen, eqs, neqs, args =
-	(* The arity signature *)
-	let arsign = extract_arity_signatures env tomatchs (List.map snd tomatchl) in
-	  (* Build the dependent arity signature, the equalities which makes
-	     the first part of the predicate and their instantiations. *)
-	let avoid = [] in
-	  build_dependent_signature env ( !isevars) avoid tomatchs arsign
-
-      in
-      let tycon, arity =
-	match tycon' with
-	| None -> let ev = mkExistential env isevars in ev, ev
-	| Some t ->
-	    Option.get tycon, prepare_predicate_from_arsign_tycon loc env ( !isevars)
-	      tomatchs sign t
-      in
-      let neqs, arity =
-	let ctx = context_of_arsign eqs in
-	let neqs = List.length ctx in
-	  neqs, it_mkProd_or_LetIn (lift neqs arity) ctx
-      in
-      let lets, matx =
-	(* Type the rhs under the assumption of equations *)
-	constrs_of_pats typing_fun env isevars matx tomatchs sign neqs arity
-      in
-      let matx = List.rev matx in
-      let _ = assert(len = List.length lets) in
-      let env = push_rels lets env in
-      let matx = List.map (fun eqn -> { eqn with rhs = { eqn.rhs with rhs_env = env } }) matx in
-      let tomatchs = List.map (fun (x, y) -> lift len x, lift_tomatch_type len y) tomatchs in
-      let args = List.rev_map (lift len) args in
-      let pred = liftn len (succ signlen) arity in
-      let pred = build_initial_predicate true allnames pred in
-
-      (* We push the initial terms to match and push their alias to rhs' envs *)
-      (* names of aliases will be recovered from patterns (hence Anonymous here) *)
-      let initial_pushed = List.map (fun tm -> Pushed (tm,[])) tomatchs in
-
-      let pb =
-	{ env      = env;
-	  isevars  = isevars;
-	  pred     = Some pred;
-	  tomatch  = initial_pushed;
-	  history  = start_history (List.length initial_pushed);
-	  mat      = matx;
-	  caseloc  = loc;
-	  casestyle= style;
-	  typing_function = typing_fun } in
-
-      let j = compile pb in
-	(* We check for unused patterns *)
-	List.iter (check_unused_pattern env) matx;
-	let body = it_mkLambda_or_LetIn (applistc j.uj_val args) lets in
-	let j =
-	  { uj_val = it_mkLambda_or_LetIn body tomatchs_lets;
-	    uj_type = nf_evar !isevars tycon; }
-	in j
-    else
-      (* We build the elimination predicate if any and check its consistency *)
-      (* with the type of arguments to match *)
-      let tmsign = List.map snd tomatchl in
-      let pred = prepare_predicate_from_rettyp loc typing_fun isevars env tomatchs tmsign tycon predopt in
-
-      (* We push the initial terms to match and push their alias to rhs' envs *)
-      (* names of aliases will be recovered from patterns (hence Anonymous here) *)
-      let initial_pushed = List.map (fun tm -> Pushed (tm,[])) tomatchs in
-      let pb =
-	{ env      = env;
-	  isevars  = isevars;
-	  pred     = pred;
-	  tomatch  = initial_pushed;
-	  history  = start_history (List.length initial_pushed);
-	  mat      = matx;
-	  caseloc  = loc;
-	  casestyle= style;
-	  typing_function = typing_fun } in
-
-      let j = compile pb in
-	(* We check for unused patterns *)
-	List.iter (check_unused_pattern env) matx;
-	inh_conv_coerce_to_tycon loc env isevars j tycon
-
-end
-
diff --git a/plugins/subtac/subtac_classes.ml b/plugins/subtac/subtac_classes.ml
deleted file mode 100644
index b0054d82..00000000
--- a/plugins/subtac/subtac_classes.ml
+++ /dev/null
@@ -1,190 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Pretyping
-open Evd
-open Environ
-open Term
-open Glob_term
-open Topconstr
-open Names
-open Libnames
-open Pp
-open Vernacexpr
-open Constrintern
-open Subtac_command
-open Typeclasses
-open Typeclasses_errors
-open Decl_kinds
-open Entries
-open Util
-
-module SPretyping = Subtac_pretyping.Pretyping
-
-let interp_constr_evars_gen evdref env ?(impls=Constrintern.empty_internalization_env) kind c =
-  SPretyping.understand_tcc_evars evdref env kind
-    (intern_gen (kind=IsType) ~impls !evdref env c)
-
-let interp_casted_constr_evars evdref env ?(impls=Constrintern.empty_internalization_env) c typ =
-  interp_constr_evars_gen evdref env ~impls (OfType (Some typ)) c
-
-let interp_context_evars evdref env params =
-  let impls_env, bl = Constrintern.interp_context_gen
-    (fun env t -> SPretyping.understand_tcc_evars evdref env IsType t)
-    (SPretyping.understand_judgment_tcc evdref) !evdref env params in bl
-
-let interp_type_evars_impls ~evdref ?(impls=empty_internalization_env) env c =
-  let c = intern_gen true ~impls !evdref env c in
-  let imps = Implicit_quantifiers.implicits_of_glob_constr ~with_products:true c in
-    SPretyping.understand_tcc_evars ~fail_evar:false evdref env IsType c, imps
-
-let type_ctx_instance evars env ctx inst subst =
-  let rec aux (subst, instctx) l = function
-    (na, b, t) :: ctx ->
-      let t' = substl subst t in
-      let c', l =
-	match b with
-	| None -> interp_casted_constr_evars evars env (List.hd l) t', List.tl l
-	| Some b -> substl subst b, l
-      in
-       evars := resolve_typeclasses ~filter:Subtac_utils.no_goals_or_obligations ~fail:true env !evars;
-       let d = na, Some c', t' in
-	aux (c' :: subst, d :: instctx) l ctx
-    | [] -> subst
-  in aux (subst, []) inst (List.rev ctx)
-
-let new_instance ?(global=false) ctx (instid, bk, cl) props ?(generalize=true) pri =
-  let env = Global.env() in
-  let evars = ref Evd.empty in
-  let tclass, _ =
-    match bk with
-    | Implicit ->
-	Implicit_quantifiers.implicit_application Idset.empty (* need no avoid *)
-	  ~allow_partial:false (fun avoid (clname, (id, _, t)) ->
-	    match clname with
-	    | Some (cl, b) ->
-		let t =
-		  if b then
-		    let _k = class_info cl in
-		      CHole (Util.dummy_loc, Some Evd.InternalHole)
-		  else CHole (Util.dummy_loc, None)
-		in t, avoid
-	    | None -> failwith ("new instance: under-applied typeclass"))
-	  cl
-      | Explicit -> cl, Idset.empty
-  in
-  let tclass = if generalize then CGeneralization (dummy_loc, Implicit, Some AbsPi, tclass) else tclass in
-  let k, cty, ctx', ctx, len, imps, subst =
-    let (env', ctx), imps = interp_context_evars evars env ctx in
-    let c', imps' = interp_type_evars_impls ~evdref:evars env' tclass in
-    let len = List.length ctx in
-    let imps = imps @ Impargs.lift_implicits len imps' in
-    let ctx', c = decompose_prod_assum c' in
-    let ctx'' = ctx' @ ctx in
-    let cl, args = Typeclasses.dest_class_app (push_rel_context ctx'' env) c in
-    let _, args = 
-      List.fold_right (fun (na, b, t) (args, args') ->
-	match b with
-	| None -> (List.tl args, List.hd args :: args')
-	| Some b -> (args, substl args' b :: args'))
-	(snd cl.cl_context) (args, [])
-    in
-      cl, c', ctx', ctx, len, imps, args
-  in
-  let id =
-    match snd instid with
-    | Name id ->
-	let sp = Lib.make_path id in
-	  if Nametab.exists_cci sp then
-	    errorlabstrm "new_instance" (Nameops.pr_id id ++ Pp.str " already exists");
-	  id
-    | Anonymous ->
-	let i = Nameops.add_suffix (Classes.id_of_class k) "_instance_0" in
-	  Namegen.next_global_ident_away i (Termops.ids_of_context env)
-  in
-  evars := resolve_typeclasses ~filter:Subtac_utils.no_goals_or_obligations ~fail:true env !evars;  
-  let ctx = Evarutil.nf_rel_context_evar !evars ctx 
-  and ctx' = Evarutil.nf_rel_context_evar !evars ctx' in
-  let env' = push_rel_context ctx env in
-  let sigma =  !evars in
-  let subst = List.map (Evarutil.nf_evar sigma) subst in
-  let props =
-    match props with
-    | Some (CRecord (loc, _, fs)) ->
-	if List.length fs > List.length k.cl_props then
-	  Classes.mismatched_props env' (List.map snd fs) k.cl_props;
-	Inl fs
-    | Some p -> Inr p
-    | None -> Inl []
-  in
-  let subst =
-    match props with
-    | Inr term ->
-	let c = interp_casted_constr_evars evars env' term cty in
-	  Inr c
-    | Inl props ->
-	let get_id =
-	  function
-	    | Ident id' -> id'
-	    | _ -> errorlabstrm "new_instance" (Pp.str "Only local structures are handled")
-	in
-	let props, rest =
-	  List.fold_left
-	    (fun (props, rest) (id,b,_) ->
-	      if b = None then
-		try
-		  let (loc_mid, c) = List.find (fun (id', _) -> Name (snd (get_id id')) = id) rest in
-		  let rest' = List.filter (fun (id', _) -> Name (snd (get_id id')) <> id) rest in
-		  let (loc, mid) = get_id loc_mid in
-		    List.iter 
-		      (fun (n, _, x) -> 
-			 if n = Name mid then
-			   Option.iter (fun x -> Dumpglob.add_glob loc (ConstRef x)) x)
-		      k.cl_projs;
-		    c :: props, rest'
-		with Not_found ->
-		  (CHole (Util.dummy_loc, None) :: props), rest
-	      else props, rest)
-	    ([], props) k.cl_props
-	in
-	  if rest <> [] then
-	    unbound_method env' k.cl_impl (get_id (fst (List.hd rest)))
-	  else
-	    Inl (type_ctx_instance evars (push_rel_context ctx' env') k.cl_props props subst)
-  in	  
-  evars := Evarutil.nf_evar_map !evars;
-  evars := resolve_typeclasses ~filter:Subtac_utils.no_goals_or_obligations ~fail:true env !evars;
-  evars := resolve_typeclasses ~filter:Typeclasses.no_goals ~fail:false env !evars;
-  let term, termtype =
-    match subst with
-    | Inl subst ->
-	let subst = List.fold_left2
-	  (fun subst' s (_, b, _) -> if b = None then s :: subst' else subst')
-	  [] subst (k.cl_props @ snd k.cl_context)
-	in
-	let app, ty_constr = instance_constructor k subst in
-	let termtype = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in
-	let term = Termops.it_mkLambda_or_LetIn (Option.get app) (ctx' @ ctx) in
-	  term, termtype
-    | Inr def ->
-	let termtype = it_mkProd_or_LetIn cty ctx in
-	let term = Termops.it_mkLambda_or_LetIn def ctx in
-	  term, termtype
-  in
-  let termtype = Evarutil.nf_evar !evars termtype in
-  let term = Evarutil.nf_evar !evars term in
-  evars := undefined_evars !evars;
-  Evarutil.check_evars env Evd.empty !evars termtype;
-  let hook vis gr =
-    let cst = match gr with ConstRef kn -> kn | _ -> assert false in
-      Impargs.declare_manual_implicits false gr ~enriching:false [imps];
-      Typeclasses.declare_instance pri (not global) (ConstRef cst)
-  in
-  let evm = Subtac_utils.evars_of_term !evars Evd.empty term in
-  let obls, _, constr, typ = Eterm.eterm_obligations env id !evars evm 0 term termtype in
-    id, Subtac_obligations.add_definition id ~term:constr typ ~kind:(Global,Instance) ~hook obls
diff --git a/plugins/subtac/subtac_classes.mli b/plugins/subtac/subtac_classes.mli
deleted file mode 100644
index bd3fe484..00000000
--- a/plugins/subtac/subtac_classes.mli
+++ /dev/null
@@ -1,39 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(*i*)
-open Names
-open Decl_kinds
-open Term
-open Sign
-open Evd
-open Environ
-open Nametab
-open Mod_subst
-open Topconstr
-open Util
-open Typeclasses
-open Implicit_quantifiers
-open Classes
-(*i*)
-
-val type_ctx_instance :     Evd.evar_map ref ->
-  Environ.env ->
-    ('a * Term.constr option * Term.constr) list ->
-    Topconstr.constr_expr list ->
-    Term.constr list ->
-    Term.constr list
-
-val new_instance :
-  ?global:bool ->
-  local_binder list ->
-  typeclass_constraint ->
-  constr_expr option ->
-  ?generalize:bool ->
-  int option ->
-  identifier * Subtac_obligations.progress
diff --git a/plugins/subtac/subtac_coercion.ml b/plugins/subtac/subtac_coercion.ml
deleted file mode 100644
index 4fe29ac8..00000000
--- a/plugins/subtac/subtac_coercion.ml
+++ /dev/null
@@ -1,510 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \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 Reductionops
-open Environ
-open Typeops
-open Pretype_errors
-open Classops
-open Recordops
-open Evarutil
-open Evarconv
-open Retyping
-open Evd
-
-open Global
-open Subtac_utils
-open Coqlib
-open Printer
-open Subtac_errors
-open Eterm
-open Pp
-
-let app_opt env evars f t =
-  whd_betaiota !evars (app_opt f t)
-
-let pair_of_array a = (a.(0), a.(1))
-let make_name s = Name (id_of_string s)
-
-let rec disc_subset x =
-  match kind_of_term x with
-  | App (c, l) ->
-      (match kind_of_term c with
-      Ind i ->
-	let len = Array.length l in
-	let sig_ = delayed_force sig_ in
-	  if len = 2 && i = Term.destInd sig_.typ
-	  then
-	    let (a, b) = pair_of_array l in
-	      Some (a, b)
-	  else None
-      | _ -> None)
-  | _ -> None
-
-and disc_exist env x =
-  match kind_of_term x with
-  | App (c, l) ->
-      (match kind_of_term c with
-      Construct c ->
-	if c = Term.destConstruct (delayed_force sig_).intro
-	then Some (l.(0), l.(1), l.(2), l.(3))
-	else None
-      | _ -> None)
-  | _ -> None
-
-module Coercion = struct
-
-  exception NoSubtacCoercion
-
-  let disc_proj_exist env x =
-    match kind_of_term x with
-      | App (c, l) ->
-	  (if Term.eq_constr c (delayed_force sig_).proj1
-	     && Array.length l = 3
-	   then disc_exist env l.(2)
-	   else None)
-      | _ -> None
-
-
-  let sort_rel s1 s2 =
-    match s1, s2 with
-	Prop Pos, Prop Pos -> Prop Pos
-      | Prop Pos, Prop Null -> Prop Null
-      | Prop Null, Prop Null -> Prop Null
-      | Prop Null, Prop Pos -> Prop Pos
-      | Type _, Prop Pos -> Prop Pos
-      | Type _, Prop Null -> Prop Null
-      | _, Type _ -> s2
-
-  let hnf env isevars c = whd_betadeltaiota env isevars c
-  let hnf_nodelta env evars c = whd_betaiota evars c
-
-  let lift_args n sign =
-    let rec liftrec k = function
-      | t::sign -> liftn n k t :: (liftrec (k-1) sign)
-      | [] -> []
-    in
-      liftrec (List.length sign) sign
-
-  let rec mu env isevars t =
-    let rec aux v =
-      let v = hnf env !isevars v in
-      match disc_subset v with
-	  Some (u, p) ->
-	    let f, ct = aux u in
-	    let p = hnf env !isevars p in
-	      (Some (fun x ->
-		     app_opt env isevars 
-		     f (mkApp ((delayed_force sig_).proj1,
-			       [| u; p; x |]))),
-	       ct)
-	| None -> (None, v)
-    in aux t
-
-  and coerce loc env isevars (x : Term.constr) (y : Term.constr)
-      : (Term.constr -> Term.constr) option
-      =
-    let rec coerce_unify env x y =
-      let x = hnf env !isevars x and y = hnf env !isevars y in
-	try
-	  isevars := the_conv_x_leq env x y !isevars;
-	  None
-	with Reduction.NotConvertible -> coerce' env x y
-    and coerce' env x y : (Term.constr -> Term.constr) option =
-      let subco () = subset_coerce env isevars x y in
-      let dest_prod c =
-	match Reductionops.splay_prod_n env ( !isevars) 1 c with
-	| [(na,b,t)], c -> (na,t), c
-	| _ -> raise NoSubtacCoercion
-      in
-      let rec coerce_application typ typ' c c' l l' =
-	let len = Array.length l in
-	let rec aux tele typ typ' i co =
-	  if i < len then
-	    let hdx = l.(i) and hdy = l'.(i) in
-	      try isevars := the_conv_x_leq env hdx hdy !isevars;
-		let (n, eqT), restT = dest_prod typ in
-		let (n', eqT'), restT' = dest_prod typ' in
-		aux (hdx :: tele) (subst1 hdx restT) (subst1 hdy restT') (succ i) co
-	      with Reduction.NotConvertible ->
-		let (n, eqT), restT = dest_prod typ in
-		let (n', eqT'), restT' = dest_prod typ' in
-		let _ =
-		  try isevars := the_conv_x_leq env eqT eqT' !isevars
-		  with Reduction.NotConvertible -> raise NoSubtacCoercion
-		in
-		(* Disallow equalities on arities *)
-		if Reduction.is_arity env eqT then raise NoSubtacCoercion;
-		let restargs = lift_args 1
-		  (List.rev (Array.to_list (Array.sub l (succ i) (len - (succ i)))))
-		in
-		let args = List.rev (restargs @ mkRel 1 :: List.map (lift 1) tele) in
-		let pred = mkLambda (n, eqT, applistc (lift 1 c) args) in
-		let eq = mkApp (delayed_force eq_ind, [| eqT; hdx; hdy |]) in
-		let evar = make_existential loc env isevars eq in
-		let eq_app x = mkApp (delayed_force eq_rect,
-				      [| eqT; hdx; pred; x; hdy; evar|]) in
-		  aux (hdy :: tele) (subst1 hdx restT) (subst1 hdy restT') (succ i)  (fun x -> eq_app (co x))
-	  else Some co
-	in
-	  if isEvar c || isEvar c' then
-	    (* Second-order unification needed. *)
-	    raise NoSubtacCoercion;
-	  aux [] typ typ' 0 (fun x -> x)
-      in
-	match (kind_of_term x, kind_of_term y) with
-	  | Sort s, Sort s' ->
-	      (match s, s' with
-		   Prop x, Prop y when x = y -> None
-		 | Prop _, Type _ -> None
-		 | Type x, Type y when x = y -> None (* false *)
-		 | _ -> subco ())
-	  | Prod (name, a, b), Prod (name', a', b') ->
-	      let name' = Name (Namegen.next_ident_away (id_of_string "x") (Termops.ids_of_context env)) in
-	      let env' = push_rel (name', None, a') env in
-	      let c1 = coerce_unify env' (lift 1 a') (lift 1 a) in
-		(* env, x : a' |- c1 : lift 1 a' > lift 1 a *)
-	      let coec1 = app_opt env' isevars c1 (mkRel 1) in
-		(* env, x : a' |- c1[x] : lift 1 a *)
-	      let c2 = coerce_unify env' (subst1 coec1 (liftn 1 2 b)) b' in
-		(* env, x : a' |- c2 : b[c1[x]/x]] > b' *)
-		(match c1, c2 with
-		| None, None -> None
-		| _, _ ->
-		    Some
-		      (fun f ->
-			mkLambda (name', a',
-				 app_opt env' isevars c2
-				   (mkApp (Term.lift 1 f, [| coec1 |])))))
-
-	  | App (c, l), App (c', l') ->
-	      (match kind_of_term c, kind_of_term c' with
-		   Ind i, Ind i' -> (* Inductive types *)
-		     let len = Array.length l in
-		     let existS = delayed_force existS in
-		     let prod = delayed_force prod in
-		       (* Sigma types *)
-		       if len = Array.length l' && len = 2 && i = i'
-			 && (i = Term.destInd existS.typ || i = Term.destInd prod.typ)
-		       then
-			 if i = Term.destInd existS.typ
-			 then
-			   begin
-			     let (a, pb), (a', pb') =
-			       pair_of_array l, pair_of_array l'
-			     in
-			     let c1 = coerce_unify env a a' in
-			     let rec remove_head a c =
-			       match kind_of_term c with
-				 | Lambda (n, t, t') -> c, t'
-				     (*| Prod (n, t, t') -> t'*)
-				 | Evar (k, args) ->
-				     let (evs, t) = Evarutil.define_evar_as_lambda env !isevars (k,args) in
-				       isevars := evs;
-				       let (n, dom, rng) = destLambda t in
-				       let (domk, args) = destEvar dom in
-					 isevars := define domk a !isevars;
-					 t, rng
-				 | _ -> raise NoSubtacCoercion
-			     in
-			     let (pb, b), (pb', b') = remove_head a pb, remove_head a' pb' in
-			     let env' = push_rel (make_name "x", None, a) env in
-			     let c2 = coerce_unify env' b b' in
-			       match c1, c2 with
-				   None, None ->
-				     None
-				 | _, _ ->
-				     Some
-				       (fun x ->
-					  let x, y =
-					    app_opt env' isevars c1 (mkApp (existS.proj1,
-							       [| a; pb; x |])),
-					    app_opt env' isevars c2 (mkApp (existS.proj2,
-							       [| a; pb; x |]))
-					  in
-					    mkApp (existS.intro, [| a'; pb'; x ; y |]))
-			   end
-			 else
-			   begin
-			     let (a, b), (a', b') =
-			       pair_of_array l, pair_of_array l'
-			     in
-			     let c1 = coerce_unify env a a' in
-			     let c2 = coerce_unify env b b' in
-			       match c1, c2 with
-				   None, None -> None
-				 | _, _ ->
-				     Some
-				       (fun x ->
-					  let x, y =
-					    app_opt env isevars c1 (mkApp (prod.proj1,
-							       [| a; b; x |])),
-					    app_opt env isevars c2 (mkApp (prod.proj2,
-							       [| a; b; x |]))
-					  in
-					    mkApp (prod.intro, [| a'; b'; x ; y |]))
-			   end
-		       else
-			 if i = i' && len = Array.length l' then
-			   let evm =  !isevars in
-			     (try subco ()
-			       with NoSubtacCoercion ->
-				 let typ = Typing.type_of env evm c in
-				 let typ' = Typing.type_of env evm c' in
-				   (* 			     if not (is_arity env evm typ) then *)
-				   coerce_application typ typ' c c' l l')
-			       (* 			     else subco () *)
-			 else
-			   subco ()
-		 | x, y when x = y ->
-		     if Array.length l = Array.length l' then
-		       let evm =  !isevars in
-		       let lam_type = Typing.type_of env evm c in
-		       let lam_type' = Typing.type_of env evm c' in
-(* 			 if not (is_arity env evm lam_type) then ( *)
-			 coerce_application lam_type lam_type' c c' l l'
-(* 			 ) else subco () *)
-		     else subco ()
-		 | _ -> subco ())
-	  | _, _ ->  subco ()
-
-    and subset_coerce env isevars x y =
-      match disc_subset x with
-	  Some (u, p) ->
-	    let c = coerce_unify env u y in
-	    let f x =
-	      app_opt env isevars c (mkApp ((delayed_force sig_).proj1,
-				[| u; p; x |]))
-	    in Some f
-	| None ->
-	    match disc_subset y with
-		Some (u, p) ->
-		  let c = coerce_unify env x u in
-		    Some
-		      (fun x ->
-			 let cx = app_opt env isevars c x in
-			 let evar = make_existential loc env isevars (mkApp (p, [| cx |]))
-			 in
-			   (mkApp
-			      ((delayed_force sig_).intro,
-			       [| u; p; cx; evar |])))
-	      | None ->
-		  raise NoSubtacCoercion
-		    (*isevars := Evd.add_conv_pb (Reduction.CONV, x, y) !isevars;
-		  None*)
-    in coerce_unify env x y
-
-  let coerce_itf loc env isevars v t c1 =
-    let evars = ref isevars in
-    let coercion = coerce loc env evars t c1 in
-    let t = Option.map (app_opt env evars coercion) v in
-      !evars, t
-
-  (* Taken from pretyping/coercion.ml *)
-
-  (* Typing operations dealing with coercions *)
-
-  (* Here, funj is a coercion therefore already typed in global context *)
-  let apply_coercion_args env argl funj =
-    let rec apply_rec acc typ = function
-      | [] -> { uj_val = applist (j_val funj,argl);
-		uj_type = typ }
-      | h::restl ->
-	  (* On devrait pouvoir s'arranger pour qu'on n'ait pas à faire hnf_constr *)
-  	  match kind_of_term (whd_betadeltaiota env Evd.empty typ) with
-	    | Prod (_,c1,c2) ->
-		(* Typage garanti par l'appel à app_coercion*)
-		apply_rec (h::acc) (subst1 h c2) restl
-	    | _ -> anomaly "apply_coercion_args"
-    in
-      apply_rec [] funj.uj_type argl
-
-  (* appliquer le chemin de coercions de patterns p *)
-  exception NoCoercion
-
-  let apply_pattern_coercion loc pat p =
-    List.fold_left
-      (fun pat (co,n) ->
-	 let f i = if i<n then Glob_term.PatVar (loc, Anonymous) else pat in
-	   Glob_term.PatCstr (loc, co, list_tabulate f (n+1), Anonymous))
-      pat p
-
-  (* raise Not_found if no coercion found *)
-  let inh_pattern_coerce_to loc pat ind1 ind2 =
-    let p = lookup_pattern_path_between (ind1,ind2) in
-      apply_pattern_coercion loc pat p
-
-  (* appliquer le chemin de coercions p à hj *)
-
-  let apply_coercion env sigma p hj typ_cl =
-    try
-      fst (List.fold_left
-             (fun (ja,typ_cl) i ->
-		let fv,isid = coercion_value i in
-		let argl = (class_args_of env sigma typ_cl)@[ja.uj_val] in
-		let jres = apply_coercion_args env argl fv in
-		  (if isid then
-		     { uj_val = ja.uj_val; uj_type = jres.uj_type }
-		   else
-		     jres),
-		jres.uj_type)
-             (hj,typ_cl) p)
-    with e when Errors.noncritical e -> anomaly "apply_coercion"
-
-  let inh_app_fun _ env isevars j =
-    let isevars = ref isevars in
-    let t = hnf env !isevars j.uj_type in
-      match kind_of_term t with
-	| Prod (_,_,_) -> (!isevars,j)
-	| Evar ev when not (is_defined_evar !isevars ev) ->
-	    let (isevars',t) = define_evar_as_product !isevars ev in
-	      (isevars',{ uj_val = j.uj_val; uj_type = t })
-	| _ ->
-       	    (try
-      	       let t,p =
-		 lookup_path_to_fun_from env !isevars j.uj_type in
-		 (!isevars,apply_coercion env !isevars p j t)
-	     with Not_found ->
-	       try
-		 let coercef, t = mu env isevars t in
-		 let res = { uj_val = app_opt env isevars coercef j.uj_val; uj_type = t } in
-		   (!isevars, res)
-	       with NoSubtacCoercion | NoCoercion ->
-		 (!isevars,j))
-
-  let inh_tosort_force loc env isevars j =
-    try
-      let t,p = lookup_path_to_sort_from env ( isevars) j.uj_type in
-      let j1 = apply_coercion env ( isevars) p j t in
-	(isevars, type_judgment env (j_nf_evar ( isevars) j1))
-    with Not_found ->
-      error_not_a_type_loc loc env ( isevars) j
-
-  let inh_coerce_to_sort loc env isevars j =
-    let typ = hnf env isevars j.uj_type in
-      match kind_of_term typ with
-	| Sort s -> (isevars,{ utj_val = j.uj_val; utj_type = s })
-	| Evar ev when not (is_defined_evar isevars ev) ->
-	    let (isevars',s) = define_evar_as_sort isevars ev in
-	      (isevars',{ utj_val = j.uj_val; utj_type = s })
-	| _ ->
-	    inh_tosort_force loc env isevars j
-
-  let inh_coerce_to_base loc env isevars j =
-    let isevars = ref isevars in
-    let typ = hnf env !isevars j.uj_type in
-    let ct, typ' = mu env isevars typ in
-    let res =
-      { uj_val = app_opt env isevars ct j.uj_val;
-	uj_type = typ' }
-    in !isevars, res
-
-  let inh_coerce_to_prod loc env isevars t =
-    let isevars = ref isevars in
-    let typ = hnf env !isevars (snd t) in
-    let _, typ' = mu env isevars typ in
-      !isevars, (fst t, typ')
-
-  let inh_coerce_to_fail env evd rigidonly v t c1 =
-    if rigidonly & not (Heads.is_rigid env c1 && Heads.is_rigid env t)
-    then
-      raise NoCoercion
-    else
-    let v', t' =
-      try
-	let t2,t1,p = lookup_path_between env evd (t,c1) in
-	  match v with
-	      Some v ->
-		let j = apply_coercion env evd p
-		  {uj_val = v; uj_type = t} t2 in
-		  Some j.uj_val, j.uj_type
-	    | None -> None, t
-      with Not_found -> raise NoCoercion
-    in
-      try (the_conv_x_leq env t' c1 evd, v')
-      with Reduction.NotConvertible -> raise NoCoercion
-
-
-  let rec inh_conv_coerce_to_fail loc env evd rigidonly v t c1 =
-    try (the_conv_x_leq env t c1 evd, v)
-    with Reduction.NotConvertible ->
-    try inh_coerce_to_fail env evd rigidonly v t c1
-    with NoCoercion ->
-    match
-      kind_of_term (whd_betadeltaiota env evd t),
-      kind_of_term (whd_betadeltaiota env evd c1)
-    with
-    | Prod (name,t1,t2), Prod (_,u1,u2) ->
-        (* Conversion did not work, we may succeed with a coercion. *)
-        (* We eta-expand (hence possibly modifying the original term!) *)
-	(* and look for a coercion c:u1->t1 s.t. fun x:u1 => v' (c x)) *)
-	(* has type forall (x:u1), u2 (with v' recursively obtained) *)
-	let name = match name with
-	  | Anonymous -> Name (id_of_string "x")
-	  | _ -> name in
-	let env1 = push_rel (name,None,u1) env in
-	let (evd', v1) =
-	  inh_conv_coerce_to_fail loc env1 evd rigidonly
-            (Some (mkRel 1)) (lift 1 u1) (lift 1 t1) in
-        let v1 = Option.get v1 in
-	let v2 = Option.map (fun v -> beta_applist (lift 1 v,[v1])) v in
-        let t2 = Termops.subst_term v1 t2 in
-	let (evd'',v2') = inh_conv_coerce_to_fail loc env1 evd' rigidonly v2 t2 u2 in
-	(evd'', Option.map (fun v2' -> mkLambda (name, u1, v2')) v2')
-    | _ -> raise NoCoercion
-
-  (* Look for cj' obtained from cj by inserting coercions, s.t. cj'.typ = t *)
-  let inh_conv_coerce_to_gen rigidonly loc env evd cj ((n, t) as _tycon) =
-    match n with
-    | None ->
-      let cj = { cj with uj_type = hnf_nodelta env evd cj.uj_type } 
-      and t = hnf_nodelta env evd t in
-      let (evd', val') =
-	try
-	  inh_conv_coerce_to_fail loc env evd rigidonly
-	  (Some cj.uj_val) cj.uj_type t
-	with NoCoercion ->
-	(try
-	   coerce_itf loc env evd (Some cj.uj_val) cj.uj_type t
-	 with NoSubtacCoercion ->
-	   error_actual_type_loc loc env evd cj t)
-      in
-      let val' = match val' with Some v -> v | None -> assert(false) in
-	(evd',{ uj_val = val'; uj_type = t })
-    | Some (init, cur) ->
-      (evd, cj)
-
-  let inh_conv_coerce_to _ = inh_conv_coerce_to_gen false
-  let inh_conv_coerce_rigid_to _ = inh_conv_coerce_to_gen true
-
-  let inh_conv_coerces_to loc env isevars t ((abs, t') as _tycon) =
-    let nabsinit, nabs =
-      match abs with
-	  None -> 0, 0
-	| Some (init, cur) -> init, cur
-    in
-      try
-	let rels, rng = Reductionops.splay_prod_n env ( isevars) nabs t in
-	(* The final range free variables must have been replaced by evars, we accept only that evars
-	   in rng are applied to free vars. *)
-	if noccur_with_meta 1 (succ nabs) rng then (
-	  let env', t, t' =
-	    let env' = push_rel_context rels env in
-	      env', rng, lift nabs t'
-	  in
-	    try
-	      fst (try inh_conv_coerce_to_fail loc env' isevars false None t t'
-		   with NoCoercion ->
-		     coerce_itf loc env' isevars None t t')
-	    with NoSubtacCoercion ->
-	      error_cannot_coerce env' isevars (t, t'))
-	else isevars
-      with e when Errors.noncritical e -> isevars
-end
diff --git a/plugins/subtac/subtac_coercion.mli b/plugins/subtac/subtac_coercion.mli
deleted file mode 100644
index 5678c10e..00000000
--- a/plugins/subtac/subtac_coercion.mli
+++ /dev/null
@@ -1,4 +0,0 @@
-open Term
-val disc_subset : types -> (types * types) option
-
-module Coercion : Coercion.S
diff --git a/plugins/subtac/subtac_command.ml b/plugins/subtac/subtac_command.ml
deleted file mode 100644
index 537a8301..00000000
--- a/plugins/subtac/subtac_command.ml
+++ /dev/null
@@ -1,544 +0,0 @@
-open Closure
-open RedFlags
-open Declarations
-open Entries
-open Libobject
-open Pattern
-open Matching
-open Pp
-open Glob_term
-open Sign
-open Tacred
-open Util
-open Names
-open Nameops
-open Libnames
-open Nametab
-open Pfedit
-open Proof_type
-open Refiner
-open Tacmach
-open Tactic_debug
-open Topconstr
-open Term
-open Tacexpr
-open Safe_typing
-open Typing
-open Hiddentac
-open Genarg
-open Decl_kinds
-open Mod_subst
-open Printer
-open Inductiveops
-open Syntax_def
-open Environ
-open Tactics
-open Tacticals
-open Tacinterp
-open Vernacexpr
-open Notation
-open Evd
-open Evarutil
-
-module SPretyping = Subtac_pretyping.Pretyping
-open Subtac_utils
-open Pretyping
-open Subtac_obligations
-
-(*********************************************************************)
-(* Functions to parse and interpret constructions *)
-
-let evar_nf isevars c =
-  Evarutil.nf_evar !isevars c
-
-let interp_gen kind isevars env
-               ?(impls=Constrintern.empty_internalization_env) ?(allow_patvar=false) ?(ltacvars=([],[]))
-               c =
-  let c' = Constrintern.intern_gen (kind=IsType) ~impls ~allow_patvar ~ltacvars ( !isevars) env c in
-  let c' = SPretyping.understand_tcc_evars isevars env kind c' in
-    evar_nf isevars c'
-
-let interp_constr isevars env c =
-  interp_gen (OfType None) isevars env c
-
-let interp_type_evars isevars env ?(impls=Constrintern.empty_internalization_env) c =
-  interp_gen IsType isevars env ~impls c
-
-let interp_casted_constr isevars env ?(impls=Constrintern.empty_internalization_env) c typ =
-  interp_gen (OfType (Some typ)) isevars env ~impls c
-
-let interp_casted_constr_evars isevars env ?(impls=Constrintern.empty_internalization_env) c typ =
-  interp_gen (OfType (Some typ)) isevars env ~impls c
-
-let interp_open_constr isevars env c =
-    msgnl (str "Pretyping " ++ my_print_constr_expr c);
-  let c = Constrintern.intern_constr ( !isevars) env c in
-  let c' = SPretyping.understand_tcc_evars isevars env (OfType None) c in
-    evar_nf isevars c'
-
-let interp_constr_judgment isevars env c =
-  let j =
-    SPretyping.understand_judgment_tcc isevars env
-      (Constrintern.intern_constr ( !isevars) env c)
-  in
-    { uj_val = evar_nf isevars j.uj_val; uj_type = evar_nf isevars j.uj_type }
-
-let locate_if_isevar loc na = function
-  | GHole _ ->
-      (try match na with
-	| Name id -> glob_constr_of_aconstr loc (Reserve.find_reserved_type id)
-	| Anonymous -> raise Not_found
-      with Not_found -> GHole (loc, Evd.BinderType na))
-  | x -> x
-
-let interp_binder sigma env na t =
-  let t = Constrintern.intern_gen true ( !sigma) env t in
-    SPretyping.understand_tcc_evars sigma env IsType (locate_if_isevar (loc_of_glob_constr t) na t)
-
-let interp_context_evars evdref env params =
-  let int_env, bl = Constrintern.intern_context false !evdref env Constrintern.empty_internalization_env params in
-  let (env, par, _, impls) =
-    List.fold_left
-      (fun (env,params,n,impls) (na, k, b, t) ->
-	match b with
-	    None ->
-	      let t' = locate_if_isevar (loc_of_glob_constr t) na t in
-	      let t = SPretyping.understand_tcc_evars evdref env IsType t' in
-	      let d = (na,None,t) in
-	      let impls =
-		if k = Implicit then
-		  let na = match na with Name n -> Some n | Anonymous -> None in
-		    (ExplByPos (n, na), (true, true, true)) :: impls
-		else impls
-	      in
-		(push_rel d env, d::params, succ n, impls)
-	  | Some b ->
-	      let c = SPretyping.understand_judgment_tcc evdref env b in
-	      let d = (na, Some c.uj_val, c.uj_type) in
-		(push_rel d env,d::params, succ n, impls))
-      (env,[],1,[]) (List.rev bl)
-  in (env, par), impls
-
-(* try to find non recursive definitions *)
-
-let list_chop_hd i l = match list_chop i l with
-  | (l1,x::l2) -> (l1,x,l2)
-  | (x :: [], l2) -> ([], x, [])
-  | _ -> assert(false)
-
-let collect_non_rec env =
-  let rec searchrec lnonrec lnamerec ldefrec larrec nrec =
-    try
-      let i =
-        list_try_find_i
-          (fun i f ->
-             if List.for_all (fun (_, def) -> not (Termops.occur_var env f def)) ldefrec
-             then i else failwith "try_find_i")
-          0 lnamerec
-      in
-      let (lf1,f,lf2) = list_chop_hd i lnamerec in
-      let (ldef1,def,ldef2) = list_chop_hd i ldefrec in
-      let (lar1,ar,lar2) = list_chop_hd i larrec in
-      let newlnv =
-	try
-	  match list_chop i nrec with
-            | (lnv1,_::lnv2) -> (lnv1@lnv2)
-	    | _ -> [] (* nrec=[] for cofixpoints *)
-        with Failure "list_chop" -> []
-      in
-      searchrec ((f,def,ar)::lnonrec)
-	(lf1@lf2) (ldef1@ldef2) (lar1@lar2) newlnv
-    with Failure "try_find_i" ->
-      (List.rev lnonrec,
-       (Array.of_list lnamerec, Array.of_list ldefrec,
-        Array.of_list larrec, Array.of_list nrec))
-  in
-  searchrec []
-
-let list_of_local_binders l =
-  let rec aux acc = function
-      Topconstr.LocalRawDef (n, c) :: tl -> aux ((n, Some c, None) :: acc) tl
-    | Topconstr.LocalRawAssum (nl, k, c) :: tl ->
-	aux (List.fold_left (fun acc n -> (n, None, Some c) :: acc) acc nl) tl
-    | [] -> List.rev acc
-  in aux [] l
-
-let lift_binders k n l =
-  let rec aux n = function
-    | (id, t, c) :: tl -> (id, Option.map (liftn k n) t, liftn k n c) :: aux (pred n) tl
-    | [] -> []
-  in aux n l
-
-let rec gen_rels = function
-    0 -> []
-  | n -> mkRel n :: gen_rels (pred n)
-
-let split_args n rel = match list_chop ((List.length rel) - n) rel with
-    (l1, x :: l2) -> l1, x, l2
-  | _ -> assert(false)
-
-open Coqlib
-
-let sigT = Lazy.lazy_from_fun build_sigma_type
-let sigT_info = lazy
-  { ci_ind       = destInd (Lazy.force sigT).typ;
-    ci_npar      = 2;
-    ci_cstr_ndecls = [|2|];
-    ci_pp_info   =  { ind_nargs = 0; style = LetStyle }
-  }
-
-let rec telescope = function
-  | [] -> assert false
-  | [(n, None, t)] -> t, [n, Some (mkRel 1), t], mkRel 1
-  | (n, None, t) :: tl ->
-      let ty, tys, (k, constr) =
-	List.fold_left
-	  (fun (ty, tys, (k, constr)) (n, b, t) ->
-	    let pred = mkLambda (n, t, ty) in
-	    let sigty = mkApp ((Lazy.force sigT).typ, [|t; pred|]) in
-	    let intro = mkApp ((Lazy.force sigT).intro, [|lift k t; lift k pred; mkRel k; constr|]) in
-	      (sigty, pred :: tys, (succ k, intro)))
-	  (t, [], (2, mkRel 1)) tl
-      in
-      let (last, subst) = List.fold_right2
-	(fun pred (n, b, t) (prev, subst) ->
-	  let proj1 = applistc (Lazy.force sigT).proj1 [t; pred; prev] in
-	  let proj2 = applistc (Lazy.force sigT).proj2 [t; pred; prev] in
-	    (lift 1 proj2, (n, Some proj1, t) :: subst))
-	(List.rev tys) tl (mkRel 1, [])
-      in ty, ((n, Some last, t) :: subst), constr
-
-  | (n, Some b, t) :: tl -> let ty, subst, term = telescope tl in
-      ty, ((n, Some b, t) :: subst), lift 1 term
-
-let nf_evar_context isevars ctx =
-  List.map (fun (n, b, t) ->
-    (n, Option.map (Evarutil.nf_evar isevars) b, Evarutil.nf_evar isevars t)) ctx
-
-let build_wellfounded (recname,n,bl,arityc,body) r measure notation =
-  Coqlib.check_required_library ["Coq";"Program";"Wf"];
-  let sigma = Evd.empty in
-  let isevars = ref (Evd.create_evar_defs sigma) in
-  let env = Global.env() in
-  let _pr c = my_print_constr env c in
-  let _prr = Printer.pr_rel_context env in
-  let _prn = Printer.pr_named_context env in
-  let _pr_rel env = Printer.pr_rel_context env in
-  let (env', binders_rel), impls = interp_context_evars isevars env bl in
-  let len = List.length binders_rel in
-  let top_env = push_rel_context binders_rel env in
-  let top_arity = interp_type_evars isevars top_env arityc in
-  let full_arity = it_mkProd_or_LetIn top_arity binders_rel in
-  let argtyp, letbinders, make = telescope binders_rel in
-  let argname = id_of_string "recarg" in
-  let arg = (Name argname, None, argtyp) in
-  let binders = letbinders @ [arg] in
-  let binders_env = push_rel_context binders_rel env in
-  let rel = interp_constr isevars env r in
-  let relty = type_of env !isevars rel in
-  let relargty =
-    let error () =
-      user_err_loc (constr_loc r,
-		   "Subtac_command.build_wellfounded",
-		   my_print_constr env rel ++ str " is not an homogeneous binary relation.")
-    in
-      try
-	let ctx, ar = Reductionops.splay_prod_n env !isevars 2 relty in
-	  match ctx, kind_of_term ar with
-	  | [(_, None, t); (_, None, u)], Sort (Prop Null)
-	      when Reductionops.is_conv env !isevars t u -> t
-	  | _, _ -> error ()
-      with e when Errors.noncritical e -> error ()
-  in
-  let measure = interp_casted_constr isevars binders_env measure relargty in
-  let wf_rel, wf_rel_fun, measure_fn =
-    let measure_body, measure =
-      it_mkLambda_or_LetIn measure letbinders,
-      it_mkLambda_or_LetIn measure binders
-    in
-    let comb = constr_of_global (delayed_force measure_on_R_ref) in
-    let wf_rel = mkApp (comb, [| argtyp; relargty; rel; measure |]) in
-    let wf_rel_fun x y =
-      mkApp (rel, [| subst1 x measure_body;
- 		     subst1 y measure_body |])
-    in wf_rel, wf_rel_fun, measure
-  in
-  let wf_proof = mkApp (delayed_force well_founded, [| argtyp ; wf_rel |]) in
-  let argid' = id_of_string (string_of_id argname ^ "'") in
-  let wfarg len = (Name argid', None,
-  		  mkSubset (Name argid') argtyp
-		    (wf_rel_fun (mkRel 1) (mkRel (len + 1))))
-  in
-  let intern_bl = wfarg 1 :: [arg] in
-  let _intern_env = push_rel_context intern_bl env in
-  let proj = (delayed_force sig_).Coqlib.proj1 in
-  let wfargpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel 3)) in
-  let projection = (* in wfarg :: arg :: before *)
-    mkApp (proj, [| argtyp ; wfargpred ; mkRel 1 |])
-  in
-  let top_arity_let = it_mkLambda_or_LetIn top_arity letbinders in
-  let intern_arity = substl [projection] top_arity_let in
-  (* substitute the projection of wfarg for something,
-     now intern_arity is in wfarg :: arg *)
-  let intern_fun_arity_prod = it_mkProd_or_LetIn intern_arity [wfarg 1] in
-  let intern_fun_binder = (Name (add_suffix recname "'"), None, intern_fun_arity_prod) in
-  let curry_fun =
-    let wfpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel (2 * len + 4))) in
-    let arg = mkApp ((delayed_force sig_).intro, [| argtyp; wfpred; lift 1 make; mkRel 1 |]) in
-    let app = mkApp (mkRel (2 * len + 2 (* recproof + orig binders + current binders *)), [| arg |]) in
-    let rcurry = mkApp (rel, [| measure; lift len measure |]) in
-    let lam = (Name (id_of_string "recproof"), None, rcurry) in
-    let body = it_mkLambda_or_LetIn app (lam :: binders_rel) in
-    let ty = it_mkProd_or_LetIn (lift 1 top_arity) (lam :: binders_rel) in
-      (Name recname, Some body, ty)
-  in
-  let fun_bl = intern_fun_binder :: [arg] in
-  let lift_lets = Termops.lift_rel_context 1 letbinders in
-  let intern_body =
-    let ctx = (Name recname, None, pi3 curry_fun) :: binders_rel in
-    let (r, l, impls, scopes) =
-      Constrintern.compute_internalization_data env
-	Constrintern.Recursive full_arity impls 
-    in
-    let newimpls = Idmap.singleton recname
-      (r, l, impls @ [(Some (id_of_string "recproof", Impargs.Manual, (true, false)))],
-       scopes @ [None]) in
-      interp_casted_constr isevars ~impls:newimpls
-	(push_rel_context ctx env) body (lift 1 top_arity)
-  in
-  let intern_body_lam = it_mkLambda_or_LetIn intern_body (curry_fun :: lift_lets @ fun_bl) in
-  let prop = mkLambda (Name argname, argtyp, top_arity_let) in
-  let def =
-    mkApp (constr_of_global (delayed_force fix_sub_ref),
-	  [| argtyp ; wf_rel ;
-	     make_existential dummy_loc ~opaque:(Define false) env isevars wf_proof ;
-	     prop ; intern_body_lam |])
-  in
-  let _ = isevars := Evarutil.nf_evar_map !isevars in
-  let binders_rel = nf_evar_context !isevars binders_rel in
-  let binders = nf_evar_context !isevars binders in
-  let top_arity = Evarutil.nf_evar !isevars top_arity in
-  let hook, recname, typ = 
-    if List.length binders_rel > 1 then
-      let name = add_suffix recname "_func" in
-      let hook l gr = 
-	let body = it_mkLambda_or_LetIn (mkApp (constr_of_global gr, [|make|])) binders_rel in
-	let ty = it_mkProd_or_LetIn top_arity binders_rel in
-	let ce =
-          { const_entry_body = Evarutil.nf_evar !isevars body;
-            const_entry_secctx = None;
-	    const_entry_type = Some ty;
-	    const_entry_opaque = false }
-	in 
-	let c = Declare.declare_constant recname (DefinitionEntry ce, IsDefinition Definition) in
-	let gr = ConstRef c in
-	  if Impargs.is_implicit_args () || impls <> [] then
-	    Impargs.declare_manual_implicits false gr [impls]
-      in
-      let typ = it_mkProd_or_LetIn top_arity binders in
-	hook, name, typ
-    else 
-      let typ = it_mkProd_or_LetIn top_arity binders_rel in
-      let hook l gr = 
-	if Impargs.is_implicit_args () || impls <> [] then
-	  Impargs.declare_manual_implicits false gr [impls]
-      in hook, recname, typ
-  in
-  let fullcoqc = Evarutil.nf_evar !isevars def in
-  let fullctyp = Evarutil.nf_evar !isevars typ in
-  let evm = evars_of_term !isevars Evd.empty fullctyp in
-  let evm = evars_of_term !isevars evm fullcoqc in
-  let evm = non_instanciated_map env isevars evm in
-  let evars, _, evars_def, evars_typ = 
-    Eterm.eterm_obligations env recname !isevars evm 0 fullcoqc fullctyp 
-  in
-    Subtac_obligations.add_definition recname ~term:evars_def evars_typ evars ~hook
-
-let interp_fix_context evdref env fix =
-  interp_context_evars evdref env fix.Command.fix_binders
-
-let interp_fix_ccl evdref (env,_) fix =
-  interp_type_evars evdref env fix.Command.fix_type
-
-let interp_fix_body evdref env_rec impls (_,ctx) fix ccl =
-  let env = push_rel_context ctx env_rec in
-  let body = Option.map (fun c -> interp_casted_constr_evars evdref env ~impls c ccl) fix.Command.fix_body in
-  Option.map (fun c -> it_mkLambda_or_LetIn c ctx) body
-
-let build_fix_type (_,ctx) ccl = it_mkProd_or_LetIn ccl ctx
-
-let prepare_recursive_declaration fixnames fixtypes fixdefs =
-  let defs = List.map (subst_vars (List.rev fixnames)) fixdefs in
-  let names = List.map (fun id -> Name id) fixnames in
-  (Array.of_list names, Array.of_list fixtypes, Array.of_list defs)
-
-let rel_index n ctx =
-  list_index0 (Name n) (List.rev_map pi1 (List.filter (fun x -> pi2 x = None) ctx))
-
-let rec unfold f b =
-  match f b with
-    | Some (x, b') -> x :: unfold f b'
-    | None -> []
-
-
-let find_annot loc id ctx = 
-  try rel_index id ctx
-  with Not_found -> 
-  user_err_loc(loc,"",
-	       str "No parameter named " ++ Nameops.pr_id id ++ str".")
-
-let compute_possible_guardness_evidences (n,_) (_, fixctx) fixtype =
-  match n with
-  | Some (loc, id) -> [find_annot loc id fixctx]
-  | None ->
-      (* If recursive argument was not given by user, we try all args.
-	 An earlier approach was to look only for inductive arguments,
-	 but doing it properly involves delta-reduction, and it finally
-         doesn't seem to worth the effort (except for huge mutual
-	 fixpoints ?) *)
-      let len = List.length fixctx in
-	unfold (function x when x = len -> None
-	  | n -> Some (n, succ n)) 0
-
-let push_named_context = List.fold_right push_named
-
-let check_evars env initial_sigma evd c =
-  let sigma =  evd in
-  let c = nf_evar sigma c in
-  let rec proc_rec c =
-    match kind_of_term c with
-      | Evar (evk,args) ->
-          assert (Evd.mem sigma evk);
-	  if not (Evd.mem initial_sigma evk) then
-            let (loc,k) = evar_source evk evd in
-	      (match k with
-	      | QuestionMark _
-	      | ImplicitArg (_, _, false) -> ()
-	      | _ ->
-		  let evi = nf_evar_info sigma (Evd.find sigma evk) in
-		    Pretype_errors.error_unsolvable_implicit loc env sigma evi k None)
-      | _ -> iter_constr proc_rec c
-  in proc_rec c
-
-let out_def = function
-  | Some def -> def
-  | None -> error "Program Fixpoint needs defined bodies."
-
-let interp_recursive fixkind l =
-  let env = Global.env() in
-  let fixl, ntnl = List.split l in
-  let kind = fixkind <> IsCoFixpoint in
-  let fixnames = List.map (fun fix -> fix.Command.fix_name) fixl in
-
-  (* Interp arities allowing for unresolved types *)
-  let evdref = ref Evd.empty in
-  let fixctxs, fiximps = List.split (List.map (interp_fix_context evdref env) fixl) in
-  let fixccls = List.map2 (interp_fix_ccl evdref) fixctxs fixl in
-  let fixtypes = List.map2 build_fix_type fixctxs fixccls in
-  let rec_sign =
-    List.fold_left2 (fun env' id t ->
-      let sort = Retyping.get_type_of env !evdref t in
-      let fixprot =
-	try mkApp (delayed_force Subtac_utils.fix_proto, [|sort; t|])
-	with e when Errors.noncritical e -> t
-      in
-	(id,None,fixprot) :: env')
-      [] fixnames fixtypes
-  in
-  let env_rec = push_named_context rec_sign env in
-
-  (* Get interpretation metadatas *)
-  let impls = Constrintern.compute_internalization_env env
-    Constrintern.Recursive fixnames fixtypes fiximps
-  in
-  let notations = List.flatten ntnl in
-
-  (* Interp bodies with rollback because temp use of notations/implicit *)
-  let fixdefs =
-    States.with_state_protection (fun () ->
-      List.iter (Metasyntax.set_notation_for_interpretation impls) notations;
-      list_map3 (interp_fix_body evdref env_rec impls) fixctxs fixl fixccls)
-      () in
-
-  let fixdefs = List.map out_def fixdefs in
-
-  (* Instantiate evars and check all are resolved *)
-  let evd = Evarconv.consider_remaining_unif_problems env_rec !evdref in
-  let evd = Typeclasses.resolve_typeclasses
-    ~filter:Typeclasses.no_goals ~split:true ~fail:false env_rec evd
-  in
-  let evd = Evarutil.nf_evar_map evd in
-  let fixdefs = List.map (nf_evar evd) fixdefs in
-  let fixtypes = List.map (nf_evar evd) fixtypes in
-  let rec_sign = nf_named_context_evar evd rec_sign in
-
-  let recdefs = List.length rec_sign in
-  List.iter (check_evars env_rec Evd.empty evd) fixdefs;
-  List.iter (check_evars env Evd.empty evd) fixtypes;
-  Command.check_mutuality env kind (List.combine fixnames fixdefs);
-
-  (* Russell-specific code *)
-
-  (* Get the interesting evars, those that were not instanciated *)
-  let isevars = Evd.undefined_evars evd in
-  let evm =  isevars in
-  (* Solve remaining evars *)
-  let rec collect_evars id def typ imps =
-      (* Generalize by the recursive prototypes  *)
-    let def =
-      Termops.it_mkNamedLambda_or_LetIn def rec_sign
-    and typ =
-      Termops.it_mkNamedProd_or_LetIn typ rec_sign
-    in
-    let evm' = Subtac_utils.evars_of_term evm Evd.empty def in
-    let evm' = Subtac_utils.evars_of_term evm evm' typ in
-    let evars, _, def, typ = Eterm.eterm_obligations env id isevars evm' recdefs def typ in
-      (id, def, typ, imps, evars)
-  in
-  let defs = list_map4 collect_evars fixnames fixdefs fixtypes fiximps in
-    (match fixkind with
-      | IsFixpoint wfl ->
-	  let possible_indexes =
-	    list_map3 compute_possible_guardness_evidences wfl fixctxs fixtypes in
-	  let fixdecls = Array.of_list (List.map (fun x -> Name x) fixnames),
-	    Array.of_list fixtypes,
-	    Array.of_list (List.map (subst_vars (List.rev fixnames)) fixdefs)
-	  in
-	  let indexes = Pretyping.search_guard dummy_loc (Global.env ()) possible_indexes fixdecls in
-	    list_iter_i (fun i _ -> Inductive.check_fix env ((indexes,i),fixdecls)) l
-      | IsCoFixpoint -> ());
-    Subtac_obligations.add_mutual_definitions defs notations fixkind
-
-let out_n = function
-    Some n -> n
-  | None -> raise Not_found
-
-let build_recursive l =
-  let g = List.map (fun ((_,wf,_,_,_),_) -> wf) l in
-    match g, l with
-	[(n, CWfRec r)], [(((_,id),_,bl,typ,def),ntn)] ->
-	  ignore(build_wellfounded (id, n, bl, typ, out_def def) r
-		    (match n with Some n -> mkIdentC (snd n) | None ->
-		      errorlabstrm "Subtac_command.build_recursive"
-			(str "Recursive argument required for well-founded fixpoints"))
-		    ntn)
-
-      | [(n, CMeasureRec (m, r))], [(((_,id),_,bl,typ,def),ntn)] ->
-	  ignore(build_wellfounded (id, n, bl, typ, out_def def) (Option.default (CRef lt_ref) r)
-		    m ntn)
-
-      | _, _ when List.for_all (fun (n, ro) -> ro = CStructRec) g ->
-	  let fixl = List.map (fun (((_,id),(n,ro),bl,typ,def),ntn) ->
-	    ({Command.fix_name = id; Command.fix_binders = bl; Command.fix_annot = n;
-	      Command.fix_body = def; Command.fix_type = typ},ntn)) l
-	  in interp_recursive (IsFixpoint g) fixl
-      | _, _ ->
-	  errorlabstrm "Subtac_command.build_recursive"
-	    (str "Well-founded fixpoints not allowed in mutually recursive blocks")
-
-let build_corecursive l =
-  let fixl = List.map (fun (((_,id),bl,typ,def),ntn) ->
-    ({Command.fix_name = id; Command.fix_binders = bl; Command.fix_annot = None;
-      Command.fix_body = def; Command.fix_type = typ},ntn))
-    l in
-  interp_recursive IsCoFixpoint fixl
diff --git a/plugins/subtac/subtac_command.mli b/plugins/subtac/subtac_command.mli
deleted file mode 100644
index 72549a01..00000000
--- a/plugins/subtac/subtac_command.mli
+++ /dev/null
@@ -1,60 +0,0 @@
-open Pretyping
-open Evd
-open Environ
-open Term
-open Topconstr
-open Names
-open Libnames
-open Pp
-open Vernacexpr
-open Constrintern
-
-val interp_gen :
-  typing_constraint ->
-  evar_map ref ->
-  env ->
-  ?impls:internalization_env ->
-  ?allow_patvar:bool ->
-  ?ltacvars:ltac_sign ->
-  constr_expr -> constr
-val interp_constr :
-  evar_map ref ->
-  env -> constr_expr -> constr
-val interp_type_evars :
-  evar_map ref ->
-  env ->
-  ?impls:internalization_env ->
-  constr_expr -> constr
-val interp_casted_constr_evars :
-  evar_map ref ->
-  env ->
-  ?impls:internalization_env ->
-  constr_expr -> types -> constr
-val interp_open_constr :
-  evar_map ref -> env -> constr_expr -> constr
-val interp_constr_judgment :
-  evar_map ref ->
-  env ->
-  constr_expr -> unsafe_judgment
-val list_chop_hd : int -> 'a list -> 'a list * 'a * 'a list
-
-val interp_binder :     Evd.evar_map ref ->
-    Environ.env -> Names.name -> Topconstr.constr_expr -> Term.constr
-
-
-val telescope :
-  (Names.name * Term.types option * Term.types) list ->
-  Term.types * (Names.name * Term.types option * Term.types) list *
-    Term.constr
-
-val build_wellfounded :
-           Names.identifier * 'a * Topconstr.local_binder list *
-           Topconstr.constr_expr * Topconstr.constr_expr ->
-           Topconstr.constr_expr ->
-           Topconstr.constr_expr -> 'b -> Subtac_obligations.progress
-
-val build_recursive :
-  (fixpoint_expr * decl_notation list) list -> unit
-
-val build_corecursive :
-  (cofixpoint_expr * decl_notation list) list -> unit
diff --git a/plugins/subtac/subtac_errors.ml b/plugins/subtac/subtac_errors.ml
deleted file mode 100644
index 067da150..00000000
--- a/plugins/subtac/subtac_errors.ml
+++ /dev/null
@@ -1,24 +0,0 @@
-open Util
-open Pp
-open Printer
-
-type term_pp = Pp.std_ppcmds
-
-type subtyping_error =
-  | UncoercibleInferType of loc * term_pp * term_pp
-  | UncoercibleInferTerm of loc * term_pp * term_pp * term_pp * term_pp
-  | UncoercibleRewrite of term_pp * term_pp
-
-type typing_error =
-  | NonFunctionalApp of loc * term_pp * term_pp * term_pp
-  | NonConvertible of loc * term_pp * term_pp
-  | NonSigma of loc * term_pp
-  | IllSorted of loc * term_pp
-
-exception Subtyping_error of subtyping_error
-exception Typing_error of typing_error
-
-exception Debug_msg of string
-
-let typing_error e = raise (Typing_error e)
-let subtyping_error e = raise (Subtyping_error e)
diff --git a/plugins/subtac/subtac_errors.mli b/plugins/subtac/subtac_errors.mli
deleted file mode 100644
index 8d75b9c0..00000000
--- a/plugins/subtac/subtac_errors.mli
+++ /dev/null
@@ -1,15 +0,0 @@
-type term_pp = Pp.std_ppcmds
-type subtyping_error =
-    UncoercibleInferType of Util.loc * term_pp * term_pp
-  | UncoercibleInferTerm of Util.loc * term_pp * term_pp * term_pp * term_pp
-  | UncoercibleRewrite of term_pp * term_pp
-type typing_error =
-    NonFunctionalApp of Util.loc * term_pp * term_pp * term_pp
-  | NonConvertible of Util.loc * term_pp * term_pp
-  | NonSigma of Util.loc * term_pp
-  | IllSorted of Util.loc * term_pp
-exception Subtyping_error of subtyping_error
-exception Typing_error of typing_error
-exception Debug_msg of string
-val typing_error : typing_error -> 'a
-val subtyping_error : subtyping_error -> 'a
diff --git a/plugins/subtac/subtac_obligations.ml b/plugins/subtac/subtac_obligations.ml
deleted file mode 100644
index 7a4916fa..00000000
--- a/plugins/subtac/subtac_obligations.ml
+++ /dev/null
@@ -1,699 +0,0 @@
-open Printf
-open Pp
-open Subtac_utils
-open Command
-open Environ
-
-open Term
-open Names
-open Libnames
-open Summary
-open Libobject
-open Entries
-open Decl_kinds
-open Util
-open Evd
-open Declare
-open Proof_type
-open Compat
-
-let ppwarn cmd = Pp.warn (str"Program:" ++ cmd)
-let pperror cmd = Util.errorlabstrm "Program" cmd
-let error s = pperror (str s)
-
-let reduce c =
-  Reductionops.clos_norm_flags Closure.betaiota (Global.env ()) Evd.empty c
-
-exception NoObligations of identifier option
-
-let explain_no_obligations = function
-    Some ident -> str "No obligations for program " ++ str (string_of_id ident)
-  | None -> str "No obligations remaining"
-
-type obligation_info = (Names.identifier * Term.types * hole_kind located *
-			  obligation_definition_status * Intset.t * tactic option) array
-
-type obligation =
-  { obl_name : identifier;
-    obl_type : types;
-    obl_location : hole_kind located;
-    obl_body : constr option;
-    obl_status : obligation_definition_status;
-    obl_deps : Intset.t;
-    obl_tac : tactic option;
-  }
-
-type obligations = (obligation array * int)
-
-type fixpoint_kind =
-  | IsFixpoint of (identifier located option * Topconstr.recursion_order_expr) list
-  | IsCoFixpoint
-
-type notations = (Vernacexpr.lstring * Topconstr.constr_expr * Topconstr.scope_name option) list
-
-type program_info = {
-  prg_name: identifier;
-  prg_body: constr;
-  prg_type: constr;
-  prg_obligations: obligations;
-  prg_deps : identifier list;
-  prg_fixkind : fixpoint_kind option ;
-  prg_implicits : (Topconstr.explicitation * (bool * bool * bool)) list;
-  prg_notations : notations ;
-  prg_kind : definition_kind;
-  prg_reduce : constr -> constr;
-  prg_hook : Tacexpr.declaration_hook;
-}
-
-let assumption_message id =
-  Flags.if_verbose message ((string_of_id id) ^ " is assumed")
-
-let (set_default_tactic, get_default_tactic, print_default_tactic) = 
-  Tactic_option.declare_tactic_option "Program tactic"
-
-(* true = All transparent, false = Opaque if possible *)
-let proofs_transparency = ref true
-
-let set_proofs_transparency = (:=) proofs_transparency
-let get_proofs_transparency () = !proofs_transparency
-
-open Goptions
-
-let _ =
-  declare_bool_option
-    { optsync  = true;
-      optdepr  = false;
-      optname  = "transparency of Program obligations";
-      optkey   = ["Transparent";"Obligations"];
-      optread  = get_proofs_transparency;
-      optwrite = set_proofs_transparency; }
-
-(* true = hide obligations *)
-let hide_obligations = ref false
-
-let set_hide_obligations = (:=) hide_obligations
-let get_hide_obligations () = !hide_obligations
-
-open Goptions
-
-let _ =
-  declare_bool_option
-    { optsync  = true;
-      optdepr  = false;
-      optname  = "Hidding of Program obligations";
-      optkey   = ["Hide";"Obligations"];
-      optread  = get_hide_obligations;
-      optwrite = set_hide_obligations; }
-
-let evar_of_obligation o = make_evar (Global.named_context_val ()) o.obl_type
-
-let get_obligation_body expand obl =
-  let c = Option.get obl.obl_body in
-    if expand && obl.obl_status = Expand then
-      match kind_of_term c with
-      | Const c -> constant_value (Global.env ()) c
-      | _ -> c
-    else c
-
-let obl_substitution expand obls deps =
-  Intset.fold
-    (fun x acc ->
-       let xobl = obls.(x) in
-       let oblb =
-	 try get_obligation_body expand xobl
-	 with e when Errors.noncritical e -> assert(false)
-       in (xobl.obl_name, (xobl.obl_type, oblb)) :: acc)
-    deps []
-
-let subst_deps expand obls deps t =
-  let subst = obl_substitution expand obls deps in
-    Term.replace_vars (List.map (fun (n, (_, b)) -> n, b) subst) t
-
-let rec prod_app t n =
-  match kind_of_term (strip_outer_cast t) with
-    | Prod (_,_,b) -> subst1 n b
-    | LetIn (_, b, t, b') -> prod_app (subst1 b b') n
-    | _ ->
-	errorlabstrm "prod_app"
-	  (str"Needed a product, but didn't find one" ++ fnl ())
-
-
-(* prod_appvect T [| a1 ; ... ; an |] -> (T a1 ... an) *)
-let prod_applist t nL = List.fold_left prod_app t nL
-
-let replace_appvars subst =
-  let rec aux c = 
-    let f, l = decompose_app c in
-      if isVar f then
-	try
-	  let c' = List.map (map_constr aux) l in
-	  let (t, b) = List.assoc (destVar f) subst in
-	    mkApp (delayed_force hide_obligation, 
-		   [| prod_applist t c'; applistc b c' |])
-	with Not_found -> map_constr aux c
-      else map_constr aux c
-  in map_constr aux
-       
-let subst_prog expand obls ints prg =
-  let subst = obl_substitution expand obls ints in
-    if get_hide_obligations () then
-      (replace_appvars subst prg.prg_body,
-       replace_appvars subst (Termops.refresh_universes prg.prg_type))
-    else 
-      let subst' = List.map (fun (n, (_, b)) -> n, b) subst in
-	(Term.replace_vars subst' prg.prg_body,
-	 Term.replace_vars subst' (Termops.refresh_universes prg.prg_type))
-
-let subst_deps_obl obls obl =
-  let t' = subst_deps true obls obl.obl_deps obl.obl_type in
-    { obl with obl_type = t' }
-
-module ProgMap = Map.Make(struct type t = identifier let compare = compare end)
-
-let map_replace k v m = ProgMap.add k v (ProgMap.remove k m)
-
-let map_keys m = ProgMap.fold (fun k _ l -> k :: l) m []
-
-let map_cardinal m =
-  let i = ref 0 in
-    ProgMap.iter (fun _ _ -> incr i) m;
-    !i
-
-exception Found of program_info
-
-let map_first m =
-  try
-    ProgMap.iter (fun _ v -> raise (Found v)) m;
-    assert(false)
-  with Found x -> x
-
-let from_prg : program_info ProgMap.t ref = ref ProgMap.empty
-
-let freeze () = !from_prg
-let unfreeze v = from_prg := v
-let init () = from_prg := ProgMap.empty
-
-(** Beware: if this code is dynamically loaded via dynlink after the start
-    of Coq, then this [init] function will not be run by [Lib.init ()].
-    Luckily, here we can launch [init] at load-time. *)
-
-let _ = init ()
-
-let _ =
-  Summary.declare_summary "program-tcc-table"
-    { Summary.freeze_function = freeze;
-      Summary.unfreeze_function = unfreeze;
-      Summary.init_function = init }
-
-let progmap_union = ProgMap.fold ProgMap.add
-
-let close sec =
-  if not (ProgMap.is_empty !from_prg) then
-    let keys = map_keys !from_prg in
-      errorlabstrm "Program" (str "Unsolved obligations when closing " ++ str sec ++ str":" ++ spc () ++
-			      prlist_with_sep spc (fun x -> Nameops.pr_id x) keys ++
-			      (str (if List.length keys = 1 then " has " else "have ") ++
-			       str "unsolved obligations"))
-
-let input : program_info ProgMap.t -> obj =
-  declare_object
-    { (default_object "Program state") with
-      cache_function = (fun (na, pi) -> from_prg := pi);
-      load_function = (fun _ (_, pi) -> from_prg := pi);
-      discharge_function = (fun _ -> close "section"; None);
-      classify_function = (fun _ -> close "module"; Dispose) }
-    
-open Evd
-
-let progmap_remove prg =
-  Lib.add_anonymous_leaf (input (ProgMap.remove prg.prg_name !from_prg))
-  
-let progmap_add n prg =
-  Lib.add_anonymous_leaf (input (ProgMap.add n prg !from_prg))
-
-let progmap_replace prg' = 
-  Lib.add_anonymous_leaf (input (map_replace prg'.prg_name prg' !from_prg))
-
-let rec intset_to = function
-    -1 -> Intset.empty
-  | n -> Intset.add n (intset_to (pred n))
-
-let subst_body expand prg =
-  let obls, _ = prg.prg_obligations in
-  let ints = intset_to (pred (Array.length obls)) in
-    subst_prog expand obls ints prg
-
-let declare_definition prg =
-  let body, typ = subst_body true prg in
-  let (local, kind) = prg.prg_kind in
-  let ce =
-    { const_entry_body = body;
-      const_entry_secctx = None;
-      const_entry_type = Some typ;
-      const_entry_opaque = false }
-  in
-    (Command.get_declare_definition_hook ()) ce;
-    match local with
-    | Local when Lib.sections_are_opened () ->
-        let c =
-          SectionLocalDef(ce.const_entry_body,ce.const_entry_type,false) in
-        let _ = declare_variable prg.prg_name (Lib.cwd(),c,IsDefinition kind) in
-          print_message (Subtac_utils.definition_message prg.prg_name);
-          if Pfedit.refining () then
-            Flags.if_verbose msg_warning
-	      (str"Local definition " ++ Nameops.pr_id prg.prg_name ++
-		  str" is not visible from current goals");
-	  progmap_remove prg; 
-          VarRef prg.prg_name
-    | (Global|Local) ->
-	let c =
-	  Declare.declare_constant
-	    prg.prg_name (DefinitionEntry ce,IsDefinition (snd prg.prg_kind))
-	in
-	let gr = ConstRef c in
-	  if Impargs.is_implicit_args () || prg.prg_implicits <> [] then
-	    Impargs.declare_manual_implicits false gr [prg.prg_implicits];
-	  print_message (Subtac_utils.definition_message prg.prg_name);
-	  progmap_remove prg; 
-	  prg.prg_hook local gr;
-	  gr
-
-open Pp
-open Ppconstr
-
-let rec lam_index n t acc =
-  match kind_of_term t with
-    | Lambda (na, _, b) ->
-	if na = Name n then acc
-	else lam_index n b (succ acc)
-    | _ -> raise Not_found
-
-let compute_possible_guardness_evidences (n,_) fixbody fixtype =
-  match n with
-  | Some (loc, n) -> [lam_index n fixbody 0]
-  | None ->
-      (* If recursive argument was not given by user, we try all args.
-	 An earlier approach was to look only for inductive arguments,
-	 but doing it properly involves delta-reduction, and it finally
-         doesn't seem to worth the effort (except for huge mutual
-	 fixpoints ?) *)
-      let m = Term.nb_prod fixtype in
-      let ctx = fst (decompose_prod_n_assum m fixtype) in
-	list_map_i (fun i _ -> i) 0 ctx
-
-let declare_mutual_definition l =
-  let len = List.length l in
-  let first = List.hd l in
-  let fixdefs, fixtypes, fiximps =
-    list_split3
-      (List.map (fun x -> 
-	let subs, typ = (subst_body true x) in
-	let term = snd (Reductionops.splay_lam_n (Global.env ()) Evd.empty len subs) in
-	let typ = snd (Reductionops.splay_prod_n (Global.env ()) Evd.empty len typ) in
-	  x.prg_reduce term, x.prg_reduce typ, x.prg_implicits) l)
-  in
-(*   let fixdefs = List.map reduce_fix fixdefs in *)
-  let fixkind = Option.get first.prg_fixkind in
-  let arrrec, recvec = Array.of_list fixtypes, Array.of_list fixdefs in
-  let fixdecls = (Array.of_list (List.map (fun x -> Name x.prg_name) l), arrrec, recvec) in
-  let (local,kind) = first.prg_kind in
-  let fixnames = first.prg_deps in
-  let kind = if fixkind <> IsCoFixpoint then Fixpoint else CoFixpoint in
-  let indexes, fixdecls =
-    match fixkind with
-      | IsFixpoint wfl ->
-	  let possible_indexes =
-	    list_map3 compute_possible_guardness_evidences wfl fixdefs fixtypes in
-	  let indexes = Pretyping.search_guard dummy_loc (Global.env ()) possible_indexes fixdecls in
-	    Some indexes, list_map_i (fun i _ -> mkFix ((indexes,i),fixdecls)) 0 l
-      | IsCoFixpoint ->
-	  None, list_map_i (fun i _ -> mkCoFix (i,fixdecls)) 0 l
-  in
-  (* Declare the recursive definitions *)
-  let kns = list_map4 (declare_fix kind) fixnames fixdecls fixtypes fiximps in
-    (* Declare notations *)
-    List.iter Metasyntax.add_notation_interpretation first.prg_notations;
-    Declare.recursive_message (fixkind<>IsCoFixpoint) indexes fixnames;
-    let gr = List.hd kns in
-    let kn = match gr with ConstRef kn -> kn | _ -> assert false in
-      first.prg_hook local gr;
-      List.iter progmap_remove l; kn
-      
-let declare_obligation prg obl body =
-  let body = prg.prg_reduce body in
-  let ty = prg.prg_reduce obl.obl_type in
-  match obl.obl_status with
-  | Expand -> { obl with obl_body = Some body }
-  | Define opaque ->
-      let opaque = if get_proofs_transparency () then false else opaque in
-      let ce = 
-	{ const_entry_body = body;
-          const_entry_secctx = None;
-	  const_entry_type = Some ty;
-	  const_entry_opaque = opaque }
-      in
-      let constant = Declare.declare_constant obl.obl_name
-	(DefinitionEntry ce,IsProof Property)
-      in
-	if not opaque then
-	  Auto.add_hints false [string_of_id prg.prg_name]
-	    (Auto.HintsUnfoldEntry [EvalConstRef constant]);
-	print_message (Subtac_utils.definition_message obl.obl_name);
-	{ obl with obl_body = Some (mkConst constant) }
-
-let init_prog_info n b t deps fixkind notations obls impls kind reduce hook =
-  let obls', b = 
-    match b with
-    | None ->
-	assert(obls = [||]);
-	let n = Nameops.add_suffix n "_obligation" in
-	  [| { obl_name = n; obl_body = None;
-	       obl_location = dummy_loc, InternalHole; obl_type = t;
-	       obl_status = Expand; obl_deps = Intset.empty; obl_tac = None } |],
-	mkVar n
-    | Some b ->
-	Array.mapi
-	  (fun i (n, t, l, o, d, tac) ->
-            { obl_name = n ; obl_body = None; 
-	      obl_location = l; obl_type = reduce t; obl_status = o;
-	      obl_deps = d; obl_tac = tac })
-	  obls, b
-  in
-    { prg_name = n ; prg_body = b; prg_type = reduce t; prg_obligations = (obls', Array.length obls');
-      prg_deps = deps; prg_fixkind = fixkind ; prg_notations = notations ;
-      prg_implicits = impls; prg_kind = kind; prg_reduce = reduce; prg_hook = hook; }
-
-let get_prog name =
-  let prg_infos = !from_prg in
-    match name with
-	Some n ->
-	  (try ProgMap.find n prg_infos
-	   with Not_found -> raise (NoObligations (Some n)))
-      | None ->
-	  (let n = map_cardinal prg_infos in
-	     match n with
-		 0 -> raise (NoObligations None)
-	       | 1 -> map_first prg_infos
-	       | _ -> error "More than one program with unsolved obligations")
-
-let get_prog_err n =
-  try get_prog n with NoObligations id -> pperror (explain_no_obligations id)
-
-let obligations_solved prg = (snd prg.prg_obligations) = 0
-
-let all_programs () =
-  ProgMap.fold (fun k p l -> p :: l) !from_prg []
-
-type progress =
-    | Remain of int
-    | Dependent
-    | Defined of global_reference
-
-let obligations_message rem =
-  if rem > 0 then
-    if rem = 1 then
-      Flags.if_verbose msgnl (int rem ++ str " obligation remaining")
-    else
-      Flags.if_verbose msgnl (int rem ++ str " obligations remaining")
-  else
-    Flags.if_verbose msgnl (str "No more obligations remaining")
-
-let update_obls prg obls rem =
-  let prg' = { prg with prg_obligations = (obls, rem) } in
-    progmap_replace prg';
-    obligations_message rem;
-    if rem > 0 then Remain rem
-    else (
-      match prg'.prg_deps with
-      | [] ->
-	  let kn = declare_definition prg' in
-	    progmap_remove prg';
-	    Defined kn
-      | l ->
-	  let progs = List.map (fun x -> ProgMap.find x !from_prg) prg'.prg_deps in
-	    if List.for_all (fun x -> obligations_solved x) progs then
-	      let kn = declare_mutual_definition progs in
-		Defined (ConstRef kn)
-	    else Dependent)
-
-let is_defined obls x = obls.(x).obl_body <> None
-
-let deps_remaining obls deps =
-  Intset.fold
-    (fun x acc ->
-      if is_defined obls x then acc
-      else x :: acc)
-    deps []
-
-let dependencies obls n =
-  let res = ref Intset.empty in
-    Array.iteri
-      (fun i obl ->
-	if i <> n && Intset.mem n obl.obl_deps then
-	  res := Intset.add i !res)
-      obls;
-    !res
-
-let kind_of_opacity o =
-  match o with
-  | Define false | Expand -> Subtac_utils.goal_kind
-  | _ -> Subtac_utils.goal_proof_kind
-
-let not_transp_msg =
-  str "Obligation should be transparent but was declared opaque." ++ spc () ++
-    str"Use 'Defined' instead."
-
-let warn_not_transp () = ppwarn not_transp_msg
-let error_not_transp () = pperror not_transp_msg
-
-let rec solve_obligation prg num tac =
-  let user_num = succ num in
-  let obls, rem = prg.prg_obligations in
-  let obl = obls.(num) in
-    if obl.obl_body <> None then
-      pperror (str "Obligation" ++ spc () ++ int user_num ++ str "already" ++ spc() ++ str "solved.")
-    else
-      match deps_remaining obls obl.obl_deps with
-      | [] ->
-	  let obl = subst_deps_obl obls obl in
-	    Lemmas.start_proof obl.obl_name (kind_of_opacity obl.obl_status) obl.obl_type
-	      (fun strength gr ->
-		let cst = match gr with ConstRef cst -> cst | _ -> assert false in
-		let obl =
-		  let transparent = evaluable_constant cst (Global.env ()) in
-		  let body =
-		    match obl.obl_status with
-		    | Expand ->
-			if not transparent then error_not_transp ()
-			else constant_value (Global.env ()) cst
-		    | Define opaque ->
-			if not opaque && not transparent then error_not_transp ()
-			else Libnames.constr_of_global gr
-		  in
-		    if transparent then
-		      Auto.add_hints true [string_of_id prg.prg_name]
-			(Auto.HintsUnfoldEntry [EvalConstRef cst]);
-		    { obl with obl_body = Some body }
-		in
-		let obls = Array.copy obls in
-		let _ = obls.(num) <- obl in
-		let res = try update_obls prg obls (pred rem)
-		  with e when Errors.noncritical e ->
-                    pperror (Errors.print (Cerrors.process_vernac_interp_error e))
-		in
-		  match res with
-		  | Remain n when n > 0 ->
-		      let deps = dependencies obls num in
-			if deps <> Intset.empty then
-			  ignore(auto_solve_obligations (Some prg.prg_name) None ~oblset:deps)
-		  | _ -> ());
-	    trace (str "Started obligation " ++ int user_num ++ str "  proof: " ++
-		      Subtac_utils.my_print_constr (Global.env ()) obl.obl_type);
-	    Pfedit.by (snd (get_default_tactic ()));
-	    Option.iter (fun tac -> Pfedit.set_end_tac (Tacinterp.interp tac)) tac;
-	    Flags.if_verbose (fun () -> msg (Printer.pr_open_subgoals ())) ()
-      | l -> pperror (str "Obligation " ++ int user_num ++ str " depends on obligation(s) "
-		       ++ str (string_of_list ", " (fun x -> string_of_int (succ x)) l))
-
-and subtac_obligation (user_num, name, typ) tac =
-  let num = pred user_num in
-  let prg = get_prog_err name in
-  let obls, rem = prg.prg_obligations in
-    if num < Array.length obls then
-      let obl = obls.(num) in
-	match obl.obl_body with
-	    None -> solve_obligation prg num tac
-	  | Some r -> error "Obligation already solved"
-    else error (sprintf "Unknown obligation number %i" (succ num))
-
-
-and solve_obligation_by_tac prg obls i tac =
-  let obl = obls.(i) in
-    match obl.obl_body with
-    | Some _ -> false
-    | None ->
-	try
-	  if deps_remaining obls obl.obl_deps = [] then
-	    let obl = subst_deps_obl obls obl in
-	    let tac =
-	      match tac with
-	      | Some t -> t
-	      | None ->
-		  match obl.obl_tac with
-		  | Some t -> t
-		  | None -> snd (get_default_tactic ())
-	    in
-	    let t = Subtac_utils.solve_by_tac (evar_of_obligation obl) tac in
-	      obls.(i) <- declare_obligation prg obl t;
-	      true
-	  else false
-	with
-	| Loc.Exc_located(_, Proof_type.LtacLocated (_, Refiner.FailError (_, s)))
-	| Loc.Exc_located(_, Refiner.FailError (_, s))
-	| Refiner.FailError (_, s) ->
-	    user_err_loc (fst obl.obl_location, "solve_obligation", Lazy.force s)
-	| Util.Anomaly _ as e -> raise e
-	| e when Errors.noncritical e -> false
-
-and solve_prg_obligations prg ?oblset tac =
-  let obls, rem = prg.prg_obligations in
-  let rem = ref rem in
-  let obls' = Array.copy obls in
-  let set = ref Intset.empty in
-  let p = match oblset with
-    | None -> (fun _ -> true)
-    | Some s -> set := s;
-      (fun i -> Intset.mem i !set)
-  in
-  let _ =
-    Array.iteri (fun i x ->
-      if p i && solve_obligation_by_tac prg obls' i tac then
-	let deps = dependencies obls i in
-	  (set := Intset.union !set deps;
-	   decr rem))
-      obls'
-  in
-    update_obls prg obls' !rem
-
-and solve_obligations n tac =
-  let prg = get_prog_err n in
-    solve_prg_obligations prg tac
-
-and solve_all_obligations tac =
-  ProgMap.iter (fun k v -> ignore(solve_prg_obligations v tac)) !from_prg
-
-and try_solve_obligation n prg tac =
-  let prg = get_prog prg in
-  let obls, rem = prg.prg_obligations in
-  let obls' = Array.copy obls in
-    if solve_obligation_by_tac prg obls' n tac then
-      ignore(update_obls prg obls' (pred rem));
-
-and try_solve_obligations n tac =
-  try ignore (solve_obligations n tac) with NoObligations _ -> ()
-
-and auto_solve_obligations n ?oblset tac : progress =
-  Flags.if_verbose msgnl (str "Solving obligations automatically...");
-  try solve_prg_obligations (get_prog_err n) ?oblset tac with NoObligations _ -> Dependent
-
-open Pp
-let show_obligations_of_prg ?(msg=true) prg =
-  let n = prg.prg_name in
-  let obls, rem = prg.prg_obligations in
-  let showed = ref 5 in
-    if msg then msgnl (int rem ++ str " obligation(s) remaining: ");
-    Array.iteri (fun i x ->
-		   match x.obl_body with
-		   | None ->
-		       if !showed > 0 then (
-			 decr showed;
-			 msgnl (str "Obligation" ++ spc() ++ int (succ i) ++ spc () ++
-				   str "of" ++ spc() ++ str (string_of_id n) ++ str ":" ++ spc () ++
-				   hov 1 (my_print_constr (Global.env ()) x.obl_type ++ str "." ++ fnl ())))
-		   | Some _ -> ())
-      obls
-
-let show_obligations ?(msg=true) n =
-  let progs = match n with
-    | None -> all_programs ()
-    | Some n ->
-	try [ProgMap.find n !from_prg]
-	with Not_found -> raise (NoObligations (Some n))
-  in List.iter (show_obligations_of_prg ~msg) progs
-
-let show_term n =
-  let prg = get_prog_err n in
-  let n = prg.prg_name in
-    msgnl (str (string_of_id n) ++ spc () ++ str":" ++ spc () ++
-	      my_print_constr (Global.env ()) prg.prg_type ++ spc () ++ str ":=" ++ fnl ()
-	    ++ my_print_constr (Global.env ()) prg.prg_body)
-
-let add_definition n ?term t ?(implicits=[]) ?(kind=Global,Definition) ?tactic
-    ?(reduce=reduce) ?(hook=fun _ _ -> ()) obls =
-  Flags.if_verbose pp (str (string_of_id n) ++ str " has type-checked");
-  let prg = init_prog_info n term t [] None [] obls implicits kind reduce hook in
-  let obls,_ = prg.prg_obligations in
-  if Array.length obls = 0 then (
-    Flags.if_verbose ppnl (str ".");
-    let cst = declare_definition prg in
-      Defined cst)
-  else (
-    let len = Array.length obls in
-    let _ = Flags.if_verbose ppnl (str ", generating " ++ int len ++ str " obligation(s)") in
-      progmap_add n prg;
-      let res = auto_solve_obligations (Some n) tactic in
-	match res with
-	| Remain rem -> Flags.if_verbose (fun () -> show_obligations ~msg:false (Some n)) (); res
-	| _ -> res)
-
-let add_mutual_definitions l ?tactic ?(kind=Global,Definition) ?(reduce=reduce)
-    ?(hook=fun _ _ -> ()) notations fixkind =
-  let deps = List.map (fun (n, b, t, imps, obls) -> n) l in
-    List.iter
-    (fun  (n, b, t, imps, obls) ->
-     let prg = init_prog_info n (Some b) t deps (Some fixkind) 
-       notations obls imps kind reduce hook 
-     in progmap_add n prg) l;
-    let _defined =
-      List.fold_left (fun finished x ->
-	if finished then finished
-	else
-	  let res = auto_solve_obligations (Some x) tactic in
-	    match res with
-	    | Defined _ -> (* If one definition is turned into a constant, the whole block is defined. *) true
-	    | _ -> false)
-	false deps
-    in ()
-
-let admit_obligations n =
-  let prg = get_prog_err n in
-  let obls, rem = prg.prg_obligations in
-  let obls = Array.copy obls in
-    Array.iteri 
-      (fun i x ->
-	match x.obl_body with
-	| None ->
-            let x = subst_deps_obl obls x in
-	    let kn = Declare.declare_constant x.obl_name 
-              (ParameterEntry (None, x.obl_type,None), IsAssumption Conjectural)
-	    in
-	      assumption_message x.obl_name;
-	      obls.(i) <- { x with obl_body = Some (mkConst kn) }
-	| Some _ -> ())
-      obls;
-    ignore(update_obls prg obls 0)
-
-exception Found of int
-
-let array_find f arr =
-  try Array.iteri (fun i x -> if f x then raise (Found i)) arr;
-    raise Not_found
-  with Found i -> i
-
-let next_obligation n tac =
-  let prg = get_prog_err n in
-  let obls, rem = prg.prg_obligations in
-  let i =
-    try array_find (fun x ->  x.obl_body = None && deps_remaining obls x.obl_deps = []) obls
-    with Not_found -> anomaly "Could not find a solvable obligation."
-  in solve_obligation prg i tac
diff --git a/plugins/subtac/subtac_obligations.mli b/plugins/subtac/subtac_obligations.mli
deleted file mode 100644
index c1d665aa..00000000
--- a/plugins/subtac/subtac_obligations.mli
+++ /dev/null
@@ -1,72 +0,0 @@
-open Names
-open Util
-open Libnames
-open Evd
-open Proof_type
-open Vernacexpr
-
-type obligation_info =
-  (identifier * Term.types * hole_kind located *
-      obligation_definition_status * Intset.t * tactic option) array
-    (* ident, type, location, (opaque or transparent, expand or define),
-       dependencies, tactic to solve it *)
-
-type progress = (* Resolution status of a program *)
-  | Remain of int  (* n obligations remaining *)
-  | Dependent (* Dependent on other definitions *)
-  | Defined of global_reference (* Defined as id *)
-      
-val set_default_tactic : bool -> Tacexpr.glob_tactic_expr -> unit
-val get_default_tactic : unit -> locality_flag * Proof_type.tactic
-val print_default_tactic : unit -> Pp.std_ppcmds
-
-val set_proofs_transparency : bool -> unit (* true = All transparent, false = Opaque if possible *)
-val get_proofs_transparency : unit -> bool
-
-val add_definition : Names.identifier -> ?term:Term.constr -> Term.types -> 
-  ?implicits:(Topconstr.explicitation * (bool * bool * bool)) list ->
-  ?kind:Decl_kinds.definition_kind ->
-  ?tactic:Proof_type.tactic ->
-  ?reduce:(Term.constr -> Term.constr) ->
-  ?hook:(Tacexpr.declaration_hook) -> obligation_info -> progress
-
-type notations = (Vernacexpr.lstring * Topconstr.constr_expr * Topconstr.scope_name option) list
-
-type fixpoint_kind =
-  | IsFixpoint of (identifier located option * Topconstr.recursion_order_expr) list
-  | IsCoFixpoint
-
-val add_mutual_definitions :
-  (Names.identifier * Term.constr * Term.types *
-      (Topconstr.explicitation * (bool * bool * bool)) list * obligation_info) list ->
-  ?tactic:Proof_type.tactic ->
-  ?kind:Decl_kinds.definition_kind ->
-  ?reduce:(Term.constr -> Term.constr) ->
-  ?hook:Tacexpr.declaration_hook ->
-  notations ->
-  fixpoint_kind -> unit
-
-val subtac_obligation : int * Names.identifier option * Topconstr.constr_expr option ->
-  Tacexpr.raw_tactic_expr option -> unit
-
-val next_obligation : Names.identifier option -> Tacexpr.raw_tactic_expr option -> unit
-
-val solve_obligations : Names.identifier option -> Proof_type.tactic option -> progress
-(* Number of remaining obligations to be solved for this program *)
-
-val solve_all_obligations : Proof_type.tactic option -> unit
-
-val try_solve_obligation : int -> Names.identifier option -> Proof_type.tactic option -> unit
-
-val try_solve_obligations : Names.identifier option -> Proof_type.tactic option -> unit
-
-val show_obligations : ?msg:bool -> Names.identifier option -> unit
-
-val show_term : Names.identifier option -> unit
-
-val admit_obligations : Names.identifier option -> unit
-
-exception NoObligations of Names.identifier option
-
-val explain_no_obligations : Names.identifier option -> Pp.std_ppcmds
-
diff --git a/plugins/subtac/subtac_plugin.mllib b/plugins/subtac/subtac_plugin.mllib
deleted file mode 100644
index a4b9d67e..00000000
--- a/plugins/subtac/subtac_plugin.mllib
+++ /dev/null
@@ -1,13 +0,0 @@
-Subtac_utils
-Eterm
-Subtac_errors
-Subtac_coercion
-Subtac_obligations
-Subtac_cases
-Subtac_pretyping_F
-Subtac_pretyping
-Subtac_command
-Subtac_classes
-Subtac
-G_subtac
-Subtac_plugin_mod
diff --git a/plugins/subtac/subtac_pretyping.ml b/plugins/subtac/subtac_pretyping.ml
deleted file mode 100644
index 68636574..00000000
--- a/plugins/subtac/subtac_pretyping.ml
+++ /dev/null
@@ -1,138 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Global
-open Pp
-open Util
-open Names
-open Sign
-open Evd
-open Term
-open Termops
-open Reductionops
-open Environ
-open Type_errors
-open Typeops
-open Libnames
-open Classops
-open List
-open Recordops
-open Evarutil
-open Pretype_errors
-open Glob_term
-open Evarconv
-open Pattern
-
-open Subtac_coercion
-open Subtac_utils
-open Coqlib
-open Printer
-open Subtac_errors
-open Eterm
-
-module Pretyping = Subtac_pretyping_F.SubtacPretyping_F(Subtac_coercion.Coercion)
-
-open Pretyping
-
-let _ = Pretyping.allow_anonymous_refs := true
-
-type recursion_info = {
-  arg_name: name;
-  arg_type: types; (* A *)
-  args_after : rel_context;
-  wf_relation: constr; (* R : A -> A -> Prop *)
-  wf_proof: constr; (* : well_founded R *)
-  f_type: types; (* f: A -> Set *)
-  f_fulltype: types; (* Type with argument and wf proof product first *)
-}
-
-let my_print_rec_info env t =
-  str "Name: " ++ Nameops.pr_name t.arg_name ++ spc () ++
-  str "Arg type: " ++ my_print_constr env t.arg_type ++ spc () ++
-  str "Wf relation: " ++ my_print_constr env t.wf_relation ++ spc () ++
-  str "Wf proof: " ++ my_print_constr env t.wf_proof ++ spc () ++
-  str "Abbreviated Type: " ++ my_print_constr env t.f_type ++ spc () ++
-  str "Full type: " ++ my_print_constr env t.f_fulltype
-(*   trace (str "pretype for " ++ (my_print_glob_constr env c) ++ *)
-(* 	   str " and tycon "++ my_print_tycon env tycon ++ *)
-(* 	   str " in environment: " ++ my_print_env env); *)
-
-let interp env isevars c tycon =
-  let j = pretype true tycon env isevars ([],[]) c in
-  let _ = isevars := Evarutil.nf_evar_map !isevars in
-  let evd = consider_remaining_unif_problems env !isevars in
-(*   let unevd = undefined_evars evd in *)
-  let unevd' = Typeclasses.resolve_typeclasses ~filter:Subtac_utils.no_goals_or_obligations ~split:true ~fail:true env evd in
-  let unevd' = Typeclasses.resolve_typeclasses ~filter:Typeclasses.all_evars ~split:true ~fail:false env unevd' in
-  let evm =  unevd' in
-    isevars := unevd';
-    nf_evar evm j.uj_val, nf_evar evm j.uj_type
-
-let find_with_index x l =
-  let rec aux i = function
-      (y, _, _) as t :: tl -> if x = y then i, t else aux (succ i) tl
-    | [] -> raise Not_found
-  in aux 0 l
-
-open Vernacexpr
-
-let coqintern_constr evd env : Topconstr.constr_expr -> Glob_term.glob_constr = 
-  Constrintern.intern_constr evd env
-let coqintern_type evd env : Topconstr.constr_expr -> Glob_term.glob_constr = 
-  Constrintern.intern_type evd env
-
-let env_with_binders env isevars l =
-  let rec aux ((env, rels) as acc) = function
-      Topconstr.LocalRawDef ((loc, name), def) :: tl ->
-	let rawdef = coqintern_constr !isevars env def in
-	let coqdef, deftyp = interp env isevars rawdef empty_tycon in
-	let reldecl = (name, Some coqdef, deftyp) in
-	  aux  (push_rel reldecl env, reldecl :: rels) tl
-    | Topconstr.LocalRawAssum (bl, k, typ) :: tl ->
-	let rawtyp = coqintern_type !isevars env typ in
-	let coqtyp, typtyp = interp env isevars rawtyp empty_tycon in
-	let acc =
-	  List.fold_left (fun (env, rels) (loc, name) ->
-			    let reldecl = (name, None, coqtyp) in
-			      (push_rel reldecl env,
-			       reldecl :: rels))
-	    (env, rels) bl
-	in aux acc tl
-    | [] -> acc
-  in aux (env, []) l
-
-let subtac_process ?(is_type=false) env isevars id bl c tycon =
-  let c = Topconstr.abstract_constr_expr c bl in
-  let tycon, imps =
-    match tycon with
-	None -> empty_tycon, None
-      | Some t ->
-	  let t = Topconstr.prod_constr_expr t bl in
-	  let t = coqintern_type !isevars env t in
-	  let imps = Implicit_quantifiers.implicits_of_glob_constr t in
-	  let coqt, ttyp = interp env isevars t empty_tycon in
-	    mk_tycon coqt, Some imps
-  in
-  let c = coqintern_constr !isevars env c in
-  let imps = match imps with 
-    | Some i -> i
-    | None -> Implicit_quantifiers.implicits_of_glob_constr ~with_products:is_type c
-  in
-  let coqc, ctyp = interp env isevars c tycon in
-  let evm = non_instanciated_map env isevars !isevars in
-  let ty = nf_evar !isevars (match tycon with Some (None, c) -> c | _ -> ctyp) in
-    evm, coqc, ty, imps
-
-open Subtac_obligations
-
-let subtac_proof kind hook env isevars id bl c tycon =
-  let evm, coqc, coqt, imps = subtac_process env isevars id bl c tycon in
-  let evm' = Subtac_utils.evars_of_term evm Evd.empty coqc in
-  let evm' = Subtac_utils.evars_of_term evm evm' coqt in
-  let evars, _, def, ty = Eterm.eterm_obligations env id !isevars evm' 0 coqc coqt in
-    add_definition id ~term:def ty ~implicits:imps ~kind ~hook evars
diff --git a/plugins/subtac/subtac_pretyping.mli b/plugins/subtac/subtac_pretyping.mli
deleted file mode 100644
index fa767790..00000000
--- a/plugins/subtac/subtac_pretyping.mli
+++ /dev/null
@@ -1,23 +0,0 @@
-open Term
-open Environ
-open Names
-open Sign
-open Evd
-open Global
-open Topconstr
-open Implicit_quantifiers
-open Impargs
-
-module Pretyping : Pretyping.S
-
-val interp :
-    Environ.env ->
-    Evd.evar_map ref ->
-    Glob_term.glob_constr ->
-    Evarutil.type_constraint -> Term.constr * Term.constr
-
-val subtac_process : ?is_type:bool -> env -> evar_map ref -> identifier -> local_binder list ->
-  constr_expr -> constr_expr option -> evar_map * constr * types * manual_explicitation list
-
-val subtac_proof : Decl_kinds.definition_kind -> Tacexpr.declaration_hook -> env -> evar_map ref -> identifier -> local_binder list ->
-  constr_expr -> constr_expr option -> Subtac_obligations.progress
diff --git a/plugins/subtac/subtac_pretyping_F.ml b/plugins/subtac/subtac_pretyping_F.ml
deleted file mode 100644
index 3fc35c81..00000000
--- a/plugins/subtac/subtac_pretyping_F.ml
+++ /dev/null
@@ -1,662 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Pp
-open Compat
-open Util
-open Names
-open Sign
-open Evd
-open Term
-open Reductionops
-open Environ
-open Type_errors
-open Typeops
-open Libnames
-open Nameops
-open Classops
-open List
-open Recordops
-open Evarutil
-open Pretype_errors
-open Glob_term
-open Evarconv
-open Pattern
-open Pretyping
-
-(************************************************************************)
-(* This concerns Cases *)
-open Declarations
-open Inductive
-open Inductiveops
-
-module SubtacPretyping_F (Coercion : Coercion.S) = struct
-
-  module Cases = Subtac_cases.Cases_F(Coercion)
-
-  (* Allow references to syntaxically inexistent variables (i.e., if applied on an inductive) *)
-  let allow_anonymous_refs = ref true
-
-  let evd_comb0 f evdref =
-    let (evd',x) = f !evdref in
-      evdref := evd';
-      x
-
-  let evd_comb1 f evdref x =
-    let (evd',y) = f !evdref x in
-      evdref := evd';
-      y
-
-  let evd_comb2 f evdref x y =
-    let (evd',z) = f !evdref x y in
-      evdref := evd';
-      z
-
-  let evd_comb3 f evdref x y z =
-    let (evd',t) = f !evdref x y z in
-      evdref := evd';
-      t
-
-  let mt_evd = Evd.empty
-
-  (* Utilisé pour inférer le prédicat des Cases *)
-  (* Semble exagérement fort *)
-  (* Faudra préférer une unification entre les types de toutes les clauses *)
-  (* et autoriser des ? à rester dans le résultat de l'unification *)
-
-  let evar_type_fixpoint loc env evdref lna lar vdefj =
-    let lt = Array.length vdefj in
-      if Array.length lar = lt then
-	for i = 0 to lt-1 do
-          if not (e_cumul env evdref (vdefj.(i)).uj_type
-		    (lift lt lar.(i))) then
-            error_ill_typed_rec_body_loc loc env !evdref
-              i lna vdefj lar
-	done
-
-  let check_branches_message loc env evdref ind c (explft,lft) =
-    for i = 0 to Array.length explft - 1 do
-      if not (e_cumul env evdref lft.(i) explft.(i)) then
-	let sigma =  !evdref in
-	  error_ill_formed_branch_loc loc env sigma c (ind,i) lft.(i) explft.(i)
-    done
-
-  (* coerce to tycon if any *)
-  let inh_conv_coerce_to_tycon resolve_tc loc env evdref j = function
-    | None -> j
-    | Some t -> evd_comb2 (Coercion.inh_conv_coerce_to resolve_tc loc env) evdref j t
-
-  let push_rels vars env = List.fold_right push_rel vars env
-
-  (*
-    let evar_type_case evdref env ct pt lft p c =
-    let (mind,bty,rslty) = type_case_branches env ( evdref) ct pt p c
-    in check_branches_message evdref env mind (c,ct) (bty,lft); (mind,rslty)
-  *)
-
-  let strip_meta id = (* For Grammar v7 compatibility *)
-    let s = string_of_id id in
-      if s.[0]='$' then id_of_string (String.sub s 1 (String.length s - 1))
-      else id
-
-  let invert_ltac_bound_name env id0 id =
-    try mkRel (pi1 (Termops.lookup_rel_id id (rel_context env)))
-    with Not_found ->
-      errorlabstrm "" (str "Ltac variable " ++ pr_id id0 ++
-	str " depends on pattern variable name " ++ pr_id id ++
-	str " which is not bound in current context")
-
-  let pretype_id loc env sigma (lvar,unbndltacvars) id =
-    let id = strip_meta id in (* May happen in tactics defined by Grammar *)
-      try
-	let (n,_,typ) = Termops.lookup_rel_id id (rel_context env) in
-	  { uj_val  = mkRel n; uj_type = lift n typ }
-      with Not_found ->
-	try
-	  let (ids,c) = List.assoc id lvar in
-	  let subst = List.map (invert_ltac_bound_name env id) ids in
-	  let c = substl subst c in
-	  { uj_val = c; uj_type = Retyping.get_type_of env sigma c }
-	with Not_found ->
-	  try
-	    let (_,_,typ) = lookup_named id env in
-	      { uj_val  = mkVar id; uj_type = typ }
-	  with Not_found ->
-	    try (* To build a nicer ltac error message *)
-	      match List.assoc id unbndltacvars with
-		| None -> user_err_loc (loc,"",
-					str "variable " ++ pr_id id ++ str " should be bound to a term")
-		| Some id0 -> Pretype_errors.error_var_not_found_loc loc id0
-	    with Not_found ->
-	      error_var_not_found_loc loc id
-
-  (* make a dependent predicate from an undependent one *)
-
-  let make_dep_of_undep env (IndType (indf,realargs)) pj =
-    let n = List.length realargs in
-    let rec decomp n p =
-      if n=0 then p else
-	match kind_of_term p with
-	  | Lambda (_,_,c) -> decomp (n-1) c
-	  | _ -> decomp (n-1) (applist (lift 1 p, [mkRel 1]))
-    in
-    let sign,s = decompose_prod_n n pj.uj_type in
-    let ind = build_dependent_inductive env indf in
-    let s' = mkProd (Anonymous, ind, s) in
-    let ccl = lift 1 (decomp n pj.uj_val) in
-    let ccl' = mkLambda (Anonymous, ind, ccl) in
-      {uj_val=Termops.it_mkLambda ccl' sign; uj_type=Termops.it_mkProd s' sign}
-
-  (*************************************************************************)
-  (* Main pretyping function                                               *)
-
-  let pretype_ref evdref env ref =
-    let c = constr_of_global ref in
-      make_judge c (Retyping.get_type_of env Evd.empty c)
-
-  let pretype_sort evdref = function
-    | GProp c -> judge_of_prop_contents c
-    | GType _ -> evd_comb0 judge_of_new_Type evdref
-
-  let split_tycon_lam loc env evd tycon =
-    let rec real_split evd c =
-      let t = whd_betadeltaiota env evd c in
-	match kind_of_term t with
-	| Prod (na,dom,rng) -> evd, (na, dom, rng)
-	| Evar ev when not (Evd.is_defined_evar evd ev) ->
-	    let (evd',prod) = define_evar_as_product evd ev in
-	    let (_,dom,rng) = destProd prod in
-	      evd',(Anonymous, dom, rng)
-	| _ -> error_not_product_loc loc env evd c
-    in
-      match tycon with
-      | None -> evd,(Anonymous,None,None)
-      | Some (abs, c) ->
-	  (match abs with
-	   | None ->
-	       let evd', (n, dom, rng) = real_split evd c in
-		 evd', (n, mk_tycon dom, mk_tycon rng)
-	   | Some (init, cur) ->
-	       evd, (Anonymous, None, Some (Some (init, succ cur), c)))
-	    
-	    
-  (* [pretype tycon env evdref lvar lmeta cstr] attempts to type [cstr] *)
-  (* in environment [env], with existential variables [( evdref)] and *)
-  (* the type constraint tycon *)
-  let rec pretype resolve_tc (tycon : type_constraint) env evdref lvar c =
-(*     let _ = try Subtac_utils.trace (str "pretype " ++ Subtac_utils.my_print_glob_constr env c ++ *)
-(* 			       str " with tycon " ++ Evarutil.pr_tycon env tycon)  *)
-(*     with _ -> () *)
-(*     in *)
-    let pretype = pretype resolve_tc in
-    let pretype_type = pretype_type resolve_tc in
-    let inh_conv_coerce_to_tycon = inh_conv_coerce_to_tycon resolve_tc in
-    match c with
-    | GRef (loc,ref) ->
-	inh_conv_coerce_to_tycon loc env evdref
-	  (pretype_ref evdref env ref)
-	  tycon
-
-    | GVar (loc, id) ->
-	inh_conv_coerce_to_tycon loc env evdref
-	  (pretype_id loc env !evdref lvar id)
-	  tycon
-
-    | GEvar (loc, ev, instopt) ->
-	(* Ne faudrait-il pas s'assurer que hyps est bien un
-	   sous-contexte du contexte courant, et qu'il n'y a pas de Rel "caché" *)
-	let hyps = evar_context (Evd.find !evdref ev) in
-	let args = match instopt with
-          | None -> instance_from_named_context hyps
-          | Some inst -> failwith "Evar subtitutions not implemented" in
-	let c = mkEvar (ev, args) in
-	let j = (Retyping.get_judgment_of env !evdref c) in
-	  inh_conv_coerce_to_tycon loc env evdref j tycon
-
-    | GPatVar (loc,(someta,n)) ->
-	anomaly "Found a pattern variable in a glob_constr to type"
-
-    | GHole (loc,k) ->
-	let ty =
-          match tycon with
-            | Some (None, ty) -> ty
-            | None | Some _ ->
-		e_new_evar evdref env ~src:(loc, InternalHole) (Termops.new_Type ()) in
-	  { uj_val = e_new_evar evdref env ~src:(loc,k) ty; uj_type = ty }
-
-    | GRec (loc,fixkind,names,bl,lar,vdef) ->
-	let rec type_bl env ctxt = function
-            [] -> ctxt
-          | (na,k,None,ty)::bl ->
-              let ty' = pretype_type empty_valcon env evdref lvar ty in
-              let dcl = (na,None,ty'.utj_val) in
-		type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl
-          | (na,k,Some bd,ty)::bl ->
-              let ty' = pretype_type empty_valcon env evdref lvar ty in
-              let bd' = pretype (mk_tycon ty'.utj_val) env evdref lvar ty in
-              let dcl = (na,Some bd'.uj_val,ty'.utj_val) in
-		type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl in
-	let ctxtv = Array.map (type_bl env empty_rel_context) bl in
-	let larj =
-          array_map2
-            (fun e ar ->
-               pretype_type empty_valcon (push_rel_context e env) evdref lvar ar)
-            ctxtv lar in
-	let lara = Array.map (fun a -> a.utj_val) larj in
-	let ftys = array_map2 (fun e a -> it_mkProd_or_LetIn a e) ctxtv lara in
-	let nbfix = Array.length lar in
-	let names = Array.map (fun id -> Name id) names in
-	  (* Note: bodies are not used by push_rec_types, so [||] is safe *)
-	let newenv =
-	  let marked_ftys =
-	    Array.map (fun ty -> let sort = Retyping.get_type_of env !evdref ty in
-			 mkApp (delayed_force Subtac_utils.fix_proto, [| sort; ty |]))
-	      ftys
-	  in
-	    push_rec_types (names,marked_ftys,[||]) env
-	in
-	let fixi = match fixkind with GFix (vn, i) -> i | GCoFix i -> i in
-	let vdefj =
-	  array_map2_i
-	    (fun i ctxt def ->
-	      let fty =
-		let ty = ftys.(i) in
-		  if i = fixi then (
-		    Option.iter (fun tycon ->
-		      evdref := Coercion.inh_conv_coerces_to loc env !evdref ftys.(i) tycon)
-		      tycon;
-		    nf_evar !evdref ty)
-		  else ty
-	      in
-              (* we lift nbfix times the type in tycon, because of
-	       * the nbfix variables pushed to newenv *)
-              let (ctxt,ty) =
-		decompose_prod_n_assum (rel_context_length ctxt)
-                  (lift nbfix fty) in
-              let nenv = push_rel_context ctxt newenv in
-              let j = pretype (mk_tycon ty) nenv evdref lvar def in
-		{ uj_val = it_mkLambda_or_LetIn j.uj_val ctxt;
-		  uj_type = it_mkProd_or_LetIn j.uj_type ctxt })
-            ctxtv vdef in
-	evar_type_fixpoint loc env evdref names ftys vdefj;
-	let ftys = Array.map (nf_evar !evdref) ftys in
-	let fdefs = Array.map (fun x -> nf_evar !evdref (j_val x)) vdefj in
-	let fixj = match fixkind with
-	  | GFix (vn,i) ->
-	      (* First, let's find the guard indexes. *)
-	      (* If recursive argument was not given by user, we try all args.
-	         An earlier approach was to look only for inductive arguments,
-		 but doing it properly involves delta-reduction, and it finally
-                 doesn't seem worth the effort (except for huge mutual
-		 fixpoints ?) *)
-	      let possible_indexes = Array.to_list (Array.mapi
-		(fun i (n,_) -> match n with
-		   | Some n -> [n]
-		   | None -> list_map_i (fun i _ -> i) 0 ctxtv.(i))
-		vn)
-	      in
-	      let fixdecls = (names,ftys,fdefs) in
-	      let indexes = search_guard loc env possible_indexes fixdecls in
-	      make_judge (mkFix ((indexes,i),fixdecls)) ftys.(i)
-	  | GCoFix i ->
-	      let cofix = (i,(names,ftys,fdefs)) in
-	      (try check_cofix env cofix
-               with e when Errors.noncritical e -> Loc.raise loc e);
-	      make_judge (mkCoFix cofix) ftys.(i) in
-	inh_conv_coerce_to_tycon loc env evdref fixj tycon
-
-    | GSort (loc,s) ->
-	let s' = pretype_sort evdref s in
-	inh_conv_coerce_to_tycon loc env evdref s' tycon
-
-    | GApp (loc,f,args) ->
-	let length = List.length args in
-	let ftycon =
-	  let ty =
-	    if length > 0 then
-	      match tycon with
-	      | None -> None
-	      | Some (None, ty) -> mk_abstr_tycon length ty
-	      | Some (Some (init, cur), ty) ->
-		  Some (Some (length + init, length + cur), ty)
- 	    else tycon
-	  in
-	    match ty with
-	    | Some (_, t) ->
-	      if Subtac_coercion.disc_subset (whd_betadeltaiota env !evdref t) = None then ty
-	      else None
-	    | _ -> None
-	in
-	let fj = pretype ftycon env evdref lvar f in
- 	let floc = loc_of_glob_constr f in
-	let rec apply_rec env n resj tycon = function
-	  | [] -> resj
-	  | c::rest ->
-	      let argloc = loc_of_glob_constr c in
-	      let resj = evd_comb1 (Coercion.inh_app_fun resolve_tc env) evdref resj in
-              let resty = whd_betadeltaiota env !evdref resj.uj_type in
-      		match kind_of_term resty with
-		  | Prod (na,c1,c2) ->
-		      Option.iter (fun ty -> evdref :=
-			Coercion.inh_conv_coerces_to loc env !evdref resty ty) tycon;
-		      let evd, (_, _, tycon) = split_tycon loc env !evdref tycon in
-		      evdref := evd;
-		      let hj = pretype (mk_tycon c1) env evdref lvar c in
-		      let value, typ = applist (j_val resj, [j_val hj]), subst1 hj.uj_val c2 in
-			apply_rec env (n+1)
-			{ uj_val = value;
-			  uj_type = typ }
-			  (Option.map (fun (abs, c) -> abs, c) tycon) rest
-
-		  | _ ->
-		      let hj = pretype empty_tycon env evdref lvar c in
-			error_cant_apply_not_functional_loc
-			  (join_loc floc argloc) env !evdref
-	      		  resj [hj]
-	in
-	let resj = apply_rec env 1 fj ftycon args in
-	let resj =
-	  match kind_of_term (whd_evar !evdref resj.uj_val) with
-	  | App (f,args) when isInd f or isConst f ->
-	      let sigma =  !evdref in
-	      let c = mkApp (f,Array.map (whd_evar sigma) args) in
-	      let t = Retyping.get_type_of env sigma c in
-	      make_judge c t
-	  | _ -> resj in
-	  inh_conv_coerce_to_tycon loc env evdref resj tycon
-
-    | GLambda(loc,name,k,c1,c2)      ->
-	let tycon' = evd_comb1
-	  (fun evd tycon ->
-	    match tycon with
-	    | None -> evd, tycon
-	    | Some ty ->
-		let evd, ty' = Coercion.inh_coerce_to_prod loc env evd ty in
-		  evd, Some ty')
-	  evdref tycon
-	in
-	let (name',dom,rng) = evd_comb1 (split_tycon_lam loc env) evdref tycon' in
-	let dom_valcon = valcon_of_tycon dom in
-	let j = pretype_type dom_valcon env evdref lvar c1 in
-	let var = (name,None,j.utj_val) in
-	let j' = pretype rng (push_rel var env) evdref lvar c2 in
-	let resj = judge_of_abstraction env name j j' in
-	  inh_conv_coerce_to_tycon loc env evdref resj tycon
-
-    | GProd(loc,name,k,c1,c2)        ->
-	let j = pretype_type empty_valcon env evdref lvar c1 in
-	let var = (name,j.utj_val) in
-	let env' = Termops.push_rel_assum var env in
-	let j' = pretype_type empty_valcon env' evdref lvar c2 in
-	let resj =
-	  try judge_of_product env name j j'
-	  with TypeError _ as e -> Loc.raise loc e in
-	  inh_conv_coerce_to_tycon loc env evdref resj tycon
-
-    | GLetIn(loc,name,c1,c2)      ->
-	let j = pretype empty_tycon env evdref lvar c1 in
-	let t = Termops.refresh_universes j.uj_type in
-	let var = (name,Some j.uj_val,t) in
-        let tycon = lift_tycon 1 tycon in
-	let j' = pretype tycon (push_rel var env) evdref lvar c2 in
-	  { uj_val = mkLetIn (name, j.uj_val, t, j'.uj_val) ;
-	    uj_type = subst1 j.uj_val j'.uj_type }
-
-    | GLetTuple (loc,nal,(na,po),c,d) ->
-	let cj = pretype empty_tycon env evdref lvar c in
-	let (IndType (indf,realargs)) =
-	  try find_rectype env !evdref cj.uj_type
-	  with Not_found ->
-	    let cloc = loc_of_glob_constr c in
-	      error_case_not_inductive_loc cloc env !evdref cj
-	in
-	let cstrs = get_constructors env indf in
-	if Array.length cstrs <> 1 then
-          user_err_loc (loc,"",str "Destructing let is only for inductive types with one constructor");
-	let cs = cstrs.(0) in
-	  if List.length nal <> cs.cs_nargs then
-            user_err_loc (loc,"", str "Destructing let on this type expects " ++ int cs.cs_nargs ++ str " variables");
-	let fsign = List.map2 (fun na (_,c,t) -> (na,c,t))
-          (List.rev nal) cs.cs_args in
-	let env_f = push_rels fsign env in
-	  (* Make dependencies from arity signature impossible *)
-	let arsgn =
-	  let arsgn,_ = get_arity env indf in
-	    if not !allow_anonymous_refs then
-	      List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn
-	    else arsgn
-	in
-	    let psign = (na,None,build_dependent_inductive env indf)::arsgn in
-	    let nar = List.length arsgn in
-	      (match po with
-		 | Some p ->
-		     let env_p = push_rels psign env in
-		     let pj = pretype_type empty_valcon env_p evdref lvar p in
-		     let ccl = nf_evar !evdref pj.utj_val in
-		     let psign = make_arity_signature env true indf in (* with names *)
-		     let p = it_mkLambda_or_LetIn ccl psign in
-		     let inst =
-		       (Array.to_list cs.cs_concl_realargs)
-		       @[build_dependent_constructor cs] in
-		     let lp = lift cs.cs_nargs p in
-		     let fty = hnf_lam_applist env !evdref lp inst in
-		     let fj = pretype (mk_tycon fty) env_f evdref lvar d in
-		     let f = it_mkLambda_or_LetIn fj.uj_val fsign in
-		     let v =
-		       let mis,_ = dest_ind_family indf in
-		       let ci = make_case_info env mis LetStyle in
-			 mkCase (ci, p, cj.uj_val,[|f|]) in
-		       { uj_val = v; uj_type = substl (realargs@[cj.uj_val]) ccl }
-
-		 | None ->
-		     let tycon = lift_tycon cs.cs_nargs tycon in
-		     let fj = pretype tycon env_f evdref lvar d in
-		     let f = it_mkLambda_or_LetIn fj.uj_val fsign in
-		     let ccl = nf_evar !evdref fj.uj_type in
-		     let ccl =
-		       if noccur_between 1 cs.cs_nargs ccl then
-			 lift (- cs.cs_nargs) ccl
-		       else
-			 error_cant_find_case_type_loc loc env !evdref
-			   cj.uj_val in
-		     let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign in
-		     let v =
-		       let mis,_ = dest_ind_family indf in
-		       let ci = make_case_info env mis LetStyle in
-			 mkCase (ci, p, cj.uj_val,[|f|] )
-		     in
-		       { uj_val = v; uj_type = ccl })
-
-    | GIf (loc,c,(na,po),b1,b2) ->
-	let cj = pretype empty_tycon env evdref lvar c in
-	let (IndType (indf,realargs)) =
-	  try find_rectype env !evdref cj.uj_type
-	  with Not_found ->
-	    let cloc = loc_of_glob_constr c in
-	      error_case_not_inductive_loc cloc env !evdref cj in
-	let cstrs = get_constructors env indf in
-	  if Array.length cstrs <> 2 then
-            user_err_loc (loc,"",
-			  str "If is only for inductive types with two constructors.");
-
-	  let arsgn =
-	    let arsgn,_ = get_arity env indf in
-	      if not !allow_anonymous_refs then
-		(* Make dependencies from arity signature impossible *)
-		List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn
-	      else arsgn
-	  in
-	  let nar = List.length arsgn in
-	  let psign = (na,None,build_dependent_inductive env indf)::arsgn in
-	  let pred,p = match po with
-	    | Some p ->
-		let env_p = push_rels psign env in
-		let pj = pretype_type empty_valcon env_p evdref lvar p in
-		let ccl = nf_evar !evdref pj.utj_val in
-		let pred = it_mkLambda_or_LetIn ccl psign in
-		let typ = lift (- nar) (beta_applist (pred,[cj.uj_val])) in
-		let jtyp = inh_conv_coerce_to_tycon loc env evdref {uj_val = pred;
-								     uj_type = typ} tycon
-		in
-		  jtyp.uj_val, jtyp.uj_type
-	    | None ->
-		let p = match tycon with
-		  | Some (None, ty) -> ty
-		  | None | Some _ ->
-                      e_new_evar evdref env ~src:(loc,InternalHole) (Termops.new_Type ())
-		in
-		  it_mkLambda_or_LetIn (lift (nar+1) p) psign, p in
-	  let pred = nf_evar !evdref pred in
-	  let p = nf_evar !evdref p in
-	  let f cs b =
-	    let n = rel_context_length cs.cs_args in
-	    let pi = lift n pred in
-	    let pi = beta_applist (pi, [build_dependent_constructor cs]) in
-	    let csgn =
-	      if not !allow_anonymous_refs then
-		List.map (fun (_,b,t) -> (Anonymous,b,t)) cs.cs_args
-	      else
-		List.map
-		  (fun (n, b, t) ->
-		     match n with
-                         Name _ -> (n, b, t)
-                       | Anonymous -> (Name (id_of_string "H"), b, t))
-		cs.cs_args
-	    in
-	    let env_c = push_rels csgn env in
-	    let bj = pretype (mk_tycon pi) env_c evdref lvar b in
-	      it_mkLambda_or_LetIn bj.uj_val cs.cs_args in
-	  let b1 = f cstrs.(0) b1 in
-	  let b2 = f cstrs.(1) b2 in
-	  let v =
-	    let mis,_ = dest_ind_family indf in
-	    let ci = make_case_info env mis IfStyle in
-	      mkCase (ci, pred, cj.uj_val, [|b1;b2|])
-	  in
-	    { uj_val = v; uj_type = p }
-
-    | GCases (loc,sty,po,tml,eqns) ->
-	Cases.compile_cases loc sty
-	  ((fun vtyc env evdref -> pretype vtyc env evdref lvar),evdref)
-	  tycon env (* loc *) (po,tml,eqns)
-
-    | GCast (loc,c,k) ->
-	let cj =
-	  match k with
-	      CastCoerce ->
-		let cj = pretype empty_tycon env evdref lvar c in
-		  evd_comb1 (Coercion.inh_coerce_to_base loc env) evdref cj
-	    | CastConv (k,t) ->
-		let tj = pretype_type empty_valcon env evdref lvar t in
-		let cj = pretype (mk_tycon tj.utj_val) env evdref lvar c in
-		let v = mkCast (cj.uj_val, k, tj.utj_val) in
-		  { uj_val = v; uj_type = tj.utj_val }
-	in
-	  inh_conv_coerce_to_tycon loc env evdref cj tycon
-
-  (* [pretype_type valcon env evdref lvar c] coerces [c] into a type *)
-  and pretype_type resolve_tc valcon env evdref lvar = function
-    | GHole loc ->
-	(match valcon with
-	   | Some v ->
-               let s =
-		 let sigma =  !evdref in
-		 let t = Retyping.get_type_of env sigma v in
-		   match kind_of_term (whd_betadeltaiota env sigma t) with
-                     | Sort s -> s
-                     | Evar ev when is_Type (existential_type sigma ev) ->
-			 evd_comb1 (define_evar_as_sort) evdref ev
-                     | _ -> anomaly "Found a type constraint which is not a type"
-               in
-		 { utj_val = v;
-		   utj_type = s }
-	   | None ->
-	       let s = Termops.new_Type_sort () in
-		 { utj_val = e_new_evar evdref env ~src:loc (mkSort s);
-		   utj_type = s})
-    | c ->
-	let j = pretype resolve_tc empty_tycon env evdref lvar c in
-	let loc = loc_of_glob_constr c in
-	let tj = evd_comb1 (Coercion.inh_coerce_to_sort loc env) evdref j in
-	  match valcon with
-	    | None -> tj
-	    | Some v ->
-		if e_cumul env evdref v tj.utj_val then tj
-		else
-		  error_unexpected_type_loc
-                    (loc_of_glob_constr c) env !evdref tj.utj_val v
-
-  let pretype_gen expand_evar fail_evar resolve_classes evdref env lvar kind c =
-    let c' = match kind with
-      | OfType exptyp ->
-	  let tycon = match exptyp with None -> empty_tycon | Some t -> mk_tycon t in
-	  (pretype resolve_classes tycon env evdref lvar c).uj_val
-      | IsType ->
-	  (pretype_type resolve_classes empty_valcon env evdref lvar c).utj_val 
-    in
-      if resolve_classes then
-	(try 
-	   evdref := Typeclasses.resolve_typeclasses ~filter:Subtac_utils.no_goals_or_obligations
-	     ~split:true ~fail:true env !evdref;
-	   evdref := Typeclasses.resolve_typeclasses ~filter:Typeclasses.all_evars
-	     ~split:true ~fail:false env !evdref
-	 with e when Errors.noncritical e ->
-           if fail_evar then raise e else ());
-      evdref := consider_remaining_unif_problems env !evdref;
-      let c = if expand_evar then nf_evar !evdref c' else c' in
-      if fail_evar then check_evars env Evd.empty !evdref c;
-      c
-
-  (* TODO: comment faire remonter l'information si le typage a resolu des
-     variables du sigma original. il faudrait que la fonction de typage
-     retourne aussi le nouveau sigma...
-  *)
-
-  let understand_judgment sigma env c =
-    let evdref = ref (create_evar_defs sigma) in
-    let j = pretype true empty_tycon env evdref ([],[]) c in
-    let evd = consider_remaining_unif_problems env !evdref in
-    let j = j_nf_evar evd j in
-    check_evars env sigma evd (mkCast(j.uj_val,DEFAULTcast, j.uj_type));
-    j
-
-  let understand_judgment_tcc evdref env c =
-    let j = pretype true empty_tycon env evdref ([],[]) c in
-    j_nf_evar !evdref j
-
-  (* Raw calls to the unsafe inference machine: boolean says if we must
-     fail on unresolved evars; the unsafe_judgment list allows us to
-     extend env with some bindings *)
-
-  let ise_pretype_gen expand_evar fail_evar resolve_classes sigma env lvar kind c =
-    let evdref = ref (Evd.create_evar_defs sigma) in
-    let c = pretype_gen expand_evar fail_evar resolve_classes evdref env lvar kind c in
-    !evdref, c
-
-  (** Entry points of the high-level type synthesis algorithm *)
-
-  let understand_gen kind sigma env c =
-    snd (ise_pretype_gen true true true sigma env ([],[]) kind c)
-
-  let understand sigma env ?expected_type:exptyp c =
-    snd (ise_pretype_gen true true true sigma env ([],[]) (OfType exptyp) c)
-
-  let understand_type sigma env c =
-    snd (ise_pretype_gen true false true sigma env ([],[]) IsType c)
-
-  let understand_ltac ?(resolve_classes=false) expand_evar sigma env lvar kind c =
-    ise_pretype_gen expand_evar false resolve_classes sigma env lvar kind c
-
-  let understand_tcc ?(resolve_classes=true) sigma env ?expected_type:exptyp c =
-    ise_pretype_gen true false resolve_classes sigma env ([],[]) (OfType exptyp) c
-
-  let understand_tcc_evars ?(fail_evar=false) ?(resolve_classes=true) evdref env kind c =
-    pretype_gen true fail_evar resolve_classes evdref env ([],[]) kind c
-end
-
-module Default : S = SubtacPretyping_F(Coercion.Default)
diff --git a/plugins/subtac/subtac_utils.ml b/plugins/subtac/subtac_utils.ml
deleted file mode 100644
index e32bb9e0..00000000
--- a/plugins/subtac/subtac_utils.ml
+++ /dev/null
@@ -1,476 +0,0 @@
-(** -*- compile-command: "make -C ../.. plugins/subtac/subtac_plugin.cma" -*- *)
-
-open Evd
-open Libnames
-open Coqlib
-open Term
-open Names
-open Util
-
-let ($) f x = f x
-
-(****************************************************************************)
-(* Library linking *)
-
-let contrib_name = "Program"
-
-let subtac_dir = [contrib_name]
-let fixsub_module = subtac_dir @ ["Wf"]
-let utils_module = subtac_dir @ ["Utils"]
-let tactics_module = subtac_dir @ ["Tactics"]
-let init_constant dir s () = gen_constant contrib_name dir s
-let init_reference dir s () = gen_reference contrib_name dir s
-
-let safe_init_constant md name () =
-  check_required_library ("Coq"::md);
-  init_constant md name ()
-
-let ex_pi1 = init_constant utils_module "ex_pi1"
-let ex_pi2 = init_constant utils_module "ex_pi2"
-
-let make_ref l s = init_reference l s
-let well_founded_ref = make_ref ["Init";"Wf"] "Well_founded"
-let acc_ref = make_ref  ["Init";"Wf"] "Acc"
-let acc_inv_ref = make_ref  ["Init";"Wf"] "Acc_inv"
-let fix_sub_ref = make_ref fixsub_module "Fix_sub"
-let measure_on_R_ref = make_ref fixsub_module "MR"
-let fix_measure_sub_ref = make_ref fixsub_module "Fix_measure_sub"
-let refl_ref = make_ref ["Init";"Logic"] "refl_equal"
-
-let make_ref s = Qualid (dummy_loc, qualid_of_string s)
-let lt_ref = make_ref "Init.Peano.lt"
-let sig_ref = make_ref "Init.Specif.sig"
-let proj1_sig_ref = make_ref "Init.Specif.proj1_sig"
-let proj2_sig_ref = make_ref "Init.Specif.proj2_sig"
-
-let build_sig () =
-  { proj1 = init_constant ["Init"; "Specif"] "proj1_sig" ();
-    proj2 = init_constant ["Init"; "Specif"] "proj2_sig" ();
-    elim = init_constant ["Init"; "Specif"] "sig_rec" ();
-    intro = init_constant ["Init"; "Specif"] "exist" ();
-    typ = init_constant ["Init"; "Specif"] "sig" () }
-
-let sig_ = build_sig
-
-let fix_proto = safe_init_constant tactics_module "fix_proto"
-
-let hide_obligation = safe_init_constant tactics_module "obligation"
-
-let eq_ind = init_constant ["Init"; "Logic"] "eq"
-let eq_rec = init_constant ["Init"; "Logic"] "eq_rec"
-let eq_rect = init_constant ["Init"; "Logic"] "eq_rect"
-let eq_refl = init_constant ["Init"; "Logic"] "refl_equal"
-let eq_ind_ref = init_reference ["Init"; "Logic"] "eq"
-let refl_equal_ref = init_reference ["Init"; "Logic"] "refl_equal"
-
-let not_ref = init_constant ["Init"; "Logic"] "not"
-
-let and_typ = Coqlib.build_coq_and
-
-let eqdep_ind = init_constant [ "Logic";"Eqdep"] "eq_dep"
-let eqdep_rec = init_constant ["Logic";"Eqdep"] "eq_dep_rec"
-let eqdep_ind_ref = init_reference [ "Logic";"Eqdep"] "eq_dep"
-let eqdep_intro_ref = init_reference [ "Logic";"Eqdep"] "eq_dep_intro"
-
-let jmeq_ind =
-  safe_init_constant ["Logic";"JMeq"] "JMeq"
-
-let jmeq_rec =
-  init_constant ["Logic";"JMeq"] "JMeq_rec"
-
-let jmeq_refl =
-  init_constant ["Logic";"JMeq"] "JMeq_refl"
-
-let ex_ind = init_constant ["Init"; "Logic"] "ex"
-let ex_intro = init_reference ["Init"; "Logic"] "ex_intro"
-
-let proj1 = init_constant ["Init"; "Logic"] "proj1"
-let proj2 = init_constant ["Init"; "Logic"] "proj2"
-
-let existS = build_sigma_type
-
-let prod = build_prod
-
-
-(* orders *)
-let well_founded = init_constant ["Init"; "Wf"] "well_founded"
-let fix = init_constant ["Init"; "Wf"] "Fix"
-let acc = init_constant ["Init"; "Wf"] "Acc"
-let acc_inv = init_constant ["Init"; "Wf"] "Acc_inv"
-
-let extconstr = Constrextern.extern_constr true (Global.env ())
-let extsort s = Constrextern.extern_constr true (Global.env ()) (mkSort s)
-
-open Pp
-
-let my_print_constr = Termops.print_constr_env
-let my_print_constr_expr = Ppconstr.pr_constr_expr
-let my_print_rel_context env ctx = Printer.pr_rel_context env ctx
-let my_print_context = Termops.print_rel_context
-let my_print_named_context = Termops.print_named_context
-let my_print_env = Termops.print_env
-let my_print_glob_constr = Printer.pr_glob_constr_env
-let my_print_evardefs = Evd.pr_evar_map None
-
-let my_print_tycon_type = Evarutil.pr_tycon_type
-
-let debug_level = 2
-
-let debug_on = true
-
-let debug n s =
-  if debug_on then
-    if !Flags.debug && n >= debug_level then
-      msgnl s
-    else ()
-  else ()
-
-let debug_msg n s =
-  if debug_on then
-    if !Flags.debug  && n >= debug_level then s
-    else mt ()
-  else mt ()
-
-let trace s =
-  if debug_on then
-    if !Flags.debug  && debug_level > 0 then msgnl s
-    else ()
-  else ()
-
-let rec pp_list f = function
-    [] -> mt()
-  | x :: y -> f x ++ spc () ++ pp_list f y
-
-let wf_relations = Hashtbl.create 10
-
-let std_relations () =
-  let add k v = Hashtbl.add wf_relations k v in
-    add (init_constant ["Init"; "Peano"] "lt" ())
-      (init_constant ["Arith"; "Wf_nat"] "lt_wf")
-
-let std_relations = Lazy.lazy_from_fun std_relations
-
-type binders = Topconstr.local_binder list
-
-let app_opt c e =
-  match c with
-      Some constr -> constr e
-    | None -> e
-
-let print_args env args =
-  Array.fold_right (fun a acc -> my_print_constr env a ++ spc () ++ acc) args (str "")
-
-let make_existential loc ?(opaque = Define true) env isevars c =
-  Evarutil.e_new_evar isevars env ~src:(loc, QuestionMark opaque) c
-
-let no_goals_or_obligations = function
-  | GoalEvar | QuestionMark _ -> false
-  | _ -> true
-
-let make_existential_expr loc env c =
-  let key = Evarutil.new_untyped_evar () in
-  let evar = Topconstr.CEvar (loc, key, None) in
-    debug 2 (str "Constructed evar " ++ int key);
-    evar
-
-let string_of_hole_kind = function
-  | ImplicitArg _ -> "ImplicitArg"
-  | BinderType _ -> "BinderType"
-  | QuestionMark _ -> "QuestionMark"
-  | CasesType -> "CasesType"
-  | InternalHole -> "InternalHole"
-  | TomatchTypeParameter _ -> "TomatchTypeParameter"
-  | GoalEvar -> "GoalEvar"
-  | ImpossibleCase -> "ImpossibleCase"
-  | MatchingVar _ -> "MatchingVar"
-
-let evars_of_term evc init c =
-  let rec evrec acc c =
-    match kind_of_term c with
-    | Evar (n, _) when Evd.mem evc n -> Evd.add acc n (Evd.find evc n)
-    | Evar (n, _) -> assert(false)
-    | _ -> fold_constr evrec acc c
-  in
-    evrec init c
-
-let non_instanciated_map env evd evm =
-  List.fold_left
-    (fun evm (key, evi) ->
-       let (loc,k) = evar_source key !evd in
-	 debug 2 (str "evar " ++ int key ++ str " has kind " ++
-		    str (string_of_hole_kind k));
-	 match k with
-	 | QuestionMark _ -> Evd.add evm key evi
-	 | ImplicitArg (_,_,false) -> Evd.add evm key evi
-	 | _ ->
-	     debug 2 (str " and is an implicit");
-	     Pretype_errors.error_unsolvable_implicit loc env evm (Evarutil.nf_evar_info evm evi) k None)
-    Evd.empty (Evarutil.non_instantiated evm)
-
-let global_kind = Decl_kinds.IsDefinition Decl_kinds.Definition
-let goal_kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Definition
-
-let global_proof_kind = Decl_kinds.IsProof Decl_kinds.Lemma
-let goal_proof_kind = Decl_kinds.Global, Decl_kinds.Proof Decl_kinds.Lemma
-
-let global_fix_kind = Decl_kinds.IsDefinition Decl_kinds.Fixpoint
-let goal_fix_kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Fixpoint
-
-open Tactics
-open Tacticals
-
-let filter_map f l =
-  let rec aux acc = function
-      hd :: tl -> (match f hd with Some t -> aux (t :: acc) tl
-		     | None -> aux acc tl)
-    | [] -> List.rev acc
-  in aux [] l
-
-let build_dependent_sum l =
-  let rec aux names conttac conttype = function
-      (n, t) :: ((_ :: _) as tl) ->
-	let hyptype = substl names t in
-	  trace (spc () ++ str ("treating evar " ^ string_of_id n));
-	  (try trace (str " assert: " ++ my_print_constr (Global.env ()) hyptype)
-	   with e when Errors.noncritical e -> ());
-	let tac = assert_tac (Name n) hyptype in
-	let conttac =
-	  (fun cont ->
-	     conttac
-	     (tclTHENS tac
-		([intros;
-		  (tclTHENSEQ
-		     [constructor_tac false (Some 1) 1
-			(Glob_term.ImplicitBindings [mkVar n]);
-		      cont]);
-		 ])))
-	in
-	let conttype =
-	  (fun typ ->
-	     let tex = mkLambda (Name n, t, typ) in
-	       conttype
-		 (mkApp (ex_ind (), [| t; tex |])))
-	in
-	  aux (mkVar n :: names) conttac conttype tl
-    | (n, t) :: [] ->
-	(conttac intros, conttype t)
-    | [] -> raise (Invalid_argument "build_dependent_sum")
-  in aux [] identity identity (List.rev l)
-
-open Proof_type
-open Tacexpr
-
-let mkProj1 a b c =
-  mkApp (delayed_force proj1, [| a; b; c |])
-
-let mkProj2 a b c =
-  mkApp (delayed_force proj2, [| a; b; c |])
-
-let mk_ex_pi1 a b c =
-  mkApp (delayed_force ex_pi1, [| a; b; c |])
-
-let mk_ex_pi2 a b c =
-  mkApp (delayed_force ex_pi2, [| a; b; c |])
-
-let mkSubset name typ prop =
-  mkApp ((delayed_force sig_).typ,
-	 [| typ; mkLambda (name, typ, prop) |])
-
-let mk_eq typ x y = mkApp (delayed_force eq_ind, [| typ; x ; y |])
-let mk_eq_refl typ x = mkApp (delayed_force eq_refl, [| typ; x |])
-let mk_JMeq typ x typ' y = mkApp (delayed_force jmeq_ind, [| typ; x ; typ'; y |])
-let mk_JMeq_refl typ x = mkApp (delayed_force jmeq_refl, [| typ; x |])
-
-let unsafe_fold_right f = function
-    hd :: tl -> List.fold_right f tl hd
-  | [] -> raise (Invalid_argument "unsafe_fold_right")
-
-let mk_conj l =
-  let conj_typ = delayed_force and_typ in
-    unsafe_fold_right
-      (fun c conj ->
-	 mkApp (conj_typ, [| c ; conj |]))
-      l
-
-let mk_not c =
-  let notc = delayed_force not_ref in
-    mkApp (notc, [| c |])
-
-let and_tac l hook =
-  let andc = Coqlib.build_coq_and () in
-  let rec aux ((accid, goal, tac, extract) as acc) = function
-    | [] -> (* Singleton *) acc
-
-    | (id, x, elgoal, eltac) :: tl ->
-	let tac' = tclTHEN simplest_split (tclTHENLIST [tac; eltac]) in
-	let proj = fun c -> mkProj2 goal elgoal c in
-	let extract = List.map (fun (id, x, y, f) -> (id, x, y, (fun c -> f (mkProj1 goal elgoal c)))) extract in
-	  aux ((string_of_id id) ^ "_" ^ accid, mkApp (andc, [| goal; elgoal |]), tac',
-	       (id, x, elgoal, proj) :: extract) tl
-
-  in
-  let and_proof_id, and_goal, and_tac, and_extract =
-    match l with
-      | [] -> raise (Invalid_argument "and_tac: empty list of goals")
-      | (hdid, x, hdg, hdt) :: tl ->
-	  aux (string_of_id hdid, hdg, hdt, [hdid, x, hdg, (fun c -> c)]) tl
-  in
-  let and_proofid = id_of_string (and_proof_id ^ "_and_proof") in
-    Lemmas.start_proof and_proofid goal_kind and_goal
-      (hook (fun c -> List.map (fun (id, x, t, f) -> (id, x, t, f c)) and_extract));
-    trace (str "Started and proof");
-    Pfedit.by and_tac;
-    trace (str "Applied and tac")
-
-
-let destruct_ex ext ex =
-  let rec aux c acc =
-    match kind_of_term c with
-	App (f, args) ->
-	  (match kind_of_term f with
-	       Ind i when i = Term.destInd (delayed_force ex_ind) && Array.length args = 2 ->
-		 let (dom, rng) =
-		   try (args.(0), args.(1))
-		   with e when Errors.noncritical e -> assert(false)
-		 in
-		 let pi1 = (mk_ex_pi1 dom rng acc) in
-		 let rng_body =
-		   match kind_of_term rng with
-		       Lambda (_, _, t) -> subst1 pi1 t
-		     | t -> rng
-		 in
-		   pi1 :: aux rng_body (mk_ex_pi2 dom rng acc)
-	     | _ -> [acc])
-      | _ -> [acc]
-  in aux ex ext
-
-open Glob_term
-
-let id_of_name = function
-    Name n -> n
-  | Anonymous -> raise (Invalid_argument "id_of_name")
-
-let definition_message id =
-  Nameops.pr_id id ++ str " is defined"
-
-let recursive_message v =
-  match Array.length v with
-    | 0 -> error "no recursive definition"
-    | 1 -> (Printer.pr_constant (Global.env ()) v.(0) ++ str " is recursively defined")
-    | _ -> hov 0 (prvect_with_sep pr_comma (Printer.pr_constant (Global.env ())) v ++
-		    spc () ++ str "are recursively defined")
-
-let print_message m =
-  Flags.if_verbose ppnl m
-
-(* Solve an obligation using tactics, return the corresponding proof term *)
-let solve_by_tac evi t =
-  let id = id_of_string "H" in
-  try
-    Pfedit.start_proof id goal_kind evi.evar_hyps evi.evar_concl
-    (fun _ _ -> ());
-    Pfedit.by (tclCOMPLETE t);
-    let _,(const,_,_,_) = Pfedit.cook_proof ignore in
-      Pfedit.delete_current_proof (); 
-      Inductiveops.control_only_guard (Global.env ())
-	const.Entries.const_entry_body;
-      const.Entries.const_entry_body
-  with reraise ->
-    Pfedit.delete_current_proof();
-    raise reraise
-
-(* let apply_tac t goal = t goal *)
-
-(* let solve_by_tac evi t = *)
-(*   let ev = 1 in *)
-(*   let evm = Evd.add Evd.empty ev evi in *)
-(*   let goal = {it = evi; sigma = evm } in *)
-(*   let (res, valid) = apply_tac t goal in *)
-(*     if res.it = [] then *)
-(*       let prooftree = valid [] in *)
-(*       let proofterm, obls = Refiner.extract_open_proof res.sigma prooftree in *)
-(* 	if obls = [] then proofterm *)
-(* 	else raise Exit *)
-(*     else raise Exit *)
-
-let rec string_of_list sep f = function
-    [] -> ""
-  | x :: [] -> f x
-  | x :: ((y :: _) as tl) -> f x ^ sep ^ string_of_list sep f tl
-
-let string_of_intset d =
-  string_of_list "," string_of_int (Intset.elements d)
-
-(**********************************************************)
-(* Pretty-printing *)
-open Printer
-open Ppconstr
-open Nameops
-open Evd
-
-let pr_meta_map evd =
-  let ml = meta_list evd in
-  let pr_name = function
-      Name id -> str"[" ++ pr_id id ++ str"]"
-    | _ -> mt() in
-  let pr_meta_binding = function
-    | (mv,Cltyp (na,b)) ->
-      	hov 0
-	  (pr_meta mv ++ pr_name na ++ str " : " ++
-           Termops.print_constr b.rebus ++ fnl ())
-    | (mv,Clval(na,b,_)) ->
-      	hov 0
-	  (pr_meta mv ++ pr_name na ++ str " := " ++
-             Termops.print_constr (fst b).rebus ++ fnl ())
-  in
-  prlist pr_meta_binding ml
-
-let pr_idl idl = prlist_with_sep pr_spc pr_id idl
-
-let pr_evar_info evi =
-  let phyps =
-    (*pr_idl (List.rev (ids_of_named_context (evar_context evi))) *)
-    Printer.pr_named_context (Global.env()) (evar_context evi)
-  in
-  let pty = Termops.print_constr evi.evar_concl in
-  let pb =
-    match evi.evar_body with
-      | Evar_empty -> mt ()
-      | Evar_defined c -> spc() ++ str"=> "  ++ Termops.print_constr c
-  in
-  hov 2 (str"["  ++ phyps ++ spc () ++ str"|- "  ++ pty ++ pb ++ str"]")
-
-let pr_evar_map sigma =
-  h 0
-    (prlist_with_sep pr_fnl
-      (fun (ev,evi) ->
-        h 0 (str(string_of_existential ev)++str"=="++ pr_evar_info evi))
-      (to_list sigma))
-
-let pr_constraints pbs =
-  h 0
-    (prlist_with_sep pr_fnl (fun (pbty,t1,t2) ->
-      Termops.print_constr t1 ++ spc() ++
-      str (match pbty with
-	| Reduction.CONV -> "=="
-	| Reduction.CUMUL -> "<=") ++
-      spc() ++ Termops.print_constr t2) pbs)
-
-let pr_evar_map evd =
-  let pp_evm =
-    let evars =  evd in
-    if evars = empty then mt() else
-      str"EVARS:"++brk(0,1)++pr_evar_map evars++fnl() in
-  let pp_met =
-    if meta_list evd = [] then mt() else
-      str"METAS:"++brk(0,1)++pr_meta_map evd in
-  v 0 (pp_evm ++ pp_met)
-
-let contrib_tactics_path =
-  make_dirpath (List.map id_of_string ["Tactics";contrib_name;"Coq"])
-
-let tactics_tac s =
-  lazy(make_kn (MPfile contrib_tactics_path) (make_dirpath []) (mk_label s))
-
-let tactics_call tac args =
-  TacArg(dummy_loc,TacCall(dummy_loc, ArgArg(dummy_loc, Lazy.force (tactics_tac tac)),args))
diff --git a/plugins/subtac/subtac_utils.mli b/plugins/subtac/subtac_utils.mli
deleted file mode 100644
index 112b1795..00000000
--- a/plugins/subtac/subtac_utils.mli
+++ /dev/null
@@ -1,131 +0,0 @@
-open Term
-open Libnames
-open Coqlib
-open Environ
-open Pp
-open Evd
-open Decl_kinds
-open Topconstr
-open Glob_term
-open Util
-open Evarutil
-open Names
-open Sign
-
-val ($) : ('a -> 'b) -> 'a -> 'b
-val contrib_name : string
-val subtac_dir : string list
-val fixsub_module : string list
-val init_constant : string list -> string -> constr delayed
-val init_reference : string list -> string -> global_reference delayed
-val well_founded_ref : global_reference delayed
-val acc_ref : global_reference delayed
-val acc_inv_ref : global_reference delayed
-val fix_sub_ref : global_reference delayed
-val measure_on_R_ref : global_reference delayed
-val fix_measure_sub_ref : global_reference delayed
-val refl_ref : global_reference delayed
-val lt_ref : reference
-val sig_ref : reference
-val proj1_sig_ref : reference
-val proj2_sig_ref : reference
-val build_sig : unit -> coq_sigma_data
-val sig_ : coq_sigma_data delayed
-
-val fix_proto : constr delayed
-
-val hide_obligation : constr delayed
-
-val eq_ind : constr delayed
-val eq_rec : constr delayed
-val eq_rect : constr delayed
-val eq_refl : constr delayed
-
-val not_ref : constr delayed
-val and_typ : constr delayed
-
-val eqdep_ind : constr delayed
-val eqdep_rec : constr delayed
-
-val jmeq_ind : constr delayed
-val jmeq_rec : constr delayed
-val jmeq_refl : constr delayed
-
-val existS : coq_sigma_data delayed
-val prod : coq_sigma_data delayed
-
-val well_founded : constr delayed
-val fix : constr delayed
-val acc : constr delayed
-val acc_inv : constr delayed
-val extconstr : constr -> constr_expr
-val extsort : sorts -> constr_expr
-
-val my_print_constr : env -> constr -> std_ppcmds
-val my_print_constr_expr : constr_expr -> std_ppcmds
-val my_print_evardefs : evar_map -> std_ppcmds
-val my_print_context : env -> std_ppcmds
-val my_print_rel_context : env -> rel_context -> std_ppcmds
-val my_print_named_context : env -> std_ppcmds
-val my_print_env : env -> std_ppcmds
-val my_print_glob_constr : env -> glob_constr -> std_ppcmds
-val my_print_tycon_type : env -> type_constraint_type -> std_ppcmds
-
-
-val debug : int -> std_ppcmds -> unit
-val debug_msg : int -> std_ppcmds -> std_ppcmds
-val trace : std_ppcmds -> unit
-val wf_relations : (constr, constr delayed) Hashtbl.t
-
-type binders = local_binder list
-val app_opt : ('a -> 'a) option -> 'a -> 'a
-val print_args : env -> constr array -> std_ppcmds
-val make_existential : loc -> ?opaque:obligation_definition_status ->
-  env -> evar_map ref -> types -> constr
-val no_goals_or_obligations : Typeclasses.evar_filter
-val make_existential_expr : loc -> 'a -> 'b -> constr_expr
-val string_of_hole_kind : hole_kind -> string
-val evars_of_term : evar_map -> evar_map -> constr -> evar_map
-val non_instanciated_map : env -> evar_map ref -> evar_map -> evar_map
-val global_kind : logical_kind
-val goal_kind : locality * goal_object_kind
-val global_proof_kind : logical_kind
-val goal_proof_kind : locality * goal_object_kind
-val global_fix_kind : logical_kind
-val goal_fix_kind : locality * goal_object_kind
-
-val mkSubset : name -> constr -> constr -> constr
-val mkProj1 : constr -> constr -> constr -> constr
-val mkProj1 : constr -> constr -> constr -> constr
-val mk_ex_pi1 : constr -> constr -> constr -> constr
-val mk_ex_pi1 : constr -> constr -> constr -> constr
-val mk_eq : types -> constr -> constr -> types
-val mk_eq_refl : types -> constr -> constr
-val mk_JMeq : types -> constr-> types -> constr -> types
-val mk_JMeq_refl : types -> constr -> constr
-val mk_conj : types list -> types
-val mk_not : types -> types
-
-val build_dependent_sum : (identifier * types) list -> Proof_type.tactic * types
-val and_tac : (identifier * 'a * constr * Proof_type.tactic) list ->
-  ((constr -> (identifier * 'a * constr * constr) list) -> Tacexpr.declaration_hook) -> unit
-
-val destruct_ex : constr -> constr -> constr list
-
-val id_of_name : name -> identifier
-
-val definition_message : identifier -> std_ppcmds
-val recursive_message : constant array -> std_ppcmds
-
-val print_message : std_ppcmds -> unit
-
-val solve_by_tac : evar_info -> Tacmach.tactic -> constr
-
-val string_of_list : string -> ('a -> string) -> 'a list -> string
-val string_of_intset : Intset.t -> string
-
-val pr_evar_map : evar_map -> Pp.std_ppcmds
-
-val tactics_call : string -> Tacexpr.glob_tactic_arg list -> Tacexpr.glob_tactic_expr
-
-val pp_list : ('a -> Pp.std_ppcmds) -> 'a list -> Pp.std_ppcmds
diff --git a/plugins/subtac/test/ListDep.v b/plugins/subtac/test/ListDep.v
deleted file mode 100644
index e3dbd127..00000000
--- a/plugins/subtac/test/ListDep.v
+++ /dev/null
@@ -1,49 +0,0 @@
-(* -*- coq-prog-args: ("-emacs-U" "-debug") -*- *)
-Require Import List.
-Require Import Coq.Program.Program.
-
-Set Implicit Arguments.
-
-Definition sub_list (A : Set) (l' l : list A) := (forall v, In v l' -> In v l) /\ length l' <= length l.
-
-Lemma sub_list_tl : forall A : Set, forall x (l l' : list A), sub_list (x :: l) l' -> sub_list l l'.
-Proof.
-  intros.
-  inversion H.
-  split.
-  intros.
-  apply H0.
-  auto with datatypes.
-  auto with arith.
-Qed.
-
-Section Map_DependentRecursor.
-  Variable U V : Set.
-  Variable l : list U.
-  Variable f : { x : U | In x l } -> V.
-
-  Obligations Tactic := unfold sub_list in * ;
-    program_simpl ; intuition.
-
-  Program Fixpoint map_rec ( l' : list U | sub_list l' l )
-    { measure length l' } : { r : list V | length r = length l' } :=
-    match l' with
-      | nil => nil
-      | cons x tl => let tl' := map_rec tl in
-	f x :: tl'
-    end.
-
-  Next Obligation.
-    destruct_call map_rec.
-    simpl in *.
-    subst l'.
-    simpl ; auto with arith.
-  Qed.
-
-  Program Definition map : list V := map_rec l.
-
-End Map_DependentRecursor.
-
-Extraction map.
-Extraction map_rec.
-
diff --git a/plugins/subtac/test/ListsTest.v b/plugins/subtac/test/ListsTest.v
deleted file mode 100644
index 2cea0841..00000000
--- a/plugins/subtac/test/ListsTest.v
+++ /dev/null
@@ -1,99 +0,0 @@
-(* -*- coq-prog-args: ("-emacs-U" "-debug") -*- *)
-Require Import Coq.Program.Program.
-Require Import List.
-
-Set Implicit Arguments.
-
-Section Accessors.
-  Variable A : Set.
-
-  Program Definition myhd : forall (l : list A | length l <> 0), A :=
-    fun l =>
-      match l with
-        | nil => !
-        | hd :: tl => hd
-      end.
-
-  Program Definition mytail (l : list A | length l <> 0) : list A :=
-    match l with
-      | nil => !
-      | hd :: tl => tl
-    end.
-End Accessors.
-
-Program Definition test_hd : nat := myhd (cons 1 nil).
-
-(*Eval compute in test_hd*)
-(*Program Definition test_tail : list A := mytail nil.*)
-
-Section app.
-  Variable A : Set.
-
-  Program Fixpoint app (l : list A) (l' : list A) { struct l } :
-    { r : list A | length r = length l + length l' } :=
-    match l with
-      | nil => l'
-      | hd :: tl => hd :: (tl ++ l')
-    end
-    where "x ++ y" := (app x y).
-
-  Next Obligation.
-    intros.
-    destruct_call app ; program_simpl.
-  Defined.
-
-  Program Lemma app_id_l : forall l : list A, l = nil ++ l.
-  Proof.
-    simpl ; auto.
-  Qed.
-
-  Program Lemma app_id_r : forall l : list A, l = l ++ nil.
-  Proof.
-    induction l ; simpl in * ; auto.
-    rewrite <- IHl ; auto.
-  Qed.
-
-End app.
-
-Extraction app.
-
-Section Nth.
-
-  Variable A : Set.
-
-  Program Fixpoint nth (l : list A) (n : nat | n < length l) { struct l } : A :=
-    match n, l with
-      | 0, hd :: _ => hd
-      | S n', _ :: tl => nth tl n'
-      | _, nil => !
-    end.
-
-  Next Obligation.
-  Proof.
-    simpl in *. auto with arith.
-  Defined.
-
-  Next Obligation.
-  Proof.
-    inversion H.
-  Qed.
-
-  Program Fixpoint nth' (l : list A) (n : nat | n < length l) { struct l } : A :=
-    match l, n with
-      | hd :: _, 0 => hd
-      | _ :: tl, S n' => nth' tl n'
-      | nil, _ => !
-    end.
-  Next Obligation.
-  Proof.
-    simpl in *. auto with arith.
-  Defined.
-
-  Next Obligation.
-  Proof.
-    intros.
-    inversion H.
-  Defined.
-
-End Nth.
-
diff --git a/plugins/subtac/test/Mutind.v b/plugins/subtac/test/Mutind.v
deleted file mode 100644
index 01e2d75f..00000000
--- a/plugins/subtac/test/Mutind.v
+++ /dev/null
@@ -1,20 +0,0 @@
-Require Import List.
-
-Program Fixpoint f a : { x : nat | x > 0 } :=
-  match a with
-  | 0 => 1
-  | S a' => g a a'
-  end
-with g a b : { x : nat | x > 0 } :=
-  match b with
-  | 0 => 1
-  | S b' => f b'
-  end.
-
-Check f.
-Check g.
-
-
-
-
-
diff --git a/plugins/subtac/test/Test1.v b/plugins/subtac/test/Test1.v
deleted file mode 100644
index 7e0755d5..00000000
--- a/plugins/subtac/test/Test1.v
+++ /dev/null
@@ -1,16 +0,0 @@
-Program Definition test (a b : nat) : { x : nat | x = a + b } :=
-  ((a + b) : { x : nat | x = a + b }).
-Proof.
-intros.
-reflexivity.
-Qed.
-
-Print test.
-
-Require Import List.
-
-Program hd_opt (l : list nat) : { x : nat | x <> 0 } :=
-  match l with
-    nil => 1
-    | a :: l => a
-  end.
diff --git a/plugins/subtac/test/euclid.v b/plugins/subtac/test/euclid.v
deleted file mode 100644
index 97c3d941..00000000
--- a/plugins/subtac/test/euclid.v
+++ /dev/null
@@ -1,24 +0,0 @@
-Require Import Coq.Program.Program.
-Require Import Coq.Arith.Compare_dec.
-Notation "( x & y )" := (existS _ x y) : core_scope.
-
-Require Import Omega.
-
-Program Fixpoint euclid (a : nat) (b : { b : nat | b <> O }) {wf lt a}  :
-  { q : nat & { r : nat | a = b * q + r /\ r < b } } :=
-  if le_lt_dec b a then let (q', r) := euclid (a - b) b in
-  (S q' & r)
-  else (O & a).
-
-Next Obligation.
-  assert(b * S q' = b * q' + b) by auto with arith ; omega.
-Defined.
-
-Program Definition test_euclid : (prod nat nat) := let (q, r) := euclid 4 2 in (q, q).
-
-Eval lazy beta zeta delta iota in test_euclid.
-
-Program Definition testsig (a : nat) : { x : nat & { y : nat | x < y } } :=
-  (a & S a).
-
-Check testsig.
diff --git a/plugins/subtac/test/id.v b/plugins/subtac/test/id.v
deleted file mode 100644
index 9ae11088..00000000
--- a/plugins/subtac/test/id.v
+++ /dev/null
@@ -1,46 +0,0 @@
-Require Coq.Arith.Arith.
-
-Require Import Coq.subtac.Utils.
-Program Fixpoint id (n : nat) : { x : nat | x = n } :=
-  match n with
-  | O => O
-  | S p => S (id p)
-  end.
-intros ; auto.
-
-pose (subset_simpl (id p)).
-simpl in e.
-unfold p0.
-rewrite e.
-auto.
-Defined.
-
-Check id.
-Print id.
-Extraction id.
-
-Axiom le_gt_dec : forall n m, { n <= m } + { n > m }.
-Require Import Omega.
-
-Program Fixpoint id_if (n : nat) { wf n lt }: { x : nat | x = n } :=
-  if le_gt_dec n 0 then 0
-  else S (id_if (pred n)).
-intros.
-auto with arith.
-intros.
-pose (subset_simpl (id_if (pred n))).
-simpl in e.
-rewrite e.
-induction n ; auto with arith.
-Defined.
-
-Print id_if_instance.
-Extraction id_if_instance.
-
-Notation "( x & y )" := (@existS _ _ x y) : core_scope.
-
-Program Definition testsig ( a : nat ) : { x : nat & { y : nat | x = y }} :=
-  (a & a).
-intros.
-auto.
-Qed.
diff --git a/plugins/subtac/test/measure.v b/plugins/subtac/test/measure.v
deleted file mode 100644
index 4f938f4f..00000000
--- a/plugins/subtac/test/measure.v
+++ /dev/null
@@ -1,20 +0,0 @@
-Notation "( x & y )" := (@existS _ _ x y) : core_scope.
-Unset Printing All.
-Require Import Coq.Arith.Compare_dec.
-
-Require Import Coq.Program.Program.
-
-Fixpoint size (a : nat) : nat :=
-  match a with
-  0 => 1
-  | S n => S (size n)
-  end.
-
-Program Fixpoint test_measure (a : nat) {measure size a}  : nat :=
-  match a with
-  | S (S n) => S (test_measure n)
-  | 0 | S 0 => a
-  end.
-
-Check test_measure.
-Print test_measure.
\ No newline at end of file
diff --git a/plugins/subtac/test/rec.v b/plugins/subtac/test/rec.v
deleted file mode 100644
index aaefd8cc..00000000
--- a/plugins/subtac/test/rec.v
+++ /dev/null
@@ -1,65 +0,0 @@
-Require Import Coq.Arith.Arith.
-Require Import Lt.
-Require Import Omega.
-
-Axiom lt_ge_dec : forall x y : nat, { x < y } + { x >= y }.
-(*Proof.
-  intros.
-  elim (le_lt_dec y x) ; intros ; auto with arith.
-Defined.
-*)
-Require Import Coq.subtac.FixSub.
-Require Import Wf_nat.
-
-Lemma preda_lt_a : forall a, 0 < a -> pred a < a.
-auto with arith.
-Qed.
-
-Program Fixpoint id_struct (a : nat) : nat :=
-  match a with
-  0 => 0
-  | S n => S (id_struct n)
-  end.
-
-Check struct_rec.
-
-  if (lt_ge_dec O a)
-  then S (wfrec (pred a))
-  else O.
-
-Program Fixpoint wfrec (a : nat) { wf a lt } : nat :=
-  if (lt_ge_dec O a)
-  then S (wfrec (pred a))
-  else O.
-intros.
-apply preda_lt_a ; auto.
-
-Defined.
-
-Extraction wfrec.
-Extraction Inline proj1_sig.
-Extract Inductive bool => "bool" [ "true" "false" ].
-Extract Inductive sumbool => "bool" [ "true" "false" ].
-Extract Inlined Constant lt_ge_dec => "<".
-
-Extraction wfrec.
-Extraction Inline lt_ge_dec le_lt_dec.
-Extraction wfrec.
-
-
-Program Fixpoint structrec (a : nat) { wf a lt } : nat :=
-  match a with
-   S n => S (structrec n)
-   | 0 => 0
-   end.
-intros.
-unfold n0.
-omega.
-Defined.
-
-Print structrec.
-Extraction structrec.
-Extraction structrec.
-
-Definition structrec_fun (a : nat) : nat := structrec a (lt_wf a).
-Print structrec_fun.
diff --git a/plugins/subtac/test/take.v b/plugins/subtac/test/take.v
deleted file mode 100644
index 90ae8bae..00000000
--- a/plugins/subtac/test/take.v
+++ /dev/null
@@ -1,34 +0,0 @@
-(* -*- coq-prog-args: ("-emacs-U" "-debug") -*- *)
-Require Import JMeq.
-Require Import List.
-Require Import Program.
-
-Set Implicit Arguments.
-Obligations Tactic := idtac.
-
-Print cons.
-
-Program Fixpoint take (A : Set) (l : list A) (n : nat | n <= length l) { struct l } : { l' : list A | length l' = n } :=
-  match n with
-  | 0 => nil
-  | S p =>
-    match l with
-    | cons hd tl => let rest := take tl p in cons hd rest
-    | nil => !
-    end
-  end.
-
-Require Import Omega.
-Solve All Obligations.
-Next Obligation.
-  destruct_call take ; program_simpl.
-Defined.
-
-Next Obligation.
-  intros.
-  inversion H.
-Defined.
-
-
-
-
diff --git a/plugins/subtac/test/wf.v b/plugins/subtac/test/wf.v
deleted file mode 100644
index 5ccc154a..00000000
--- a/plugins/subtac/test/wf.v
+++ /dev/null
@@ -1,48 +0,0 @@
-Notation "( x & y )" := (@existS _ _ x y) : core_scope.
-Unset Printing All.
-Require Import Coq.Arith.Compare_dec.
-
-Require Import Coq.subtac.Utils.
-
-Ltac one_simpl_hyp :=
- match goal with
- | [H : (`exist _ _ _) = _ |- _] => simpl in H
- | [H : _ = (`exist _ _ _) |- _] => simpl in H
- | [H : (`exist _ _ _) < _ |- _] => simpl in H
- | [H : _ < (`exist _ _ _) |- _] => simpl in H
- | [H : (`exist _ _ _) <= _ |- _] => simpl in H
- | [H : _ <= (`exist _ _ _) |- _] => simpl in H
- | [H : (`exist _ _ _) > _ |- _] => simpl in H
- | [H : _ > (`exist _ _ _) |- _] => simpl in H
- | [H : (`exist _ _ _) >= _ |- _] => simpl in H
- | [H : _ >= (`exist _ _ _) |- _] => simpl in H
- end.
-
-Ltac one_simpl_subtac :=
-  destruct_exists ;
-  repeat one_simpl_hyp ; simpl.
-
-Ltac simpl_subtac :=  do 3 one_simpl_subtac ; simpl.
-
-Require Import Omega.
-Require Import Wf_nat.
-
-Program Fixpoint euclid (a : nat) (b : { b : nat | b <> O }) {wf a lt}  :
-  { q : nat & { r : nat | a = b * q + r /\ r < b } } :=
-  if le_lt_dec b a then let (q', r) := euclid (a - b) b in
-  (S q' & r)
-  else (O & a).
-destruct b ; simpl_subtac.
-omega.
-simpl_subtac.
-assert(x0 * S q' = x0 + x0 * q').
-rewrite <- mult_n_Sm.
-omega.
-rewrite H2 ; omega.
-simpl_subtac.
-split ; auto with arith.
-omega.
-apply lt_wf.
-Defined.
-
-Check euclid_evars_proof.
\ No newline at end of file
diff --git a/plugins/syntax/ascii_syntax.ml b/plugins/syntax/ascii_syntax.ml
index bd2285bb..67c9dd0a 100644
--- a/plugins/syntax/ascii_syntax.ml
+++ b/plugins/syntax/ascii_syntax.ml
@@ -7,20 +7,18 @@
 (***********************************************************************)
 
 open Pp
+open Errors
 open Util
 open Names
-open Pcoq
 open Glob_term
-open Topconstr
-open Libnames
+open Globnames
 open Coqlib
-open Bigint
 
 exception Non_closed_ascii
 
-let make_dir l = make_dirpath (List.map id_of_string (List.rev l))
-let make_kn dir id = Libnames.encode_mind (make_dir dir) (id_of_string id)
-let make_path dir id = Libnames.make_path (make_dir dir) (id_of_string id)
+let make_dir l = DirPath.make (List.rev_map Id.of_string l)
+let make_kn dir id = Globnames.encode_mind (make_dir dir) (Id.of_string id)
+let make_path dir id = Libnames.make_path (make_dir dir) (Id.of_string id)
 
 let ascii_module = ["Coq";"Strings";"Ascii"]
 
@@ -37,17 +35,17 @@ open Lazy
 
 let interp_ascii dloc p =
   let rec aux n p =
-     if n = 0 then [] else
+     if Int.equal n 0 then [] else
      let mp = p mod 2 in
-     GRef (dloc,if mp = 0 then glob_false else glob_true)
+     GRef (dloc,(if Int.equal mp 0 then glob_false else glob_true),None)
      :: (aux (n-1) (p/2)) in
-  GApp (dloc,GRef(dloc,force glob_Ascii), aux 8 p)
+  GApp (dloc,GRef(dloc,force glob_Ascii,None), aux 8 p)
 
 let interp_ascii_string dloc s =
   let p =
-    if String.length s = 1 then int_of_char s.[0]
+    if Int.equal (String.length s) 1 then int_of_char s.[0]
     else
-      if String.length s = 3 & is_digit s.[0] & is_digit s.[1] & is_digit s.[2]
+      if Int.equal (String.length s) 3 && is_digit s.[0] && is_digit s.[1] && is_digit s.[2]
       then int_of_string s
       else
 	user_err_loc (dloc,"interp_ascii_string",
@@ -56,13 +54,13 @@ let interp_ascii_string dloc s =
 
 let uninterp_ascii r =
   let rec uninterp_bool_list n = function
-    | [] when n = 0 -> 0
-    | GRef (_,k)::l when k = glob_true  -> 1+2*(uninterp_bool_list (n-1)  l)
-    | GRef (_,k)::l when k = glob_false -> 2*(uninterp_bool_list (n-1) l)
+    | [] when Int.equal n 0 -> 0
+    | GRef (_,k,_)::l when Globnames.eq_gr k glob_true  -> 1+2*(uninterp_bool_list (n-1)  l)
+    | GRef (_,k,_)::l when Globnames.eq_gr k glob_false -> 2*(uninterp_bool_list (n-1) l)
     | _ -> raise Non_closed_ascii in
   try
-    let rec aux = function
-    | GApp (_,GRef (_,k),l) when k = force glob_Ascii -> uninterp_bool_list 8 l
+    let aux = function
+    | GApp (_,GRef (_,k,_),l) when Globnames.eq_gr k (force glob_Ascii) -> uninterp_bool_list 8 l
     | _ -> raise Non_closed_ascii in
     Some (aux r)
   with
@@ -78,4 +76,4 @@ let _ =
   Notation.declare_string_interpreter "char_scope"
     (ascii_path,ascii_module)
     interp_ascii_string
-    ([GRef (dummy_loc,static_glob_Ascii)], uninterp_ascii_string, true)
+    ([GRef (Loc.ghost,static_glob_Ascii,None)], uninterp_ascii_string, true)
diff --git a/plugins/syntax/nat_syntax.ml b/plugins/syntax/nat_syntax.ml
index 2899f17f..0f280aad 100644
--- a/plugins/syntax/nat_syntax.ml
+++ b/plugins/syntax/nat_syntax.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -9,19 +9,11 @@
 (* This file defines the printer for natural numbers in [nat] *)
 
 (*i*)
-open Pcoq
-open Pp
-open Util
-open Names
-open Coqlib
 open Glob_term
-open Libnames
 open Bigint
 open Coqlib
-open Notation
 open Pp
-open Util
-open Names
+open Errors
 (*i*)
 
 (**********************************************************************)
@@ -33,13 +25,13 @@ let threshold = of_int 5000
 let nat_of_int dloc n =
   if is_pos_or_zero n then begin
       if less_than threshold n then
-	Flags.if_warn msg_warning
+	msg_warning
 	  (strbrk "Stack overflow or segmentation fault happens when " ++
 	   strbrk "working with large numbers in nat (observed threshold " ++
 	   strbrk "may vary from 5000 to 70000 depending on your system " ++
 	   strbrk "limits and on the command executed).");
-      let ref_O = GRef (dloc, glob_O) in
-      let ref_S = GRef (dloc, glob_S) in
+      let ref_O = GRef (dloc, glob_O, None) in
+      let ref_S = GRef (dloc, glob_S, None) in
       let rec mk_nat acc n =
 	if n <> zero then
 	  mk_nat (GApp (dloc,ref_S, [acc])) (sub_1 n)
@@ -58,8 +50,8 @@ let nat_of_int dloc n =
 exception Non_closed_number
 
 let rec int_of_nat = function
-  | GApp (_,GRef (_,s),[a]) when s = glob_S -> add_1 (int_of_nat a)
-  | GRef (_,z) when z = glob_O -> zero
+  | GApp (_,GRef (_,s,_),[a]) when Globnames.eq_gr s glob_S -> add_1 (int_of_nat a)
+  | GRef (_,z,_) when Globnames.eq_gr z glob_O -> zero
   | _ -> raise Non_closed_number
 
 let uninterp_nat p =
@@ -73,6 +65,6 @@ let uninterp_nat p =
 
 let _ =
   Notation.declare_numeral_interpreter "nat_scope"
-    (nat_path,["Coq";"Init";"Datatypes"])
+    (nat_path,datatypes_module_name)
     nat_of_int
-    ([GRef (dummy_loc,glob_S); GRef (dummy_loc,glob_O)], uninterp_nat, true)
+    ([GRef (Loc.ghost,glob_S,None); GRef (Loc.ghost,glob_O,None)], uninterp_nat, true)
diff --git a/plugins/syntax/numbers_syntax.ml b/plugins/syntax/numbers_syntax.ml
index 5d43b353..b990c0d2 100644
--- a/plugins/syntax/numbers_syntax.ml
+++ b/plugins/syntax/numbers_syntax.ml
@@ -1,6 +1,6 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -9,18 +9,19 @@
 (* digit-based syntax for int31, bigN bigZ and bigQ *)
 
 open Bigint
-open Libnames
+open Names
+open Globnames
 open Glob_term
 
 (*** Constants for locating int31 / bigN / bigZ / bigQ constructors ***)
 
-let make_dir l = Names.make_dirpath (List.map Names.id_of_string (List.rev l))
-let make_path dir id = Libnames.make_path (make_dir dir) (Names.id_of_string id)
+let make_dir l = DirPath.make (List.rev_map Id.of_string l)
+let make_path dir id = Libnames.make_path (make_dir dir) (Id.of_string id)
 
-let make_mind mp id = Names.make_mind mp Names.empty_dirpath (Names.mk_label id)
-let make_mind_mpfile dir id = make_mind (Names.MPfile (make_dir dir)) id
+let make_mind mp id = Names.MutInd.make2 mp (Label.make id)
+let make_mind_mpfile dir id = make_mind (MPfile (make_dir dir)) id
 let make_mind_mpdot dir modname id =
-  let mp = Names.MPdot (Names.MPfile (make_dir dir), Names.mk_label modname)
+  let mp = MPdot (MPfile (make_dir dir), Label.make modname)
   in make_mind mp id
 
 
@@ -82,9 +83,9 @@ exception Non_closed
 (* parses a *non-negative* integer (from bigint.ml) into an int31
    wraps modulo 2^31 *)
 let int31_of_pos_bigint dloc n =
-  let ref_construct = GRef (dloc, int31_construct) in
-  let ref_0 = GRef (dloc, int31_0) in
-  let ref_1 = GRef (dloc, int31_1) in
+  let ref_construct = GRef (dloc, int31_construct, None) in
+  let ref_0 = GRef (dloc, int31_0, None) in
+  let ref_1 = GRef (dloc, int31_1, None) in
   let rec args counter n =
     if counter <= 0 then
       []
@@ -95,7 +96,7 @@ let int31_of_pos_bigint dloc n =
   GApp (dloc, ref_construct, List.rev (args 31 n))
 
 let error_negative dloc =
-  Util.user_err_loc (dloc, "interp_int31", Pp.str "int31 are only non-negative numbers.")
+  Errors.user_err_loc (dloc, "interp_int31", Pp.str "int31 are only non-negative numbers.")
 
 let interp_int31 dloc n =
   if is_pos_or_zero n then
@@ -109,12 +110,12 @@ let bigint_of_int31 =
   let rec args_parsing args cur =
     match args with
       | [] -> cur
-      | (GRef (_,b))::l when b = int31_0 -> args_parsing l (mult_2 cur)
-      | (GRef (_,b))::l when b = int31_1 -> args_parsing l (add_1 (mult_2 cur))
+      | (GRef (_,b,_))::l when eq_gr b int31_0 -> args_parsing l (mult_2 cur)
+      | (GRef (_,b,_))::l when eq_gr b int31_1 -> args_parsing l (add_1 (mult_2 cur))
       | _ -> raise Non_closed
   in
   function
-  | GApp (_, GRef (_, c), args) when c=int31_construct -> args_parsing args zero
+  | GApp (_, GRef (_, c, _), args) when eq_gr c int31_construct -> args_parsing args zero
   | _ -> raise Non_closed
 
 let uninterp_int31 i =
@@ -127,7 +128,7 @@ let uninterp_int31 i =
 let _ = Notation.declare_numeral_interpreter int31_scope
   (int31_path, int31_module)
   interp_int31
-  ([GRef (Util.dummy_loc, int31_construct)],
+  ([GRef (Loc.ghost, int31_construct, None)],
    uninterp_int31,
    true)
 
@@ -158,16 +159,16 @@ let height bi =
 
 (* n must be a non-negative integer (from bigint.ml) *)
 let word_of_pos_bigint dloc hght n =
-  let ref_W0 = GRef (dloc, zn2z_W0) in
-  let ref_WW = GRef (dloc, zn2z_WW) in
+  let ref_W0 = GRef (dloc, zn2z_W0, None) in
+  let ref_WW = GRef (dloc, zn2z_WW, None) in
   let rec decomp hgt n =
     if hgt <= 0 then
       int31_of_pos_bigint dloc n
     else if equal n zero then
-      GApp (dloc, ref_W0, [GHole (dloc, Evd.InternalHole)])
+      GApp (dloc, ref_W0, [GHole (dloc, Evar_kinds.InternalHole, Misctypes.IntroAnonymous, None)])
     else
       let (h,l) = split_at hgt n in
-      GApp (dloc, ref_WW, [GHole (dloc, Evd.InternalHole);
+      GApp (dloc, ref_WW, [GHole (dloc, Evar_kinds.InternalHole, Misctypes.IntroAnonymous, None);
 			   decomp (hgt-1) h;
 			   decomp (hgt-1) l])
   in
@@ -175,7 +176,7 @@ let word_of_pos_bigint dloc hght n =
 
 let bigN_of_pos_bigint dloc n =
   let h = height n in
-  let ref_constructor = GRef (dloc, bigN_constructor h) in
+  let ref_constructor = GRef (dloc, bigN_constructor h, None) in
   let word = word_of_pos_bigint dloc h n in
   let args =
     if h < n_inlined then [word]
@@ -184,7 +185,7 @@ let bigN_of_pos_bigint dloc n =
   GApp (dloc, ref_constructor, args)
 
 let bigN_error_negative dloc =
-  Util.user_err_loc (dloc, "interp_bigN", Pp.str "bigN are only non-negative numbers.")
+  Errors.user_err_loc (dloc, "interp_bigN", Pp.str "bigN are only non-negative numbers.")
 
 let interp_bigN dloc n =
   if is_pos_or_zero n then
@@ -198,14 +199,14 @@ let interp_bigN dloc n =
 let bigint_of_word =
   let rec get_height rc =
     match rc with
-    | GApp (_,GRef(_,c), [_;lft;rght]) when c = zn2z_WW ->
+    | GApp (_,GRef(_,c,_), [_;lft;rght]) when eq_gr c zn2z_WW ->
       1+max (get_height lft) (get_height rght)
     | _ -> 0
   in
   let rec transform hght rc =
     match rc with
-    | GApp (_,GRef(_,c),_) when c = zn2z_W0-> zero
-    | GApp (_,GRef(_,c), [_;lft;rght]) when c=zn2z_WW->
+    | GApp (_,GRef(_,c,_),_) when eq_gr c zn2z_W0-> zero
+    | GApp (_,GRef(_,c,_), [_;lft;rght]) when eq_gr c zn2z_WW->
       let new_hght = hght-1 in
       add (mult (rank new_hght)
              (transform new_hght lft))
@@ -235,7 +236,7 @@ let uninterp_bigN rc =
 let bigN_list_of_constructors =
   let rec build i =
     if i < n_inlined+1 then
-      GRef (Util.dummy_loc, bigN_constructor i)::(build (i+1))
+      GRef (Loc.ghost, bigN_constructor i,None)::(build (i+1))
     else
       []
   in
@@ -252,8 +253,8 @@ let _ = Notation.declare_numeral_interpreter bigN_scope
 
 (*** Parsing for bigZ in digital notation ***)
 let interp_bigZ dloc n =
-  let ref_pos = GRef (dloc, bigZ_pos) in
-  let ref_neg = GRef (dloc, bigZ_neg) in
+  let ref_pos = GRef (dloc, bigZ_pos, None) in
+  let ref_neg = GRef (dloc, bigZ_neg, None) in
   if is_pos_or_zero n then
     GApp (dloc, ref_pos, [bigN_of_pos_bigint dloc n])
   else
@@ -261,8 +262,8 @@ let interp_bigZ dloc n =
 
 (* pretty printing functions for bigZ *)
 let bigint_of_bigZ = function
-  | GApp (_, GRef(_,c), [one_arg]) when c = bigZ_pos -> bigint_of_bigN one_arg
-  | GApp (_, GRef(_,c), [one_arg]) when c = bigZ_neg ->
+  | GApp (_, GRef(_,c,_), [one_arg]) when eq_gr c bigZ_pos -> bigint_of_bigN one_arg
+  | GApp (_, GRef(_,c,_), [one_arg]) when eq_gr c bigZ_neg ->
       let opp_val = bigint_of_bigN one_arg in
       if equal opp_val zero then
 	raise Non_closed
@@ -281,19 +282,19 @@ let uninterp_bigZ rc =
 let _ = Notation.declare_numeral_interpreter bigZ_scope
   (bigZ_path, bigZ_module)
   interp_bigZ
-  ([GRef (Util.dummy_loc, bigZ_pos);
-    GRef (Util.dummy_loc, bigZ_neg)],
+  ([GRef (Loc.ghost, bigZ_pos, None);
+    GRef (Loc.ghost, bigZ_neg, None)],
    uninterp_bigZ,
    true)
 
 (*** Parsing for bigQ in digital notation ***)
 let interp_bigQ dloc n =
-  let ref_z = GRef (dloc, bigQ_z) in
+  let ref_z = GRef (dloc, bigQ_z, None) in
   GApp (dloc, ref_z, [interp_bigZ dloc n])
 
 let uninterp_bigQ rc =
   try match rc with
-    | GApp (_, GRef(_,c), [one_arg]) when c = bigQ_z ->
+    | GApp (_, GRef(_,c,_), [one_arg]) when eq_gr c bigQ_z ->
 	Some (bigint_of_bigZ one_arg)
     | _ -> None (* we don't pretty-print yet fractions *)
   with Non_closed -> None
@@ -302,5 +303,5 @@ let uninterp_bigQ rc =
 let _ = Notation.declare_numeral_interpreter bigQ_scope
   (bigQ_path, bigQ_module)
   interp_bigQ
-  ([GRef (Util.dummy_loc, bigQ_z)], uninterp_bigQ,
+  ([GRef (Loc.ghost, bigQ_z, None)], uninterp_bigQ,
    true)
diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml
index 79a4d8e6..2c195755 100644
--- a/plugins/syntax/r_syntax.ml
+++ b/plugins/syntax/r_syntax.ml
@@ -1,17 +1,14 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Pp
 open Util
 open Names
-open Pcoq
-open Topconstr
-open Libnames
+open Globnames
 
 exception Non_closed_number
 
@@ -19,18 +16,17 @@ exception Non_closed_number
 (* Parsing R via scopes                                               *)
 (**********************************************************************)
 
-open Libnames
 open Glob_term
 open Bigint
 
-let make_dir l = make_dirpath (List.map id_of_string (List.rev l))
+let make_dir l = DirPath.make (List.rev_map Id.of_string l)
 let rdefinitions = make_dir ["Coq";"Reals";"Rdefinitions"]
-let make_path dir id = Libnames.make_path dir (id_of_string id)
+let make_path dir id = Libnames.make_path dir (Id.of_string id)
 
 let r_path = make_path rdefinitions "R"
 
 (* TODO: temporary hack *)
-let make_path dir id = Libnames.encode_con dir (id_of_string id)
+let make_path dir id = Globnames.encode_con dir (Id.of_string id)
 
 let r_kn = make_path rdefinitions "R"
 let glob_R = ConstRef r_kn
@@ -46,24 +42,24 @@ let four = mult_2 two
 
 (* Unary representation of strictly positive numbers *)
 let rec small_r dloc n =
-  if equal one n then GRef (dloc, glob_R1)
-  else GApp(dloc,GRef (dloc,glob_Rplus),
-            [GRef (dloc, glob_R1);small_r dloc (sub_1 n)])
+  if equal one n then GRef (dloc, glob_R1, None)
+  else GApp(dloc,GRef (dloc,glob_Rplus, None),
+            [GRef (dloc, glob_R1, None);small_r dloc (sub_1 n)])
 
 let r_of_posint dloc n =
-  let r1 = GRef (dloc, glob_R1) in
+  let r1 = GRef (dloc, glob_R1, None) in
   let r2 = small_r dloc two in
   let rec r_of_pos n =
     if less_than n four then small_r dloc n
     else
       let (q,r) = div2_with_rest n in
-      let b = GApp(dloc,GRef(dloc,glob_Rmult),[r2;r_of_pos q]) in
-      if r then GApp(dloc,GRef(dloc,glob_Rplus),[r1;b]) else b in
-  if n <> zero then r_of_pos n else GRef(dloc,glob_R0)
+      let b = GApp(dloc,GRef(dloc,glob_Rmult,None),[r2;r_of_pos q]) in
+      if r then GApp(dloc,GRef(dloc,glob_Rplus,None),[r1;b]) else b in
+  if not (Bigint.equal n zero) then r_of_pos n else GRef(dloc,glob_R0,None)
 
 let r_of_int dloc z =
   if is_strictly_neg z then
-    GApp (dloc, GRef(dloc,glob_Ropp), [r_of_posint dloc (neg z)])
+    GApp (dloc, GRef(dloc,glob_Ropp,None), [r_of_posint dloc (neg z)])
   else
     r_of_posint dloc z
 
@@ -75,35 +71,35 @@ let bignat_of_r =
 (* for numbers > 1 *)
 let rec bignat_of_pos = function
   (* 1+1 *)
-  | GApp (_,GRef (_,p), [GRef (_,o1); GRef (_,o2)])
-      when p = glob_Rplus & o1 = glob_R1 & o2 = glob_R1 -> two
+  | GApp (_,GRef (_,p,_), [GRef (_,o1,_); GRef (_,o2,_)])
+      when Globnames.eq_gr p glob_Rplus && Globnames.eq_gr o1 glob_R1 && Globnames.eq_gr o2 glob_R1 -> two
   (* 1+(1+1) *)
-  | GApp (_,GRef (_,p1), [GRef (_,o1);
-      GApp(_,GRef (_,p2),[GRef(_,o2);GRef(_,o3)])])
-      when p1 = glob_Rplus & p2 = glob_Rplus &
-           o1 = glob_R1 & o2 = glob_R1 & o3 = glob_R1 -> three
+  | GApp (_,GRef (_,p1,_), [GRef (_,o1,_);
+      GApp(_,GRef (_,p2,_),[GRef(_,o2,_);GRef(_,o3,_)])])
+      when Globnames.eq_gr p1 glob_Rplus && Globnames.eq_gr p2 glob_Rplus &&
+           Globnames.eq_gr o1 glob_R1 && Globnames.eq_gr o2 glob_R1 && Globnames.eq_gr o3 glob_R1 -> three
   (* (1+1)*b *)
-  | GApp (_,GRef (_,p), [a; b]) when p = glob_Rmult ->
-      if bignat_of_pos a <> two then raise Non_closed_number;
+  | GApp (_,GRef (_,p,_), [a; b]) when Globnames.eq_gr p glob_Rmult ->
+      if not (Bigint.equal (bignat_of_pos a) two) then raise Non_closed_number;
       mult_2 (bignat_of_pos b)
   (* 1+(1+1)*b *)
-  | GApp (_,GRef (_,p1), [GRef (_,o); GApp (_,GRef (_,p2),[a;b])])
-      when p1 = glob_Rplus & p2 = glob_Rmult & o = glob_R1  ->
-      if bignat_of_pos a <> two then raise Non_closed_number;
+  | GApp (_,GRef (_,p1,_), [GRef (_,o,_); GApp (_,GRef (_,p2,_),[a;b])])
+      when Globnames.eq_gr p1 glob_Rplus && Globnames.eq_gr p2 glob_Rmult && Globnames.eq_gr o glob_R1  ->
+      if not (Bigint.equal (bignat_of_pos a) two) then raise Non_closed_number;
         add_1 (mult_2 (bignat_of_pos b))
   | _ -> raise Non_closed_number
 in
 let bignat_of_r = function
-  | GRef (_,a) when a = glob_R0 -> zero
-  | GRef (_,a) when a = glob_R1 -> one
+  | GRef (_,a,_) when Globnames.eq_gr a glob_R0 -> zero
+  | GRef (_,a,_) when Globnames.eq_gr a glob_R1 -> one
   | r -> bignat_of_pos r
 in
 bignat_of_r
 
 let bigint_of_r = function
-  | GApp (_,GRef (_,o), [a]) when o = glob_Ropp ->
+  | GApp (_,GRef (_,o,_), [a]) when Globnames.eq_gr o glob_Ropp ->
       let n = bignat_of_r a in
-      if n = zero then raise Non_closed_number;
+      if Bigint.equal n zero then raise Non_closed_number;
       neg n
   | a -> bignat_of_r a
 
@@ -113,11 +109,12 @@ let uninterp_r p =
   with Non_closed_number ->
     None
 
+let mkGRef gr = GRef (Loc.ghost,gr,None)
+
 let _ = Notation.declare_numeral_interpreter "R_scope"
   (r_path,["Coq";"Reals";"Rdefinitions"])
   r_of_int
-  ([GRef(dummy_loc,glob_Ropp);GRef(dummy_loc,glob_R0);
-    GRef(dummy_loc,glob_Rplus);GRef(dummy_loc,glob_Rmult);
-    GRef(dummy_loc,glob_R1)],
+  (List.map mkGRef 
+    [glob_Ropp;glob_R0;glob_Rplus;glob_Rmult;glob_R1],
     uninterp_r,
     false)
diff --git a/plugins/syntax/string_syntax.ml b/plugins/syntax/string_syntax.ml
index d670f602..2e696f39 100644
--- a/plugins/syntax/string_syntax.ml
+++ b/plugins/syntax/string_syntax.ml
@@ -6,12 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-open Pp
-open Util
-open Names
-open Pcoq
-open Libnames
-open Topconstr
+open Globnames
 open Ascii_syntax
 open Glob_term
 open Coqlib
@@ -37,8 +32,8 @@ open Lazy
 let interp_string dloc s =
   let le = String.length s in
   let rec aux n =
-     if n = le then GRef (dloc, force glob_EmptyString) else
-     GApp (dloc,GRef (dloc, force glob_String),
+     if n = le then GRef (dloc, force glob_EmptyString, None) else
+     GApp (dloc,GRef (dloc, force glob_String, None),
        [interp_ascii dloc (int_of_char s.[n]); aux (n+1)])
   in aux 0
 
@@ -46,11 +41,11 @@ let uninterp_string r =
   try
     let b = Buffer.create 16 in
     let rec aux = function
-    | GApp (_,GRef (_,k),[a;s]) when k = force glob_String ->
+    | GApp (_,GRef (_,k,_),[a;s]) when eq_gr k (force glob_String) ->
 	(match uninterp_ascii a with
 	  | Some c -> Buffer.add_char b (Char.chr c); aux s
 	  | _ -> raise Non_closed_string)
-    | GRef (_,z) when z = force glob_EmptyString ->
+    | GRef (_,z,_) when eq_gr z (force glob_EmptyString) ->
 	Some (Buffer.contents b)
     | _ ->
 	raise Non_closed_string
@@ -62,6 +57,6 @@ let _ =
   Notation.declare_string_interpreter "string_scope"
     (string_path,["Coq";"Strings";"String"])
     interp_string
-    ([GRef (dummy_loc,static_glob_String);
-      GRef (dummy_loc,static_glob_EmptyString)],
+    ([GRef (Loc.ghost,static_glob_String,None);
+      GRef (Loc.ghost,static_glob_EmptyString,None)],
      uninterp_string, true)
diff --git a/plugins/syntax/z_syntax.ml b/plugins/syntax/z_syntax.ml
index 4025893d..e3721362 100644
--- a/plugins/syntax/z_syntax.ml
+++ b/plugins/syntax/z_syntax.ml
@@ -1,17 +1,15 @@
 (************************************************************************)
 (*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-open Pcoq
 open Pp
+open Errors
 open Util
 open Names
-open Topconstr
-open Libnames
 open Bigint
 
 exception Non_closed_number
@@ -20,20 +18,20 @@ exception Non_closed_number
 (* Parsing positive via scopes                                        *)
 (**********************************************************************)
 
-open Libnames
+open Globnames
 open Glob_term
 
 let binnums = ["Coq";"Numbers";"BinNums"]
 
-let make_dir l = make_dirpath (List.map id_of_string (List.rev l))
-let make_path dir id = Libnames.make_path (make_dir dir) (id_of_string id)
+let make_dir l = DirPath.make (List.rev_map Id.of_string l)
+let make_path dir id = Libnames.make_path (make_dir dir) (Id.of_string id)
 
 let positive_path = make_path binnums "positive"
 
 (* TODO: temporary hack *)
-let make_kn dir id = Libnames.encode_mind dir id
+let make_kn dir id = Globnames.encode_mind dir id
 
-let positive_kn = make_kn (make_dir binnums) (id_of_string "positive")
+let positive_kn = make_kn (make_dir binnums) (Id.of_string "positive")
 let glob_positive = IndRef (positive_kn,0)
 let path_of_xI = ((positive_kn,0),1)
 let path_of_xO = ((positive_kn,0),2)
@@ -43,13 +41,13 @@ let glob_xO = ConstructRef path_of_xO
 let glob_xH = ConstructRef path_of_xH
 
 let pos_of_bignat dloc x =
-  let ref_xI = GRef (dloc, glob_xI) in
-  let ref_xH = GRef (dloc, glob_xH) in
-  let ref_xO = GRef (dloc, glob_xO) in
+  let ref_xI = GRef (dloc, glob_xI, None) in
+  let ref_xH = GRef (dloc, glob_xH, None) in
+  let ref_xO = GRef (dloc, glob_xO, None) in
   let rec pos_of x =
     match div2_with_rest x with
       | (q,false) -> GApp (dloc, ref_xO,[pos_of q])
-      | (q,true) when q <> zero -> GApp (dloc,ref_xI,[pos_of q])
+      | (q,true) when not (Bigint.equal q zero) -> GApp (dloc,ref_xI,[pos_of q])
       | (q,true) -> ref_xH
   in
   pos_of x
@@ -67,9 +65,9 @@ let interp_positive dloc n =
 (**********************************************************************)
 
 let rec bignat_of_pos = function
-  | GApp (_, GRef (_,b),[a]) when b = glob_xO -> mult_2(bignat_of_pos a)
-  | GApp (_, GRef (_,b),[a]) when b = glob_xI -> add_1(mult_2(bignat_of_pos a))
-  | GRef (_, a) when a = glob_xH -> Bigint.one
+  | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_xO -> mult_2(bignat_of_pos a)
+  | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_xI -> add_1(mult_2(bignat_of_pos a))
+  | GRef (_, a, _) when Globnames.eq_gr a glob_xH -> Bigint.one
   | _ -> raise Non_closed_number
 
 let uninterp_positive p =
@@ -85,9 +83,9 @@ let uninterp_positive p =
 let _ = Notation.declare_numeral_interpreter "positive_scope"
   (positive_path,binnums)
   interp_positive
-  ([GRef (dummy_loc, glob_xI);
-    GRef (dummy_loc, glob_xO);
-    GRef (dummy_loc, glob_xH)],
+  ([GRef (Loc.ghost, glob_xI, None);
+    GRef (Loc.ghost, glob_xO, None);
+    GRef (Loc.ghost, glob_xH, None)],
    uninterp_positive,
    true)
 
@@ -95,7 +93,7 @@ let _ = Notation.declare_numeral_interpreter "positive_scope"
 (* Parsing N via scopes                                               *)
 (**********************************************************************)
 
-let n_kn = make_kn (make_dir binnums) (id_of_string "N")
+let n_kn = make_kn (make_dir binnums) (Id.of_string "N")
 let glob_n = IndRef (n_kn,0)
 let path_of_N0 = ((n_kn,0),1)
 let path_of_Npos = ((n_kn,0),2)
@@ -105,10 +103,10 @@ let glob_Npos = ConstructRef path_of_Npos
 let n_path = make_path binnums "N"
 
 let n_of_binnat dloc pos_or_neg n =
-  if n <> zero then
-    GApp(dloc, GRef (dloc,glob_Npos), [pos_of_bignat dloc n])
+  if not (Bigint.equal n zero) then
+    GApp(dloc, GRef (dloc,glob_Npos,None), [pos_of_bignat dloc n])
   else
-    GRef (dloc, glob_N0)
+    GRef (dloc, glob_N0, None)
 
 let error_negative dloc =
   user_err_loc (dloc, "interp_N", str "No negative numbers in type \"N\".")
@@ -122,8 +120,8 @@ let n_of_int dloc n =
 (**********************************************************************)
 
 let bignat_of_n = function
-  | GApp (_, GRef (_,b),[a]) when b = glob_Npos -> bignat_of_pos a
-  | GRef (_, a) when a = glob_N0 -> Bigint.zero
+  | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_Npos -> bignat_of_pos a
+  | GRef (_, a,_) when Globnames.eq_gr a glob_N0 -> Bigint.zero
   | _ -> raise Non_closed_number
 
 let uninterp_n p =
@@ -136,8 +134,8 @@ let uninterp_n p =
 let _ = Notation.declare_numeral_interpreter "N_scope"
   (n_path,binnums)
   n_of_int
-  ([GRef (dummy_loc, glob_N0);
-    GRef (dummy_loc, glob_Npos)],
+  ([GRef (Loc.ghost, glob_N0, None);
+    GRef (Loc.ghost, glob_Npos, None)],
   uninterp_n,
   true)
 
@@ -146,7 +144,7 @@ let _ = Notation.declare_numeral_interpreter "N_scope"
 (**********************************************************************)
 
 let z_path = make_path binnums "Z"
-let z_kn = make_kn (make_dir binnums) (id_of_string "Z")
+let z_kn = make_kn (make_dir binnums) (Id.of_string "Z")
 let glob_z = IndRef (z_kn,0)
 let path_of_ZERO = ((z_kn,0),1)
 let path_of_POS = ((z_kn,0),2)
@@ -156,21 +154,21 @@ let glob_POS = ConstructRef path_of_POS
 let glob_NEG = ConstructRef path_of_NEG
 
 let z_of_int dloc n =
-  if n <> zero then
+  if not (Bigint.equal n zero) then
     let sgn, n =
       if is_pos_or_zero n then glob_POS, n else glob_NEG, Bigint.neg n in
-    GApp(dloc, GRef (dloc,sgn), [pos_of_bignat dloc n])
+    GApp(dloc, GRef (dloc,sgn,None), [pos_of_bignat dloc n])
   else
-    GRef (dloc, glob_ZERO)
+    GRef (dloc, glob_ZERO, None)
 
 (**********************************************************************)
 (* Printing Z via scopes                                              *)
 (**********************************************************************)
 
 let bigint_of_z = function
-  | GApp (_, GRef (_,b),[a]) when b = glob_POS -> bignat_of_pos a
-  | GApp (_, GRef (_,b),[a]) when b = glob_NEG -> Bigint.neg (bignat_of_pos a)
-  | GRef (_, a) when a = glob_ZERO -> Bigint.zero
+  | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_POS -> bignat_of_pos a
+  | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_NEG -> Bigint.neg (bignat_of_pos a)
+  | GRef (_, a, _) when Globnames.eq_gr a glob_ZERO -> Bigint.zero
   | _ -> raise Non_closed_number
 
 let uninterp_z p =
@@ -184,8 +182,8 @@ let uninterp_z p =
 let _ = Notation.declare_numeral_interpreter "Z_scope"
   (z_path,binnums)
   z_of_int
-  ([GRef (dummy_loc, glob_ZERO);
-    GRef (dummy_loc, glob_POS);
-    GRef (dummy_loc, glob_NEG)],
+  ([GRef (Loc.ghost, glob_ZERO, None);
+    GRef (Loc.ghost, glob_POS, None);
+    GRef (Loc.ghost, glob_NEG, None)],
   uninterp_z,
   true)
diff --git a/plugins/xml/COPYRIGHT b/plugins/xml/COPYRIGHT
deleted file mode 100644
index c8d231fd..00000000
--- a/plugins/xml/COPYRIGHT
+++ /dev/null
@@ -1,25 +0,0 @@
-(******************************************************************************)
-(* Copyright (C) 2000-2004, Claudio Sacerdoti Coen <sacerdot@cs.unibo.it>     *)
-(*                          Project Helm   (http://helm.cs.unibo.it)          *)
-(*                          Project MoWGLI (http://mowgli.cs.unibo.it)        *)
-(*                                                                            *)
-(*                     Coq Exportation to XML                                 *)
-(*                                                                            *)
-(******************************************************************************)
-
-This Coq module has been developed by Claudio Sacerdoti Coen
-<sacerdot@cs.unibo.it> as a developer of projects HELM and MoWGLI.
-
-Project HELM (for Hypertextual Electronic Library of Mathematics) is a
-project developed at the Department of Computer Science, University of Bologna;
-http://helm.cs.unibo.it
-
-Project MoWGLI (Mathematics on the Web: Get It by Logics and Interfaces)
-is a UE IST project that generalizes and extends the HELM project;
-http://mowgli.cs.unibo.it
-
-The author is interested in any possible usage of the module.
-So, if you plan to use the module, please send him an e-mail.
-
-The licensing policy applied to the module is the same as for the whole Coq
-distribution.
diff --git a/plugins/xml/README b/plugins/xml/README
index a45dd31a..e3bcdaf0 100644
--- a/plugins/xml/README
+++ b/plugins/xml/README
@@ -1,254 +1,15 @@
-(******************************************************************************)
-(* Copyright (C) 2000-2004, Claudio Sacerdoti Coen <sacerdot@cs.unibo.it>     *)
-(*                          Project Helm   (http://helm.cs.unibo.it)          *)
-(*                          Project MoWGLI (http://mowgli.cs.unibo.it)        *)
-(*                                                                            *)
-(*                     Coq Exportation to XML                                 *)
-(*                                                                            *)
-(******************************************************************************)
-
-This module provides commands to export a piece of Coq library in XML format.
-Only the information relevant to proof-checking and proof-rendering is exported,
-i.e. only the CIC proof objects (lambda-terms).
-
-This document is tructured in the following way:
- 1. User documentation
-   1.1. New vernacular commands available
-   1.2. New coqc/coqtop flags and suggested usage
-   1.3. How to exploit the XML files
- 2. Technical informations
-   2.1. Inner-types
-   2.2. CIC with Explicit Named Substitutions
-   2.3. The CIC with Explicit Named Substitutions XML DTD
-
-================================================================================
-                            USER DOCUMENTATION
-================================================================================
-
-=======================================
-1.1. New vernacular commands available:
-=======================================
-
-The new commands are:
-
- Print XML qualid.                 It prints in XML (to standard output) the
-                                   object whose qualified name is qualid and
-                                   its inner-types (see Sect. 2.1).
-                                   The inner-types are always printed
-                                   in their own XML file. If the object is a
-                                   constant, its type and body are also printed
-                                   as two distinct XML files.
-                                   The object printed is always the most
-                                   discharged form of the object (see
-                                   the Section command of the Coq manual).
-
- Print XML File "filename" qualid. Similar to "Print XML qualid". The generated
-                                   files are stored on the hard-disk using the
-                                   base file name "filename".
-
- Show XML Proof.                   It prints in XML the current proof in
-                                   progress. Its inner-types are also printed.
-
- Show XML File "filename" Proof.   Similar to "Show XML Proof". The generated
-                                   files are stored on the hard-disk using
-                                   the base file name "filename".
-
- The verbosity of the previous commands is raised if the configuration
- parameter verbose of xmlcommand.ml is set to true at compile time.
-
-==============================================
-1.2. New coqc/coqtop flags and suggested usage
-==============================================
-
- The following flag has been added to coqc and coqtop:
-
-  -xml     export XML files either to the hierarchy rooted in
-           the directory $COQ_XML_LIBRARY_ROOT (if the environment
-           variable is set) or to stdout (if unset)
-
- If the flag is set, every definition or declaration is immediately
- exported to XML. The XML files describe the user-provided non-discharged
- form of the definition or declaration. 
-
-
- The coq_makefile utility has also been modified to easily allow XML
- exportation:
-
-   make COQ_XML=-xml   (or, equivalently, setting the environment
-                        variable COQ_XML)
-
-
- The suggested usage of the module is the following:
-
-   1. add to your own contribution a valid Make file and use coq_makefile
-      to generate the Makefile from the Make file.
-      *WARNING:* Since logical names are used to structure the XML hierarchy,
-      always add to the Make file at least one "-R" option to map physical
-      file names to logical module paths. See the Coq manual for further
-      informations on the -R flag.
-   2. set $COQ_XML_LIBRARY_ROOT to the directory where the XML file hierarchy
-      must be physically rooted.
-   3. compile your contribution with "make COQ_XML=-xml"
-
-
-=================================
-1.3. How to exploit the XML files
-=================================
-
- Once the information is exported to XML, it becomes possible to implement
- services that are completely Coq-independent. Projects HELM and MoWGLI
- already provide rendering, searching and data mining functionalities.
-
- In particular, the standard library and contributions of Coq can be
- browsed and searched on the HELM web site:
-
-                  http://helm.cs.unibo.it/library.html
-
-
- If you want to publish your own contribution so that it is included in the
- HELM library, use the MoWGLI prototype upload form:
-
-                  http://mowgli.cs.unibo.it
-
-
-================================================================================
-                            TECHNICAL INFORMATIONS
-================================================================================
-
-==========================
-2.1. Inner-types
-==========================
-
-In order to do proof-rendering (for example in natural language),
-some redundant typing information is required, i.e. the type of
-at least some of the subterms of the bodies and types. So, each
-new command described in section 1.1 print not only
-the object, but also another XML file in which you can find
-the type of all the subterms of the terms of the printed object
-which respect the following conditions:
-
- 1. It's sort is Prop or CProp (the "sort"-like definition used in
-    CoRN to type computationally relevant predicative propositions).
- 2. It is not a cast or an atomic term, i.e. it's root is not a CAST, REL,
-    VAR, MUTCONSTR or CONST.
- 3. If it's root is a LAMBDA, then the root's parent node is not a LAMBDA,
-    i.e. only the type of the outer LAMBDA of a block of nested LAMBDAs is
-    printed.
-
-The rationale for the 3rd condition is that the type of the inner LAMBDAs
-could be easily computed starting from the type of the outer LAMBDA; moreover,
-the types of the inner LAMBDAs requires a lot of disk/memory space: removing
-the 3rd condition leads to XML file that are two times as big as the ones
-exported appling the 3rd condition.
-
-==========================================
-2.2. CIC with Explicit Named Substitutions
-==========================================
-
-The exported files are and XML encoding of the lambda-terms used by the
-Coq system. The implementative details of the Coq system are hidden as much
-as possible, so that the XML DTD is a straightforward encoding of the  
-Calculus of (Co)Inductive Constructions.
-
-Nevertheless, there is a feature of the Coq system that can not be
-hidden in a completely satisfactory way: discharging. In Coq it is possible
-to open a section, declare variables and use them in the rest of the section
-as if they were axiom declarations. Once the section is closed, every definition
-and theorem in the section is discharged by abstracting it over the section
-variables. Variable declarations as well as section declarations are entirely
-dropped. Since we are interested in an XML encoding of definitions and
-theorems as close as possible to those directly provided the user, we
-do not want to export discharged forms. Exporting non-discharged theorem
-and definitions together with theorems that rely on the discharged forms
-obliges the tools that work on the XML encoding to implement discharging to
-achieve logical consistency. Moreover, the rendering of the files can be
-misleading, since hyperlinks can be shown between occurrences of the discharge
-form of a definition and the non-discharged definition, that are different
-objects.
-
-To overcome the previous limitations, Claudio Sacerdoti Coen developed in his
-PhD. thesis an extension of CIC, called Calculus of (Co)Inductive Constructions
-with Explicit Named Substitutions, that is a slight extension of CIC where
-discharging is not necessary. The DTD of the exported XML files describes
-constants, inductive types and variables of the Calculus of (Co)Inductive
-Constructions with Explicit Named Substitions. The conversion to the new
-calculus is performed during the exportation phase.
-
-The following example shows a very small Coq development together with its
-version in CIC with Explicit Named Substitutions.
-
-# CIC version: #
-Section S.
- Variable A : Prop.
-
- Definition impl := A -> A.
-
- Theorem t : impl.           (* uses the undischarged form of impl *)
-  Proof.
-   exact (fun (a:A) => a).
-  Qed.
-
-End S.
-
-Theorem t' : (impl False).   (* uses the discharged form of impl *) 
- Proof.
-  exact (t False).           (* uses the discharged form of t *)
- Qed.
-
-# Corresponding CIC with Explicit Named Substitutions version: #
-Section S.
- Variable A : Prop.
-
- Definition impl(A) := A -> A.   (* theorems and definitions are
-                                    explicitly abstracted over the
-                                    variables. The name is sufficient
-                                    to completely describe the abstraction *)
-
- Theorem t(A) : impl.            (* impl where A is not instantiated *)
-  Proof.
-   exact (fun (a:A) => a).
-  Qed.
-
-End S.
-
-Theorem t'() : impl{False/A}.    (* impl where A is instantiated with False
-                                    Notice that t' does not depend on A     *) 
- Proof.
-  exact t{False/A}.              (* t where A is instantiated with False *)
- Qed.
-
-Further details on the typing and reduction rules of the calculus can be
-found in Claudio Sacerdoti Coen PhD. dissertation, where the consistency
-of the calculus is also proved.
-
-======================================================
-2.3. The CIC with Explicit Named Substitutions XML DTD
-======================================================
-
-A copy of the DTD can be found in the file "cic.dtd".
-
-<ConstantType>     is the root element of the files that correspond to
-                   constant types.
-<ConstantBody>     is the root element of the files that correspond to
-                   constant bodies. It is used only for closed definitions and
-                   theorems (i.e. when no metavariable occurs in the body
-                   or type of the constant)
-<CurrentProof>     is the root element of the file that correspond to
-                   the body of a constant that depends on metavariables
-                   (e.g. unfinished proofs)
-<Variable>         is the root element of the files that correspond to variables
-<InductiveTypes>   is the root element of the files that correspond to blocks
-                   of mutually defined inductive definitions
-
-The elements
- <LAMBDA>,<CAST>,<PROD>,<REL>,<SORT>,<APPLY>,<VAR>,<META>, <IMPLICIT>,<CONST>,
- <LETIN>,<MUTIND>,<MUTCONSTRUCT>,<MUTCASE>,<FIX> and <COFIX>
-are used to encode the constructors of CIC. The sort or type attribute of the
-element, if present, is respectively the sort or the type of the term, that
-is a sort because of the typing rules of CIC.
-
-The element <instantiate> correspond to the application of an explicit named
-substitution to its first argument, that is a reference to a definition
-or declaration in the environment.
-
-All the other elements are just syntactic sugar.
+The xml export plugin for Coq has been discontinued for lack of users:
+it was most certainly broken while imposing a non-negligible cost on
+Coq development. Its purpose was to give export Coq's kernel objects
+in xml form for treatment by external tools.
+
+If you are looking for such a tool, you may want to look at commit
+7cfe0a70eda671ada6a46cd779ef9308f7e0fdb9 responsible for the deletion
+of this plugin (for instance, git checkout
+7cfe0a70eda671ada6a46cd779ef9308f7e0fdb9^ including the "^", will lead
+you to the last commit before the xml plugin was deleted).
+
+Bear in mind, however, that the plugin was not working properly at the
+time. You may want instead to write to the original author of the
+plugin, Claudio Sacerdoti-Coen at sacerdot@cs.unibo.it. He has a
+stable version of the plugin for an old version of Coq.
diff --git a/plugins/xml/acic.ml b/plugins/xml/acic.ml
deleted file mode 100644
index 653c2b7b..00000000
--- a/plugins/xml/acic.ml
+++ /dev/null
@@ -1,108 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
-(*   \VV/  **************************************************************)
-(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
-(*         *   University of Bologna                                    *)
-(************************************************************************)
-(*          This file is distributed under the terms of the             *)
-(*           GNU Lesser General Public License Version 2.1              *)
-(*                                                                      *)
-(*                 Copyright (C) 2000-2004, HELM Team.                  *)
-(*                       http://helm.cs.unibo.it                        *)
-(************************************************************************)
-
-open Names
-open Term
-
-(* Maps fron \em{unshared} [constr] to ['a]. *)
-module CicHash =
- Hashtbl.Make
-  (struct
-    type t = Term.constr
-    let equal = (==)
-    let hash = Hashtbl.hash
-   end)
-;;
-
-type id = string  (* the type of the (annotated) node identifiers *)
-type uri = string
-
-type 'constr context_entry =
-   Decl of 'constr             (* Declaration *)
- | Def  of 'constr * 'constr   (* Definition; the second argument (the type) *)
-                               (* is not present in the DTD, but is needed   *)
-                               (* to use Coq functions during exportation.   *)
-
-type 'constr hypothesis = identifier * 'constr context_entry
-type context = constr hypothesis list
-
-type conjecture = existential_key * context * constr
-type metasenv = conjecture list
-
-(* list of couples section path -- variables defined in that section *)
-type params = (string * uri list) list
-
-type obj =
-   Constant of string *                            (* id,           *)
-    constr option * constr *                       (*  value, type, *)
-    params                                         (*  parameters   *)
- | Variable of
-    string * constr option * constr *              (* name, body, type *)
-    params                                         (*  parameters   *)
- | CurrentProof of
-    string * metasenv *                            (*  name, conjectures, *)
-    constr * constr                                (*  value, type        *)
- | InductiveDefinition of
-    inductiveType list *                           (* inductive types ,      *)
-    params * int                                   (*  parameters,n ind. pars*)
-and inductiveType =
- identifier * bool * constr *                 (* typename, inductive, arity *)
-  constructor list                            (*  constructors              *)
-and constructor =
- identifier * constr                          (* id, type *)
-
-type aconstr =
-  | ARel       of id * int * id * identifier
-  | AVar       of id * uri
-  | AEvar      of id * existential_key * aconstr list
-  | ASort      of id * sorts
-  | ACast      of id * aconstr * aconstr
-  | AProds     of (id * name * aconstr) list * aconstr
-  | ALambdas   of (id * name * aconstr) list * aconstr
-  | ALetIns    of (id * name * aconstr) list * aconstr
-  | AApp       of id * aconstr list
-  | AConst     of id * explicit_named_substitution * uri
-  | AInd       of id * explicit_named_substitution * uri * int
-  | AConstruct of id * explicit_named_substitution * uri * int * int
-  | ACase      of id * uri * int * aconstr * aconstr * aconstr list
-  | AFix       of id * int * ainductivefun list
-  | ACoFix     of id * int * acoinductivefun list
-and ainductivefun =
- id * identifier * int * aconstr * aconstr
-and acoinductivefun =
- id * identifier * aconstr * aconstr
-and explicit_named_substitution = id option * (uri * aconstr) list
-
-type acontext = (id * aconstr hypothesis) list
-type aconjecture = id * existential_key * acontext * aconstr
-type ametasenv = aconjecture list
-
-type aobj =
-   AConstant of id * string *                      (* id,           *)
-    aconstr option * aconstr *                     (*  value, type, *)
-    params                                         (*  parameters   *)
- | AVariable of id *
-    string * aconstr option * aconstr *            (* name, body, type *)
-    params                                         (*  parameters   *)
- | ACurrentProof of id *
-    string * ametasenv *                           (*  name, conjectures, *)
-    aconstr * aconstr                              (*  value, type        *)
- | AInductiveDefinition of id *
-    anninductiveType list *                        (* inductive types ,      *)
-    params * int                                   (*  parameters,n ind. pars*)
-and anninductiveType =
- id * identifier * bool * aconstr *           (* typename, inductive, arity *)
-  annconstructor list                         (*  constructors              *)
-and annconstructor =
- identifier * aconstr                         (* id, type *)
diff --git a/plugins/xml/acic2Xml.ml4 b/plugins/xml/acic2Xml.ml4
deleted file mode 100644
index 97f7e2bd..00000000
--- a/plugins/xml/acic2Xml.ml4
+++ /dev/null
@@ -1,363 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
-(*   \VV/  **************************************************************)
-(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
-(*         *   University of Bologna                                    *)
-(************************************************************************)
-(*          This file is distributed under the terms of the             *)
-(*           GNU Lesser General Public License Version 2.1              *)
-(*                                                                      *)
-(*                 Copyright (C) 2000-2004, HELM Team.                  *)
-(*                       http://helm.cs.unibo.it                        *)
-(************************************************************************)
-
-(*CSC codice cut & paste da cicPp e xmlcommand *)
-
-exception ImpossiblePossible;;
-exception NotImplemented;;
-let dtdname = "http://mowgli.cs.unibo.it/dtd/cic.dtd";;
-let typesdtdname = "http://mowgli.cs.unibo.it/dtd/cictypes.dtd";;
-
-let rec find_last_id =
- function
-    [] -> Util.anomaly "find_last_id: empty list"
-  | [id,_,_] -> id
-  | _::tl -> find_last_id tl
-;;
-
-let export_existential = string_of_int
-
-let print_term ids_to_inner_sorts =
- let rec aux =
-  let module A = Acic in
-  let module N = Names in
-  let module X = Xml in
-    function
-       A.ARel (id,n,idref,b) ->
-        let sort = Hashtbl.find ids_to_inner_sorts id in
-         X.xml_empty "REL"
-          ["value",(string_of_int n) ; "binder",(N.string_of_id b) ;
-           "id",id ; "idref",idref; "sort",sort]
-     | A.AVar (id,uri) ->
-        let sort = Hashtbl.find ids_to_inner_sorts id in
-         X.xml_empty "VAR" ["uri", uri ; "id",id ; "sort",sort]
-     | A.AEvar (id,n,l) ->
-        let sort = Hashtbl.find ids_to_inner_sorts id in
-         X.xml_nempty "META"
-	   ["no",(export_existential n) ; "id",id ; "sort",sort]
-          (List.fold_left
-            (fun i t ->
-              [< i ; X.xml_nempty "substitution" [] (aux t) >]
-            ) [< >] (List.rev l))
-     | A.ASort (id,s) ->
-        let string_of_sort =
-         match Term.family_of_sort s with
-            Term.InProp -> "Prop"
-          | Term.InSet  -> "Set"
-          | Term.InType -> "Type"
-        in
-         X.xml_empty "SORT" ["value",string_of_sort ; "id",id]
-     | A.AProds (prods,t) ->
-        let last_id = find_last_id prods in
-        let sort = Hashtbl.find ids_to_inner_sorts last_id in
-         X.xml_nempty "PROD" ["type",sort]
-          [< List.fold_left
-              (fun i (id,binder,s) ->
-                let sort =
-                 Hashtbl.find ids_to_inner_sorts (Cic2acic.source_id_of_id id)
-                in
-                 let attrs =
-                  ("id",id)::("type",sort)::
-                  match binder with
-                     Names.Anonymous -> []
-                   | Names.Name b -> ["binder",Names.string_of_id b]
-                 in
-                  [< X.xml_nempty "decl" attrs (aux s) ; i >]
-              ) [< >] prods ;
-             X.xml_nempty "target" [] (aux t)
-          >]
-     | A.ACast (id,v,t) ->
-        let sort = Hashtbl.find ids_to_inner_sorts id in
-         X.xml_nempty "CAST" ["id",id ; "sort",sort]
-          [< X.xml_nempty "term" [] (aux v) ;
-             X.xml_nempty "type" [] (aux t)
-          >]
-     | A.ALambdas (lambdas,t) ->
-        let last_id = find_last_id lambdas in
-        let sort = Hashtbl.find ids_to_inner_sorts last_id in
-         X.xml_nempty "LAMBDA" ["sort",sort]
-          [< List.fold_left
-              (fun i (id,binder,s) ->
-                let sort =
-                 Hashtbl.find ids_to_inner_sorts (Cic2acic.source_id_of_id id)
-                in
-                 let attrs =
-                  ("id",id)::("type",sort)::
-                  match binder with
-                     Names.Anonymous -> []
-                   | Names.Name b -> ["binder",Names.string_of_id b]
-                 in
-                  [< X.xml_nempty "decl" attrs (aux s) ; i >]
-              ) [< >] lambdas ;
-             X.xml_nempty "target" [] (aux t)
-          >]
-     | A.ALetIns (letins,t) ->
-        let last_id = find_last_id letins in
-        let sort = Hashtbl.find ids_to_inner_sorts last_id in
-         X.xml_nempty "LETIN" ["sort",sort]
-          [< List.fold_left
-              (fun i (id,binder,s) ->
-                let sort =
-                 Hashtbl.find ids_to_inner_sorts (Cic2acic.source_id_of_id id)
-                in
-                 let attrs =
-                  ("id",id)::("sort",sort)::
-                  match binder with
-                     Names.Anonymous -> assert false
-                   | Names.Name b -> ["binder",Names.string_of_id b]
-                 in
-                  [< X.xml_nempty "def" attrs (aux s) ; i >]
-              ) [< >] letins ;
-             X.xml_nempty "target" [] (aux t)
-          >]
-     | A.AApp (id,li) ->
-        let sort = Hashtbl.find ids_to_inner_sorts id in
-         X.xml_nempty "APPLY" ["id",id ; "sort",sort]
-          [< (List.fold_left (fun i x -> [< i ; (aux x) >]) [<>] li)
-          >]
-     | A.AConst (id,subst,uri) ->
-        let sort = Hashtbl.find ids_to_inner_sorts id in
-        let attrs = ["uri", uri ; "id",id ; "sort",sort] in
-         aux_subst (X.xml_empty "CONST" attrs) subst
-     | A.AInd (id,subst,uri,i) ->
-        let attrs = ["uri", uri ; "noType",(string_of_int i) ; "id",id] in
-         aux_subst (X.xml_empty "MUTIND" attrs) subst
-     | A.AConstruct (id,subst,uri,i,j) ->
-        let sort = Hashtbl.find ids_to_inner_sorts id in
-        let attrs =
-         ["uri", uri ;
-          "noType",(string_of_int i) ; "noConstr",(string_of_int j) ;
-          "id",id ; "sort",sort]
-        in
-         aux_subst (X.xml_empty "MUTCONSTRUCT" attrs) subst
-     | A.ACase (id,uri,typeno,ty,te,patterns) ->
-        let sort = Hashtbl.find ids_to_inner_sorts id in
-         X.xml_nempty "MUTCASE"
-          ["uriType", uri ;
-           "noType", (string_of_int typeno) ;
-           "id", id ; "sort",sort]
-          [< X.xml_nempty "patternsType" [] [< (aux ty) >] ;
-             X.xml_nempty "inductiveTerm" [] [< (aux te) >] ;
-             List.fold_left
-              (fun i x -> [< i ; X.xml_nempty "pattern" [] [< aux x >] >])
-              [<>] patterns
-          >]
-     | A.AFix (id, no, funs) ->
-        let sort = Hashtbl.find ids_to_inner_sorts id in
-         X.xml_nempty "FIX"
-          ["noFun", (string_of_int no) ; "id",id ; "sort",sort]
-          [< List.fold_left
-              (fun i (id,fi,ai,ti,bi) ->
-                [< i ;
-                   X.xml_nempty "FixFunction"
-                    ["id",id ; "name", (Names.string_of_id fi) ;
-                     "recIndex", (string_of_int ai)]
-                    [< X.xml_nempty "type" [] [< aux ti >] ;
-                       X.xml_nempty "body" [] [< aux bi >]
-                    >]
-                >]
-              ) [<>] funs
-          >]
-     | A.ACoFix (id,no,funs) ->
-        let sort = Hashtbl.find ids_to_inner_sorts id in
-         X.xml_nempty "COFIX"
-          ["noFun", (string_of_int no) ; "id",id ; "sort",sort]
-          [< List.fold_left
-              (fun i (id,fi,ti,bi) ->
-                [< i ;
-                   X.xml_nempty "CofixFunction"
-                    ["id",id ; "name", Names.string_of_id fi]
-                    [< X.xml_nempty "type" [] [< aux ti >] ;
-                       X.xml_nempty "body" [] [< aux bi >]
-                    >]
-                >]
-              ) [<>] funs
-          >]
- and aux_subst target (id,subst) =
-  if subst = [] then
-   target
-  else
-   Xml.xml_nempty "instantiate"
-    (match id with None -> [] | Some id -> ["id",id])
-    [< target ;
-       List.fold_left
-        (fun i (uri,arg) ->
-          [< i ; Xml.xml_nempty "arg" ["relUri", uri] (aux arg) >]
-        ) [<>] subst
-    >]
- in
-  aux
-;;
-
-let param_attribute_of_params params =
- List.fold_right
-  (fun (path,l) i ->
-    List.fold_right
-     (fun x i ->path ^ "/" ^ x ^ ".var" ^ match i with "" -> "" | i' -> " " ^ i'
-     ) l "" ^ match i with "" -> "" | i' -> " " ^ i'
-  ) params ""
-;;
-
-let print_object uri ids_to_inner_sorts =
- let rec aux =
-  let module A = Acic in
-  let module X = Xml in
-    function
-       A.ACurrentProof (id,n,conjectures,bo,ty) ->
-        let xml_for_current_proof_body =
-(*CSC: Should the CurrentProof also have the list of variables it depends on? *)
-(*CSC: I think so. Not implemented yet.                                       *)
-         X.xml_nempty "CurrentProof" ["of",uri ; "id", id]
-          [< List.fold_left
-              (fun i (cid,n,canonical_context,t) ->
-                [< i ;
-                   X.xml_nempty "Conjecture"
-                    ["id", cid ; "no",export_existential n]
-                    [< List.fold_left
-                        (fun i (hid,t) ->
-                          [< (match t with
-                                n,A.Decl t ->
-                                 X.xml_nempty "Decl"
-                                  ["id",hid;"name",Names.string_of_id n]
-                                  (print_term ids_to_inner_sorts t)
-                              | n,A.Def (t,_) ->
-                                 X.xml_nempty "Def"
-                                  ["id",hid;"name",Names.string_of_id n]
-                                  (print_term ids_to_inner_sorts t)
-                             ) ;
-                             i
-                          >]
-                        ) [< >] canonical_context ;
-                       X.xml_nempty "Goal" []
-                        (print_term ids_to_inner_sorts t)
-                    >]
-                >])
-              [<>] (List.rev conjectures) ;
-             X.xml_nempty "body" [] (print_term ids_to_inner_sorts bo) >]
-        in
-        let xml_for_current_proof_type =
-         X.xml_nempty "ConstantType" ["name",n ; "id", id]
-          (print_term ids_to_inner_sorts ty)
-        in
-        let xmlbo =
-         [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
-            X.xml_cdata ("<!DOCTYPE CurrentProof SYSTEM \""^dtdname ^"\">\n");
-            xml_for_current_proof_body
-         >] in
-        let xmlty =
-         [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
-            X.xml_cdata
-             ("<!DOCTYPE ConstantType SYSTEM \"" ^ dtdname ^ "\">\n");
-            xml_for_current_proof_type
-         >]
-        in
-         xmlty, Some xmlbo
-     | A.AConstant (id,n,bo,ty,params) ->
-        let params' = param_attribute_of_params params in
-        let xmlbo =
-         match bo with
-            None -> None
-          | Some bo ->
-             Some
-              [< X.xml_cdata
-                  "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
-                 X.xml_cdata
-                  ("<!DOCTYPE ConstantBody SYSTEM \"" ^ dtdname ^ "\">\n") ;
-                 X.xml_nempty "ConstantBody"
-                  ["for",uri ; "params",params' ; "id", id]
-                  [< print_term ids_to_inner_sorts bo >]
-              >]
-        in
-        let xmlty =
-         [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
-            X.xml_cdata ("<!DOCTYPE ConstantType SYSTEM \""^dtdname ^"\">\n");
-             X.xml_nempty "ConstantType"
-              ["name",n ; "params",params' ; "id", id]
-              [< print_term ids_to_inner_sorts ty >]
-         >]
-        in
-         xmlty, xmlbo
-     | A.AVariable (id,n,bo,ty,params) ->
-        let params' = param_attribute_of_params params in
-         [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
-            X.xml_cdata ("<!DOCTYPE Variable SYSTEM \"" ^ dtdname ^ "\">\n") ;
-            X.xml_nempty "Variable" ["name",n ; "params",params' ; "id", id]
-             [< (match bo with
-                    None -> [<>]
-                  | Some bo ->
-                     X.xml_nempty "body" []
-                      (print_term ids_to_inner_sorts bo)
-                ) ;
-                X.xml_nempty "type" [] (print_term ids_to_inner_sorts ty)
-             >]
-         >], None
-     | A.AInductiveDefinition (id,tys,params,nparams) ->
-        let params' = param_attribute_of_params params in
-         [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
-            X.xml_cdata ("<!DOCTYPE InductiveDefinition SYSTEM \"" ^
-             dtdname ^ "\">\n") ;
-            X.xml_nempty "InductiveDefinition"
-             ["noParams",string_of_int nparams ;
-              "id",id ;
-              "params",params']
-             [< (List.fold_left
-                  (fun i (id,typename,finite,arity,cons) ->
-                    [< i ;
-                       X.xml_nempty "InductiveType"
-                        ["id",id ; "name",Names.string_of_id typename ;
-                         "inductive",(string_of_bool finite)
-                        ]
-                        [< X.xml_nempty "arity" []
-                            (print_term ids_to_inner_sorts arity) ;
-                           (List.fold_left
-                            (fun i (name,lc) ->
-                              [< i ;
-                                 X.xml_nempty "Constructor"
-                                  ["name",Names.string_of_id name]
-                                  (print_term ids_to_inner_sorts lc)
-                              >]) [<>] cons
-                           )
-                        >]
-                    >]
-                  ) [< >] tys
-                )
-             >]
-         >], None
- in
-  aux
-;;
-
-let print_inner_types curi ids_to_inner_sorts ids_to_inner_types =
- let module C2A = Cic2acic in
- let module X = Xml in
-  [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
-     X.xml_cdata ("<!DOCTYPE InnerTypes SYSTEM \"" ^ typesdtdname ^"\">\n");
-      X.xml_nempty "InnerTypes" ["of",curi]
-       (Hashtbl.fold
-         (fun id {C2A.annsynthesized = synty ; C2A.annexpected = expty} x ->
-           [< x ;
-              X.xml_nempty "TYPE" ["of",id]
-               [< X.xml_nempty "synthesized" []
-                   (print_term ids_to_inner_sorts synty) ;
-                  match expty with
-                     None -> [<>]
-                   | Some expty' ->
-                      X.xml_nempty "expected" []
-                       (print_term ids_to_inner_sorts expty')
-               >]
-           >]
-         ) ids_to_inner_types [<>]
-       )
-  >]
-;;
diff --git a/plugins/xml/cic.dtd b/plugins/xml/cic.dtd
deleted file mode 100644
index c8035cab..00000000
--- a/plugins/xml/cic.dtd
+++ /dev/null
@@ -1,259 +0,0 @@
-<?xml encoding="ISO-8859-1"?>
-
-<!-- Copyright (C) 2000-2004, HELM Team                                -->
-<!--                                                                   -->
-<!-- This file is part of HELM, an Hypertextual, Electronic            -->
-<!-- Library of Mathematics, developed at the Computer Science         -->
-<!-- Department, University of Bologna, Italy.                         -->
-<!--                                                                   -->
-<!-- HELM is free software; you can redistribute it and/or             -->
-<!-- modify it under the terms of the GNU General Public License       -->
-<!-- as published by the Free Software Foundation; either version 2    -->
-<!-- of the License, or (at your option) any later version.            -->
-<!--                                                                   -->
-<!-- HELM is distributed in the hope that it will be useful,           -->
-<!-- but WITHOUT ANY WARRANTY; without even the implied warranty of    -->
-<!-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the     -->
-<!-- GNU General Public License for more details.                      -->
-<!--                                                                   -->
-<!-- You should have received a copy of the GNU General Public License -->
-<!-- along with HELM; if not, write to the Free Software               -->
-<!-- Foundation, Inc., 59 Temple Place - Suite 330, Boston,            -->
-<!-- MA  02111-1307, USA.                                              -->
-<!--                                                                   -->
-<!-- For details, see the HELM World-Wide-Web page,                    -->
-<!-- http://cs.unibo.it/helm/.                                         -->
-
-<!-- DTD FOR CIC OBJECTS: -->
-
-<!-- CIC term declaration -->
-
-<!ENTITY % term '(LAMBDA|CAST|PROD|REL|SORT|APPLY|VAR|META|IMPLICIT|CONST|
-                  LETIN|MUTIND|MUTCONSTRUCT|MUTCASE|FIX|COFIX|instantiate)'>
-
-<!-- CIC sorts -->
-
-<!ENTITY % sort '(Prop|Set|Type|CProp)'>
-
-<!-- CIC sequents -->
-
-<!ENTITY % sequent '((Decl|Def|Hidden)*,Goal)'>
-
-<!-- CIC objects: -->
-
-<!ELEMENT ConstantType %term;>
-<!ATTLIST ConstantType
-          name       CDATA      #REQUIRED
-          params     CDATA      #REQUIRED
-          id         ID         #REQUIRED>
-
-<!ELEMENT ConstantBody %term;>
-<!ATTLIST ConstantBody
-          for        CDATA      #REQUIRED
-          params     CDATA      #REQUIRED
-          id         ID         #REQUIRED>
-
-<!ELEMENT CurrentProof (Conjecture*,body)>
-<!ATTLIST CurrentProof
-          of         CDATA      #REQUIRED
-          id         ID         #REQUIRED>
-
-<!ELEMENT InductiveDefinition (InductiveType+)>
-<!ATTLIST InductiveDefinition
-          noParams NMTOKEN #REQUIRED
-          params   CDATA   #REQUIRED
-          id       ID      #REQUIRED>
-
-<!ELEMENT Variable (body?,type)>
-<!ATTLIST Variable
-          name   CDATA #REQUIRED
-          params CDATA #REQUIRED
-          id     ID    #REQUIRED>
-
-<!ELEMENT Sequent %sequent;>
-<!ATTLIST Sequent
-          no  NMTOKEN #REQUIRED
-          id  ID      #REQUIRED>
-
-<!-- Elements used in CIC objects, which are not terms: -->
-
-<!ELEMENT InductiveType (arity,Constructor*)>
-<!ATTLIST InductiveType
-          name      CDATA        #REQUIRED
-          inductive (true|false) #REQUIRED
-          id        ID           #REQUIRED>
-
-<!ELEMENT Conjecture %sequent;>
-<!ATTLIST Conjecture
-          no NMTOKEN #REQUIRED
-          id ID      #REQUIRED>
-
-<!ELEMENT Constructor %term;>
-<!ATTLIST Constructor
-          name CDATA #REQUIRED>
-
-<!ELEMENT Decl %term;>
-<!ATTLIST Decl
-          name CDATA #IMPLIED
-          id   ID    #REQUIRED>
-
-<!ELEMENT Def %term;>
-<!ATTLIST Def
-          name CDATA #IMPLIED
-          id   ID    #REQUIRED>
-
-<!ELEMENT Hidden EMPTY>
-<!ATTLIST Hidden
-          id ID #REQUIRED>
-
-<!ELEMENT Goal %term;>
-
-<!-- CIC terms: -->
-
-<!ELEMENT LAMBDA (decl*,target)>
-<!ATTLIST LAMBDA
-          sort %sort; #REQUIRED>
-
-<!ELEMENT LETIN (def*,target)>
-<!ATTLIST LETIN
-          sort %sort; #REQUIRED>
-
-<!ELEMENT PROD (decl*,target)>
-<!ATTLIST PROD
-          type %sort; #REQUIRED>
-
-<!ELEMENT CAST (term,type)>
-<!ATTLIST CAST
-          id   ID     #REQUIRED
-          sort %sort; #REQUIRED>
-
-<!ELEMENT REL EMPTY>
-<!ATTLIST REL
-          value  NMTOKEN #REQUIRED
-          binder CDATA   #REQUIRED
-          id     ID      #REQUIRED
-          idref  IDREF   #REQUIRED
-          sort   %sort;  #REQUIRED>
-
-<!ELEMENT SORT EMPTY>
-<!ATTLIST SORT
-          value CDATA #REQUIRED
-          id    ID    #REQUIRED>
-
-<!ELEMENT APPLY (%term;)+>
-<!ATTLIST APPLY
-          id   ID     #REQUIRED
-          sort %sort; #REQUIRED>
-
-<!ELEMENT VAR EMPTY>
-<!ATTLIST VAR
-          uri  CDATA  #REQUIRED
-          id   ID     #REQUIRED
-          sort %sort; #REQUIRED>
-
-<!-- The substitutions are ordered by increasing DeBrujin  -->
-<!-- index. An empty substitution means that that index is -->
-<!-- not accessible.                                       -->
-<!ELEMENT META (substitution*)>
-<!ATTLIST META
-          no              NMTOKEN #REQUIRED
-          id              ID      #REQUIRED
-          sort            %sort;  #REQUIRED>
-
-<!ELEMENT IMPLICIT EMPTY>
-<!ATTLIST IMPLICIT
-          id ID #REQUIRED>
-
-<!ELEMENT CONST EMPTY>
-<!ATTLIST CONST
-          uri  CDATA  #REQUIRED
-          id   ID     #REQUIRED
-          sort %sort; #REQUIRED>
-
-<!ELEMENT MUTIND EMPTY>
-<!ATTLIST MUTIND
-          uri    CDATA   #REQUIRED
-          noType NMTOKEN #REQUIRED
-          id     ID      #REQUIRED>
-
-<!ELEMENT MUTCONSTRUCT EMPTY>
-<!ATTLIST MUTCONSTRUCT
-          uri      CDATA   #REQUIRED
-          noType   NMTOKEN #REQUIRED
-          noConstr NMTOKEN #REQUIRED
-          id       ID      #REQUIRED
-          sort     %sort;  #REQUIRED>
-
-<!ELEMENT MUTCASE (patternsType,inductiveTerm,pattern*)>
-<!ATTLIST MUTCASE
-          uriType CDATA   #REQUIRED
-          noType  NMTOKEN #REQUIRED
-          id      ID      #REQUIRED
-          sort    %sort;  #REQUIRED>
-
-<!ELEMENT FIX (FixFunction+)>
-<!ATTLIST FIX
-          noFun NMTOKEN #REQUIRED
-          id    ID      #REQUIRED
-          sort  %sort;  #REQUIRED>
-
-<!ELEMENT COFIX (CofixFunction+)>
-<!ATTLIST COFIX
-          noFun NMTOKEN #REQUIRED
-          id    ID      #REQUIRED
-          sort  %sort;  #REQUIRED>
-
-<!-- Elements used in CIC terms: -->
-
-<!ELEMENT FixFunction (type,body)>
-<!ATTLIST FixFunction
-          name     CDATA   #REQUIRED
-          id       ID      #REQUIRED
-          recIndex NMTOKEN #REQUIRED>
-
-<!ELEMENT CofixFunction (type,body)>
-<!ATTLIST CofixFunction
-          id       ID      #REQUIRED
-          name     CDATA   #REQUIRED>
-
-<!ELEMENT substitution ((%term;)?)>
-
-<!-- Explicit named substitutions: -->
-
-<!ELEMENT instantiate ((CONST|MUTIND|MUTCONSTRUCT|VAR),arg+)>
-<!ATTLIST instantiate
-          id ID #IMPLIED>
-
-<!-- Sintactic sugar for CIC terms and for CIC objects: -->
-
-<!ELEMENT arg %term;>
-<!ATTLIST arg
-          relUri CDATA #REQUIRED>
-
-<!ELEMENT decl %term;>
-<!ATTLIST decl
-          id     ID     #REQUIRED
-          type   %sort; #REQUIRED
-          binder CDATA  #IMPLIED>
-          
-<!ELEMENT def %term;>
-<!ATTLIST def
-          id     ID     #REQUIRED
-          sort   %sort; #REQUIRED
-          binder CDATA  #IMPLIED>
-
-<!ELEMENT target %term;>
-
-<!ELEMENT term %term;>
-
-<!ELEMENT type  %term;>
-
-<!ELEMENT arity %term;>
-
-<!ELEMENT patternsType  %term;>
-
-<!ELEMENT inductiveTerm  %term;>
-
-<!ELEMENT pattern  %term;>
-
-<!ELEMENT body  %term;>
diff --git a/plugins/xml/cic2Xml.ml b/plugins/xml/cic2Xml.ml
deleted file mode 100644
index 981503a6..00000000
--- a/plugins/xml/cic2Xml.ml
+++ /dev/null
@@ -1,17 +0,0 @@
-let print_xml_term ch env sigma cic =
-  let ids_to_terms = Hashtbl.create 503 in
-  let constr_to_ids = Acic.CicHash.create 503 in
-  let ids_to_father_ids = Hashtbl.create 503 in
-  let ids_to_inner_sorts = Hashtbl.create 503 in
-  let ids_to_inner_types = Hashtbl.create 503 in
-  let seed = ref 0 in
-  let acic =
-   Cic2acic.acic_of_cic_context' true seed ids_to_terms constr_to_ids
-    ids_to_father_ids ids_to_inner_sorts ids_to_inner_types
-    env [] sigma (Unshare.unshare cic) None in
-  let xml = Acic2Xml.print_term ids_to_inner_sorts acic in
-  Xml.pp_ch xml ch
-;;
-
-Tacinterp.declare_xml_printer print_xml_term
-;;
diff --git a/plugins/xml/cic2acic.ml b/plugins/xml/cic2acic.ml
deleted file mode 100644
index 165bf83d..00000000
--- a/plugins/xml/cic2acic.ml
+++ /dev/null
@@ -1,942 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
-(*   \VV/  **************************************************************)
-(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
-(*         *   University of Bologna                                    *)
-(************************************************************************)
-(*          This file is distributed under the terms of the             *)
-(*           GNU Lesser General Public License Version 2.1              *)
-(*                                                                      *)
-(*                 Copyright (C) 2000-2004, HELM Team.                  *)
-(*                       http://helm.cs.unibo.it                        *)
-(************************************************************************)
-
-(* Utility Functions *)
-
-exception TwoModulesWhoseDirPathIsOneAPrefixOfTheOther;;
-let get_module_path_of_full_path path =
- let dirpath = fst (Libnames.repr_path path) in
- let modules = Lib.library_dp () :: (Library.loaded_libraries ()) in
-  match
-   List.filter
-    (function modul -> Libnames.is_dirpath_prefix_of modul dirpath) modules
-  with
-     [] ->
-       Pp.msg_warn ("Modules not supported: reference to "^
-         Libnames.string_of_path path^" will be wrong");
-       dirpath
-   | [modul] -> modul
-   | _ ->
-       raise TwoModulesWhoseDirPathIsOneAPrefixOfTheOther
-;;
-
-(*CSC: Problem: here we are using the wrong (???) hypothesis that there do *)
-(*CSC: not exist two modules whose dir_paths are one a prefix of the other *)
-let remove_module_dirpath_from_dirpath ~basedir dir =
- let module Ln = Libnames in
-  if Ln.is_dirpath_prefix_of basedir dir then
-   let ids = Names.repr_dirpath dir in
-   let rec remove_firsts n l =
-    match n,l with
-       (0,l) -> l
-     | (n,he::tl) -> remove_firsts (n-1) tl
-     | _ -> assert false
-   in
-    let ids' =
-     List.rev
-      (remove_firsts
-        (List.length (Names.repr_dirpath basedir))
-        (List.rev ids))
-    in
-     ids'
-  else Names.repr_dirpath dir
-;;
-
-
-let get_uri_of_var v pvars =
- let module D = Decls in
- let module N = Names in
-  let rec search_in_open_sections =
-   function
-      [] -> Util.error ("Variable "^v^" not found")
-    | he::tl as modules ->
-       let dirpath = N.make_dirpath modules in
-        if List.mem (N.id_of_string v) (D.last_section_hyps dirpath) then
-         modules
-        else
-         search_in_open_sections tl
-  in
-   let path =
-    if List.mem v pvars then
-      []
-    else
-      search_in_open_sections (N.repr_dirpath (Lib.cwd ()))
-   in
-    "cic:" ^
-     List.fold_left
-      (fun i x -> "/" ^ N.string_of_id x ^ i) "" path
-;;
-
-type tag =
-   Constant of Names.constant
- | Inductive of Names.mutual_inductive
- | Variable of Names.kernel_name
-;;
-
-type etag =
-   TConstant
- | TInductive
- | TVariable
-;;
-
-let etag_of_tag =
- function
-    Constant _ -> TConstant
-  | Inductive _ -> TInductive
-  | Variable _ -> TVariable
-
-let ext_of_tag =
- function
-    TConstant -> "con"
-  | TInductive -> "ind"
-  | TVariable -> "var"
-;;
-
-exception FunctorsXMLExportationNotImplementedYet;;
-
-let subtract l1 l2 =
- let l1' = List.rev (Names.repr_dirpath l1) in
- let l2' = List.rev (Names.repr_dirpath l2) in
-  let rec aux =
-   function
-      he::tl when tl = l2' -> [he]
-    | he::tl -> he::(aux tl)
-    | [] -> assert (l2' = []) ; []
-  in
-   Names.make_dirpath (List.rev (aux l1'))
-;;
-
-let token_list_of_path dir id tag =
- let module N = Names in
-  let token_list_of_dirpath dirpath =
-   List.rev_map N.string_of_id (N.repr_dirpath dirpath) in
-  token_list_of_dirpath dir @ [N.string_of_id id ^ "." ^ (ext_of_tag tag)]
-
-let token_list_of_kernel_name tag =
- let module N = Names in
- let module LN = Libnames in
- let id,dir = match tag with
-   | Variable kn ->
-       N.id_of_label (N.label kn), Lib.cwd ()
-   | Constant con ->
-       N.id_of_label (N.con_label con),
-       Lib.remove_section_part (LN.ConstRef con)
-   | Inductive kn ->
-       N.id_of_label (N.mind_label kn),
-       Lib.remove_section_part (LN.IndRef (kn,0))
- in
- token_list_of_path dir id (etag_of_tag tag)
-;;
-
-let uri_of_kernel_name tag =
-  let tokens = token_list_of_kernel_name tag in
-   "cic:/" ^ String.concat "/" tokens
-
-let uri_of_declaration id tag =
- let module LN = Libnames in
- let dir = LN.pop_dirpath_n (Lib.sections_depth ()) (Lib.cwd ()) in
- let tokens = token_list_of_path dir id tag in
-  "cic:/" ^ String.concat "/" tokens
-
-(* Special functions for handling of CCorn's CProp "sort" *)
-
-type sort =
-   Coq_sort of Term.sorts_family
- | CProp
-;;
-
-let prerr_endline _ = ();;
-
-let family_of_term ty =
- match Term.kind_of_term ty with
-    Term.Sort s -> Coq_sort (Term.family_of_sort s)
-  | Term.Const _ -> CProp  (* I could check that the constant is CProp *)
-  | _ -> Util.anomaly "family_of_term"
-;;
-
-module CPropRetyping =
- struct
-  module T = Term
-
-  let outsort env sigma t =
-   family_of_term (DoubleTypeInference.whd_betadeltaiotacprop env sigma t)
-
-  let rec subst_type env sigma typ = function
-  | [] -> typ
-  | h::rest ->
-      match T.kind_of_term (DoubleTypeInference.whd_betadeltaiotacprop env sigma typ) with
-        | T.Prod (na,c1,c2) -> subst_type env sigma (T.subst1 h c2) rest
-        | _ -> Util.anomaly "Non-functional construction"
-
-
-  let sort_of_atomic_type env sigma ft args =
-  let rec concl_of_arity env ar =
-    match T.kind_of_term (DoubleTypeInference.whd_betadeltaiotacprop env sigma ar) with
-      | T.Prod (na, t, b) -> concl_of_arity (Environ.push_rel (na,None,t) env) b
-      | T.Sort s -> Coq_sort (T.family_of_sort s)
-      | _ -> outsort env sigma (subst_type env sigma ft (Array.to_list args))
-  in concl_of_arity env ft
-
-let typeur sigma metamap =
-  let rec type_of env cstr=
-    match Term.kind_of_term cstr with
-    | T.Meta n ->
-          (try T.strip_outer_cast (List.assoc n metamap)
-           with Not_found -> Util.anomaly "type_of: this is not a well-typed term")
-    | T.Rel n ->
-        let (_,_,ty) = Environ.lookup_rel n env in
-        T.lift n ty
-    | T.Var id ->
-        (try
-          let (_,_,ty) = Environ.lookup_named id env in
-          ty
-        with Not_found ->
-          Util.anomaly ("type_of: variable "^(Names.string_of_id id)^" unbound"))
-    | T.Const c ->
-        let cb = Environ.lookup_constant c env in
-        Typeops.type_of_constant_type env (cb.Declarations.const_type)
-    | T.Evar ev -> Evd.existential_type sigma ev
-    | T.Ind ind -> Inductiveops.type_of_inductive env ind
-    | T.Construct cstr -> Inductiveops.type_of_constructor env cstr
-    | T.Case (_,p,c,lf) ->
-        let Inductiveops.IndType(_,realargs) =
-          try Inductiveops.find_rectype env sigma (type_of env c)
-          with Not_found -> Util.anomaly "type_of: Bad recursive type" in
-        let t = Reductionops.whd_beta sigma (T.applist (p, realargs)) in
-        (match Term.kind_of_term (DoubleTypeInference.whd_betadeltaiotacprop env sigma (type_of env t)) with
-          | T.Prod _ -> Reductionops.whd_beta sigma (T.applist (t, [c]))
-          | _ -> t)
-    | T.Lambda (name,c1,c2) ->
-          T.mkProd (name, c1, type_of (Environ.push_rel (name,None,c1) env) c2)
-    | T.LetIn (name,b,c1,c2) ->
-         T.subst1 b (type_of (Environ.push_rel (name,Some b,c1) env) c2)
-    | T.Fix ((_,i),(_,tys,_)) -> tys.(i)
-    | T.CoFix (i,(_,tys,_)) -> tys.(i)
-    | T.App(f,args)->
-        T.strip_outer_cast
-          (subst_type env sigma (type_of env f) (Array.to_list args))
-    | T.Cast (c,_, t) -> t
-    | T.Sort _ | T.Prod _ ->
-       match sort_of env cstr with
-          Coq_sort T.InProp -> T.mkProp
-        | Coq_sort T.InSet -> T.mkSet
-        | Coq_sort T.InType -> T.mkType Univ.type1_univ (* ERROR HERE *)
-        | CProp -> T.mkConst DoubleTypeInference.cprop
-
-  and sort_of env t =
-    match Term.kind_of_term t with
-    | T.Cast (c,_, s) when T.isSort s -> family_of_term s
-    | T.Sort (T.Prop c) -> Coq_sort T.InType
-    | T.Sort (T.Type u) -> Coq_sort T.InType
-    | T.Prod (name,t,c2) ->
-       (match sort_of env t,sort_of (Environ.push_rel (name,None,t) env) c2 with
-          | _, (Coq_sort T.InProp as s) -> s
-          | Coq_sort T.InProp, (Coq_sort T.InSet as s)
-          | Coq_sort T.InSet, (Coq_sort T.InSet as s) -> s
-          | Coq_sort T.InType, (Coq_sort T.InSet as s)
-          | CProp, (Coq_sort T.InSet as s) when
-              Environ.engagement env = Some Declarations.ImpredicativeSet -> s
-          | Coq_sort T.InType, Coq_sort T.InSet
-          | CProp, Coq_sort T.InSet -> Coq_sort T.InType
-          | _, (Coq_sort T.InType as s) -> s (*Type Univ.dummy_univ*)
-          | _, (CProp as s) -> s)
-    | T.App(f,args) -> sort_of_atomic_type env sigma (type_of env f) args
-    | T.Lambda _ | T.Fix _ | T.Construct _ ->
-        Util.anomaly "sort_of: Not a type (1)"
-    | _ -> outsort env sigma (type_of env t)
-
-  and sort_family_of env t =
-    match T.kind_of_term t with
-    | T.Cast (c,_, s) when T.isSort s -> family_of_term s
-    | T.Sort (T.Prop c) -> Coq_sort T.InType
-    | T.Sort (T.Type u) -> Coq_sort T.InType
-    | T.Prod (name,t,c2) -> sort_family_of (Environ.push_rel (name,None,t) env) c2
-    | T.App(f,args) ->
-       sort_of_atomic_type env sigma (type_of env f) args
-    | T.Lambda _ | T.Fix _ | T.Construct _ ->
-        Util.anomaly "sort_of: Not a type (1)"
-    | _ -> outsort env sigma (type_of env t)
-
-  in type_of, sort_of, sort_family_of
-
-  let get_type_of env sigma c = let f,_,_ = typeur sigma [] in f env c
-  let get_sort_family_of env sigma c = let _,_,f = typeur sigma [] in f env c
-
- end
-;;
-
-let get_sort_family_of env evar_map ty =
- CPropRetyping.get_sort_family_of env evar_map ty
-;;
-
-let type_as_sort env evar_map ty =
-(* CCorn code *)
- family_of_term (DoubleTypeInference.whd_betadeltaiotacprop env evar_map ty)
-;;
-
-let is_a_Prop =
- function
-    "Prop"
-  | "CProp" -> true
-  | _ -> false
-;;
-
-(* Main Functions *)
-
-type anntypes =
- {annsynthesized : Acic.aconstr ; annexpected : Acic.aconstr option}
-;;
-
-let gen_id seed =
- let res = "i" ^ string_of_int !seed in
-  incr seed ;
-  res
-;;
-
-let fresh_id seed ids_to_terms constr_to_ids ids_to_father_ids =
- fun father t ->
-  let res = gen_id seed in
-   Hashtbl.add ids_to_father_ids res father ;
-   Hashtbl.add ids_to_terms res t ;
-   Acic.CicHash.add constr_to_ids t res ;
-   res
-;;
-
-let source_id_of_id id = "#source#" ^ id;;
-
-let acic_of_cic_context' computeinnertypes seed ids_to_terms constr_to_ids
- ids_to_father_ids ids_to_inner_sorts ids_to_inner_types
- ?(fake_dependent_products=false) env idrefs evar_map t expectedty
-=
- let module D = DoubleTypeInference in
- let module E = Environ in
- let module N = Names in
- let module A = Acic in
- let module T = Term in
-  let fresh_id' = fresh_id seed ids_to_terms constr_to_ids ids_to_father_ids in
-   (* CSC: do you have any reasonable substitute for 503? *)
-   let terms_to_types = Acic.CicHash.create 503 in
-    D.double_type_of env evar_map t expectedty terms_to_types ;
-    let rec aux computeinnertypes father passed_lambdas_or_prods_or_letins env
-     idrefs ?(subst=None,[]) tt
-    =
-     let fresh_id'' = fresh_id' father tt in
-     let aux' = aux computeinnertypes (Some fresh_id'') [] in
-      let string_of_sort_family =
-       function
-          Coq_sort T.InProp -> "Prop"
-        | Coq_sort T.InSet  -> "Set"
-        | Coq_sort T.InType -> "Type"
-        | CProp -> "CProp"
-      in
-      let string_of_sort t =
-       string_of_sort_family
-        (type_as_sort env evar_map t)
-      in
-       let ainnertypes,innertype,innersort,expected_available =
-        let {D.synthesized = synthesized; D.expected = expected} =
-         if computeinnertypes then
-try
-          Acic.CicHash.find terms_to_types tt
-with e when e <> Sys.Break ->
-(*CSC: Warning: it really happens, for example in Ring_theory!!! *)
-Pp.ppnl (Pp.(++) (Pp.str "BUG: this subterm was not visited during the double-type-inference: ") (Printer.pr_lconstr tt)) ; assert false
-         else
-          (* We are already in an inner-type and Coscoy's double *)
-          (* type inference algorithm has not been applied.      *)
-          (* We need to refresh the universes because we are doing *)
-          (* type inference on an already inferred type.           *)
-          {D.synthesized =
-            Reductionops.nf_beta evar_map
-             (CPropRetyping.get_type_of env evar_map
-              (Termops.refresh_universes tt)) ;
-           D.expected = None}
-        in
-(* Debugging only:
-print_endline "TERMINE:" ; flush stdout ;
-Pp.ppnl (Printer.pr_lconstr tt) ; flush stdout ;
-print_endline "TIPO:" ; flush stdout ;
-Pp.ppnl (Printer.pr_lconstr synthesized) ; flush stdout ;
-print_endline "ENVIRONMENT:" ; flush stdout ;
-Pp.ppnl (Printer.pr_context_of env) ; flush stdout ;
-print_endline "FINE_ENVIRONMENT" ; flush stdout ;
-*)
-         let innersort =
-          let synthesized_innersort =
-           get_sort_family_of env evar_map synthesized
-          in
-           match expected with
-              None -> synthesized_innersort
-            | Some ty ->
-              let expected_innersort =
-               get_sort_family_of env evar_map ty
-              in
-               match expected_innersort, synthesized_innersort with
-                  CProp, _
-                | _, CProp -> CProp
-                | _, _ -> expected_innersort
-         in
-(* Debugging only:
-print_endline "PASSATO" ; flush stdout ;
-*)
-          let ainnertypes,expected_available =
-           if computeinnertypes then
-            let annexpected,expected_available =
-               match expected with
-                  None -> None,false
-                | Some expectedty' ->
-                   Some (aux false (Some fresh_id'') [] env idrefs expectedty'),
-                    true
-            in
-             Some
-              {annsynthesized =
-                aux false (Some fresh_id'') [] env idrefs synthesized ;
-               annexpected = annexpected
-              }, expected_available
-           else
-            None,false
-          in
-           ainnertypes,synthesized, string_of_sort_family innersort,
-            expected_available
-       in
-        let add_inner_type id =
-         match ainnertypes with
-            None -> ()
-          | Some ainnertypes -> Hashtbl.add ids_to_inner_types id ainnertypes
-        in
-
-         (* explicit_substitute_and_eta_expand_if_required h t t'         *)
-         (* where [t] = [] and [tt] = [h]{[t']} ("{.}" denotes explicit   *)
-         (* named substitution) or [tt] = (App [h]::[t]) (and [t'] = [])  *)
-         (* check if [h] is a term that requires an explicit named        *)
-         (* substitution and, in that case, uses the first arguments of   *)
-         (* [t] as the actual arguments of the substitution. If there     *)
-         (* are not enough parameters in the list [t], then eta-expansion *)
-         (* is performed.                                                 *)
-         let
-          explicit_substitute_and_eta_expand_if_required h t t'
-           compute_result_if_eta_expansion_not_required
-         =
-          let subst,residual_args,uninst_vars =
-           let variables,basedir =
-             try
-               let g = Libnames.global_of_constr h in
-               let sp =
-                match g with
-                   Libnames.ConstructRef ((induri,_),_)
-                 | Libnames.IndRef (induri,_) ->
-                    Nametab.path_of_global (Libnames.IndRef (induri,0))
-                 | Libnames.VarRef id ->
-                    (* Invariant: variables are never cooked in Coq *)
-                    raise Not_found
-                 | _ -> Nametab.path_of_global g
-               in
-               Dischargedhypsmap.get_discharged_hyps sp,
-               get_module_path_of_full_path sp
-             with Not_found ->
-                (* no explicit substitution *)
-                [], Libnames.dirpath_of_string "dummy"
-           in
-           (* returns a triple whose first element is  *)
-           (* an explicit named substitution of "type" *)
-           (* (variable * argument) list, whose        *)
-           (* second element is the list of residual   *)
-           (* arguments and whose third argument is    *)
-           (* the list of uninstantiated variables     *)
-           let rec get_explicit_subst variables arguments =
-            match variables,arguments with
-               [],_ -> [],arguments,[]
-             | _,[] -> [],[],variables
-             | he1::tl1,he2::tl2 ->
-                let subst,extra_args,uninst = get_explicit_subst tl1 tl2 in
-                let (he1_sp, he1_id) = Libnames.repr_path he1 in
-                let he1' = remove_module_dirpath_from_dirpath ~basedir he1_sp in
-                let he1'' =
-                 String.concat "/"
-                  (List.map Names.string_of_id (List.rev he1')) ^ "/"
-                 ^ (Names.string_of_id he1_id) ^ ".var"
-                in
-                 (he1'',he2)::subst, extra_args, uninst
-           in
-            get_explicit_subst variables t'
-          in
-           let uninst_vars_length = List.length uninst_vars in
-            if uninst_vars_length > 0 then
-             (* Not enough arguments provided. We must eta-expand! *)
-             let un_args,_ =
-              T.decompose_prod_n uninst_vars_length
-               (CPropRetyping.get_type_of env evar_map tt)
-             in
-              let eta_expanded =
-               let arguments =
-                List.map (T.lift uninst_vars_length) t @
-                 Termops.rel_list 0 uninst_vars_length
-               in
-                Unshare.unshare
-                 (T.lamn uninst_vars_length un_args
-                  (T.applistc h arguments))
-              in
-               D.double_type_of env evar_map eta_expanded
-                None terms_to_types ;
-               Hashtbl.remove ids_to_inner_types fresh_id'' ;
-               aux' env idrefs eta_expanded
-            else
-             compute_result_if_eta_expansion_not_required subst residual_args
-         in
-
-          (* Now that we have all the auxiliary functions we  *)
-          (* can finally proceed with the main case analysis. *)
-          match T.kind_of_term tt with
-             T.Rel n ->
-              let id =
-               match List.nth (E.rel_context env) (n - 1) with
-                  (N.Name id,_,_)   -> id
-                | (N.Anonymous,_,_) -> Nameops.make_ident "_" None
-              in
-               Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
-               if is_a_Prop innersort  && expected_available then
-                add_inner_type fresh_id'' ;
-               A.ARel (fresh_id'', n, List.nth idrefs (n-1), id)
-           | T.Var id ->
-	      let pvars = Termops.ids_of_named_context (E.named_context env) in
-	      let pvars = List.map N.string_of_id pvars in
-              let path = get_uri_of_var (N.string_of_id id) pvars in
-               Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
-               if is_a_Prop innersort  && expected_available then
-                add_inner_type fresh_id'' ;
-               A.AVar
-                (fresh_id'', path ^ "/" ^ (N.string_of_id id) ^ ".var")
-           | T.Evar (n,l) ->
-              Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
-              if is_a_Prop innersort  && expected_available then
-               add_inner_type fresh_id'' ;
-              A.AEvar
-               (fresh_id'', n, Array.to_list (Array.map (aux' env idrefs) l))
-           | T.Meta _ -> Util.anomaly "Meta met during exporting to XML"
-           | T.Sort s -> A.ASort (fresh_id'', s)
-           | T.Cast (v,_, t) ->
-              Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
-              if is_a_Prop innersort then
-               add_inner_type fresh_id'' ;
-              A.ACast (fresh_id'', aux' env idrefs v, aux' env idrefs t)
-           | T.Prod (n,s,t) ->
-              let n' =
-               match n with
-                  N.Anonymous -> N.Anonymous
-                | _ ->
-                  if not fake_dependent_products && T.noccurn 1 t then
-                   N.Anonymous
-                  else
-                   N.Name
-                    (Namegen.next_name_away n (Termops.ids_of_context env))
-              in
-               Hashtbl.add ids_to_inner_sorts fresh_id''
-                (string_of_sort innertype) ;
-               let sourcetype = CPropRetyping.get_type_of env evar_map s in
-                Hashtbl.add ids_to_inner_sorts (source_id_of_id fresh_id'')
-                 (string_of_sort sourcetype) ;
-               let new_passed_prods =
-                let father_is_prod =
-                 match father with
-                    None -> false
-                  | Some father' ->
-                     match
-                      Term.kind_of_term (Hashtbl.find ids_to_terms father')
-                     with
-                        T.Prod _ -> true
-                      | _ -> false
-                in
-                 (fresh_id'', n', aux' env idrefs s)::
-                  (if father_is_prod then
-                    passed_lambdas_or_prods_or_letins
-                   else [])
-               in
-                let new_env = E.push_rel (n', None, s) env in
-                let new_idrefs = fresh_id''::idrefs in
-                 (match Term.kind_of_term t with
-                     T.Prod _ ->
-                      aux computeinnertypes (Some fresh_id'') new_passed_prods
-                       new_env new_idrefs t
-                   | _ ->
-                     A.AProds (new_passed_prods, aux' new_env new_idrefs t))
-           | T.Lambda (n,s,t) ->
-              let n' =
-               match n with
-                  N.Anonymous -> N.Anonymous
-                | _ ->
-                  N.Name (Namegen.next_name_away n (Termops.ids_of_context env))
-              in
-               Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
-               let sourcetype = CPropRetyping.get_type_of env evar_map s in
-                Hashtbl.add ids_to_inner_sorts (source_id_of_id fresh_id'')
-                 (string_of_sort sourcetype) ;
-               let father_is_lambda =
-                match father with
-                   None -> false
-                 | Some father' ->
-                    match
-                     Term.kind_of_term (Hashtbl.find ids_to_terms father')
-                    with
-                       T.Lambda _ -> true
-                     | _ -> false
-               in
-                if is_a_Prop innersort &&
-                   ((not father_is_lambda) || expected_available)
-                then add_inner_type fresh_id'' ;
-                let new_passed_lambdas =
-                 (fresh_id'',n', aux' env idrefs s)::
-                  (if father_is_lambda then
-                    passed_lambdas_or_prods_or_letins
-                   else []) in
-                let new_env = E.push_rel (n', None, s) env in
-                let new_idrefs = fresh_id''::idrefs in
-                 (match Term.kind_of_term t with
-                     T.Lambda _ ->
-                      aux computeinnertypes (Some fresh_id'') new_passed_lambdas
-                       new_env new_idrefs t
-                   | _ ->
-                     let t' = aux' new_env new_idrefs t in
-                      (* eta-expansion for explicit named substitutions *)
-                      (* can create nested Lambdas. Here we perform the *)
-                      (* flattening.                                    *)
-                      match t' with
-                         A.ALambdas (lambdas, t'') ->
-                          A.ALambdas (lambdas@new_passed_lambdas, t'')
-                       | _ ->
-                         A.ALambdas (new_passed_lambdas, t')
-                 )
-           | T.LetIn (n,s,t,d) ->
-              let id =
-               match n with
-                   N.Anonymous -> N.id_of_string "_X"
-                 | N.Name id -> id
-              in
-              let n' =
-               N.Name (Namegen.next_ident_away id (Termops.ids_of_context env))
-              in
-               Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
-               let sourcesort =
-                get_sort_family_of env evar_map
-                 (CPropRetyping.get_type_of env evar_map s)
-               in
-                Hashtbl.add ids_to_inner_sorts (source_id_of_id fresh_id'')
-                 (string_of_sort_family sourcesort) ;
-               let father_is_letin =
-                match father with
-                   None -> false
-                 | Some father' ->
-                    match
-                     Term.kind_of_term (Hashtbl.find ids_to_terms father')
-                    with
-                       T.LetIn _ -> true
-                     | _ -> false
-               in
-                if is_a_Prop innersort then
-                 add_inner_type fresh_id'' ;
-                let new_passed_letins =
-                 (fresh_id'',n', aux' env idrefs s)::
-                  (if father_is_letin then
-                    passed_lambdas_or_prods_or_letins
-                   else []) in
-                let new_env = E.push_rel (n', Some s, t) env in
-                let new_idrefs = fresh_id''::idrefs in
-                 (match Term.kind_of_term d with
-                     T.LetIn _ ->
-                      aux computeinnertypes (Some fresh_id'') new_passed_letins
-                       new_env new_idrefs d
-                   | _ -> A.ALetIns
-                           (new_passed_letins, aux' new_env new_idrefs d))
-           | T.App (h,t) ->
-              Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
-              if is_a_Prop innersort then
-               add_inner_type fresh_id'' ;
-              let
-               compute_result_if_eta_expansion_not_required subst residual_args
-              =
-               let residual_args_not_empty = residual_args <> [] in
-               let h' =
-                if residual_args_not_empty then
-                 aux' env idrefs ~subst:(None,subst) h
-                else
-                 aux' env idrefs ~subst:(Some fresh_id'',subst) h
-               in
-                (* maybe all the arguments were used for the explicit *)
-                (* named substitution                                 *)
-                if residual_args_not_empty then
-                 A.AApp (fresh_id'', h'::residual_args)
-                else
-                 h'
-              in
-               let t' =
-                Array.fold_right (fun x i -> (aux' env idrefs x)::i) t []
-               in
-                explicit_substitute_and_eta_expand_if_required h
-                 (Array.to_list t) t'
-                 compute_result_if_eta_expansion_not_required
-           | T.Const kn ->
-              Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
-              if is_a_Prop innersort  && expected_available then
-               add_inner_type fresh_id'' ;
-              let compute_result_if_eta_expansion_not_required _ _ =
-               A.AConst (fresh_id'', subst, (uri_of_kernel_name (Constant kn)))
-              in
-               let (_,subst') = subst in
-                explicit_substitute_and_eta_expand_if_required tt []
-                 (List.map snd subst')
-                 compute_result_if_eta_expansion_not_required
-           | T.Ind (kn,i) ->
-              let compute_result_if_eta_expansion_not_required _ _ =
-               A.AInd (fresh_id'', subst, (uri_of_kernel_name (Inductive kn)), i)
-              in
-               let (_,subst') = subst in
-                explicit_substitute_and_eta_expand_if_required tt []
-                 (List.map snd subst')
-                 compute_result_if_eta_expansion_not_required
-           | T.Construct ((kn,i),j) ->
-              Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
-              if is_a_Prop innersort  && expected_available then
-               add_inner_type fresh_id'' ;
-              let compute_result_if_eta_expansion_not_required _ _ =
-               A.AConstruct
-                (fresh_id'', subst, (uri_of_kernel_name (Inductive kn)), i, j)
-              in
-               let (_,subst') = subst in
-                explicit_substitute_and_eta_expand_if_required tt []
-                 (List.map snd subst')
-                 compute_result_if_eta_expansion_not_required
-           | T.Case ({T.ci_ind=(kn,i)},ty,term,a) ->
-              Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
-              if is_a_Prop innersort then
-               add_inner_type fresh_id'' ;
-              let a' =
-               Array.fold_right (fun x i -> (aux' env idrefs x)::i) a []
-              in
-               A.ACase
-                (fresh_id'', (uri_of_kernel_name (Inductive kn)), i,
-                  aux' env idrefs ty, aux' env idrefs term, a')
-           | T.Fix ((ai,i),(f,t,b)) ->
-              Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
-              if is_a_Prop innersort then add_inner_type fresh_id'' ;
-              let fresh_idrefs =
-               Array.init (Array.length t) (function _ -> gen_id seed) in
-              let new_idrefs =
-               (List.rev (Array.to_list fresh_idrefs)) @ idrefs
-              in
-               let f' =
-                let ids = ref (Termops.ids_of_context env) in
-                 Array.map
-                  (function
-                      N.Anonymous -> Util.error "Anonymous fix function met"
-                    | N.Name id as n ->
-                       let res = N.Name (Namegen.next_name_away n !ids) in
-                        ids := id::!ids ;
-                        res
-                 ) f
-               in
-                A.AFix (fresh_id'', i,
-                 Array.fold_right
-                  (fun (id,fi,ti,bi,ai) i ->
-                    let fi' =
-                     match fi with
-                        N.Name fi -> fi
-                      | N.Anonymous -> Util.error "Anonymous fix function met"
-                    in
-                     (id, fi', ai,
-                      aux' env idrefs ti,
-                      aux' (E.push_rec_types (f',t,b) env) new_idrefs bi)::i)
-                  (Array.mapi
-                   (fun j x -> (fresh_idrefs.(j),x,t.(j),b.(j),ai.(j))) f'
-                  ) []
-                 )
-           | T.CoFix (i,(f,t,b)) ->
-              Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
-              if is_a_Prop innersort then add_inner_type fresh_id'' ;
-              let fresh_idrefs =
-               Array.init (Array.length t) (function _ -> gen_id seed) in
-              let new_idrefs =
-               (List.rev (Array.to_list fresh_idrefs)) @ idrefs
-              in
-               let f' =
-                let ids = ref (Termops.ids_of_context env) in
-                 Array.map
-                  (function
-                      N.Anonymous -> Util.error "Anonymous fix function met"
-                    | N.Name id as n ->
-                       let res = N.Name (Namegen.next_name_away n !ids) in
-                        ids := id::!ids ;
-                        res
-                 ) f
-               in
-                A.ACoFix (fresh_id'', i,
-                 Array.fold_right
-                  (fun (id,fi,ti,bi) i ->
-                    let fi' =
-                     match fi with
-                        N.Name fi -> fi
-                      | N.Anonymous -> Util.error "Anonymous fix function met"
-                    in
-                     (id, fi',
-                      aux' env idrefs ti,
-                      aux' (E.push_rec_types (f',t,b) env) new_idrefs bi)::i)
-                  (Array.mapi
-                    (fun j x -> (fresh_idrefs.(j),x,t.(j),b.(j)) ) f'
-                  ) []
-                 )
-    in
-     aux computeinnertypes None [] env idrefs t
-;;
-
-(* Obsolete [HH 1/2009]
-let acic_of_cic_context metasenv context t =
- let ids_to_terms = Hashtbl.create 503 in
- let constr_to_ids = Acic.CicHash.create 503 in
- let ids_to_father_ids = Hashtbl.create 503 in
- let ids_to_inner_sorts = Hashtbl.create 503 in
- let ids_to_inner_types = Hashtbl.create 503 in
- let seed = ref 0 in
-   acic_of_cic_context' true seed ids_to_terms constr_to_ids ids_to_father_ids
-    ids_to_inner_sorts ids_to_inner_types metasenv context t,
-   ids_to_terms, ids_to_father_ids, ids_to_inner_sorts, ids_to_inner_types
-;;
-*)
-
-let acic_object_of_cic_object sigma obj =
- let module A = Acic in
-  let ids_to_terms = Hashtbl.create 503 in
-  let constr_to_ids = Acic.CicHash.create 503 in
-  let ids_to_father_ids = Hashtbl.create 503 in
-  let ids_to_inner_sorts = Hashtbl.create 503 in
-  let ids_to_inner_types = Hashtbl.create 503 in
-  let ids_to_conjectures = Hashtbl.create 11 in
-  let ids_to_hypotheses = Hashtbl.create 127 in
-  let hypotheses_seed = ref 0 in
-  let conjectures_seed = ref 0 in
-  let seed = ref 0 in
-  let acic_term_of_cic_term_context' =
-   acic_of_cic_context' true seed ids_to_terms constr_to_ids ids_to_father_ids
-    ids_to_inner_sorts ids_to_inner_types in
-(*CSC: is this the right env to use? Hhmmm. There is a problem: in    *)
-(*CSC: Global.env () the object we are exporting is already defined,  *)
-(*CSC: either in the environment or in the named context (in the case *)
-(*CSC: of variables. Is this a problem?                               *)
-  let env = Global.env () in
-  let acic_term_of_cic_term' ?fake_dependent_products =
-   acic_term_of_cic_term_context' ?fake_dependent_products env [] sigma in
-(*CSC: the fresh_id is not stored anywhere. This _MUST_ be fixed using *)
-(*CSC: a modified version of the already existent fresh_id function    *)
-  let fresh_id () =
-   let res = "i" ^ string_of_int !seed in
-    incr seed ;
-    res
-  in
-   let aobj =
-    match obj with
-      A.Constant (id,bo,ty,params) ->
-       let abo =
-        match bo with
-           None -> None
-         | Some bo' -> Some (acic_term_of_cic_term' bo' (Some ty))
-       in
-       let aty = acic_term_of_cic_term' ty None in
-        A.AConstant (fresh_id (),id,abo,aty,params)
-    | A.Variable (id,bo,ty,params) ->
-       let abo =
-        match bo with
-           Some bo -> Some (acic_term_of_cic_term' bo (Some ty))
-         | None -> None
-       in
-       let aty = acic_term_of_cic_term' ty None in
-        A.AVariable (fresh_id (),id,abo,aty,params)
-    | A.CurrentProof (id,conjectures,bo,ty) ->
-       let aconjectures =
-        List.map
-         (function (i,canonical_context,term) as conjecture ->
-           let cid = "c" ^ string_of_int !conjectures_seed in
-            Hashtbl.add ids_to_conjectures cid conjecture ;
-            incr conjectures_seed ;
-            let canonical_env,idrefs',acanonical_context =
-             let rec aux env idrefs =
-              function
-                 [] -> env,idrefs,[]
-               | ((n,decl_or_def) as hyp)::tl ->
-                  let hid = "h" ^ string_of_int !hypotheses_seed in
-                  let new_idrefs = hid::idrefs in
-                   Hashtbl.add ids_to_hypotheses hid hyp ;
-                   incr hypotheses_seed ;
-                   match decl_or_def with
-                       A.Decl t ->
-                        let final_env,final_idrefs,atl =
-                         aux (Environ.push_rel (Names.Name n,None,t) env)
-                          new_idrefs tl
-                        in
-                         let at =
-                          acic_term_of_cic_term_context' env idrefs sigma t None
-                         in
-                          final_env,final_idrefs,(hid,(n,A.Decl at))::atl
-                     | A.Def (t,ty) ->
-                        let final_env,final_idrefs,atl =
-                         aux
-                          (Environ.push_rel (Names.Name n,Some t,ty) env)
-                           new_idrefs tl
-                        in
-                         let at =
-                          acic_term_of_cic_term_context' env idrefs sigma t None
-                         in
-                         let dummy_never_used =
-                          let s = "dummy_never_used" in
-                           A.ARel (s,99,s,Names.id_of_string s)
-                         in
-                          final_env,final_idrefs,
-                           (hid,(n,A.Def (at,dummy_never_used)))::atl
-             in
-              aux env [] canonical_context
-            in
-             let aterm =
-              acic_term_of_cic_term_context' canonical_env idrefs' sigma term
-               None
-             in
-              (cid,i,List.rev acanonical_context,aterm)
-         ) conjectures in
-       let abo = acic_term_of_cic_term_context' env [] sigma bo (Some ty) in
-       let aty = acic_term_of_cic_term_context' env [] sigma ty None in
-        A.ACurrentProof (fresh_id (),id,aconjectures,abo,aty)
-    | A.InductiveDefinition (tys,params,paramsno) ->
-       let env' =
-        List.fold_right
-         (fun (name,_,arity,_) env ->
-           Environ.push_rel (Names.Name name, None, arity) env
-         ) (List.rev tys) env in
-       let idrefs = List.map (function _ -> gen_id seed) tys in
-       let atys =
-        List.map2
-         (fun id (name,inductive,ty,cons) ->
-           let acons =
-            List.map
-             (function (name,ty) ->
-               (name,
-                 acic_term_of_cic_term_context' ~fake_dependent_products:true
-                  env' idrefs Evd.empty ty None)
-             ) cons
-           in
-            let aty =
-             acic_term_of_cic_term' ~fake_dependent_products:true ty None
-            in
-             (id,name,inductive,aty,acons)
-         ) (List.rev idrefs) tys
-       in
-       A.AInductiveDefinition (fresh_id (),atys,params,paramsno)
-   in
-    aobj,ids_to_terms,constr_to_ids,ids_to_father_ids,ids_to_inner_sorts,
-     ids_to_inner_types,ids_to_conjectures,ids_to_hypotheses
-;;
diff --git a/plugins/xml/doubleTypeInference.ml b/plugins/xml/doubleTypeInference.ml
deleted file mode 100644
index c22c16f0..00000000
--- a/plugins/xml/doubleTypeInference.ml
+++ /dev/null
@@ -1,273 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
-(*   \VV/  **************************************************************)
-(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
-(*         *   University of Bologna                                    *)
-(************************************************************************)
-(*          This file is distributed under the terms of the             *)
-(*           GNU Lesser General Public License Version 2.1              *)
-(*                                                                      *)
-(*                 Copyright (C) 2000-2004, HELM Team.                  *)
-(*                       http://helm.cs.unibo.it                        *)
-(************************************************************************)
-
-(*CSC: tutto da rifare!!! Basarsi su Retyping che e' meno costoso! *)
-type types = {synthesized : Term.types ; expected : Term.types option};;
-
-let prerr_endline _ = ();;
-
-let cprop =
- let module N = Names in
-  N.make_con
-   (N.MPfile
-     (Libnames.dirpath_of_string "CoRN.algebra.CLogic"))
-   (N.make_dirpath [])
-   (N.mk_label "CProp")
-;;
-
-let whd_betadeltaiotacprop env _evar_map ty =
- let module R = Glob_term in
- let module C = Closure in
- let module CR = C.RedFlags in
- (*** CProp is made Opaque ***)
- let flags = CR.red_sub C.betadeltaiota (CR.fCONST cprop) in
- C.whd_val (C.create_clos_infos flags env) (C.inject ty)
-;;
-
-
-(* Code similar to the code in the Typing module, but:   *)
-(*  - the term is already assumed to be well typed       *)
-(*  - some checks have been removed                      *)
-(*  - both the synthesized and expected types of every   *)
-(*    node are computed (Coscoy's double type inference) *)
-
-let assumption_of_judgment env sigma j =
-  Typeops.assumption_of_judgment env (Evarutil.j_nf_evar sigma j)
-;;
-
-let type_judgment env sigma j =
-  Typeops.type_judgment env (Evarutil.j_nf_evar sigma j)
-;;
-
-let type_judgment_cprop env sigma j =
-  match Term.kind_of_term(whd_betadeltaiotacprop env sigma j.Environ.uj_type) with
-    | Term.Sort s -> Some {Environ.utj_val = j.Environ.uj_val; Environ.utj_type = s }
-    | _ -> None  (* None means the CProp constant *)
-;;
-
-let double_type_of env sigma cstr expectedty subterms_to_types =
- (*CSC: the code is inefficient because judgments are created just to be   *)
- (*CSC: destroyed using Environ.j_type. Moreover I am pretty sure that the *)
- (*CSC: functions used do checks that we do not need                       *)
- let rec execute env sigma cstr expectedty =
-  let module T = Term in
-  let module E = Environ in
-   (* the type part is the synthesized type *)
-   let judgement =
-    match T.kind_of_term cstr with
-       T.Meta n ->
-        Util.error
-         "DoubleTypeInference.double_type_of: found a non-instanciated goal"
-
-     | T.Evar ((n,l) as ev) ->
-        let ty = Unshare.unshare (Evd.existential_type sigma ev) in
-        let jty = execute env sigma ty None in
-        let jty = assumption_of_judgment env sigma jty in
-        let evar_context =
-	  E.named_context_of_val (Evd.find sigma n).Evd.evar_hyps in
-         let rec iter actual_args evar_context =
-          match actual_args,evar_context with
-             [],[] -> ()
-           | he1::tl1,(n,_,ty)::tl2 ->
-              (* for side-effects *)
-              let _ = execute env sigma he1 (Some ty) in
-              let tl2' =
-               List.map
-                (function (m,bo,ty) ->
-                  (* Warning: the substitution should be performed also on bo *)
-                  (* This is not done since bo is not used later yet          *)
-                  (m,bo,Unshare.unshare (T.replace_vars [n,he1] ty))
-                ) tl2
-              in
-               iter tl1 tl2'
-           | _,_ -> assert false
-         in
-          (* for side effects only *)
-          iter (List.rev (Array.to_list l)) (List.rev evar_context) ;
-          E.make_judge cstr jty
-
-     | T.Rel n ->
-        Typeops.judge_of_relative env n
-
-     | T.Var id ->
-        Typeops.judge_of_variable env id
-
-     | T.Const c ->
-        E.make_judge cstr (Typeops.type_of_constant env c)
-
-     | T.Ind ind ->
-        E.make_judge cstr (Inductiveops.type_of_inductive env ind)
-
-     | T.Construct cstruct ->
-        E.make_judge cstr (Inductiveops.type_of_constructor env cstruct)
-
-     | T.Case (ci,p,c,lf) ->
-        let expectedtype =
-         Reduction.whd_betadeltaiota env (Retyping.get_type_of env sigma c) in
-        let cj = execute env sigma c (Some expectedtype) in
-        let pj = execute env sigma p None in
-        let (expectedtypes,_,_) =
-         let indspec = Inductive.find_rectype env cj.Environ.uj_type in
-          Inductive.type_case_branches env indspec pj cj.Environ.uj_val
-        in
-        let lfj =
-         execute_array env sigma lf
-          (Array.map (function x -> Some x) expectedtypes) in
-        let (j,_) = Typeops.judge_of_case env ci pj cj lfj in
-         j
-
-     | T.Fix ((vn,i as vni),recdef) ->
-        let (_,tys,_ as recdef') = execute_recdef env sigma recdef in
-        let fix = (vni,recdef') in
-        E.make_judge (T.mkFix fix) tys.(i)
-
-     | T.CoFix (i,recdef) ->
-        let (_,tys,_ as recdef') = execute_recdef env sigma recdef in
-        let cofix = (i,recdef') in
-        E.make_judge (T.mkCoFix cofix) tys.(i)
-
-     | T.Sort (T.Prop c) ->
-        Typeops.judge_of_prop_contents c
-
-     | T.Sort (T.Type u) ->
-(*CSC: In case of need, I refresh the universe. But exportation of the   *)
-(*CSC: right universe level information is destroyed. It must be changed *)
-(*CSC: again once Judicael will introduce his non-bugged algebraic       *)
-(*CSC: universes.                                                        *)
-(try
-        Typeops.judge_of_type u
- with e when e <> Sys.Break ->
- (* Successor of a non universe-variable universe anomaly *)
- (Pp.ppnl (Pp.str "Warning: universe refresh performed!!!") ; flush stdout ) ;
-  Typeops.judge_of_type (Termops.new_univ ())
-)
-
-     | T.App (f,args) ->
-        let expected_head =
-         Reduction.whd_betadeltaiota env (Retyping.get_type_of env sigma f) in
-        let j = execute env sigma f (Some expected_head) in
-        let expected_args =
-         let rec aux typ =
-          function
-             [] -> []
-           | hj::restjl ->
-              match T.kind_of_term (Reduction.whd_betadeltaiota env typ) with
-                 T.Prod (_,c1,c2) ->
-                  (Some (Reductionops.nf_beta sigma c1)) ::
-                   (aux (T.subst1 hj c2) restjl)
-               | _ -> assert false
-         in
-          Array.of_list (aux j.Environ.uj_type (Array.to_list args))
-        in
-        let jl = execute_array env sigma args expected_args in
-        let (j,_) = Typeops.judge_of_apply env j jl in
-         j
-
-     | T.Lambda (name,c1,c2) ->
-        let j = execute env sigma c1 None in
-        let var = type_judgment env sigma j in
-        let env1 = E.push_rel (name,None,var.E.utj_val) env in
-        let expectedc2type =
-         match expectedty with
-            None -> None
-          | Some ety ->
-              match T.kind_of_term (Reduction.whd_betadeltaiota env ety) with
-                 T.Prod (_,_,expected_target_type) ->
-                  Some (Reductionops.nf_beta sigma expected_target_type)
-               | _ -> assert false
-        in
-        let j' = execute env1 sigma c2 expectedc2type in
-         Typeops.judge_of_abstraction env1 name var j'
-
-     | T.Prod (name,c1,c2) ->
-        let j = execute env sigma c1 None in
-        let varj = type_judgment env sigma j in
-        let env1 = E.push_rel (name,None,varj.E.utj_val) env in
-        let j' = execute env1 sigma c2 None in
-        (match type_judgment_cprop env1 sigma j' with
-            Some varj' -> Typeops.judge_of_product env name varj varj'
-          | None ->
-             (* CProp found *)
-             { Environ.uj_val = T.mkProd (name, j.Environ.uj_val, j'.Environ.uj_val);
-               Environ.uj_type = T.mkConst cprop })
-
-     | T.LetIn (name,c1,c2,c3) ->
-(*CSC: What are the right expected types for the source and *)
-(*CSC: target of a LetIn? None used.                        *)
-        let j1 = execute env sigma c1 None in
-        let j2 = execute env sigma c2 None in
-        let j2 = type_judgment env sigma j2 in
-        let env1 =
-         E.push_rel (name,Some j1.E.uj_val,j2.E.utj_val) env
-        in
-         let j3 = execute env1 sigma c3 None in
-          Typeops.judge_of_letin env name j1 j2 j3
-
-     | T.Cast (c,k,t) ->
-        let cj = execute env sigma c (Some (Reductionops.nf_beta sigma t)) in
-        let tj = execute env sigma t None in
-	let tj = type_judgment env sigma tj in
-        let j, _ = Typeops.judge_of_cast env cj k tj in
-	 j
-    in
-     let synthesized = E.j_type judgement in
-     let synthesized' = Reductionops.nf_beta sigma synthesized in
-      let types,res =
-       match expectedty with
-          None ->
-           (* No expected type *)
-           {synthesized = synthesized' ; expected = None}, synthesized
-        | Some ty when Term.eq_constr synthesized' ty ->
-           (* The expected type is synthactically equal to the    *)
-           (* synthesized type. Let's forget it.                  *)
-           (* Note: since eq_constr is up to casts, it is better  *)
-           (* to keep the expected type, since it can bears casts *)
-           (* that change the innersort to CProp                  *)
-           {synthesized = ty ; expected = None}, ty
-        | Some expectedty' ->
-           {synthesized = synthesized' ; expected = Some expectedty'},
-           expectedty'
-      in
-(*CSC: debugging stuff to be removed *)
-if Acic.CicHash.mem subterms_to_types cstr then
- (Pp.ppnl (Pp.(++) (Pp.str "DUPLICATE INSERTION: ") (Printer.pr_lconstr cstr)) ; flush stdout ) ;
-       Acic.CicHash.add subterms_to_types cstr types ;
-       E.make_judge cstr res
-
-
- and execute_recdef env sigma (names,lar,vdef) =
-   let length = Array.length lar in
-   let larj =
-    execute_array env sigma lar (Array.make length None) in
-   let lara = Array.map (assumption_of_judgment env sigma) larj in
-   let env1 = Environ.push_rec_types (names,lara,vdef) env in
-   let expectedtypes =
-    Array.map (function i -> Some (Term.lift length i)) lar
-   in
-   let vdefj = execute_array env1 sigma vdef expectedtypes in
-   let vdefv = Array.map Environ.j_val vdefj in
-   (names,lara,vdefv)
-
- and execute_array env sigma v expectedtypes =
-   let jl =
-    execute_list env sigma (Array.to_list v) (Array.to_list expectedtypes)
-   in
-    Array.of_list jl
-
- and execute_list env sigma =
-  List.map2 (execute env sigma)
-
-in
- ignore (execute env sigma cstr expectedty)
-;;
diff --git a/plugins/xml/doubleTypeInference.mli b/plugins/xml/doubleTypeInference.mli
deleted file mode 100644
index 5c00bdc6..00000000
--- a/plugins/xml/doubleTypeInference.mli
+++ /dev/null
@@ -1,24 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
-(*   \VV/  **************************************************************)
-(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
-(*         *   University of Bologna                                    *)
-(************************************************************************)
-(*          This file is distributed under the terms of the             *)
-(*           GNU Lesser General Public License Version 2.1              *)
-(*                                                                      *)
-(*                 Copyright (C) 2000-2004, HELM Team.                  *)
-(*                       http://helm.cs.unibo.it                        *)
-(************************************************************************)
-
-type types = { synthesized : Term.types; expected : Term.types option; }
-
-val cprop : Names.constant
-
-val whd_betadeltaiotacprop :
-  Environ.env -> Evd.evar_map -> Term.constr -> Term.constr
-
-val double_type_of :
-  Environ.env -> Evd.evar_map -> Term.constr -> Term.constr option ->
-   types Acic.CicHash.t -> unit
diff --git a/plugins/xml/dumptree.ml4 b/plugins/xml/dumptree.ml4
deleted file mode 100644
index 76364541..00000000
--- a/plugins/xml/dumptree.ml4
+++ /dev/null
@@ -1,136 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(** This module provides the "Dump Tree" command that allows dumping the
-    current state of the proof stree in XML format *)
-
-(** Contributed by Cezary Kaliszyk, Radboud University Nijmegen *)
-
-(*i camlp4deps: "parsing/grammar.cma" i*)
-open Tacexpr;;
-open Decl_mode;;
-open Printer;;
-open Pp;;
-open Environ;;
-open Format;;
-open Proof_type;;
-open Evd;;
-open Termops;;
-open Ppconstr;;
-open Names;;
-
-exception Different
-
-let xmlstream s =
-  (* In XML we want to print the whole stream so we can force the evaluation *)
-  Stream.of_list (List.map xmlescape (Stream.npeek max_int s))
-;;
-
-let thin_sign osign sign =
-  Sign.fold_named_context
-    (fun (id,c,ty as d) sign ->
-       try
-        if Sign.lookup_named id osign = (id,c,ty) then sign
-         else raise Different
-       with Not_found | Different -> Environ.push_named_context_val d sign)
-    sign ~init:Environ.empty_named_context_val
-;;
-
-let pr_tactic_xml = function
-  | TacArg (_,Tacexp t) -> str "<tactic cmd=\"" ++ xmlstream (Pptactic.pr_glob_tactic (Global.env()) t) ++ str "\"/>"
-  | t -> str "<tactic cmd=\"" ++ xmlstream (Pptactic.pr_tactic (Global.env()) t) ++ str "\"/>"
-;;
-
-let pr_proof_instr_xml instr =
-  Ppdecl_proof.pr_proof_instr (Global.env()) instr
-;;
-
-let pr_rule_xml pr = function
-  | Prim r -> str "<rule text=\"" ++ xmlstream (pr_prim_rule r) ++ str "\"/>"
-  | Nested(cmpd, subtree) ->
-      hov 2 (str "<cmpdrule>" ++ fnl () ++
-        begin match cmpd with
-          Tactic (texp, _) -> pr_tactic_xml texp
-        end ++ fnl ()
-        ++ pr subtree
-      ) ++ fnl () ++ str "</cmpdrule>"
-  | Daimon -> str "<daimon/>"
-  | Decl_proof _ -> str "<proof/>"
-;;
-
-let pr_var_decl_xml env (id,c,typ) =
-  let ptyp = print_constr_env env typ in
-  match c with
-  | None ->
-      (str "<hyp id=\"" ++ xmlstream (pr_id id) ++ str "\" type=\"" ++ xmlstream ptyp ++ str "\"/>")
-  | Some c ->
-      (* Force evaluation *)
-      let pb = print_constr_env env c in
-      (str "<hyp id=\"" ++ xmlstream (pr_id id) ++ str "\" type=\"" ++ xmlstream ptyp ++ str "\" body=\"" ++
-         xmlstream pb ++ str "\"/>")
-;;
-
-let pr_rel_decl_xml env (na,c,typ) =
-  let pbody = match c with
-    | None -> mt ()
-    | Some c ->
-	(* Force evaluation *)
-	let pb = print_constr_env env c in
-	  (str" body=\"" ++ xmlstream pb ++ str "\"") in
-  let ptyp = print_constr_env env typ in
-  let pid =
-    match na with
-    | Anonymous -> mt ()
-    | Name id -> str " id=\"" ++ pr_id id ++ str "\""
-  in
-  (str "<hyp" ++ pid ++ str " type=\"" ++ xmlstream ptyp ++ str "\"" ++ pbody ++ str "/>")
-;;
-
-let pr_context_xml env =
-  let sign_env =
-    fold_named_context
-      (fun env d pp -> pp ++ pr_var_decl_xml env d)
-      env ~init:(mt ())
-  in
-  let db_env =
-    fold_rel_context
-      (fun env d pp -> pp ++ pr_rel_decl_xml env d)
-      env ~init:(mt ())
-  in
-  (sign_env ++ db_env)
-;;
-
-let pr_subgoal_metas_xml metas env=
-  let pr_one (meta, typ) =
-    fnl () ++ str "<meta index=\"" ++ int meta ++ str " type=\"" ++ xmlstream (pr_goal_concl_style_env env typ) ++
-      str "\"/>"
-  in
-  List.fold_left (++) (mt ()) (List.map pr_one metas)
-;;
-
-let pr_goal_xml sigma g =
-  let env = try Goal.V82.unfiltered_env sigma g with _ -> empty_env in
-  if Decl_mode.try_get_info sigma g = None then
-    (hov 2 (str "<goal>" ++ fnl () ++ str "<concl type=\"" ++
-    xmlstream (pr_goal_concl_style_env env (Goal.V82.concl sigma g)) ++
-    str "\"/>" ++
-    (pr_context_xml env)) ++
-    fnl () ++ str "</goal>")
-  else
-    (hov 2 (str "<goal type=\"declarative\">" ++
-    (pr_context_xml env)) ++
-    fnl () ++ str "</goal>")
-;;
-
-let print_proof_xml () =
-  Util.anomaly "Dump Tree command not supported in this version."
-
-
-VERNAC COMMAND EXTEND DumpTree
-  [ "Dump" "Tree" ] -> [ print_proof_xml () ]
-END
diff --git a/plugins/xml/proof2aproof.ml b/plugins/xml/proof2aproof.ml
deleted file mode 100644
index 2d16190b..00000000
--- a/plugins/xml/proof2aproof.ml
+++ /dev/null
@@ -1,78 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
-(*   \VV/  **************************************************************)
-(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
-(*         *   University of Bologna                                    *)
-(************************************************************************)
-(*          This file is distributed under the terms of the             *)
-(*           GNU Lesser General Public License Version 2.1              *)
-(*                                                                      *)
-(*                 Copyright (C) 2000-2004, HELM Team.                  *)
-(*                       http://helm.cs.unibo.it                        *)
-(************************************************************************)
-
-(* Note: we can not use the Set module here because we _need_ physical *)
-(* equality and there exists no comparison function compatible with    *)
-(* physical equality.                                                  *)
-
-module S =
- struct
-  let empty = []
-  let mem = List.memq
-  let add x l = x::l
- end
-;;
-
-(* evar reduction that preserves some terms *)
-let nf_evar sigma ~preserve =
- let module T = Term in
-  let rec aux t =
-   if preserve t then t else
-    match T.kind_of_term t with
-     | T.Rel _ | T.Meta _ | T.Var _ | T.Sort _ | T.Const _ | T.Ind _
-     | T.Construct _ -> t
-     | T.Cast (c1,k,c2) -> T.mkCast (aux c1, k, aux c2)
-     | T.Prod (na,c1,c2) -> T.mkProd (na, aux c1, aux c2)
-     | T.Lambda (na,t,c) -> T.mkLambda (na, aux t, aux c)
-     | T.LetIn (na,b,t,c) -> T.mkLetIn (na, aux b, aux t, aux c)
-     | T.App (c,l) ->
-        let c' = aux c in
-        let l' = Array.map aux l in
-         (match T.kind_of_term c' with
-             T.App (c'',l'') -> T.mkApp (c'', Array.append l'' l')
-           | T.Cast (he,_,_) ->
-              (match T.kind_of_term he with
-                  T.App (c'',l'') -> T.mkApp (c'', Array.append l'' l')
-                | _ -> T.mkApp (c', l')
-              )
-           | _ -> T.mkApp (c', l'))
-     | T.Evar (e,l) when Evd.mem sigma e & Evd.is_defined sigma e ->
-	aux (Evd.existential_value sigma (e,l))
-     | T.Evar (e,l) -> T.mkEvar (e, Array.map aux l)
-     | T.Case (ci,p,c,bl) -> T.mkCase (ci, aux p, aux c, Array.map aux bl)
-     | T.Fix (ln,(lna,tl,bl)) ->
-         T.mkFix (ln,(lna,Array.map aux tl,Array.map aux bl))
-     | T.CoFix(ln,(lna,tl,bl)) ->
-         T.mkCoFix (ln,(lna,Array.map aux tl,Array.map aux bl))
-   in
-    aux
-;;
-
-module ProofTreeHash =
- Hashtbl.Make
-  (struct
-    type t = Proof_type.proof_tree
-    let equal = (==)
-    let hash = Hashtbl.hash
-   end)
-;;
-
-
-let extract_open_proof sigma pf =
-  (* Deactivated and candidate for removal. (Apr. 2010) *)
-   ()
-
-let extract_open_pftreestate pts =
-  (* Deactivated and candidate for removal. (Apr. 2010) *)
-   ()
diff --git a/plugins/xml/proofTree2Xml.ml4 b/plugins/xml/proofTree2Xml.ml4
deleted file mode 100644
index 2f5eb6ac..00000000
--- a/plugins/xml/proofTree2Xml.ml4
+++ /dev/null
@@ -1,205 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
-(*   \VV/  **************************************************************)
-(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
-(*         *   University of Bologna                                    *)
-(************************************************************************)
-(*          This file is distributed under the terms of the             *)
-(*           GNU Lesser General Public License Version 2.1              *)
-(*                                                                      *)
-(*                 Copyright (C) 2000-2004, HELM Team.                  *)
-(*                       http://helm.cs.unibo.it                        *)
-(************************************************************************)
-
-let prooftreedtdname = "http://mowgli.cs.unibo.it/dtd/prooftree.dtd";;
-
-let idref_of_id id = "v" ^ id;;
-
-(* Transform a constr to an Xml.token Stream.t *)
-(* env is a named context                      *)
-(*CSC: in verita' dovrei "separare" le variabili vere e lasciarle come Var! *)
-let constr_to_xml obj sigma env =
-  let ids_to_terms = Hashtbl.create 503 in
-  let constr_to_ids = Acic.CicHash.create 503 in
-  let ids_to_father_ids = Hashtbl.create 503 in
-  let ids_to_inner_sorts = Hashtbl.create 503 in
-  let ids_to_inner_types = Hashtbl.create 503 in
-
-  (* named_context holds section variables and local variables *)
-  let named_context = Environ.named_context env  in
-  (* real_named_context holds only the section variables *)
-  let real_named_context = Environ.named_context (Global.env ()) in
-  (* named_context' holds only the local variables *)
-  let named_context' =
-   List.filter (function n -> not (List.mem n real_named_context)) named_context
-  in
-  let idrefs =
-   List.map
-    (function x,_,_ -> idref_of_id (Names.string_of_id x)) named_context' in
-  let rel_context = Sign.push_named_to_rel_context named_context' [] in
-  let rel_env =
-   Environ.push_rel_context rel_context
-    (Environ.reset_with_named_context
-	(Environ.val_of_named_context real_named_context) env) in
-  let obj' =
-   Term.subst_vars (List.map (function (i,_,_) -> i) named_context') obj in
-  let seed = ref 0 in
-   try
-    let annobj =
-     Cic2acic.acic_of_cic_context' false seed ids_to_terms constr_to_ids
-      ids_to_father_ids ids_to_inner_sorts ids_to_inner_types rel_env
-      idrefs sigma (Unshare.unshare obj') None
-    in
-     Acic2Xml.print_term ids_to_inner_sorts annobj
-   with e ->
-    Util.anomaly
-     ("Problem during the conversion of constr into XML: " ^
-      Printexc.to_string e)
-(* CSC: debugging stuff
-Pp.ppnl (Pp.str "Problem during the conversion of constr into XML") ;
-Pp.ppnl (Pp.str "ENVIRONMENT:") ;
-Pp.ppnl (Printer.pr_context_of rel_env) ;
-Pp.ppnl (Pp.str "TERM:") ;
-Pp.ppnl (Printer.pr_lconstr_env rel_env obj') ;
-Pp.ppnl (Pp.str "RAW-TERM:") ;
-Pp.ppnl (Printer.pr_lconstr obj') ;
-Xml.xml_empty "MISSING TERM" [] (*; raise e*)
-*)
-;;
-
-let first_word s =
-   try let i = String.index s ' ' in
-       String.sub s 0 i
-   with _ -> s
-;;
-
-let string_of_prim_rule x = match x with
-  | Proof_type.Intro _-> "Intro"
-  | Proof_type.Cut _ -> "Cut"
-  | Proof_type.FixRule _ -> "FixRule"
-  | Proof_type.Cofix _ -> "Cofix"
-  | Proof_type.Refine _ -> "Refine"
-  | Proof_type.Convert_concl _ -> "Convert_concl"
-  | Proof_type.Convert_hyp _->"Convert_hyp"
-  | Proof_type.Thin _ -> "Thin"
-  | Proof_type.ThinBody _-> "ThinBody"
-  | Proof_type.Move (_,_,_) -> "Move"
-  | Proof_type.Order _ -> "Order"
-  | Proof_type.Rename (_,_) -> "Rename"
-  | Proof_type.Change_evars -> "Change_evars"
-
-let
- print_proof_tree curi sigma pf proof_tree_to_constr
-  proof_tree_to_flattened_proof_tree constr_to_ids
-=
- let module PT = Proof_type in
- let module L = Logic in
- let module X = Xml in
- let module T = Tacexpr in
-  let ids_of_node node =
-   let constr = Proof2aproof.ProofTreeHash.find proof_tree_to_constr node in
-(*
-let constr =
- try
-    Proof2aproof.ProofTreeHash.find proof_tree_to_constr node
- with _ -> Pp.ppnl (Pp.(++) (Pp.str "Node of the proof-tree that generated
-no lambda-term: ") (Refiner.print_script true (Evd.empty)
-(Global.named_context ()) node)) ; assert false (* Closed bug, should not
-happen any more *)
-in
-*)
-   try
-    Some (Acic.CicHash.find constr_to_ids constr)
-   with _ ->
-Pp.ppnl (Pp.(++) (Pp.str
-"The_generated_term_is_not_a_subterm_of_the_final_lambda_term")
-(Printer.pr_lconstr constr)) ;
-    None
-  in
-  let rec aux node old_hyps =
-   let of_attribute =
-    match ids_of_node node with
-       None -> []
-     | Some id -> ["of",id]
-   in
-    match node with
-       {PT.ref=Some(PT.Prim tactic_expr,nodes)} ->
-         let tac = string_of_prim_rule tactic_expr in
-         let of_attribute = ("name",tac)::of_attribute in
-          if nodes = [] then
-           X.xml_empty "Prim" of_attribute
-          else
-           X.xml_nempty "Prim" of_attribute
-            (List.fold_left
-              (fun i n -> [< i ; (aux n old_hyps) >]) [<>] nodes)
-
-     | {PT.goal=goal;
-        PT.ref=Some(PT.Nested (PT.Tactic(tactic_expr,_),hidden_proof),nodes)} ->
-         (* [hidden_proof] is the proof of the tactic;                     *)
-         (* [nodes] are the proof of the subgoals generated by the tactic; *)
-         (* [flat_proof] if the proof-tree obtained substituting [nodes]   *)
-         (*  for the holes in [hidden_proof]                               *)
-        let flat_proof =
-         Proof2aproof.ProofTreeHash.find proof_tree_to_flattened_proof_tree node
-        in begin
-        match tactic_expr with
-        | T.TacArg (_,T.Tacexp _) ->
-            (* We don't need to keep the level of abstraction introduced at *)
-            (* user-level invocation of tactic... (see Tacinterp.hide_interp)*)
-            aux flat_proof old_hyps
-        | _ ->
-         (****** la tactique employee *)
-	 let prtac = Pptactic.pr_tactic (Global.env()) in
-         let tac = Pp.string_of_ppcmds (prtac tactic_expr) in
-         let tacname= first_word tac in
-         let of_attribute = ("name",tacname)::("script",tac)::of_attribute in
-
-         (****** le but *)
-
-	 let concl = Goal.V82.concl sigma goal in
-	 let hyps = Goal.V82.hyps sigma goal in
-
-         let env = Global.env_of_context hyps in
-	   
-
-         let xgoal =
-          X.xml_nempty "Goal" [] (constr_to_xml concl sigma env) in
-
-         let rec build_hyps =
-          function
-           | [] -> xgoal
-           | (id,c,tid)::hyps1 ->
-              let id' = Names.string_of_id id in
-               [< build_hyps hyps1;
-                  (X.xml_nempty "Hypothesis"
-                    ["id",idref_of_id id' ; "name",id']
-                    (constr_to_xml tid sigma env))
-               >] in
-         let old_names = List.map (fun (id,c,tid)->id) old_hyps in
-	 let nhyps = Environ.named_context_of_val hyps in
-         let new_hyps =
-          List.filter (fun (id,c,tid)-> not (List.mem id old_names)) nhyps in
-
-         X.xml_nempty "Tactic" of_attribute
-          [<(build_hyps new_hyps) ; (aux flat_proof nhyps)>]
-        end
-
-     | {PT.ref=Some(PT.Daimon,_)} ->
-         X.xml_empty "Hidden_open_goal" of_attribute
-
-     | {PT.ref=None;PT.goal=goal} ->
-         X.xml_empty "Open_goal" of_attribute
-     | {PT.ref=Some(PT.Decl_proof _, _)} -> failwith "TODO: xml and decl_proof"
-  in
-   [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
-      X.xml_cdata ("<!DOCTYPE ProofTree SYSTEM \""^prooftreedtdname ^"\">\n\n");
-      X.xml_nempty "ProofTree" ["of",curi] (aux pf [])
-   >]
-;;
-
-
-(* Hook registration *)
-(* CSC: debranched since it is bugged
-Xmlcommand.set_print_proof_tree print_proof_tree;;
-*)
diff --git a/plugins/xml/theoryobject.dtd b/plugins/xml/theoryobject.dtd
deleted file mode 100644
index 953fe009..00000000
--- a/plugins/xml/theoryobject.dtd
+++ /dev/null
@@ -1,62 +0,0 @@
-<?xml encoding="ISO-8859-1"?>
-
-<!-- Copyright (C) 2000-2004, HELM Team                                -->
-<!--                                                                   -->
-<!-- This file is part of HELM, an Hypertextual, Electronic            -->
-<!-- Library of Mathematics, developed at the Computer Science         -->
-<!-- Department, University of Bologna, Italy.                         -->
-<!--                                                                   -->
-<!-- HELM is free software; you can redistribute it and/or             -->
-<!-- modify it under the terms of the GNU General Public License       -->
-<!-- as published by the Free Software Foundation; either version 2    -->
-<!-- of the License, or (at your option) any later version.            -->
-<!--                                                                   -->
-<!-- HELM is distributed in the hope that it will be useful,           -->
-<!-- but WITHOUT ANY WARRANTY; without even the implied warranty of    -->
-<!-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the     -->
-<!-- GNU General Public License for more details.                      -->
-<!--                                                                   -->
-<!-- You should have received a copy of the GNU General Public License -->
-<!-- along with HELM; if not, write to the Free Software               -->
-<!-- Foundation, Inc., 59 Temple Place - Suite 330, Boston,            -->
-<!-- MA  02111-1307, USA.                                              -->
-<!--                                                                   -->
-<!-- For details, see the HELM World-Wide-Web page,                    -->
-<!-- http://cs.unibo.it/helm/.                                         -->
-
-
-
-<!-- Notice: the markup described in this DTD is meant to be embedded -->
-<!-- in foreign markup (e.g. XHTML)                                   -->
-
-<!ENTITY % theorystructure
-  '(ht:AXIOM|ht:DEFINITION|ht:THEOREM|ht:VARIABLE|ht:SECTION|ht:MUTUAL)*'>
-
-<!ELEMENT ht:SECTION (%theorystructure;)>
-<!ATTLIST ht:SECTION
-          uri CDATA #REQUIRED>
-
-<!ELEMENT ht:MUTUAL (ht:DEFINITION,ht:DEFINITION+)>
-
-<!-- Theory Items -->
-
-<!ELEMENT ht:AXIOM (Axiom)>
-<!ATTLIST ht:AXIOM
-          uri CDATA #REQUIRED
-          as (Axiom|Declaration) #REQUIRED>
-
-<!ELEMENT ht:DEFINITION (Definition|InductiveDefinition)>
-<!ATTLIST ht:DEFINITION
-          uri CDATA #REQUIRED
-          as (Definition|InteractiveDefinition|Inductive|CoInductive
-             |Record) #REQUIRED>
-
-<!ELEMENT ht:THEOREM (type)>
-<!ATTLIST ht:THEOREM
-          uri CDATA #REQUIRED
-          as (Theorem|Lemma|Corollary|Fact|Remark) #REQUIRED>
-
-<!ELEMENT ht:VARIABLE (Variable)>
-<!ATTLIST ht:VARIABLE
-          uri CDATA #REQUIRED
-          as (Assumption|Hypothesis|LocalDefinition|LocalFact) #REQUIRED>
diff --git a/plugins/xml/unshare.ml b/plugins/xml/unshare.ml
deleted file mode 100644
index c854427d..00000000
--- a/plugins/xml/unshare.ml
+++ /dev/null
@@ -1,52 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
-(*   \VV/  **************************************************************)
-(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
-(*         *   University of Bologna                                    *)
-(************************************************************************)
-(*          This file is distributed under the terms of the             *)
-(*           GNU Lesser General Public License Version 2.1              *)
-(*                                                                      *)
-(*                 Copyright (C) 2000-2004, HELM Team.                  *)
-(*                       http://helm.cs.unibo.it                        *)
-(************************************************************************)
-
-exception CanNotUnshare;;
-
-(* [unshare t] gives back a copy of t where all sharing has been removed   *)
-(* Physical equality becomes meaningful on unshared terms. Hashtables that *)
-(* use physical equality can now be used to associate information to evey  *)
-(* node of the term.                                                       *)
-let unshare ?(already_unshared = function _ -> false) t =
- let obj = Obj.repr t in
-  let rec aux obj =
-   if already_unshared (Obj.obj obj) then
-    obj
-   else
-    (if Obj.is_int obj then
-      obj
-     else if Obj.is_block obj then
-      begin
-       let tag = Obj.tag obj in
-        if tag < Obj.no_scan_tag then
-         begin
-          let size = Obj.size obj in
-           let new_obj = Obj.new_block 0 size in
-            Obj.set_tag new_obj tag ;
-            for i = 0 to size - 1 do
-             Obj.set_field new_obj i (aux (Obj.field obj i))
-            done ;
-            new_obj
-         end
-        else if tag = Obj.string_tag then
-         obj
-        else
-         raise CanNotUnshare
-      end
-     else
-      raise CanNotUnshare
-    )
-  in
-   Obj.obj (aux obj)
-;;
diff --git a/plugins/xml/unshare.mli b/plugins/xml/unshare.mli
deleted file mode 100644
index cace2de6..00000000
--- a/plugins/xml/unshare.mli
+++ /dev/null
@@ -1,21 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
-(*   \VV/  **************************************************************)
-(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
-(*         *   University of Bologna                                    *)
-(************************************************************************)
-(*          This file is distributed under the terms of the             *)
-(*           GNU Lesser General Public License Version 2.1              *)
-(*                                                                      *)
-(*                 Copyright (C) 2000-2004, HELM Team.                  *)
-(*                       http://helm.cs.unibo.it                        *)
-(************************************************************************)
-
-exception CanNotUnshare;;
-
-(* [unshare t] gives back a copy of t where all sharing has been removed   *)
-(* Physical equality becomes meaningful on unshared terms. Hashtables that *)
-(* use physical equality can now be used to associate information to evey  *)
-(* node of the term.                                                       *)
-val unshare: ?already_unshared:('a -> bool) -> 'a -> 'a
diff --git a/plugins/xml/xml.ml4 b/plugins/xml/xml.ml4
deleted file mode 100644
index 8a4eb39a..00000000
--- a/plugins/xml/xml.ml4
+++ /dev/null
@@ -1,78 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
-(*   \VV/  **************************************************************)
-(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
-(*         *   University of Bologna                                    *)
-(************************************************************************)
-(*          This file is distributed under the terms of the             *)
-(*           GNU Lesser General Public License Version 2.1              *)
-(*                                                                      *)
-(*                 Copyright (C) 2000-2004, HELM Team.                  *)
-(*                       http://helm.cs.unibo.it                        *)
-(************************************************************************)
-
-(* the type token for XML cdata, empty elements and not-empty elements *)
-(* Usage:                                                                *)
-(*  Str cdata                                                            *)
-(*  Empty (element_name, [attrname1, value1 ; ... ; attrnamen, valuen]   *)
-(*  NEmpty (element_name, [attrname1, value2 ; ... ; attrnamen, valuen], *)
-(*          content                                                      *)
-type token = Str of string
-           | Empty of string * (string * string) list
-	   | NEmpty of string * (string * string) list * token Stream.t
-;;
-
-(* currified versions of the constructors make the code more readable *)
-let xml_empty name attrs = [< 'Empty(name,attrs) >]
-let xml_nempty name attrs content = [< 'NEmpty(name,attrs,content) >]
-let xml_cdata str = [< 'Str str >]
-
-(* Usage:                                                                   *)
-(*  pp tokens None     pretty prints the output on stdout                   *)
-(*  pp tokens (Some filename) pretty prints the output on the file filename *)
-let pp_ch strm channel =
- let rec pp_r m =
-  parser
-    [< 'Str a ; s >] ->
-      print_spaces m ;
-      fprint_string (a ^ "\n") ;
-      pp_r m s
-  | [< 'Empty(n,l) ; s >] ->
-      print_spaces m ;
-      fprint_string ("<" ^ n) ;
-      List.iter (function (n,v) -> fprint_string (" " ^ n ^ "=\"" ^ v ^ "\"")) l;
-      fprint_string "/>\n" ;
-      pp_r m s
-  | [< 'NEmpty(n,l,c) ; s >] ->
-      print_spaces m ;
-      fprint_string ("<" ^ n) ;
-      List.iter (function (n,v) -> fprint_string (" " ^ n ^ "=\"" ^ v ^ "\"")) l;
-      fprint_string ">\n" ;
-      pp_r (m+1) c ;
-      print_spaces m ;
-      fprint_string ("</" ^ n ^ ">\n") ;
-      pp_r m s
-  | [< >] -> ()
- and print_spaces m =
-  for i = 1 to m do fprint_string "  " done
- and fprint_string str =
-  output_string channel str
- in
-  pp_r 0 strm
-;;
-
-
-let pp strm fn =
-  match fn with
-     Some filename ->
-      let filename = filename ^ ".xml" in
-      let ch = open_out filename in
-       pp_ch strm ch;
-       close_out ch ;
-       print_string ("\nWriting on file \"" ^ filename ^ "\" was successful\n");
-       flush stdout
-   | None ->
-       pp_ch strm stdout
-;;
-
diff --git a/plugins/xml/xml.mli b/plugins/xml/xml.mli
deleted file mode 100644
index 0b6d5198..00000000
--- a/plugins/xml/xml.mli
+++ /dev/null
@@ -1,38 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
-(*   \VV/  **************************************************************)
-(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
-(*         *   University of Bologna                                    *)
-(************************************************************************)
-(*          This file is distributed under the terms of the             *)
-(*           GNU Lesser General Public License Version 2.1              *)
-(*                                                                      *)
-(*                 Copyright (C) 2000-2004, HELM Team.                  *)
-(*                       http://helm.cs.unibo.it                        *)
-(************************************************************************)
-
-(* Tokens for XML cdata, empty elements and not-empty elements           *)
-(* Usage:                                                                *)
-(*  Str cdata                                                            *)
-(*  Empty (element_name, [attrname1, value1 ; ... ; attrnamen, valuen]   *)
-(*  NEmpty (element_name, [attrname1, value2 ; ... ; attrnamen, valuen], *)
-(*          content                                                      *)
-type token =
-  | Str of string
-  | Empty of string * (string * string) list
-  | NEmpty of string * (string * string) list * token Stream.t
-
-(* currified versions of the token constructors make the code more readable *)
-val xml_empty : string -> (string * string) list -> token Stream.t
-val xml_nempty :
-  string -> (string * string) list -> token Stream.t -> token Stream.t
-val xml_cdata : string -> token Stream.t
-
-val pp_ch : token Stream.t -> out_channel -> unit
-
-(* The pretty printer for streams of token                                  *)
-(* Usage:                                                                   *)
-(*  pp tokens None     pretty prints the output on stdout                   *)
-(*  pp tokens (Some filename) pretty prints the output on the file filename *)
-val pp : token Stream.t -> string option -> unit
diff --git a/plugins/xml/xml_plugin.mllib b/plugins/xml/xml_plugin.mllib
deleted file mode 100644
index 90797e8d..00000000
--- a/plugins/xml/xml_plugin.mllib
+++ /dev/null
@@ -1,13 +0,0 @@
-Unshare
-Xml
-Acic
-DoubleTypeInference
-Cic2acic
-Acic2Xml
-Proof2aproof
-Xmlcommand
-ProofTree2Xml
-Xmlentries
-Cic2Xml
-Dumptree
-Xml_plugin_mod
diff --git a/plugins/xml/xmlcommand.ml b/plugins/xml/xmlcommand.ml
deleted file mode 100644
index 59ade01e..00000000
--- a/plugins/xml/xmlcommand.ml
+++ /dev/null
@@ -1,691 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
-(*   \VV/  **************************************************************)
-(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
-(*         *   University of Bologna                                    *)
-(************************************************************************)
-(*          This file is distributed under the terms of the             *)
-(*           GNU Lesser General Public License Version 2.1              *)
-(*                                                                      *)
-(*                 Copyright (C) 2000-2004, HELM Team.                  *)
-(*                       http://helm.cs.unibo.it                        *)
-(************************************************************************)
-
-(* CONFIGURATION PARAMETERS *)
-
-let verbose = ref false;;
-
-(* HOOKS *)
-let print_proof_tree, set_print_proof_tree =
- let print_proof_tree = ref (fun _ _ _ _ _ _ -> None) in
-  (fun () -> !print_proof_tree),
-   (fun f ->
-     print_proof_tree :=
-     fun
-      curi sigma0 pf proof_tree_to_constr proof_tree_to_flattened_proof_tree
-      constr_to_ids
-     ->
-      Some
-       (f curi sigma0 pf proof_tree_to_constr
-        proof_tree_to_flattened_proof_tree constr_to_ids))
-;;
-
-(* UTILITY FUNCTIONS *)
-
-let print_if_verbose s = if !verbose then print_string s;;
-
-(* Next exception is used only inside print_coq_object and tag_of_string_tag *)
-exception Uninteresting;;
-
-(* NOT USED anymore, we back to the V6 point of view with global parameters
-
-(* Internally, for Coq V7, params of inductive types are associated     *)
-(* not to the whole block of mutual inductive (as it was in V6) but to  *)
-(* each member of the block; but externally, all params are required    *)
-(* to be the same; the following function checks that the parameters    *)
-(* of each inductive of a same block are all the same, then returns     *)
-(* this number; it fails otherwise                                      *)
-let extract_nparams pack =
- let module D = Declarations in
- let module U = Util in
- let module S = Sign in
-
-  let {D.mind_nparams=nparams0} = pack.(0) in
-  let arity0 = pack.(0).D.mind_user_arity in
-  let params0, _ = S.decompose_prod_n_assum nparams0 arity0 in
-  for i = 1 to Array.length pack - 1 do
-    let {D.mind_nparams=nparamsi} = pack.(i) in
-    let arityi = pack.(i).D.mind_user_arity in
-    let paramsi, _ = S.decompose_prod_n_assum nparamsi arityi in
-    if params0 <> paramsi then U.error "Cannot convert a block of inductive definitions with parameters specific to each inductive to a block of mutual inductive definitions with parameters global to the whole block"
-  done;
-  nparams0
-
-*)
-
-(* could_have_namesakes sp = true iff o is an object that could be cooked and *)
-(* than that could exists in cooked form with the same name in a super        *)
-(* section of the actual section                                              *)
-let could_have_namesakes o sp =      (* namesake = omonimo in italian *)
- let module DK = Decl_kinds in
- let module D = Declare in
-  let tag = Libobject.object_tag o in
-   print_if_verbose ("Object tag: " ^ tag ^ "\n") ;
-   match tag with
-      "CONSTANT"        -> true   (* constants/parameters are non global *)
-    | "INDUCTIVE"       -> true   (* mutual inductive types are never local   *)
-    | "VARIABLE"        -> false  (* variables are local, so no namesakes     *)
-    | _                 -> false  (* uninteresting thing that won't be printed*)
-;;
-
-(* filter_params pvars hyps *)
-(* filters out from pvars (which is a list of lists) all the variables *)
-(* that does not belong to hyps (which is a simple list)               *)
-(* It returns a list of couples relative section path -- list of       *)
-(* variable names.                                                     *)
-let filter_params pvars hyps =
- let rec aux ids =
-  function
-     [] -> []
-   | (id,he)::tl ->
-      let ids' = id::ids in
-      let ids'' =
-       "cic:/" ^
-        String.concat "/" (List.rev (List.map Names.string_of_id ids')) in
-      let he' =
-       ids'', List.rev (List.filter (function x -> List.mem x hyps) he) in
-      let tl' = aux ids' tl in
-       match he' with
-          _,[] -> tl'
-        | _,_  -> he'::tl'
- in
-  let cwd = Lib.cwd () in
-  let cwdsp = Libnames.make_path cwd (Names.id_of_string "dummy") in
-  let modulepath = Cic2acic.get_module_path_of_full_path cwdsp in
-   aux (Names.repr_dirpath modulepath) (List.rev pvars)
-;;
-
-type variables_type =
-   Definition of string * Term.constr * Term.types
- | Assumption of string * Term.constr
-;;
-
-(* The computation is very inefficient, but we can't do anything *)
-(* better unless this function is reimplemented in the Declare   *)
-(* module.                                                       *)
-let search_variables () =
- let module N = Names in
-  let cwd = Lib.cwd () in
-  let cwdsp = Libnames.make_path cwd (Names.id_of_string "dummy") in
-  let modulepath = Cic2acic.get_module_path_of_full_path cwdsp in
-   let rec aux =
-    function
-       [] -> []
-     | he::tl as modules ->
-        let one_section_variables =
-         let dirpath = N.make_dirpath (modules @ N.repr_dirpath modulepath) in
-          let t = List.map N.string_of_id (Decls.last_section_hyps dirpath) in
-           [he,t]
-        in
-         one_section_variables @ aux tl
-   in
-    aux
-     (Cic2acic.remove_module_dirpath_from_dirpath
-       ~basedir:modulepath cwd)
-;;
-
-(* FUNCTIONS TO PRINT A SINGLE OBJECT OF COQ *)
-
-let rec join_dirs cwd =
- function
-    []  -> cwd
-  | he::tail ->
-      (try
-        Unix.mkdir cwd 0o775
-       with e when e <> Sys.Break -> () (* Let's ignore the errors on mkdir *)
-      ) ;
-     let newcwd = cwd ^ "/" ^ he in
-      join_dirs newcwd tail
-;;
-
-let filename_of_path xml_library_root tag =
- let module N = Names in
-  match xml_library_root with
-     None -> None  (* stdout *)
-   | Some xml_library_root' ->
-      let tokens = Cic2acic.token_list_of_kernel_name tag in
-       Some (join_dirs xml_library_root' tokens)
-;;
-
-let body_filename_of_filename =
- function
-    Some f -> Some (f ^ ".body")
-  | None   -> None
-;;
-
-let types_filename_of_filename =
- function
-    Some f -> Some (f ^ ".types")
-  | None   -> None
-;;
-
-let prooftree_filename_of_filename =
- function
-    Some f -> Some (f ^ ".proof_tree")
-  | None   -> None
-;;
-
-let theory_filename xml_library_root =
- let module N = Names in
-  match xml_library_root with
-    None -> None  (* stdout *)
-  | Some xml_library_root' ->
-     let toks = List.map N.string_of_id (N.repr_dirpath (Lib.library_dp ())) in
-     (* theory from A/B/C/F.v goes into A/B/C/F.theory *)
-     let alltoks = List.rev toks in
-       Some (join_dirs xml_library_root' alltoks ^ ".theory")
-
-let print_object uri obj sigma proof_tree_infos filename =
- (* function to pretty print and compress an XML file *)
-(*CSC: Unix.system "gzip ..." is an horrible non-portable solution. *)
- let pp xml filename =
-  Xml.pp xml filename ;
-  match filename with
-     None -> ()
-   | Some fn ->
-      let fn' =
-       let rec escape s n =
-        try
-         let p = String.index_from s n '\'' in
-          String.sub s n (p - n) ^ "\\'" ^ escape s (p+1)
-        with Not_found -> String.sub s n (String.length s - n)
-       in
-        escape fn 0
-      in
-       ignore (Unix.system ("gzip " ^ fn' ^ ".xml"))
- in
-  let (annobj,_,constr_to_ids,_,ids_to_inner_sorts,ids_to_inner_types,_,_) =
-   Cic2acic.acic_object_of_cic_object sigma obj in
-  let (xml, xml') = Acic2Xml.print_object uri ids_to_inner_sorts annobj in
-  let xmltypes =
-   Acic2Xml.print_inner_types uri ids_to_inner_sorts ids_to_inner_types in
-  pp xml filename ;
-  begin
-   match xml' with
-      None -> ()
-    | Some xml' -> pp xml' (body_filename_of_filename filename)
-  end ;
-  pp xmltypes (types_filename_of_filename filename) ;
-  match proof_tree_infos with
-     None -> ()
-   | Some (sigma0,proof_tree,proof_tree_to_constr,
-           proof_tree_to_flattened_proof_tree) ->
-      let xmlprooftree =
-       print_proof_tree ()
-        uri sigma0 proof_tree proof_tree_to_constr
-        proof_tree_to_flattened_proof_tree constr_to_ids
-      in
-       match xmlprooftree with
-          None -> ()
-        | Some xmlprooftree ->
-           pp xmlprooftree (prooftree_filename_of_filename filename)
-;;
-
-let string_list_of_named_context_list =
- List.map
-  (function (n,_,_) -> Names.string_of_id n)
-;;
-
-(* Function to collect the variables that occur in a term. *)
-(* Used only for variables (since for constants and mutual *)
-(* inductive types this information is already available.  *)
-let find_hyps t =
- let module T = Term in
-  let rec aux l t =
-   match T.kind_of_term t with
-      T.Var id when not (List.mem id l) ->
-       let (_,bo,ty) = Global.lookup_named id in
-        let boids =
-         match bo with
-            Some bo' -> aux l bo'
-          | None -> l
-        in
-         id::(aux boids ty)
-    | T.Var _
-    | T.Rel _
-    | T.Meta _
-    | T.Evar _
-    | T.Sort _ -> l
-    | T.Cast (te,_, ty) -> aux (aux l te) ty
-    | T.Prod (_,s,t) -> aux (aux l s) t
-    | T.Lambda (_,s,t) -> aux (aux l s) t
-    | T.LetIn (_,s,_,t) -> aux (aux l s) t
-    | T.App (he,tl) -> Array.fold_left (fun i x -> aux i x) (aux l he) tl
-    | T.Const con ->
-       let hyps = (Global.lookup_constant con).Declarations.const_hyps in
-        map_and_filter l hyps @ l
-    | T.Ind ind
-    | T.Construct (ind,_) ->
-       let hyps = (fst (Global.lookup_inductive ind)).Declarations.mind_hyps in
-        map_and_filter l hyps @ l
-    | T.Case (_,t1,t2,b) ->
-       Array.fold_left (fun i x -> aux i x) (aux (aux l t1) t2) b
-    | T.Fix (_,(_,tys,bodies))
-    | T.CoFix (_,(_,tys,bodies)) ->
-       let r = Array.fold_left (fun i x -> aux i x) l tys in
-        Array.fold_left (fun i x -> aux i x) r bodies
-  and map_and_filter l =
-   function
-      [] -> []
-    | (n,_,_)::tl when not (List.mem n l) -> n::(map_and_filter l tl)
-    | _::tl -> map_and_filter l tl
-  in
-   aux [] t
-;;
-
-(* Functions to construct an object *)
-
-let mk_variable_obj id body typ =
- let hyps,unsharedbody =
-  match body with
-     None -> [],None
-   | Some bo -> find_hyps bo, Some (Unshare.unshare bo)
- in
-  let hyps' = find_hyps typ @ hyps in
-  let hyps'' = List.map Names.string_of_id hyps' in
-  let variables = search_variables () in
-  let params = filter_params variables hyps'' in
-   Acic.Variable
-    (Names.string_of_id id, unsharedbody, Unshare.unshare typ, params)
-;;
-
-(* Unsharing is not performed on the body, that must be already unshared. *)
-(* The evar map and the type, instead, are unshared by this function.     *)
-let mk_current_proof_obj is_a_variable id bo ty evar_map env =
- let unshared_ty = Unshare.unshare ty in
- let metasenv =
-  List.map
-   (function
-     (n, {Evd.evar_concl = evar_concl ;
-          Evd.evar_hyps = evar_hyps}
-      ) ->
-       (* We map the named context to a rel context and every Var to a Rel *)
-       let final_var_ids,context =
-        let rec aux var_ids =
-         function
-            [] -> var_ids,[]
-          | (n,None,t)::tl ->
-              let final_var_ids,tl' = aux (n::var_ids) tl in
-              let t' = Term.subst_vars var_ids t in
-               final_var_ids,(n, Acic.Decl (Unshare.unshare t'))::tl'
-          | (n,Some b,t)::tl ->
-              let final_var_ids,tl' = aux (n::var_ids) tl in
-              let b' = Term.subst_vars var_ids b in
-               (* t will not be exported to XML. Thus no unsharing performed *)
-               final_var_ids,(n, Acic.Def  (Unshare.unshare b',t))::tl'
-        in
-         aux [] (List.rev (Environ.named_context_of_val evar_hyps))
-       in
-        (* We map the named context to a rel context and every Var to a Rel *)
-        (n,context,Unshare.unshare (Term.subst_vars final_var_ids evar_concl))
-   ) (Evarutil.non_instantiated evar_map)
- in
-  let id' = Names.string_of_id id in
-   if metasenv = [] then
-    let ids =
-     Names.Idset.union
-      (Environ.global_vars_set env bo) (Environ.global_vars_set env ty) in
-    let hyps0 = Environ.keep_hyps env ids in
-    let hyps = string_list_of_named_context_list hyps0 in
-    (* Variables are the identifiers of the variables in scope *)
-    let variables = search_variables () in
-    let params = filter_params variables hyps in
-     if is_a_variable then
-      Acic.Variable (id',Some bo,unshared_ty,params)
-     else
-      Acic.Constant (id',Some bo,unshared_ty,params)
-   else
-    Acic.CurrentProof (id',metasenv,bo,unshared_ty)
-;;
-
-let mk_constant_obj id bo ty variables hyps =
- let hyps = string_list_of_named_context_list hyps in
- let ty = Unshare.unshare ty in
- let params = filter_params variables hyps in
-  match bo with
-     None ->
-      Acic.Constant (Names.string_of_id id,None,ty,params)
-   | Some c ->
-      Acic.Constant
-       (Names.string_of_id id, Some (Unshare.unshare (Declarations.force c)),
-         ty,params)
-;;
-
-let mk_inductive_obj sp mib packs variables nparams hyps finite =
- let module D = Declarations in
-  let hyps = string_list_of_named_context_list hyps in
-  let params = filter_params variables hyps in
-(*  let nparams = extract_nparams packs in *)
-   let tys =
-    let tyno = ref (Array.length packs) in
-    Array.fold_right
-     (fun p i ->
-       decr tyno ;
-       let {D.mind_consnames=consnames ;
-            D.mind_typename=typename } = p
-       in
-        let arity = Inductive.type_of_inductive (Global.env()) (mib,p) in
-        let lc = Inductiveops.arities_of_constructors (Global.env ()) (sp,!tyno) in
-        let cons =
-         (Array.fold_right (fun (name,lc) i -> (name,lc)::i)
-          (Array.mapi
-           (fun j x ->(x,Unshare.unshare lc.(j))) consnames)
-          []
-         )
-        in
-         (typename,finite,Unshare.unshare arity,cons)::i
-     ) packs []
-   in
-    Acic.InductiveDefinition (tys,params,nparams)
-;;
-
-(* The current channel for .theory files *)
-let theory_buffer = Buffer.create 4000;;
-
-let theory_output_string ?(do_not_quote = false) s =
-  (* prepare for coqdoc post-processing *)
-  let s = if do_not_quote then s else "(** #"^s^"\n#*)\n" in
-  print_if_verbose s;
-   Buffer.add_string theory_buffer s
-;;
-
-let kind_of_global_goal = function
-  | Decl_kinds.Global, Decl_kinds.DefinitionBody _ -> "DEFINITION","InteractiveDefinition"
-  | Decl_kinds.Global, (Decl_kinds.Proof k) -> "THEOREM",Decl_kinds.string_of_theorem_kind k
-  | Decl_kinds.Local, _ -> assert false
-
-let kind_of_inductive isrecord kn =
- "DEFINITION",
- if (fst (Global.lookup_inductive (kn,0))).Declarations.mind_finite
- then begin 
-   match isrecord with 
-   | Declare.KernelSilent -> "Record"
-   | _ -> "Inductive"
- end
- else "CoInductive"
-;;
-
-let kind_of_variable id =
-  let module DK = Decl_kinds in
-  match Decls.variable_kind id with
-    | DK.IsAssumption DK.Definitional -> "VARIABLE","Assumption"
-    | DK.IsAssumption DK.Logical -> "VARIABLE","Hypothesis"
-    | DK.IsAssumption DK.Conjectural -> "VARIABLE","Conjecture"
-    | DK.IsDefinition DK.Definition -> "VARIABLE","LocalDefinition"
-    | DK.IsProof _ -> "VARIABLE","LocalFact"
-    | _ -> Util.anomaly "Unsupported variable kind"
-;;
-
-let kind_of_constant kn =
-  let module DK = Decl_kinds in
-  match Decls.constant_kind kn with
-    | DK.IsAssumption DK.Definitional -> "AXIOM","Declaration"
-    | DK.IsAssumption DK.Logical -> "AXIOM","Axiom"
-    | DK.IsAssumption DK.Conjectural ->
-        Pp.msg_warn "Conjecture not supported in dtd (used Declaration instead)";
-        "AXIOM","Declaration"
-    | DK.IsDefinition DK.Definition -> "DEFINITION","Definition"
-    | DK.IsDefinition DK.Example ->
-        Pp.msg_warn "Example not supported in dtd (used Definition instead)";
-        "DEFINITION","Definition"
-    | DK.IsDefinition DK.Coercion ->
-        Pp.msg_warn "Coercion not supported in dtd (used Definition instead)";
-        "DEFINITION","Definition"
-    | DK.IsDefinition DK.SubClass ->
-        Pp.msg_warn "SubClass not supported in dtd (used Definition instead)";
-        "DEFINITION","Definition"
-    | DK.IsDefinition DK.CanonicalStructure ->
-        Pp.msg_warn "CanonicalStructure not supported in dtd (used Definition instead)";
-        "DEFINITION","Definition"
-    | DK.IsDefinition DK.Fixpoint ->
-        Pp.msg_warn "Fixpoint not supported in dtd (used Definition instead)";
-        "DEFINITION","Definition"
-    | DK.IsDefinition DK.CoFixpoint ->
-        Pp.msg_warn "CoFixpoint not supported in dtd (used Definition instead)";
-        "DEFINITION","Definition"
-    | DK.IsDefinition DK.Scheme ->
-        Pp.msg_warn "Scheme not supported in dtd (used Definition instead)";
-        "DEFINITION","Definition"
-    | DK.IsDefinition DK.StructureComponent ->
-        Pp.msg_warn "StructureComponent not supported in dtd (used Definition instead)";
-        "DEFINITION","Definition"
-    | DK.IsDefinition DK.IdentityCoercion ->
-        Pp.msg_warn "IdentityCoercion not supported in dtd (used Definition instead)";
-        "DEFINITION","Definition"
-    | DK.IsDefinition DK.Instance ->
-        Pp.msg_warn "Instance not supported in dtd (used Definition instead)";
-        "DEFINITION","Definition"
-    | DK.IsDefinition DK.Method ->
-        Pp.msg_warn "Method not supported in dtd (used Definition instead)";
-        "DEFINITION","Definition"
-    | DK.IsProof (DK.Theorem|DK.Lemma|DK.Corollary|DK.Fact|DK.Remark as thm) ->
-        "THEOREM",DK.string_of_theorem_kind thm
-    | DK.IsProof _ ->
-        Pp.msg_warn "Unsupported theorem kind (used Theorem instead)";
-        "THEOREM",DK.string_of_theorem_kind DK.Theorem
-;;
-
-let kind_of_global r =
-  let module Ln = Libnames in
-  let module DK = Decl_kinds in
-  match r with
-  | Ln.IndRef kn | Ln.ConstructRef (kn,_) ->
-      let isrecord =
-	try let _ = Recordops.lookup_projections kn in Declare.KernelSilent
-        with Not_found -> Declare.KernelVerbose in
-      kind_of_inductive isrecord (fst kn)
-  | Ln.VarRef id -> kind_of_variable id
-  | Ln.ConstRef kn -> kind_of_constant kn
-;;
-
-let print_object_kind uri (xmltag,variation) =
-  let s =
-    Printf.sprintf "<ht:%s uri=\"%s\" as=\"%s\"/>\n" xmltag uri variation
-  in
-  theory_output_string s
-;;
-
-(* print id dest                                                          *)
-(*  where sp   is the qualified identifier (section path) of a            *)
-(*             definition/theorem, variable or inductive definition       *)
-(*  and   dest is either None (for stdout) or (Some filename)             *)
-(* pretty prints via Xml.pp the object whose identifier is id on dest     *)
-(* Note: it is printed only (and directly) the most cooked available      *)
-(*       form of the definition (all the parameters are                   *)
-(*       lambda-abstracted, but the object can still refer to variables)  *)
-let print internal glob_ref kind xml_library_root =
- let module D = Declarations in
- let module De = Declare in
- let module G = Global in
- let module N = Names in
- let module Nt = Nametab in
- let module T = Term in
- let module X = Xml in
- let module Ln = Libnames in
-  (* Variables are the identifiers of the variables in scope *)
-  let variables = search_variables () in
-  let tag,obj =
-   match glob_ref with
-      Ln.VarRef id ->
-       (* this kn is fake since it is not provided by Coq *)
-       let kn =
-        let (mod_path,dir_path) = Lib.current_prefix () in
-        N.make_kn mod_path dir_path (N.label_of_id id)
-       in
-       let (_,body,typ) = G.lookup_named id in
-        Cic2acic.Variable kn,mk_variable_obj id body typ
-    | Ln.ConstRef kn ->
-       let id = N.id_of_label (N.con_label kn) in
-       let cb = G.lookup_constant kn in
-       let val0 = D.body_of_constant cb in
-       let typ = cb.D.const_type in
-       let hyps = cb.D.const_hyps in
-       let typ = Typeops.type_of_constant_type (Global.env()) typ in
-        Cic2acic.Constant kn,mk_constant_obj id val0 typ variables hyps
-    | Ln.IndRef (kn,_) ->
-       let mib = G.lookup_mind kn in
-       let {D.mind_nparams=nparams;
-	    D.mind_packets=packs ;
-            D.mind_hyps=hyps;
-            D.mind_finite=finite} = mib in
-          Cic2acic.Inductive kn,mk_inductive_obj kn mib packs variables nparams hyps finite
-    | Ln.ConstructRef _ ->
-       Util.error ("a single constructor cannot be printed in XML")
-  in
-  let fn = filename_of_path xml_library_root tag in
-  let uri = Cic2acic.uri_of_kernel_name tag in
-  (match internal with
-    | Declare.KernelSilent -> ()
-    | _ -> print_object_kind uri kind);
-   print_object uri obj Evd.empty None fn
-;;
-
-let print_ref qid fn =
-  let ref = Nametab.global qid in
-  print Declare.UserVerbose ref (kind_of_global ref) fn
-
-(* show dest                                                  *)
-(*  where dest is either None (for stdout) or (Some filename) *)
-(* pretty prints via Xml.pp the proof in progress on dest     *)
-let show_pftreestate internal fn (kind,pftst) id =
- if true then
-   Util.anomaly "Xmlcommand.show_pftreestate is not supported in this version."
-
-let show fn =
- let pftst = Pfedit.get_pftreestate () in
- let (id,kind,_,_) = Pfedit.current_proof_statement () in
-  show_pftreestate false fn (kind,pftst) id
-;;
-
-
-(* Let's register the callbacks *)
-let xml_library_root =
-  try
-   Some (Sys.getenv "COQ_XML_LIBRARY_ROOT")
-  with Not_found -> None
-;;
-
-let proof_to_export = ref None (* holds the proof-tree to export *)
-;;
-
-let _ =
-  Pfedit.set_xml_cook_proof
-   (function pftreestate -> proof_to_export := Some pftreestate)
-;;
-
-let _ =
-  Declare.set_xml_declare_variable
-   (function (sp,kn) ->
-     let id = Libnames.basename sp in
-     print Declare.UserVerbose (Libnames.VarRef id) (kind_of_variable id) xml_library_root ;
-     proof_to_export := None)
-;;
-
-let _ =
-  Declare.set_xml_declare_constant
-   (function (internal,kn) ->
-     match !proof_to_export with
-        None ->
-          print internal (Libnames.ConstRef kn) (kind_of_constant kn)
-	    xml_library_root
-      | Some pftreestate ->
-         (* It is a proof. Let's export it starting from the proof-tree *)
-         (* I saved in the Pfedit.set_xml_cook_proof callback.          *)
-        let fn = filename_of_path xml_library_root (Cic2acic.Constant kn) in
-         show_pftreestate internal fn pftreestate
-	  (Names.id_of_label (Names.con_label kn)) ;
-         proof_to_export := None)
-;;
-
-let _ =
-  Declare.set_xml_declare_inductive
-   (function (isrecord,(sp,kn)) ->
-      print Declare.UserVerbose (Libnames.IndRef (Names.mind_of_kn kn,0))
-        (kind_of_inductive isrecord (Names.mind_of_kn kn))
-        xml_library_root)
-;;
-
-let _ =
-  Vernac.set_xml_start_library
-   (function () ->
-     Buffer.reset theory_buffer;
-     theory_output_string "<?xml version=\"1.0\" encoding=\"latin1\"?>\n";
-     theory_output_string ("<!DOCTYPE html [\n" ^
-      "<!ENTITY % xhtml-lat1.ent    SYSTEM \"http://helm.cs.unibo.it/dtd/xhtml-lat1.ent\">\n" ^
-      "<!ENTITY % xhtml-special.ent SYSTEM \"http://helm.cs.unibo.it/dtd/xhtml-special.ent\">\n" ^
-      "<!ENTITY % xhtml-symbol.ent  SYSTEM \"http://helm.cs.unibo.it/dtd/xhtml-symbol.ent\">\n\n" ^
-      "%xhtml-lat1.ent;\n" ^
-      "%xhtml-special.ent;\n" ^
-      "%xhtml-symbol.ent;\n" ^
-      "]>\n\n");
-     theory_output_string "<html xmlns=\"http://www.w3.org/1999/xhtml\" xmlns:ht=\"http://www.cs.unibo.it/helm/namespaces/helm-theory\" xmlns:helm=\"http://www.cs.unibo.it/helm\">\n";
-     theory_output_string "<head></head>\n<body>\n")
-;;
-
-let _ =
-  Vernac.set_xml_end_library
-   (function () ->
-      theory_output_string "</body>\n</html>\n";
-      let ofn = theory_filename xml_library_root in
-       begin
-        match ofn with
-           None ->
-             Buffer.output_buffer stdout theory_buffer ;
-         | Some fn ->
-             let ch = open_out (fn ^ ".v") in
-             Buffer.output_buffer ch theory_buffer ;
-             close_out ch;
-             (* dummy glob file *)
-             let ch = open_out (fn ^ ".glob") in
-             close_out ch
-       end ;
-       Option.iter
-	(fun fn ->
-	  let coqdoc = Filename.concat Envars.coqbin ("coqdoc" ^ Coq_config.exec_extension) in
-	  let options = " --html -s --body-only --no-index --latin1 --raw-comments" in
-          let command cmd =
-           if Sys.command cmd <> 0 then
-            Util.anomaly ("Error executing \"" ^ cmd ^ "\"")
-          in
-           command (coqdoc^options^" -o "^fn^".xml "^fn^".v");
-           command ("rm "^fn^".v "^fn^".glob");
-           print_string("\nWriting on file \"" ^ fn ^ ".xml\" was successful\n"))
-       ofn)
-;;
-
-let _ = Lexer.set_xml_output_comment (theory_output_string ~do_not_quote:true) ;;
-
-let uri_of_dirpath dir =
-  "/" ^ String.concat "/"
-    (List.map Names.string_of_id (List.rev (Names.repr_dirpath dir)))
-;;
-
-let _ =
-  Lib.set_xml_open_section
-    (fun _ ->
-      let s = "cic:" ^ uri_of_dirpath (Lib.cwd ()) in
-      theory_output_string ("<ht:SECTION uri=\""^s^"\">"))
-;;
-
-let _ =
-  Lib.set_xml_close_section
-    (fun _ -> theory_output_string "</ht:SECTION>")
-;;
-
-let _ =
-  Library.set_xml_require
-    (fun d -> theory_output_string
-      (Printf.sprintf "<b>Require</b> <a helm:helm_link=\"href\" href=\"theory:%s.theory\">%s</a>.<br/>"
-       (uri_of_dirpath d) (Names.string_of_dirpath d)))
-;;
diff --git a/plugins/xml/xmlcommand.mli b/plugins/xml/xmlcommand.mli
deleted file mode 100644
index ec50d623..00000000
--- a/plugins/xml/xmlcommand.mli
+++ /dev/null
@@ -1,39 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
-(*   \VV/  **************************************************************)
-(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
-(*         *   University of Bologna                                    *)
-(************************************************************************)
-(*          This file is distributed under the terms of the             *)
-(*           GNU Lesser General Public License Version 2.1              *)
-(*                                                                      *)
-(*                 Copyright (C) 2000-2004, HELM Team.                  *)
-(*                       http://helm.cs.unibo.it                        *)
-(************************************************************************)
-
-(* print_global qid fn                                                    *)
-(*  where qid  is a long name denoting a definition/theorem or            *)
-(*             an inductive definition                                    *)
-(*  and   dest is either None (for stdout) or (Some filename)             *)
-(* pretty prints via Xml.pp the object whose name is ref on dest          *)
-(* Note: it is printed only (and directly) the most discharged available  *)
-(*       form of the definition (all the parameters are                   *)
-(*       lambda-abstracted, but the object can still refer to variables)  *)
-val print_ref : Libnames.reference -> string option -> unit
-
-(* show dest                                                  *)
-(*  where dest is either None (for stdout) or (Some filename) *)
-(* pretty prints via Xml.pp the proof in progress on dest     *)
-val show : string option -> unit
-
-(* set_print_proof_tree f                                      *)
-(*  sets a callback function f to export the proof_tree to XML *)
-val set_print_proof_tree :
-    (string ->
-     Evd.evar_map ->
-     Proof_type.proof_tree ->
-     Term.constr Proof2aproof.ProofTreeHash.t ->
-     Proof_type.proof_tree Proof2aproof.ProofTreeHash.t ->
-     string Acic.CicHash.t -> Xml.token Stream.t) ->
-    unit
diff --git a/plugins/xml/xmlentries.ml4 b/plugins/xml/xmlentries.ml4
deleted file mode 100644
index d65a1bd3..00000000
--- a/plugins/xml/xmlentries.ml4
+++ /dev/null
@@ -1,38 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
-(*   \VV/  **************************************************************)
-(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
-(*         *   University of Bologna                                    *)
-(************************************************************************)
-(*          This file is distributed under the terms of the             *)
-(*           GNU Lesser General Public License Version 2.1              *)
-(*                                                                      *)
-(*                 Copyright (C) 2000-2004, HELM Team.                  *)
-(*                       http://helm.cs.unibo.it                        *)
-(************************************************************************)
-
-(*i camlp4deps: "parsing/grammar.cma" i*)
-
-open Util;;
-open Vernacinterp;;
-
-open Extend;;
-open Genarg;;
-open Pp;;
-open Pcoq;;
-
-(* File name *)
-
-VERNAC ARGUMENT EXTEND filename
-| [ "File" string(fn) ] -> [ Some fn ]
-| [ ] -> [ None ]
-END
-
-(* Print XML and Show XML *)
-
-VERNAC COMMAND EXTEND Xml
-| [ "Print" "XML" filename(fn) global(qid) ] -> [ Xmlcommand.print_ref qid fn ]
-
-| [ "Show" "XML" filename(fn) "Proof" ] -> [ Xmlcommand.show fn ]
-END